diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 7bb88e10d9b..c8adcfe6995 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -14,8 +14,8 @@ jobs: - uses: actions/checkout@v2 with: submodules: true - - uses: cachix/install-nix-action@v20 - - uses: cachix/cachix-action@v12 + - uses: cachix/install-nix-action@v27 + - uses: cachix/cachix-action@v15 with: name: wire-server signingKey: '${{ secrets.CACHIX_SIGNING_KEY }}' diff --git a/.hlint.yaml b/.hlint.yaml index 9fa143c7cba..3e972c604bd 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -24,7 +24,7 @@ - error: { name: Use shutdown, lhs: runSettings, rhs: runSettingsWithShutdown } - ignore: { name: Use shutdown, within: [ Network.Wai.Utilities.Server, # this is the implementation 'runSettingsWithShutdown' - Federator.Response, # this is just a naming conincidence + Federator.Interpreter, # this is just a naming coincidence Cannon.Run # we do something similar, but not identical here by hand ] } diff --git a/.ormolu b/.ormolu index a427ec702a8..59d9336af2a 100644 --- a/.ormolu +++ b/.ormolu @@ -1,5 +1,15 @@ -infixr 10 .= +module Imports exports Prelude +infixl 9 .= +infixl 9 .: +infixr 4 ?~ +infixr 4 .~ +infixl 1 & infix 4 === infix 4 =/= infixr 3 !!! infixr 3 +infix 4 <$$$> +infixl 1 `bindResponse` diff --git a/CHANGELOG.md b/CHANGELOG.md index b5b8da28b1a..16fbd73b4aa 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,154 @@ +# [2024-07-08] (Chart Release 5.4.0) + +## Release notes + + +* Phone registration and login is not supported anymore. All API endpoints dealing with phone numbers and phone activation codes now fail with a 400 error. Brig options related to phone number support have now been deleted, namely: + - `setTwilio` + - `setNexmo` + - `setAllowlistPhonePrefixes`. (#4045) + + +## API changes + + +* Internal API endpoints related to phone numbers have been removed. + + In brig: + - `iGetPhonePrefix` + - `iDeletePhonePrefix` + - `iPostPhonePrefix`. + + In stern: + - `get-users-by-phone` + - `put-phone`. (#4045) + + +## Features + + +* charts/coturn: support putting coturn into 'drain' mode when terminating pods, denying new incoming client connections. This speeds up graceful coturn restarts significantly. (#4098) + +* Set SFT usernames's `shared` field according to team settings (#4117) + +* Updated the `mlsE2EId` feature config with two additional fields `crlProxy` and `useProxyOnMobile` (#4051) + +* reject MLS messages for future epochs (#4110) + +* Introduce more configuration options to the `coturn` helm chart (#4083) + +* Update email templates to v1.0.121. (#4064) + +* Support connecting to RabbitMQ over TLS. See "Configure RabbitMQ" section in the documentation for details. (#4094) + +* Support connecting to Redis over TLS + + It can be enabled by setting these options on the wire-server helm chart: + + ```yaml + gundeck: + config: + redis: + enableTls: true + + # When custom CAs are required, one of these must be set: + tlsCa: + tlsCaSecretRef: + name: + key: + + # When TLS needs to be used without verification: + insecureSkipVerifyTls: true + ``` + (#4016) + + +## Bug fixes and other updates + + +* fixed stern endpoint `/i/users/meta-info` (#4101) + +* Log password reset errors instead of propagating them (#4114) + +* Log request ids in brig. (#4086) + +* Do not set update origin "scim" in public brig api. (#4072) + +* Disabling legalhold before user's approval doesn't result in an error (#4104) + +* Make scim-delete-user idempotent. Hide information about existing users (make delete idempotent) (#4120) + +* Expose /providers/assets via nginz (#4082) + +* federator: Expect a client certificate to be the certificate chain + + Without this openssl doesn't forward to whole chain causing mTLS to not succeed. (#4089) + +* Only resend proposals once after external commit (#4103) + +* gundeck: Better tolerance for redis-cluster restarts (#4084) + +* GHC does not support repeated --with-rtsopts options, and it simply applies the last one. This means many of the baked-in options were actually not being passed, including -N for some of the services and -T for cannon. (#4118) + +* Ensure that a Request ID is logged whenever unexpected errors are caught in any service (#4059) + +* charts/coturn: use allowed dir to write PID file (#4098) + +* Make pending LH requests (with no LH devices listening yet) not throw LH policy errors. This helps eg. in cases where a LH request is issued to the wrong user by accident, and the user can clear up the mistake. (#4056) + + +## Documentation + + +* Adjust documentation for migrated helm charts (#4058) + + +## Internal changes + + +* Adapt EJPD data to current requirements. (#3945) + +* Port team feature tests to the `integration` package (#4063) + +* Ported flaky legalhold test to the new integration test suite (#4057) + +* Added profile update operations to the user subsystem. (#4046) + +* Introduce authentication subsystem with password reset. (#4086) + +* update nixpkgs and hence GHC version as well as some other tooling. (#4071) + +* nginz: Added `allowlisted_fqdn_origins` to `nginx_conf` value (#4087) + +* Add weeder for dead code elimination. (#4088) + +* Introduce email subsystem (#4111) + +* replace cabal.project.local template and update cabal.project (#4119) + +* Add HTTP proxy in the local setup for elasticsearch in federation-v0. This makes it possible to use a single elasticsearch instance for both the main backends and federation-v0. (#4062) + +* federator: Add metrics for garbage collections and unexpected errors that were caught (#4085) + +* federator: Simplify polysemy setup to make it similar to other services so the + interpreter is only used for hoisting the servant application and not explicitly + inside handler of an endpoint (#4059) + +* Added prometheus enable and datacenter size variables for k8ssandra-test-cluster helm chart. (#4011) + +* Make `Handle` type abstract to guarantee it always contains *valid* Handles. (#4076) + +* metrics-core: Delete `Data.Metrics` in favour of defining metrics closer to where they are being emitted (#4085) + +* add more metadata into the meta attribute of all nix derivations produced locally (#4069) + +* Do not log anything when warp kills a worker thread. (#4112) + +* Introduce VerificationCodSubsystem (#4121) + +* add tests for bots that use self-signed certs and add documentation on why we cannot test the bots to work with PKI (#4027) + + # [2024-05-21] (Chart Release 5.3.0) ## API changes diff --git a/Makefile b/Makefile index 40e8876bb52..7ec7a59287a 100644 --- a/Makefile +++ b/Makefile @@ -73,8 +73,7 @@ clean-hint: .PHONY: cabal.project.local cabal.project.local: - echo "optimization: False" > ./cabal.project.local - ./hack/bin/cabal-project-local-template.sh "ghc-options: -O0" >> ./cabal.project.local + cp ./hack/bin/cabal.project.local.template ./cabal.project.local # Usage: make c package=brig test=1 .PHONY: c @@ -127,11 +126,8 @@ devtest: ghcid --command 'cabal repl integration' --test='Testlib.Run.mainI []' .PHONY: sanitize-pr -sanitize-pr: - ./hack/bin/generate-local-nix-packages.sh - make formatf - make hlint-inplace-pr - make hlint-check-pr # sometimes inplace has been observed not to do its job very well. +sanitize-pr: + make lint-all-shallow make git-add-cassandra-schema @git diff-files --quiet -- || ( echo "There are unstaged changes, please take a look, consider committing them, and try again."; exit 1 ) @git diff-index --quiet --cached HEAD -- || ( echo "There are staged changes, please take a look, consider committing them, and try again."; exit 1 ) @@ -155,7 +151,25 @@ ghcid: # Used by CI .PHONY: lint-all -lint-all: formatc hlint-check-all check-local-nix-derivations treefmt-check +lint-all: formatc hlint-check-all lint-common + +# For use by local devs. +# +# This is not safe for CI because files not changed on the branch may +# have been pushed to develop, or caused by merging develop into the +# branch implicitly on github. +# +# The extra 'hlint-check-pr' has been witnessed to be necessary due to +# some bu in `hlint-inplace-pr`. Details got lost in history. +.PHONY: lint-all-shallow +lint-all-shallow: formatf hlint-inplace-pr hlint-check-pr lint-common + +.PHONY: lint-common +lint-common: check-local-nix-derivations treefmt-check # weeder (does not work on CI yet) + +.PHONY: weeder +weeder: + weeder -N .PHONY: hlint-check-all hlint-check-all: diff --git a/cabal.project b/cabal.project index 5ebc608c29e..fe2c42af262 100644 --- a/cabal.project +++ b/cabal.project @@ -19,7 +19,6 @@ packages: , libs/metrics-core/ , libs/metrics-wai/ , libs/polysemy-wire-zoo/ - , libs/ropes/ , libs/schema-profunctor/ , libs/sodium-crypto-sign/ , libs/ssl-util/ @@ -62,117 +61,7 @@ packages: tests: True benchmarks: True -package assets - ghc-options: -Werror -package auto-whitelist - ghc-options: -Werror -package background-worker - ghc-options: -Werror -package bilge - ghc-options: -Werror -package brig - ghc-options: -Werror -package brig-types - ghc-options: -Werror -package cannon - ghc-options: -Werror -package cargohold - ghc-options: -Werror -package cargohold-types - ghc-options: -Werror -package cassandra-util - ghc-options: -Werror -package deriving-swagger2 - ghc-options: -Werror -package dns-util - ghc-options: -Werror -package extended - ghc-options: -Werror -package federator - ghc-options: -Werror -package find-undead - ghc-options: -Werror -package galley - ghc-options: -Werror -package galley-types - ghc-options: -Werror -package gundeck - ghc-options: -Werror -package gundeck-types - ghc-options: -Werror -package hscim - ghc-options: -Werror -package http2-manager - ghc-options: -Werror -package inconsistencies - ghc-options: -Werror -package integration - ghc-options: -Werror -package imports - ghc-options: -Werror -package jwt-tools - ghc-options: -Werror -package metrics-core - ghc-options: -Werror -package metrics-wai - ghc-options: -Werror -package migrate-sso-feature-flag - ghc-options: -Werror -package mlsstats - ghc-options: -Werror -package move-team - ghc-options: -Werror -package polysemy-wire-zoo - ghc-options: -Werror -package proxy - ghc-options: -Werror -package mlsstats - ghc-options: -Werror -package phone-users - ghc-options: -Werror -package rabbitmq-consumer - ghc-options: -Werror -package repair-handles - ghc-options: -Werror -package rex - ghc-options: -Werror -package ropes - ghc-options: -Werror -package schema-profunctor - ghc-options: -Werror -package service-backfill - ghc-options: -Werror -package sodium-crypto-sign - ghc-options: -Werror -package spar - ghc-options: -Werror -package ssl-util - ghc-options: -Werror -package stern - ghc-options: -Werror -package tasty-cannon - ghc-options: -Werror -package test-stats - ghc-options: -Werror -package types-common - ghc-options: -Werror -package types-common-aws - ghc-options: -Werror -package types-common-journal - ghc-options: -Werror -package wai-utilities - ghc-options: -Werror -package wire-api - ghc-options: -Werror -package wire-api-federation - ghc-options: -Werror -package wire-message-proto-lens - ghc-options: -Werror -package wire-subsystems - ghc-options: -Werror -package zauth - ghc-options: -Werror -package fedcalls +program-options ghc-options: -Werror -- NOTE: diff --git a/cassandra-schema.cql b/cassandra-schema.cql index 06052e52b77..bbeefe5b6e3 100644 --- a/cassandra-schema.cql +++ b/cassandra-schema.cql @@ -1205,9 +1205,11 @@ CREATE TABLE galley_test.team_features ( mls_default_ciphersuite int, mls_default_protocol int, mls_e2eid_acme_discovery_url blob, + mls_e2eid_crl_proxy blob, mls_e2eid_grace_period int, mls_e2eid_lock_status int, mls_e2eid_status int, + mls_e2eid_use_proxy_on_mobile boolean, mls_e2eid_ver_exp timestamp, mls_lock_status int, mls_migration_finalise_regardless_after timestamp, diff --git a/charts/background-worker/templates/configmap.yaml b/charts/background-worker/templates/configmap.yaml index 1a03ad0d5e4..fea77ab59d5 100644 --- a/charts/background-worker/templates/configmap.yaml +++ b/charts/background-worker/templates/configmap.yaml @@ -21,8 +21,19 @@ data: host: federator port: 8080 + {{- with .rabbitmq }} rabbitmq: -{{toYaml .rabbitmq | indent 6 }} + host: {{ .host }} + port: {{ .port }} + vHost: {{ .vHost }} + adminPort: {{ .adminPort }} + enableTls: {{ .enableTls }} + insecureSkipVerifyTls: {{ .insecureSkipVerifyTls }} + {{- if .tlsCaSecretRef }} + caCert: /etc/wire/background-worker/rabbitmq-ca/{{ .tlsCaSecretRef.key }} + {{- end }} + {{- end }} + backendNotificationPusher: {{toYaml .backendNotificationPusher | indent 6 }} {{- end }} diff --git a/charts/background-worker/templates/deployment.yaml b/charts/background-worker/templates/deployment.yaml index 2f556f6fc5d..bbc0b6f71f4 100644 --- a/charts/background-worker/templates/deployment.yaml +++ b/charts/background-worker/templates/deployment.yaml @@ -36,6 +36,11 @@ spec: - name: "background-worker-secrets" secret: secretName: "background-worker" + {{- if .Values.config.rabbitmq.tlsCaSecretRef }} + - name: "rabbitmq-ca" + secret: + secretName: {{ .Values.config.rabbitmq.tlsCaSecretRef.name }} + {{- end }} containers: - name: background-worker image: "{{ .Values.image.repository }}:{{ .Values.image.tag }}" @@ -47,6 +52,10 @@ spec: volumeMounts: - name: "background-worker-config" mountPath: "/etc/wire/background-worker/conf" + {{- if .Values.config.rabbitmq.tlsCaSecretRef }} + - name: "rabbitmq-ca" + mountPath: "/etc/wire/background-worker/rabbitmq-ca/" + {{- end }} env: - name: RABBITMQ_USERNAME valueFrom: diff --git a/charts/background-worker/values.yaml b/charts/background-worker/values.yaml index a7a552a4536..e38cd9c8225 100644 --- a/charts/background-worker/values.yaml +++ b/charts/background-worker/values.yaml @@ -23,6 +23,12 @@ config: port: 5672 vHost: / adminPort: 15672 + enableTls: false + insecureSkipVerifyTls: false + # tlsCaSecretRef: + # name: + # key: + backendNotificationPusher: pushBackoffMinWait: 10000 # in microseconds, so 10ms pushBackoffMaxWait: 300000000 # microseconds, so 300s diff --git a/charts/brig/templates/configmap.yaml b/charts/brig/templates/configmap.yaml index 8e002aa35a7..669e047bdc9 100644 --- a/charts/brig/templates/configmap.yaml +++ b/charts/brig/templates/configmap.yaml @@ -80,8 +80,18 @@ data: federatorInternal: host: federator port: 8080 + + {{- with .rabbitmq }} rabbitmq: -{{ toYaml .rabbitmq | indent 6}} + host: {{ .host }} + port: {{ .port }} + vHost: {{ .vHost }} + enableTls: {{ .enableTls }} + insecureSkipVerifyTls: {{ .insecureSkipVerifyTls }} + {{- if .tlsCaSecretRef }} + caCert: /etc/wire/brig/rabbitmq-ca/{{ .tlsCaSecretRef.key }} + {{- end }} + {{- end }} {{- end }} {{- with .aws }} @@ -243,8 +253,6 @@ data: {{- if .setExpiredUserCleanupTimeout }} setExpiredUserCleanupTimeout: {{ .setExpiredUserCleanupTimeout }} {{- end }} - setTwilio: /etc/wire/brig/secrets/twilio-credentials.yaml - setNexmo: /etc/wire/brig/secrets/nexmo-credentials.yaml setUserMaxConnections: {{ .setUserMaxConnections }} setCookieInsecure: {{ .setCookieInsecure }} setUserCookieRenewAge: {{ .setUserCookieRenewAge }} diff --git a/charts/brig/templates/deployment.yaml b/charts/brig/templates/deployment.yaml index dea3c0dacba..cff8bffd9bb 100644 --- a/charts/brig/templates/deployment.yaml +++ b/charts/brig/templates/deployment.yaml @@ -57,6 +57,11 @@ spec: secret: secretName: {{ include "additionalElasticsearchTlsSecretName" .Values.config }} {{- end }} + {{- if .Values.config.rabbitmq.tlsCaSecretRef }} + - name: "rabbitmq-ca" + secret: + secretName: {{ .Values.config.rabbitmq.tlsCaSecretRef.name }} + {{- end }} containers: - name: brig @@ -87,6 +92,10 @@ spec: - name: "additional-elasticsearch-ca" mountPath: "/etc/wire/brig/additional-elasticsearch-ca/" {{- end }} + {{- if .Values.config.rabbitmq.tlsCaSecretRef }} + - name: "rabbitmq-ca" + mountPath: "/etc/wire/brig/rabbitmq-ca/" + {{- end }} env: - name: LOG_LEVEL value: {{ .Values.config.logLevel }} diff --git a/charts/brig/templates/secret.yaml b/charts/brig/templates/secret.yaml index c2359979f57..b596954c7d8 100644 --- a/charts/brig/templates/secret.yaml +++ b/charts/brig/templates/secret.yaml @@ -20,8 +20,6 @@ data: awsKeyId: {{ .awsKeyId | b64enc | quote }} awsSecretKey: {{ .awsSecretKey | b64enc | quote }} {{- end }} - twilio-credentials.yaml: {{ .setTwilio | b64enc | quote }} - nexmo-credentials.yaml: {{ .setNexmo | b64enc | quote }} {{- if (not $.Values.config.useSES) }} smtp-password.txt: {{ .smtpPassword | b64enc | quote }} {{- end }} diff --git a/charts/brig/templates/tests/brig-integration.yaml b/charts/brig/templates/tests/brig-integration.yaml index 62bea731895..15996698ba8 100644 --- a/charts/brig/templates/tests/brig-integration.yaml +++ b/charts/brig/templates/tests/brig-integration.yaml @@ -54,6 +54,11 @@ spec: secret: secretName: {{ (include "tlsSecretRef" .Values.config | fromYaml).name }} {{- end}} + {{- if .Values.config.rabbitmq.tlsCaSecretRef }} + - name: "rabbitmq-ca" + secret: + secretName: {{ .Values.config.rabbitmq.tlsCaSecretRef.name }} + {{- end }} containers: - name: integration image: "{{ .Values.image.repository }}-integration:{{ .Values.image.tag }}" @@ -119,6 +124,10 @@ spec: - name: "brig-cassandra" mountPath: "/etc/wire/brig/cassandra" {{- end }} + {{- if .Values.config.rabbitmq.tlsCaSecretRef }} + - name: "rabbitmq-ca" + mountPath: "/etc/wire/brig/rabbitmq-ca/" + {{- end }} env: # these dummy values are necessary for Amazonka's "Discover" diff --git a/charts/brig/values.yaml b/charts/brig/values.yaml index e11aa931a5a..7dcedbce2dc 100644 --- a/charts/brig/values.yaml +++ b/charts/brig/values.yaml @@ -69,6 +69,11 @@ config: host: rabbitmq port: 5672 vHost: / + enableTls: false + insecureSkipVerifyTls: false + # tlsCaSecretRef: + # name: + # key: emailSMS: general: templateBranding: diff --git a/charts/coturn/Chart.yaml b/charts/coturn/Chart.yaml index a5b11da7b38..6a8abef6c9d 100644 --- a/charts/coturn/Chart.yaml +++ b/charts/coturn/Chart.yaml @@ -11,4 +11,4 @@ version: 0.0.42 # This is the version number of the application being deployed. This version number should be # incremented each time you make changes to the application. Versions are not expected to # follow Semantic Versioning. They should reflect the version the application is using. -appVersion: 4.6.2-federation-wireapp.12 +appVersion: 4.6.2-federation-wireapp.16 diff --git a/charts/coturn/templates/configmap-coturn-conf-template.yaml b/charts/coturn/templates/configmap-coturn-conf-template.yaml index b020ee5080d..f829900ad1c 100644 --- a/charts/coturn/templates/configmap-coturn-conf-template.yaml +++ b/charts/coturn/templates/configmap-coturn-conf-template.yaml @@ -26,17 +26,22 @@ data: ## don't turn on coturn's cli. no-cli + pidfile="/var/tmp/turnserver.pid" + ## turn, stun. listening-ip={{ default "__COTURN_EXT_IP__" .Values.coturnTurnListenIP }} listening-port={{ .Values.coturnTurnListenPort }} - relay-ip=__COTURN_EXT_IP__ + relay-ip={{ default "__COTURN_EXT_IP__" .Values.coturnTurnRelayIP }} + {{- if .Values.coturnTurnExternalIP }} + external-ip={{ default "__COTURN_EXT_IP__" .Values.coturnTurnExternalIP }} + {{- end }} realm=dummy.io no-stun-backward-compatibility secure-stun no-rfc5780 ## prometheus metrics - prometheus-ip=__COTURN_POD_IP__ + prometheus-ip={{ default "__COTURN_POD_IP__" .Values.coturnPrometheusIP }} prometheus-port={{ .Values.coturnMetricsListenPort }} ## logs @@ -87,7 +92,7 @@ data: {{- if .Values.federate.enabled }} ### federation setup - federation-listening-ip=__COTURN_EXT_IP__ + federation-listening-ip={{ default "__COTURN_EXT_IP__" .Values.coturnFederationListeningIP }} federation-listening-port={{ .Values.federate.port }} federation-no-dtls={{ not .Values.federate.dtls.enabled }} {{- if .Values.federate.dtls.enabled }} diff --git a/charts/coturn/templates/statefulset.yaml b/charts/coturn/templates/statefulset.yaml index d2b9c7ef9b7..e33c8be7ae2 100644 --- a/charts/coturn/templates/statefulset.yaml +++ b/charts/coturn/templates/statefulset.yaml @@ -100,6 +100,10 @@ spec: valueFrom: fieldRef: fieldPath: metadata.name + - name: HOST_IP + valueFrom: + fieldRef: + fieldPath: status.hostIP volumeMounts: - name: external-ip mountPath: /external-ip @@ -127,12 +131,14 @@ spec: readOnly: true {{- end }} command: + - /usr/bin/dumb-init + - -- - /bin/sh - -c - | set -e EXTERNAL_IP=$(cat /external-ip/ip) - sed -Ee "s;__COTURN_EXT_IP__;$EXTERNAL_IP;g" -e "s;__COTURN_POD_IP__;$POD_IP;g" /coturn-template/coturn.conf.template > /coturn-config/turnserver.conf + sed -Ee "s;__COTURN_EXT_IP__;$EXTERNAL_IP;g" -e "s;__COTURN_POD_IP__;$POD_IP;g" -e "s;__COTURN_HOST_IP__;$HOST_IP;g" /coturn-template/coturn.conf.template > /coturn-config/turnserver.conf sed -Ee 's/^/static-auth-secret=/' /secrets/zrest_secret.txt >> /coturn-config/turnserver.conf exec /usr/bin/turnserver -c /coturn-config/turnserver.conf {{- if .Values.coturnGracefulTermination }} @@ -142,7 +148,7 @@ spec: command: - /bin/sh - -c - - exec /usr/local/bin/pre-stop-hook "$POD_IP" {{ .Values.coturnMetricsListenPort }} + - "exec /usr/local/bin/pre-stop-hook \"$POD_IP\" {{ .Values.coturnMetricsListenPort }}" {{- end }} ports: diff --git a/charts/coturn/values.yaml b/charts/coturn/values.yaml index 10279a6aa3e..fc6fe3b2917 100644 --- a/charts/coturn/values.yaml +++ b/charts/coturn/values.yaml @@ -26,9 +26,11 @@ coturnTurnListenPort: 3478 coturnMetricsListenPort: 9641 coturnTurnTlsListenPort: 5349 -# If you need to specify which IP Coturn should bind to. -# This will typically be the IP of the kubenode. -# coturnTurnListenIP: "182.168.22.133" +# coturnTurnListenIP: "1.2.3.4" # can also be __COTURN_EXT_IP__, __COTURN_POD_IP__,__COTURN_HOST_IP__ +coturnTurnExternalIP: null +# coturnTurnRelayIP: +# coturnPrometheusIP: +# coturnFederationListeningIP: tls: enabled: false @@ -93,17 +95,17 @@ metrics: serviceMonitor: enabled: false -# This chart optionally supports waiting for traffic to drain from coturn -# before pods are terminated. Warning: coturn does not have any way to steer -# incoming client traffic away from itself on its own, so this functionality -# relies on external traffic management (e.g. service discovery for active coturn -# instances) to prevent clients from sending new requests to pods which are in a -# terminating state. +# This chart supports waiting for traffic to drain from coturn +# before pods are actually terminated. Once in 'drain' mode, no new connections +# are accepted, but old ones are kept alive. +# If you have 2 or more replicas, it's recommended to set this to true, +# and if you only have one coturn replica you may want this to be false, as +# otherwise while the pod restarts, no new calls can be established. coturnGracefulTermination: false # Grace period for terminating coturn pods, after which they will be forcibly # terminated. This setting is only effective when coturnGracefulTermination is # set to true. -coturnGracePeriodSeconds: 86400 # one day +coturnGracePeriodSeconds: 43200 # 12 hours livenessProbe: timeoutSeconds: 5 diff --git a/charts/galley/templates/configmap.yaml b/charts/galley/templates/configmap.yaml index 1043cc17416..ea0cd15354c 100644 --- a/charts/galley/templates/configmap.yaml +++ b/charts/galley/templates/configmap.yaml @@ -41,8 +41,18 @@ data: federator: host: federator port: 8080 + + {{- with .rabbitmq }} rabbitmq: -{{ toYaml .rabbitmq | indent 6}} + host: {{ .host }} + port: {{ .port }} + vHost: {{ .vHost }} + enableTls: {{ .enableTls }} + insecureSkipVerifyTls: {{ .insecureSkipVerifyTls }} + {{- if .tlsCaSecretRef }} + caCert: /etc/wire/galley/rabbitmq-ca/{{ .tlsCaSecretRef.key }} + {{- end }} + {{- end }} {{- end }} {{- if (.journal) }} diff --git a/charts/galley/templates/deployment.yaml b/charts/galley/templates/deployment.yaml index df9eee0c206..ebfb5582abd 100644 --- a/charts/galley/templates/deployment.yaml +++ b/charts/galley/templates/deployment.yaml @@ -41,6 +41,11 @@ spec: secret: secretName: {{ (include "tlsSecretRef" .Values.config | fromYaml).name }} {{- end }} + {{- if .Values.config.rabbitmq.tlsCaSecretRef }} + - name: "rabbitmq-ca" + secret: + secretName: {{ .Values.config.rabbitmq.tlsCaSecretRef.name }} + {{- end }} containers: - name: galley image: "{{ .Values.image.repository }}:{{ .Values.image.tag }}" @@ -58,6 +63,10 @@ spec: - name: "galley-cassandra" mountPath: "/etc/wire/galley/cassandra" {{- end }} + {{- if .Values.config.rabbitmq.tlsCaSecretRef }} + - name: "rabbitmq-ca" + mountPath: "/etc/wire/galley/rabbitmq-ca/" + {{- end }} env: {{- if hasKey .Values.secrets "awsKeyId" }} - name: AWS_ACCESS_KEY_ID diff --git a/charts/galley/templates/tests/galley-integration.yaml b/charts/galley/templates/tests/galley-integration.yaml index 1fdd9e206ac..b7f71d353e6 100644 --- a/charts/galley/templates/tests/galley-integration.yaml +++ b/charts/galley/templates/tests/galley-integration.yaml @@ -45,6 +45,11 @@ spec: secret: secretName: {{ (include "tlsSecretRef" .Values.config | fromYaml).name }} {{- end }} + {{- if .Values.config.rabbitmq.tlsCaSecretRef }} + - name: "rabbitmq-ca" + secret: + secretName: {{ .Values.config.rabbitmq.tlsCaSecretRef.name }} + {{- end }} containers: - name: integration image: "{{ .Values.image.repository }}-integration:{{ .Values.image.tag }}" @@ -93,6 +98,10 @@ spec: - name: "galley-cassandra" mountPath: "/etc/wire/galley/cassandra" {{- end }} + {{- if .Values.config.rabbitmq.tlsCaSecretRef }} + - name: "rabbitmq-ca" + mountPath: "/etc/wire/galley/rabbitmq-ca/" + {{- end }} env: # these dummy values are necessary for Amazonka's "Discover" - name: AWS_ACCESS_KEY_ID diff --git a/charts/galley/values.yaml b/charts/galley/values.yaml index 8239f4019e8..1d170d39883 100644 --- a/charts/galley/values.yaml +++ b/charts/galley/values.yaml @@ -35,6 +35,11 @@ config: host: rabbitmq port: 5672 vHost: / + enableTls: false + insecureSkipVerifyTls: false + # tlsCaSecretRef: + # name: + # key: settings: httpPoolSize: 128 maxTeamSize: 10000 diff --git a/charts/gundeck/templates/_helpers.tpl b/charts/gundeck/templates/_helpers.tpl index ed317e0b213..e51069720fc 100644 --- a/charts/gundeck/templates/_helpers.tpl +++ b/charts/gundeck/templates/_helpers.tpl @@ -23,3 +23,43 @@ created one (in case the CA is provided as PEM string.) {{- dict "name" "gundeck-cassandra" "key" "ca.pem" | toYaml -}} {{- end -}} {{- end -}} + +{{- define "configureRedisCa" -}} +{{ or (hasKey .redis "tlsCa") (hasKey .redis "tlsCaSecretRef") }} +{{- end -}} + +{{- define "redisTlsSecretName" -}} +{{- if .redis.tlsCaSecretRef -}} +{{ .redis.tlsCaSecretRef.name }} +{{- else }} +{{- print "gundeck-redis-ca" -}} +{{- end -}} +{{- end -}} + +{{- define "redisTlsSecretKey" -}} +{{- if .redis.tlsCaSecretRef -}} +{{ .redis.tlsCaSecretRef.key }} +{{- else }} +{{- print "ca.pem" -}} +{{- end -}} +{{- end -}} + +{{- define "configureAdditionalRedisCa" -}} +{{ and (hasKey . "redisAdditionalWrite") (or (hasKey .redisAdditionalWrite "additionalTlsCa") (hasKey .redis "additionalTlsCaSecretRef")) }} +{{- end -}} + +{{- define "additionalRedisTlsSecretName" -}} +{{- if .redis.additionalTlsCaSecretRef -}} +{{ .redis.additionalTlsCaSecretRef.name }} +{{- else }} +{{- print "gundeck-additional-redis-ca" -}} +{{- end -}} +{{- end -}} + +{{- define "additionalRedisTlsSecretKey" -}} +{{- if .redis.additionalTlsCaSecretRef -}} +{{ .redis.additionalTlsCaSecretRef.key }} +{{- else }} +{{- print "ca.pem" -}} +{{- end -}} +{{- end -}} diff --git a/charts/gundeck/templates/configmap.yaml b/charts/gundeck/templates/configmap.yaml index bd49b906760..446fa7bab39 100644 --- a/charts/gundeck/templates/configmap.yaml +++ b/charts/gundeck/templates/configmap.yaml @@ -33,10 +33,22 @@ data: host: {{ .redis.host }} port: {{ .redis.port }} connectionMode: {{ .redis.connectionMode }} + enableTls: {{ .redis.enableTls }} + insecureSkipVerifyTls: {{ .redis.insecureSkipVerifyTls }} + {{- if eq (include "configureRedisCa" .) "true" }} + tlsCa: /etc/wire/gundeck/redis-ca/{{ include "redisTlsSecretKey" .}} + {{- end }} {{- if .redisAdditionalWrite }} redisAdditionalWrite: - {{- toYaml .redisAdditionalWrite | nindent 6 }} + host: {{ .redisAdditionalWrite.host }} + port: {{ .redisAdditionalWrite.port }} + connectionMode: {{ .redisAdditionalWrite.connectionMode }} + enableTls: {{ .redisAdditionalWrite.enableTls }} + insecureSkipVerifyTls: {{ .redisAdditionalWrite.insecureSkipVerifyTls }} + {{- if eq (include "configureAdditionalRedisCa" .) "true" }} + tlsCa: /etc/wire/gundeck/additional-redis-ca/{{ include "additionalRedisTlsSecretKey" .}} + {{- end }} {{- end }} # Gundeck uses discovery for AWS access key / secrets diff --git a/charts/gundeck/templates/deployment.yaml b/charts/gundeck/templates/deployment.yaml index ec1e064ccc2..5afbdd9c4cf 100644 --- a/charts/gundeck/templates/deployment.yaml +++ b/charts/gundeck/templates/deployment.yaml @@ -37,6 +37,16 @@ spec: secret: secretName: {{ (include "tlsSecretRef" .Values.config | fromYaml).name }} {{- end}} + {{- if eq (include "configureRedisCa" .Values.config) "true" }} + - name: "redis-ca" + secret: + secretName: {{ include "redisTlsSecretName" .Values.config }} + {{- end }} + {{- if eq (include "configureAdditionalRedisCa" .Values.config) "true" }} + - name: "additional-redis-ca" + secret: + secretName: {{ include "additionalRedisTlsSecretName" .Values.config }} + {{- end }} containers: - name: gundeck image: "{{ .Values.image.repository }}:{{ .Values.image.tag }}" @@ -52,6 +62,14 @@ spec: - name: "gundeck-cassandra" mountPath: "/etc/wire/gundeck/cassandra" {{- end }} + {{- if eq (include "configureRedisCa" .Values.config) "true" }} + - name: "redis-ca" + mountPath: "/etc/wire/gundeck/redis-ca/" + {{- end }} + {{- if eq (include "configureAdditionalRedisCa" .Values.config) "true" }} + - name: "additional-redis-ca" + mountPath: "/etc/wire/gundeck/additional-redis-ca/" + {{- end }} env: {{- if hasKey .Values.secrets "awsKeyId" }} - name: AWS_ACCESS_KEY_ID diff --git a/charts/gundeck/templates/redis-ca-secret.yaml b/charts/gundeck/templates/redis-ca-secret.yaml new file mode 100644 index 00000000000..de1f752e55a --- /dev/null +++ b/charts/gundeck/templates/redis-ca-secret.yaml @@ -0,0 +1,30 @@ +--- +{{- if not (empty .Values.config.redis.tlsCa) }} +apiVersion: v1 +kind: Secret +metadata: + name: "gundeck-redis-ca" + labels: + app: gundeck + chart: {{ .Chart.Name }}-{{ .Chart.Version | replace "+" "_" }} + release: "{{ .Release.Name }}" + heritage: "{{ .Release.Service }}" +type: Opaque +data: + ca.pem: {{ .Values.config.redis.tlsCa | b64enc | quote }} +{{- end }} +--- +{{- if not (empty .Values.config.redis.additionalTlsCa) }} +apiVersion: v1 +kind: Secret +metadata: + name: "gundeck-additional-redis-ca" + labels: + app: gundeck + chart: {{ .Chart.Name }}-{{ .Chart.Version | replace "+" "_" }} + release: "{{ .Release.Name }}" + heritage: "{{ .Release.Service }}" +type: Opaque +data: + ca.pem: {{ .Values.config.redis.additionalTlsCa | b64enc | quote }} +{{- end }} diff --git a/charts/gundeck/templates/tests/configmap.yaml b/charts/gundeck/templates/tests/configmap.yaml index b3e1423acf6..dd05cb6d4df 100644 --- a/charts/gundeck/templates/tests/configmap.yaml +++ b/charts/gundeck/templates/tests/configmap.yaml @@ -44,3 +44,5 @@ data: host: redis-ephemeral-2-master port: 6379 connectionMode: master + enableTls: false + insecureSkipVerifyTls: false diff --git a/charts/gundeck/templates/tests/gundeck-integration.yaml b/charts/gundeck/templates/tests/gundeck-integration.yaml index 088ed679bdb..9aa7b56347d 100644 --- a/charts/gundeck/templates/tests/gundeck-integration.yaml +++ b/charts/gundeck/templates/tests/gundeck-integration.yaml @@ -18,6 +18,11 @@ spec: secret: secretName: {{ (include "tlsSecretRef" .Values.config | fromYaml).name }} {{- end}} + {{- if eq (include "configureRedisCa" .Values.config) "true" }} + - name: "redis-ca" + secret: + secretName: {{ include "redisTlsSecretName" .Values.config }} + {{- end }} containers: - name: integration # TODO: When deployed to staging (or real AWS env), _all_ tests should be run @@ -63,6 +68,10 @@ spec: - name: "gundeck-cassandra" mountPath: "/etc/wire/gundeck/cassandra" {{- end }} + {{- if eq (include "configureRedisCa" .Values.config) "true" }} + - name: "redis-ca" + mountPath: "/etc/wire/gundeck/redis-ca/" + {{- end }} env: # these dummy values are necessary for Amazonka's "Discover" - name: AWS_ACCESS_KEY_ID diff --git a/charts/gundeck/values.yaml b/charts/gundeck/values.yaml index 80816a0eaad..ea8b6406a51 100644 --- a/charts/gundeck/values.yaml +++ b/charts/gundeck/values.yaml @@ -20,21 +20,42 @@ config: logNetStrings: false cassandra: host: aws-cassandra -# To enable TLS provide a CA: -# tlsCa: -# -# Or refer to an existing secret (containing the CA): -# tlsCaSecretRef: -# name: -# key: + # To enable TLS provide a CA: + # tlsCa: + # + # Or refer to an existing secret (containing the CA): + # tlsCaSecretRef: + # name: + # key: redis: host: redis-ephemeral-master port: 6379 connectionMode: "master" # master | cluster + enableTls: false + insecureSkipVerifyTls: false + # To configure custom TLS CA, please provide one of these: + # tlsCa: + # + # Or refer to an existing secret (containing the CA): + # tlsCaSecretRef: + # name: + # key: + + # To enable additional writes during a migration: # redisAdditionalWrite: # host: redis-two # port: 6379 # connectionMode: master + # enableTls: false + # insecureSkipVerifyTls: false + # + # # To configure custom TLS CA, please provide one of these: + # # tlsCa: + # # + # # Or refer to an existing secret (containing the CA): + # # tlsCaSecretRef: + # # name: + # # key: bulkPush: true aws: region: "eu-west-1" diff --git a/charts/integration/templates/configmap.yaml b/charts/integration/templates/configmap.yaml index 2c2178dc14f..ca2d49f9bec 100644 --- a/charts/integration/templates/configmap.yaml +++ b/charts/integration/templates/configmap.yaml @@ -59,7 +59,7 @@ data: rabbitmq: host: rabbitmq - adminPort: 15672 + adminPort: 15671 backendTwo: diff --git a/charts/integration/templates/integration-integration.yaml b/charts/integration/templates/integration-integration.yaml index fa5e32bb604..56dbf2bf8e7 100644 --- a/charts/integration/templates/integration-integration.yaml +++ b/charts/integration/templates/integration-integration.yaml @@ -80,6 +80,14 @@ spec: secret: secretName: {{ .Values.config.elasticsearch.tlsCaSecretRef.name }} + - name: redis-ca + secret: + secretName: {{ .Values.config.redis.tlsCaSecretRef.name }} + + - name: rabbitmq-ca + secret: + secretName: {{ .Values.config.rabbitmq.tlsCaSecretRef.name }} + {{- if eq (include "useCassandraTLS" .Values.config) "true" }} - name: integration-cassandra secret: @@ -101,6 +109,8 @@ spec: - name: "integration-cassandra" mountPath: "/certs/cassandra" {{- end }} + - name: rabbitmq-ca + mountPath: /certs/rabbitmq-ca env: - name: INTEGRATION_DYNAMIC_BACKENDS_POOLSIZE value: "{{ .Values.config.dynamicBackendsPoolsize }}" @@ -239,6 +249,18 @@ spec: - name: elasticsearch-ca mountPath: /etc/wire/brig/elasticsearch-ca + - name: redis-ca + mountPath: /etc/wire/gundeck/redis-ca + + - name: rabbitmq-ca + mountPath: /etc/wire/brig/rabbitmq-ca + + - name: rabbitmq-ca + mountPath: /etc/wire/galley/rabbitmq-ca + + - name: rabbitmq-ca + mountPath: /etc/wire/background-worker/rabbitmq-ca + {{- if eq (include "useCassandraTLS" .Values.config) "true" }} - name: "integration-cassandra" mountPath: "/certs" diff --git a/charts/k8ssandra-test-cluster/templates/k8ssandra-cluster.yaml b/charts/k8ssandra-test-cluster/templates/k8ssandra-cluster.yaml index 35197d8b8fd..33c39c50d90 100644 --- a/charts/k8ssandra-test-cluster/templates/k8ssandra-cluster.yaml +++ b/charts/k8ssandra-test-cluster/templates/k8ssandra-cluster.yaml @@ -9,7 +9,7 @@ spec: serverVersion: "3.11.11" telemetry: prometheus: - enabled: true + enabled: {{ .Values.prometheus.enabled }} resources: requests: cpu: 1 @@ -33,7 +33,7 @@ spec: datacenters: - metadata: name: datacenter-1 - size: 1 + size: {{ .Values.datacenter.size }} storageConfig: cassandraDataVolumeClaimSpec: storageClassName: {{ .Values.storageClassName }} diff --git a/charts/k8ssandra-test-cluster/values.yaml b/charts/k8ssandra-test-cluster/values.yaml index a34ca0da5f5..239dba3c21d 100644 --- a/charts/k8ssandra-test-cluster/values.yaml +++ b/charts/k8ssandra-test-cluster/values.yaml @@ -30,3 +30,11 @@ syncCACertToSecret: false # Limit syncing to this namespace. Otherwise, the secret is synced to all # namespaces. # syncCACertNamespace: + +# For telemetry data +prometheus: + enabled: true + +# Size of the datacenter +datacenter: + size: 1 diff --git a/charts/nginx-ingress-services/templates/service.yaml b/charts/nginx-ingress-services/templates/service.yaml index 1acbc358089..4bcfa2fce4f 100644 --- a/charts/nginx-ingress-services/templates/service.yaml +++ b/charts/nginx-ingress-services/templates/service.yaml @@ -14,7 +14,7 @@ spec: selector: app: webapp {{- end }} -{{- if not .Values.service.s3.externallyCreated }} +{{- if .Values.service.useFakeS3 }} --- apiVersion: v1 kind: Service diff --git a/charts/nginx-ingress-services/values.yaml b/charts/nginx-ingress-services/values.yaml index 73d7ee2ee6f..d254733505f 100644 --- a/charts/nginx-ingress-services/values.yaml +++ b/charts/nginx-ingress-services/values.yaml @@ -100,7 +100,7 @@ service: s3: externalPort: 9000 serviceName: fake-aws-s3 - externallyCreated: false # See note below + useFakeS3: true # See note below teamSettings: externalPort: 8080 accountPages: @@ -142,14 +142,13 @@ config: # # For Services: # service: -# s3: -# externallyCreated: true -# ^ externallyCreated might be useful if S3 access is provided by -# an external service such as `minio-external`: in such cases -# we do not want to create yet another service here but rather -# use that service instead in the ingress -# serviceName: minio-external - +# useFakeS3: true +# ^ useFakeS3 should be enabled if S3 access is to be +# provided by fake-aws-s3, inside of the kubernetes cluster. +# when it is something outside of the cluster (like minio-external), +# we should leave this setting off. this setting creates a +# fake-aws-s3 service inside of the cluster, which should be +# what is referred to in the brig configuration. # Configure CSP headers directly in the ingress. # # This is only suggested / needed in setups with multiple backend domains diff --git a/charts/nginz/templates/conf/_nginx.conf.tpl b/charts/nginz/templates/conf/_nginx.conf.tpl index e50fadfa021..9e5e0d61b76 100644 --- a/charts/nginz/templates/conf/_nginx.conf.tpl +++ b/charts/nginz/templates/conf/_nginx.conf.tpl @@ -146,7 +146,14 @@ http { {{ range $origin := .Values.nginx_conf.randomport_allowlisted_origins }} "~^https?://{{ $origin }}(:[0-9]{2,5})?$" "$http_origin"; {{ end }} - } + {{/* Allow additional origin FQDNs, if present */}} + {{- range $origin := .Values.nginx_conf.allowlisted_fqdn_origins }} + "https://{{ $origin }}" "$http_origin"; + {{- end }} + {{- if and .Values.nginx_conf.allowlisted_fqdn_origins (not (eq .Values.nginx_conf.env "staging")) -}} + {{ fail "allowlisted_fqdn_origins is only cleared for usage in staging."}} + {{- end }} + } # diff --git a/charts/nginz/values.yaml b/charts/nginz/values.yaml index 2bfa5ae21d9..c3db69f37fc 100644 --- a/charts/nginz/values.yaml +++ b/charts/nginz/values.yaml @@ -78,6 +78,9 @@ nginx_conf: - webapp - teams - account + # Fully-qualified domain names from which to allow Cross-Origin Requests + # (they are **not** combined with 'external_env_domain') + allowlisted_fqdn_origins: [] # The origins from which we allow CORS requests at random ports. This is # useful for testing with HTTP proxies and should not be used in production. @@ -232,6 +235,10 @@ nginx_conf: - path: /properties envs: - all + - path: /provider$ + envs: + - all + allow_credentials: true - path: /provider/register envs: - all @@ -253,16 +260,28 @@ nginx_conf: envs: - all disable_zauth: true - - path: /providers + - path: /provider/email envs: - all - - path: /services + allow_credentials: true + - path: /provider/password + envs: + - all + allow_credentials: true + - path: /provider/pid envs: - all - - path: /provider + allow_credentials: true + - path: /provider/services envs: - all allow_credentials: true + - path: /providers + envs: + - all + - path: /services + envs: + - all - path: /bot/self envs: - all diff --git a/charts/wire-server/values.yaml b/charts/wire-server/values.yaml index 7e41eca7838..f0488133713 100644 --- a/charts/wire-server/values.yaml +++ b/charts/wire-server/values.yaml @@ -6,11 +6,8 @@ # services: true tags: - team-settings: false - account-pages: false legalhold: false federation: false # see also galley.config.enableFederation and brig.config.enableFederation - sftd: false backoffice: false mlsstats: false integration: false diff --git a/deploy/dockerephemeral/docker-compose.yaml b/deploy/dockerephemeral/docker-compose.yaml index b44ad1932d0..58ff49b4c30 100644 --- a/deploy/dockerephemeral/docker-compose.yaml +++ b/deploy/dockerephemeral/docker-compose.yaml @@ -1,4 +1,3 @@ -version: '2' networks: redis: driver: bridge @@ -22,7 +21,7 @@ services: fake_dynamodb: container_name: demo_wire_dynamodb # image: cnadiminti/dynamodb-local:2018-04-11 - image: julialongtin/dynamodb_local:0.0.9 + image: quay.io/wire/dynamodb_local:0.0.9 ulimits: nofile: soft: 65536 @@ -46,7 +45,7 @@ services: fake_localstack: container_name: demo_wire_localstack # image: localstack/localstack:0.8.0 # NB: this is younger than 0.8.6! - image: julialongtin/localstack:0.0.9 + image: quay.io/wire/localstack:0.0.9 ports: - 127.0.0.1:4569:4579 # ses # needed for local integration tests - 127.0.0.1:4575:4575 # sns @@ -90,7 +89,26 @@ services: redis-cluster: image: 'redis:6.0-alpine' - command: redis-cli --cluster create 172.20.0.31:6373 172.20.0.32:6374 172.20.0.33:6375 172.20.0.34:6376 172.20.0.35:6377 172.20.0.36:6378 --cluster-replicas 1 --cluster-yes -a very-secure-redis-cluster-password + command: + - redis-cli + - --cluster + - create + - 172.20.0.31:6373 + - 172.20.0.32:6374 + - 172.20.0.33:6375 + - 172.20.0.34:6376 + - 172.20.0.35:6377 + - 172.20.0.36:6378 + - --cluster-replicas + - "1" + - --cluster-yes + - -a + - very-secure-redis-cluster-password + - --cacert + - /usr/local/etc/redis/ca.pem + - --tls + volumes: + - ./docker/redis-ca.pem:/usr/local/etc/redis/ca.pem networks: redis: ipv4_address: 172.20.0.30 @@ -109,6 +127,9 @@ services: volumes: - redis-node-1-data:/var/lib/redis - ./docker/redis-node-1.conf:/usr/local/etc/redis/redis.conf + - ./docker/redis-node-1-cert.pem:/usr/local/etc/redis/cert.pem + - ./docker/redis-node-1-key.pem:/usr/local/etc/redis/key.pem + - ./docker/redis-ca.pem:/usr/local/etc/redis/ca.pem networks: redis: ipv4_address: 172.20.0.31 @@ -120,6 +141,9 @@ services: volumes: - redis-node-2-data:/var/lib/redis - ./docker/redis-node-2.conf:/usr/local/etc/redis/redis.conf + - ./docker/redis-node-2-cert.pem:/usr/local/etc/redis/cert.pem + - ./docker/redis-node-2-key.pem:/usr/local/etc/redis/key.pem + - ./docker/redis-ca.pem:/usr/local/etc/redis/ca.pem networks: redis: ipv4_address: 172.20.0.32 @@ -131,6 +155,9 @@ services: volumes: - redis-node-3-data:/var/lib/redis - ./docker/redis-node-3.conf:/usr/local/etc/redis/redis.conf + - ./docker/redis-node-3-cert.pem:/usr/local/etc/redis/cert.pem + - ./docker/redis-node-3-key.pem:/usr/local/etc/redis/key.pem + - ./docker/redis-ca.pem:/usr/local/etc/redis/ca.pem networks: redis: ipv4_address: 172.20.0.33 @@ -142,6 +169,9 @@ services: volumes: - redis-node-4-data:/var/lib/redis - ./docker/redis-node-4.conf:/usr/local/etc/redis/redis.conf + - ./docker/redis-node-4-cert.pem:/usr/local/etc/redis/cert.pem + - ./docker/redis-node-4-key.pem:/usr/local/etc/redis/key.pem + - ./docker/redis-ca.pem:/usr/local/etc/redis/ca.pem networks: redis: ipv4_address: 172.20.0.34 @@ -153,6 +183,9 @@ services: volumes: - redis-node-5-data:/var/lib/redis - ./docker/redis-node-5.conf:/usr/local/etc/redis/redis.conf + - ./docker/redis-node-5-cert.pem:/usr/local/etc/redis/cert.pem + - ./docker/redis-node-5-key.pem:/usr/local/etc/redis/key.pem + - ./docker/redis-ca.pem:/usr/local/etc/redis/ca.pem networks: redis: ipv4_address: 172.20.0.35 @@ -164,6 +197,9 @@ services: volumes: - redis-node-6-data:/var/lib/redis - ./docker/redis-node-6.conf:/usr/local/etc/redis/redis.conf + - ./docker/redis-node-6-cert.pem:/usr/local/etc/redis/cert.pem + - ./docker/redis-node-6-key.pem:/usr/local/etc/redis/key.pem + - ./docker/redis-ca.pem:/usr/local/etc/redis/ca.pem networks: redis: ipv4_address: 172.20.0.36 @@ -173,7 +209,7 @@ services: build: context: . dockerfile_inline: | - FROM julialongtin/elasticsearch:0.0.9-amd64 + FROM quay.io/wire/elasticsearch:0.0.9-amd64 RUN /usr/share/elasticsearch/bin/elasticsearch-plugin install x-pack -b # this seems to be necessary to run X-Pack on Alpine (https://discuss.elastic.co/t/elasticsearch-failing-to-start-due-to-x-pack/85125/7) RUN rm -rf /usr/share/elasticsearch/plugins/x-pack/platform/linux-x86_64 @@ -202,7 +238,7 @@ services: cassandra: container_name: demo_wire_cassandra #image: cassandra:3.11.2 - image: julialongtin/cassandra:0.0.9 + image: quay.io/wire/cassandra:0.0.9 ports: - "127.0.0.1:9042:9042" ulimits: @@ -228,11 +264,14 @@ services: container_name: rabbitmq image: rabbitmq:3.11-management-alpine environment: - - RABBITMQ_DEFAULT_USER=${RABBITMQ_USERNAME} - - RABBITMQ_DEFAULT_PASS=${RABBITMQ_PASSWORD} + - RABBITMQ_USERNAME + - RABBITMQ_PASSWORD ports: - - '127.0.0.1:5672:5672' - - '127.0.0.1:15672:15672' + - '127.0.0.1:5671:5671' + - '127.0.0.1:15671:15671' + volumes: + - ./rabbitmq-config/rabbitmq.conf:/etc/rabbitmq/conf.d/20-wire.conf + - ./rabbitmq-config/certificates:/etc/rabbitmq/certificates networks: - demo_wire @@ -246,6 +285,7 @@ services: entrypoint: /scripts/init_vhosts.sh volumes: - ./:/scripts + - ./rabbitmq-config/certificates/ca.pem:/etc/rabbitmq-ca.pem networks: - demo_wire diff --git a/deploy/dockerephemeral/docker/elasticsearch-ca.pem b/deploy/dockerephemeral/docker/elasticsearch-ca.pem index d4ef94d4d2a..f17e9cb41ac 100644 --- a/deploy/dockerephemeral/docker/elasticsearch-ca.pem +++ b/deploy/dockerephemeral/docker/elasticsearch-ca.pem @@ -1,19 +1,20 @@ -----BEGIN CERTIFICATE----- -MIIDHjCCAgagAwIBAgIUXd/KjPrGXSmRyZ4Q/9O3LPGB70owDQYJKoZIhvcNAQEL -BQAwJzElMCMGA1UEAxMcZWxhc3RpY3NlYXJjaC5jYS5leGFtcGxlLmNvbTAeFw0y -NDA0MjIxMjA0MDBaFw0yOTA0MjExMjA0MDBaMCcxJTAjBgNVBAMTHGVsYXN0aWNz +MIIDLzCCAhegAwIBAgIUMGKU64YSPkGrWyHiXiLsuoKC/9owDQYJKoZIhvcNAQEL +BQAwJzElMCMGA1UEAwwcZWxhc3RpY3NlYXJjaC5jYS5leGFtcGxlLmNvbTAeFw0y +NDA2MTcxMzE1MzFaFw0zNDA2MTUxMzE1MzFaMCcxJTAjBgNVBAMMHGVsYXN0aWNz ZWFyY2guY2EuZXhhbXBsZS5jb20wggEiMA0GCSqGSIb3DQEBAQUAA4IBDwAwggEK -AoIBAQC0R+Ptk46Hd8SrR+S/dM7nGvhYA2ErWUFhpyUDWi7VpUpTgtlyTzmNgxAl -h9QWn8GuqvwqCFBnbiLL+OV6EsT1/fKt/3iYVv+myg5gBTPHt/QNaHZ5E7wMdwDR -HRuAKQI9kCdZZZ7/prVPTQDx0E12yxMWbE+NgvYfNmkJXSG3Y5S5ihE8RO+JZYec -AWfc3iwEZeD7d9WnVsb0sM+iJwMOOTlxKSI8Cw+ukcXdTh9pmxyQNZVd1tSGX/NH -281EKroIPLqIAxgy1d2cUqiCKIf4pGEbijb8m/OkoFez+7vjmD57A8uSuwyXz7+x -E2uRJFAisug5zdb8KWAJBlEkggWbAgMBAAGjQjBAMA4GA1UdDwEB/wQEAwIBBjAP -BgNVHRMBAf8EBTADAQH/MB0GA1UdDgQWBBQ1/LWQ/Ckxpc7HdBp6mNBfZNQssDAN -BgkqhkiG9w0BAQsFAAOCAQEAfGo1ONgSfTwRtT/ZsZgAnseqZSQCuvUQ4nrg2dDe -cFZtC05EczfmPx7G7Q2VeF9ZU56m/Ep57gE4W2wwVIwoG3Zam0kG4HirkgLNPagf -j3RkDrCvrjeESYFj7qwdnmgFNxotlC0KjHkGrfdT7gTDSWoNE3tobxyFaT1YQyBB -L6oRVlKa6O0ivgADUw/VMIARqFgCni/PhaHd4UlR9bgLVQ4MEVb463MMpGAdK4ZZ -l1bYVRf0pTeYnEiUG2HXt/1JFzSowFoZD8wVOXa0kcxy9SK/UCX8PVzMx06G4Ion -NNkzz9uSme9hAQlVsW6gxzl0NhwOtClpPIlvEqHwgF54KQ== +AoIBAQC/oFJpJMdyG9FTpNw4K9f1pdkNikwbQsx4dokiQBMTu89IMTnNfsHz2IDr +xCKTCKC3oPupniaEPNprYpV6RMz1UPvUYu/IpvOXGeIGlVd9ixcoYN6763R2nZhM +lFS8Tma9mV+e/B0jr9DbV1pUWIPufuPrYXcOotxDO/W5I+GpKVTz/ZGD//O5odX1 +mJzkwqjeqGa1WNdg+/ALiDtVZ/YAKGdfjx81uqc16fYuYRDw3BYImBp5MyNu/jxd +gNxFB1edcVowvcKXVs5pSlay2ad0eQSa0Ux8n3RjfisjTLAHks/4dkPa3hQyBYzm +xwBhMcMDc06yxiCkXsVnlXRn9nf/AgMBAAGjUzBRMB0GA1UdDgQWBBSGMhy1Uvrs +lmdHKAGQ9avMSWhz2jAfBgNVHSMEGDAWgBSGMhy1UvrslmdHKAGQ9avMSWhz2jAP +BgNVHRMBAf8EBTADAQH/MA0GCSqGSIb3DQEBCwUAA4IBAQA4vndI6NRcMgzba1y3 +lUPxy40bs/jQajR3A5fmCCX4c0ZeRc4YqE9cdYgeGffCZvPogyYjWDlavOma2uAQ ++3lZ35k0wG9GsU2g3fDIXpUuoSUjfYRLBQ3oqD7VRKYs1rDD87c+91DrsfIVZKF1 +W1RzOOvcW9QX2RHghFS4IluX6LEboo48cKtycA/nfmYDT/L9I4oYjaxc9l+HMUSH +gkQUU1xZnQ9GCqdhL3+2dmn0jvdgJLiFuefMGkE0oP/kFD/bhuOmDhpIDb10Cuck +Nw/nOSbBLINx2qDOa1f3Kox/PesQO4tp0dMp6XqZCOPTQ95vHsIOxuX1d+pxhX2V +ToWP -----END CERTIFICATE----- diff --git a/deploy/dockerephemeral/docker/elasticsearch-cert.pem b/deploy/dockerephemeral/docker/elasticsearch-cert.pem index 5de2ffadd23..3a9d4ad013f 100755 --- a/deploy/dockerephemeral/docker/elasticsearch-cert.pem +++ b/deploy/dockerephemeral/docker/elasticsearch-cert.pem @@ -1,20 +1,20 @@ -----BEGIN CERTIFICATE----- -MIIDTzCCAjegAwIBAgIUZg82eQUqHA61XD0suiu4Gp5C0rswDQYJKoZIhvcNAQEL -BQAwJzElMCMGA1UEAxMcZWxhc3RpY3NlYXJjaC5jYS5leGFtcGxlLmNvbTAeFw0y -NDA0MjIxMjA0MDBaFw0yNTA0MjIxMjA0MDBaMAAwggEiMA0GCSqGSIb3DQEBAQUA -A4IBDwAwggEKAoIBAQC4I8zWkyQGetTaVB7GuDi8dDqEabCHis6TVaA8hORbCSs/ -swlPM5e8gJuyuQIOiyC07Ai4sl/C5lyjbMK4eaBz+jB3tGA1YEgZzruZiKJV0JlN -kzTWFly5960quj7XuD2vlJ+0+ozT3GDsykh675mBx6LRF+/eWd9VFcexxqXvj0GC -M+01ffT8Ue0CvhxtGhg89m1NY4Lo3n/22PCPHnSqMJGbTx7gVpUs1eDQ6rgMIoES -kstFLgq5JiTr4ojLq1q2iGjAbxR+DCle/6abUMCcegBHBN6n5hAPO4X++T/moOta -3FIjwJN68SGRG3V4BNOE1x1nunKxQjKzsOqU0SvbAgMBAAGjgZkwgZYwDgYDVR0P -AQH/BAQDAgWgMB0GA1UdJQQWMBQGCCsGAQUFBwMBBggrBgEFBQcDAjAMBgNVHRMB -Af8EAjAAMB0GA1UdDgQWBBTsbRvngQ1YdeLmiHuDEHTWlTufXjAfBgNVHSMEGDAW -gBQ1/LWQ/Ckxpc7HdBp6mNBfZNQssDAXBgNVHREBAf8EDTALgglsb2NhbGhvc3Qw -DQYJKoZIhvcNAQELBQADggEBAElA1AylS20xyMtFlFda/f3neLapwRf9beVLbzR3 -4N+VaN6ZeUeO62E5t1nFWayguapPkAPW5YkQtW72KlthcIKKwu+WOMUxUJmiVfJJ -hNtBSx5RpEoiJ7qi0gQCUshYoU/B5tlRTgy+vstXCbP9ME/B2Oqn2RN5PsrRmiYU -/hJ6WqQiRaX7ysrn1cCyDMjCpBv2s4QZVBD/08l8sZfeOpxxgWj6cy4ucHn3Vbvi -4MQvwWPuAGpJy7w77v1na8DRjEnMlYoMyoDVjKAFBwwTo+8rWfLsnDSWtAHDQJsI -eluO9vR0JNNEp3f/mV4lqeFwdgN6cJzYDfePdWpqGrTSL4U= +MIIDMDCCAhigAwIBAgIBADANBgkqhkiG9w0BAQsFADAnMSUwIwYDVQQDDBxlbGFz +dGljc2VhcmNoLmNhLmV4YW1wbGUuY29tMB4XDTI0MDYxNzEzMTUzMVoXDTI0MDcx +NzEzMTUzMVowFDESMBAGA1UEAwwJbG9jYWxob3N0MIIBIjANBgkqhkiG9w0BAQEF +AAOCAQ8AMIIBCgKCAQEAvWOmaFQEjlt8yqmMtpKFyoFoaGYfsGX5YhNoZOMtEtKX +F6ct1nIcJA9h5awgAlivRKeAkySUZSsWKCibaeNGneN9XTcrhedVpEtcz3js2CbB +1MDyfS9mrgt78uv4zQ5ZHY3wh6LC8k5Aj0aK2PJMNjJogIksO7zKBBGU/L+IMglU +j0kPIn8qiIxgNYRhqxQ0iQpiD065PrjU+jfwz7/Q1Oslq+Xxa9fY2+yYG1XMVdC8 +s2waBl953qv3gNtWZ3O+O3cS5egH/HiNKSWRmaoFebuI3RPAORbRVgHe1k/xTI7V +VE9A2IvHkETmd0Kx4qh66tAc2qayX4c979I7oA382QIDAQABo3oweDAdBgNVHSUE +FjAUBggrBgEFBQcDAQYIKwYBBQUHAwIwFwYDVR0RAQH/BA0wC4IJbG9jYWxob3N0 +MB0GA1UdDgQWBBQDv9kWb35hEik7oNPxU62c6mt6UzAfBgNVHSMEGDAWgBSGMhy1 +UvrslmdHKAGQ9avMSWhz2jANBgkqhkiG9w0BAQsFAAOCAQEASMywZx+iTfpXH4Tu +C9261lD5Q2HZ3NtNRjGiImRjLhPQUt+5gLwwca0oiHBFa+xIt5MVwhnatJ2x8IZ1 +8ttQiqJUhXC8k62DVq1oMsgIusf+FaVxRQO5uCp5erroeUqJWvumC8013lNDjXHW +/X9PiouUTSndGI/pv6RokK+8VCT8mv7DvwhsTRyely51o7tCqHp6VjtD2wpm9ApW +qpySHKwEdwRSMvOIH2+x/Qa0ykFPKV1T+oqF4xM1x6ob06z3rS74uSK825g7Kyqd +zcjImK2DCVIkA3bSGxONQ/APTNd0TwAw9khhncjLJWjk1as6tuQGtpKWRA/01z+M +KHyT2Q== -----END CERTIFICATE----- diff --git a/deploy/dockerephemeral/docker/elasticsearch-key.pem b/deploy/dockerephemeral/docker/elasticsearch-key.pem index ee573176b4d..0f15c75e114 100755 --- a/deploy/dockerephemeral/docker/elasticsearch-key.pem +++ b/deploy/dockerephemeral/docker/elasticsearch-key.pem @@ -1,27 +1,28 @@ ------BEGIN RSA PRIVATE KEY----- -MIIEpAIBAAKCAQEAuCPM1pMkBnrU2lQexrg4vHQ6hGmwh4rOk1WgPITkWwkrP7MJ -TzOXvICbsrkCDosgtOwIuLJfwuZco2zCuHmgc/owd7RgNWBIGc67mYiiVdCZTZM0 -1hZcufetKro+17g9r5SftPqM09xg7MpIeu+Zgcei0Rfv3lnfVRXHscal749BgjPt -NX30/FHtAr4cbRoYPPZtTWOC6N5/9tjwjx50qjCRm08e4FaVLNXg0Oq4DCKBEpLL -RS4KuSYk6+KIy6tatohowG8UfgwpXv+mm1DAnHoARwTep+YQDzuF/vk/5qDrWtxS -I8CTevEhkRt1eATThNcdZ7pysUIys7DqlNEr2wIDAQABAoIBABR7lvt/XpCB9U9b -8Bh2wYjk/OVhxEsve48UBUD2H1ipCnCJf82ZlZVYUPlubvYjL74wS0AQR2qsqT1c -icRvcxOzjtSh8dm+HgcQ4flQI46cJ5FjgIsX7bSaAl8wXHEug14WkDVXcXbXmsh8 -L9fM8yxmgovzt7DqGleilpYF3Mtq2bNYMm7q74SKSaiz/FplgYpFJJ+jWG4ExELN -mzmMFjQQ77n0ORsnyXAzIHy4XE5loj2oHlLene5XUbNv02Bi4kY5GRADVaxEphKK -YD6m2ktLHJXzfqpsdmzup3nKi7j+m0sOcMr3SC+JBqjwwG6cyhENmPxi6fKK4XhS -bPo2JyECgYEA3ovs9f5jUMV0uZ/4jGI9rNGXgQo1DPpY2zz8UvYBN/erk8+PLxK1 -mNns5Lt5UFeduRwwbNSIUR817dLLeRnNClxOjS3aaT6jCciHVGiXkWFzCbnaV9Xl -Ozv4V+s9Duwu7sqAnZrW47ykjU9G9UrsmlidoLDKXHwAshwDXkN7wiMCgYEA09Hm -ZyC4ypR94yUMmgCKq57T5mfYJEXZoe6KlQ8zTJCOjOZesl767vrjV4hijML9I25U -dqLCxf+7ifJWhgfBJNbXfHAVEPWVkazJ1ZF/6UXvKIUoHfcL9/aNQv2uX1kto7sR -wUSSxIDxaNqtnRB3gYS67PKju0ZvFU3d0qtDPukCgYAeLK7Gc+WXcA5xlMUok7F1 -Gz4FmxKyXcdqgoxb20szAXvcIMpzQYAp53J9WQYL5LVYAgB24SJSjX7MbkZ0dxEc -FIP6FHuGxZ1pmCzxPvU+Gw50BSUbv77DF1CG6zhuK4v5iK+Drxjv7AYLuvIOFEic -bOOChDYL8CxP+ghi4ZeILQKBgQCfeFt6MMxu17SfGfmOx/Gem4j04iF7zYq3uxti -dXstnXd05MtOhutsmD4oXGm1h+eEkT/NwWPaJVpP1L8HUTc8QPMioE974Sil7+xU -eaJPQXN4kidNx/yexmQ7lzl8V2tg5SnM04+bmWgmhNxIb2lJfWAtm89g4vomk+T5 -Ai8yYQKBgQDAEtH13565FJnd0qxYI+o1ooNbAhVQx/bR6tWaMF3/h4fQi5vTn1/6 -Z6f9Y8koJSoxNxkN1hpg0h2SqzAFtvUfpSyRMaYunm4VXNRsGOJALzgOwGlZ/3C9 -v6tnxXBASSfwOeFr3ToYlTTJg6b612cTHb6w4VyDA+Sy96YLbnd9Cg== ------END RSA PRIVATE KEY----- +-----BEGIN PRIVATE KEY----- +MIIEvgIBADANBgkqhkiG9w0BAQEFAASCBKgwggSkAgEAAoIBAQC9Y6ZoVASOW3zK +qYy2koXKgWhoZh+wZfliE2hk4y0S0pcXpy3WchwkD2HlrCACWK9Ep4CTJJRlKxYo +KJtp40ad431dNyuF51WkS1zPeOzYJsHUwPJ9L2auC3vy6/jNDlkdjfCHosLyTkCP +RorY8kw2MmiAiSw7vMoEEZT8v4gyCVSPSQ8ifyqIjGA1hGGrFDSJCmIPTrk+uNT6 +N/DPv9DU6yWr5fFr19jb7JgbVcxV0LyzbBoGX3neq/eA21Znc747dxLl6Af8eI0p +JZGZqgV5u4jdE8A5FtFWAd7WT/FMjtVUT0DYi8eQROZ3QrHiqHrq0BzaprJfhz3v +0jugDfzZAgMBAAECggEAKZ8z3CvS0IJ0u4llnl43PxkPnBoNjtPqac6AG+P9bOyR +PiaEoWN0ocwrpLEeW8WnxzvUuwHIBy/f77V06mGDjIGJdKoCS6xamv/hBsu5qYti +/+HjqPV46HknpWyMwmwL0731BaoUk/H0qEhFjYY6j5KmetEqwnosH5bJmn5xbSVU +yrXSoWYX5yX9e2gL2QD3IyVdlIzbRnWwxaHhSUSo4jIlw7t/oaLL2gurzYQVpI6R +a+0HsQ81IulEIMH6iWZCyKn3NCcB/5TifA3e3DwjiYxYxGC2JmxRBb84F0pV8DhX +vETgIhG8vrkz8h2coCzYe7XIwiklMpbijMREpC6QnQKBgQDrfD0JjHWhQ9u1qCAb +E1vN+xVAZ9LUJVFoex+BeOjU0JkcM7i1tQy4mEcq8LGjpPCX7k5XqtMo2UUPDhLf +bppuNWCmFeDJjetj3b/zxEe0UMz4+Z8anW9AZpIJYkeRN6R4/ptiErbygxqr0Wus +inT+qRvjZuSz6ajj8qdeZun9NwKBgQDN42I84JYtViVptJeIG2TcJVSVRq24ADNy +w9V/y53Nc4zRCfR5Yz9pw0pRuFaSgaDZvKFGwU51j/8/t/nDyO7+Y4fFziiDpsFP +LBKc9fI4UTpPP8QEPBxQ7gK4vTN0ouziqQ1bA7kXF3mPh/g1rRBesEEFtnu+lcoR +nnz5HtlebwKBgHH30PqcFhoUY3NJiTBRcC8Cg8iF9w1hekLcw+S/hb/prRBvH8gh +daSpXlgz4WVX4HFHjnbzX/r3HGsq3otwViFciAgZso8ZtoDAw7PQnPtx16Hv/ca9 +xygd/DO6cvSfP2SnpMAUWqKIPRJG6pu47uKJKcwm8iz4uxqHR+VyXXCFAoGBAMPv +jlEDJshUgFxdigv0jgLX3+wEDFTclBm29xqcizu3qJ5TS/6tje639KVaucDJbmto +kU8FrgZBmJdqHV7OfWtJCzAa5wGLE9KlzbzkbrRb0RMUSxYAoq3+JEbtf+eTGb8H +RPeFzoKES6JlsrhaUAbc07R9GrygTmKAIszuJ80vAoGBAIudK5mEcqD8VNMnMAo/ +atWoImkCKLNDkAxr1E34BCorQ3ZvJZ5k+vjxTtiaOIzo6/qj1MAzfHBx22sCyJ36 +4RhCfk56XiAzZiwTRALDcd0l40Z6OoitwsXdXazeG6PMPleZmV+t7lejYfGokeI6 +6jRKZxwsF6kSk7XNnHmeB9qX +-----END PRIVATE KEY----- diff --git a/deploy/dockerephemeral/docker/redis-ca.pem b/deploy/dockerephemeral/docker/redis-ca.pem new file mode 100644 index 00000000000..85d169823c6 --- /dev/null +++ b/deploy/dockerephemeral/docker/redis-ca.pem @@ -0,0 +1,19 @@ +-----BEGIN CERTIFICATE----- +MIIDHzCCAgegAwIBAgIUba2QSPicJVmpvwiyTu4YRiUzi5QwDQYJKoZIhvcNAQEL +BQAwHzEdMBsGA1UEAwwUcmVkaXMuY2EuZXhhbXBsZS5jb20wHhcNMjQwNjE3MTMx +NTMyWhcNMzQwNjE1MTMxNTMyWjAfMR0wGwYDVQQDDBRyZWRpcy5jYS5leGFtcGxl +LmNvbTCCASIwDQYJKoZIhvcNAQEBBQADggEPADCCAQoCggEBALm/Ta6NRzTQLyTJ +PbktHqHLhRnlrtsCp3IfJ7JGiuc5HLJL1NbNbLw+XgZwjiVwmeQeZMjH8Sa7tRay +9OtqeP55zbgww4nZtTFKH6AdDVVJDg5X10xghijqhjRRUSh1dRxI4q4f/bjKhvc9 +Uk9B6gMIIS5gzS+XCf+WxQ0Zp2Zr11wbFlQ2ynp8Bb1k1Fyao3e0cHzIRrCn0qbv +VNOtNwDL5/M6sJyu3gvuxOGKhFJ9GzPtSYjTSIkQnddmoMQuDT6GZMo9RkcWTRFh +6f0EDan1iAIWNcK5NrHZKA/L3gPLIb+d29HuKbZcdgcQLfMkfgX49cTDcSv3XI90 +Fz1IAVMCAwEAAaNTMFEwHQYDVR0OBBYEFIeV2duiox4T4NjZWcFgRiS44y44MB8G +A1UdIwQYMBaAFIeV2duiox4T4NjZWcFgRiS44y44MA8GA1UdEwEB/wQFMAMBAf8w +DQYJKoZIhvcNAQELBQADggEBAG1E1db7eaoS5OW+7XQcXHPpqvIP1GRPnsetN+L/ +1fc5lH0lzRyiY2BHNJUMsENiDXMbgPzuVR0Eks8i8goSM9F9rZK7znpnesgS3ec9 +alTIDHIgsgSrRTJWXsGFq4GH1atcjX3nkxETx/o4sV9MC2h5SrfiKnO7nc+/LUDC +hxrGLQikDmt+thygMG8LguCtEAVr8QghbAGxPyKKCLai4S8w+Mo1YtQYLLKhSeWl +Wmf+IpdLXZy1MS/G3b0Wy5py8ZkYQORL0UQMk2kCFj3J5m2N1xo0KsiXY7yZE9Wr +XNeZPtygtjDqTME+GvPB6vQloizMom8E3p40vdSx3Rsr+wc= +-----END CERTIFICATE----- diff --git a/deploy/dockerephemeral/docker/redis-node-1-cert.pem b/deploy/dockerephemeral/docker/redis-node-1-cert.pem new file mode 100644 index 00000000000..37bd4bc75dd --- /dev/null +++ b/deploy/dockerephemeral/docker/redis-node-1-cert.pem @@ -0,0 +1,19 @@ +-----BEGIN CERTIFICATE----- +MIIDGDCCAgCgAwIBAgIBADANBgkqhkiG9w0BAQsFADAfMR0wGwYDVQQDDBRyZWRp +cy5jYS5leGFtcGxlLmNvbTAeFw0yNDA2MTcxMzE1MzJaFw0yNDA3MTcxMzE1MzJa +MAAwggEiMA0GCSqGSIb3DQEBAQUAA4IBDwAwggEKAoIBAQCkyI311U2ZCCKvnPqv +K0y5A8CI8A3W146s2490ReOZp1xA+l1bPcVJan2N0Na/kLNYo9Lm1xbuNWxadllq +0DnhYTMzP48Rlh69lPL1GjWWI0vZjC4qcv0r6k4DrKVn6yvzs8jQDiykvsIXHcPi +OovQ+ol30xd01KV8k7CsAgFpDON9PgaLKTV5S9I2R+zfTGWHWZCfJlJea2fbf6Ui +O4VwNCO62C46aRLUh0qgdkqvjts1BV9/rzeLQ6UQBU3o4h+9obTOI56ZaUk5fU5v +mb9P0Fj+NLlEqIb2Zl7IopwiIBQSzA+3USFYMQl/fppyCm5X7OrQ1tjJNZ3Tpm+K +7CflAgMBAAGjfjB8MB0GA1UdJQQWMBQGCCsGAQUFBwMBBggrBgEFBQcDAjAbBgNV +HREBAf8EETAPggdyZWRpcy0xhwSsFAAfMB0GA1UdDgQWBBT7rOsZpR0sBNmrAIIj +raJniMK0FTAfBgNVHSMEGDAWgBSHldnboqMeE+DY2VnBYEYkuOMuODANBgkqhkiG +9w0BAQsFAAOCAQEAcYPqHdms1aYR5aWdqJYPRgydaAdTp14J6jXNQh8NU9jMIV0S +CTVuZwuSMoiMzQXezicHJjMc5YZTvB6SHNi0bidvx48Xuw/JUvlDHVysZgPZYR11 +diAsp+iD0+EB2hR5vHseehwTmyfyVIbFvWXNDNvRrU628gzWUlC4adsUVue8xsfp +dzQQUJKizO4sBM9hpxjF2iWnRDsE/QZPmPpuRD3ys8ym08zUH+R3dLFbNuDkWb9t +mr8IQJI6eALdbcn9vVHlGIluRni4Oe9d/lZ+adbLvbwsZsyeUldn/VzPUIAFE1P9 +HqWg9/JFnc3EQeuLGEqea+nk6WCHJyU5w7GETQ== +-----END CERTIFICATE----- diff --git a/deploy/dockerephemeral/docker/redis-node-1-key.pem b/deploy/dockerephemeral/docker/redis-node-1-key.pem new file mode 100644 index 00000000000..024e676a48f --- /dev/null +++ b/deploy/dockerephemeral/docker/redis-node-1-key.pem @@ -0,0 +1,28 @@ +-----BEGIN PRIVATE KEY----- +MIIEvQIBADANBgkqhkiG9w0BAQEFAASCBKcwggSjAgEAAoIBAQCkyI311U2ZCCKv +nPqvK0y5A8CI8A3W146s2490ReOZp1xA+l1bPcVJan2N0Na/kLNYo9Lm1xbuNWxa +dllq0DnhYTMzP48Rlh69lPL1GjWWI0vZjC4qcv0r6k4DrKVn6yvzs8jQDiykvsIX +HcPiOovQ+ol30xd01KV8k7CsAgFpDON9PgaLKTV5S9I2R+zfTGWHWZCfJlJea2fb +f6UiO4VwNCO62C46aRLUh0qgdkqvjts1BV9/rzeLQ6UQBU3o4h+9obTOI56ZaUk5 +fU5vmb9P0Fj+NLlEqIb2Zl7IopwiIBQSzA+3USFYMQl/fppyCm5X7OrQ1tjJNZ3T +pm+K7CflAgMBAAECggEAKKucSBbVoGXe47+nqrjR5p8rs9Cl5ccNnpHRQgYm4uto +7Fuu04B3M0POicRH4H+XGFNU0Cc5sGDspZYswx1yD7O1FprDFbjazPlYjtChdbUv ++RltYoo/fMmHaEZCC9hCIJPYxisdbyrqzhhJWsqO7C0N5U5rLWl3j7wHAKk9Dl9b +lIdn+AlEiA2cpAk/5rqSZysOv0+v56jh1ay6Hqsp7jm9NAdEoSpJMDwZ/FJxu4PZ +vvxxpACJhyVZkJuuJPc68HbwXIPhEImPzc2TA2Zok+PdgEpnNWpiSGainsaDY6l3 +9XQabptbwhHke0eikQQ+27PXFl5XuvU6qHBEXnFXQQKBgQDdDRILeIUyZHFRJCaJ +uaK9/0IXgTD2p5/ef6a5RcoSEDda+fvKUbd7MlLnLkSOWko27uheVwnpVC3RtgQf +XmMenbAcsh+3a6bDHBK1VwJZAHTb11aLOVzBiof16FTr89OO5gu4WEM2XedOW+Lz +o6QJQsoJfR/6Q7jfwSwNQR54pQKBgQC+1hRuRJsJiaDRIq/T/9dmNhMdPMw1ojM2 +i4EeS1wYUnDr2D/KfpDFKZ/uVobFekH1eqKOQhaUkND9/kHyx/4XBZYcabxxyC2w +SoY26G6ha/gKNlgKhioqAtMc8f7caNwZADrggYIilfPc2uQAaAtKbWb8TuJlGDmF +WcxPRvSOQQKBgQCEZo3GXRu6wTq2VSbYG16E2t1lYrZHJsO061SbaFfOVfQyA8Vy +u1tg6RWK7sWVVjNZj+OSjiObpBYFpDX36/sGnYCcz3v7yvkJqEj0YPdBA+r6upJV +tbf/HNCu08f5xAOVdejTM9qeN8SRxKu9LujTuzN0V4PNzL5xFy0hiz2LGQKBgEO1 +CMKmrKsRnXEV8XQyDWZCQT3aWEmfJrRvgnwRGLe4aEAFFXzussaBIjEZme9ulQBX +Zl06rXBAgSXck+Fje48HeF7UVPu5nhwyFLReewHioLpe1ZXGTCdjoStf4KCqw4xL +PJhy2o0SztbJAqPyRi896ZATHNfpZF8foRFvh00BAoGAIrvHzt0EBLUaquJEKotX +b56F7s7uhgoc/ugcHgAK/b7K82B4/3K8lg3naynmabkU0/rdmcnyVfyXnjVFevpe +szUiOX+zG20LJnN9G589fRxFJM9Vny2WLV+7y7VoDoLl5BkjR9VBUo11aYVW97QH +Vr72lA4ZaymQK2MtMWlTXsQ= +-----END PRIVATE KEY----- diff --git a/deploy/dockerephemeral/docker/redis-node-1.conf b/deploy/dockerephemeral/docker/redis-node-1.conf index 011df166cda..f30468e3e11 100644 --- a/deploy/dockerephemeral/docker/redis-node-1.conf +++ b/deploy/dockerephemeral/docker/redis-node-1.conf @@ -1,7 +1,16 @@ -port 6373 +port 0 +tls-port 6373 +tls-cert-file /usr/local/etc/redis/cert.pem +tls-key-file /usr/local/etc/redis/key.pem +tls-ca-cert-file /usr/local/etc/redis/ca.pem +tls-auth-clients no +tls-cluster yes + cluster-enabled yes cluster-config-file nodes.conf cluster-node-timeout 5000 + appendonly yes + requirepass very-secure-redis-cluster-password masterauth very-secure-redis-cluster-password \ No newline at end of file diff --git a/deploy/dockerephemeral/docker/redis-node-2-cert.pem b/deploy/dockerephemeral/docker/redis-node-2-cert.pem new file mode 100644 index 00000000000..4681392ce71 --- /dev/null +++ b/deploy/dockerephemeral/docker/redis-node-2-cert.pem @@ -0,0 +1,19 @@ +-----BEGIN CERTIFICATE----- +MIIDGDCCAgCgAwIBAgIBADANBgkqhkiG9w0BAQsFADAfMR0wGwYDVQQDDBRyZWRp +cy5jYS5leGFtcGxlLmNvbTAeFw0yNDA2MTcxMzE1MzJaFw0yNDA3MTcxMzE1MzJa +MAAwggEiMA0GCSqGSIb3DQEBAQUAA4IBDwAwggEKAoIBAQDusjRUdb9cOIGhRXVG +WqsawsdIqljT2r2G7wTtSPfTPpLqMY1rcw1VJdHKG4Kx8SYEZZ02IOjHkV8Ik7/m +0kiKUNo+nRURvNkWsedoQt8/5NvL6O0d15BoHMSjJMkQYKDew2pEbcR3YyLrndjl +qRv4QSaESA1c854IejG1V91Tvk7KC4jqmisZEz6hrHg5XBPGk0cTb3rAQhFgpZo1 +tpjhc9CHQzNv+FM6lgy/n53kpTDYpGJgYN1I+lqU1qN29WHKaMNHXBj3GT9uZ64e +4IPmbCIn+U3+KWZACaD2HbDq8QLcTFxT3kyETH27UPkETDa56pPHgqRWziaNbwgS +cZx5AgMBAAGjfjB8MB0GA1UdJQQWMBQGCCsGAQUFBwMBBggrBgEFBQcDAjAbBgNV +HREBAf8EETAPggdyZWRpcy0yhwSsFAAgMB0GA1UdDgQWBBRd+gHa2Eis8uVk//hq +jqoBINup4DAfBgNVHSMEGDAWgBSHldnboqMeE+DY2VnBYEYkuOMuODANBgkqhkiG +9w0BAQsFAAOCAQEAV8hQotbxJAdXEyZQjQPmG8AmUZSi4U8LnMDe9od58sD59J7o +m26WbNvq7tDRVpBsrUCk/rfVT8I26h1ImS2tlZtyW5LiKOi9t3I3W1s2fnWk6GBg +tH3SKf0aZRw96RSoYa7DNp4MilRtF3pQF8rg78b3BYaAUezCe2KO9Ddlym2YhAth +rzSY4cek3Gsd62SFyq8ufFq54Q3pImcVF6shGidmqfeAgRRXumekdDSr7rkvEJ+5 +6fAVMhLRu4YGGH5SPF2dauFgpMCgMFHp5uUmAcq4sLbnLZhSckuzaagoaQRZAALT +NdJ9nFHupmUGV/dagYSx+cFccEVJ0nl29YF4qg== +-----END CERTIFICATE----- diff --git a/deploy/dockerephemeral/docker/redis-node-2-key.pem b/deploy/dockerephemeral/docker/redis-node-2-key.pem new file mode 100644 index 00000000000..ab7fffcf64c --- /dev/null +++ b/deploy/dockerephemeral/docker/redis-node-2-key.pem @@ -0,0 +1,28 @@ +-----BEGIN PRIVATE KEY----- +MIIEvgIBADANBgkqhkiG9w0BAQEFAASCBKgwggSkAgEAAoIBAQDusjRUdb9cOIGh +RXVGWqsawsdIqljT2r2G7wTtSPfTPpLqMY1rcw1VJdHKG4Kx8SYEZZ02IOjHkV8I +k7/m0kiKUNo+nRURvNkWsedoQt8/5NvL6O0d15BoHMSjJMkQYKDew2pEbcR3YyLr +ndjlqRv4QSaESA1c854IejG1V91Tvk7KC4jqmisZEz6hrHg5XBPGk0cTb3rAQhFg +pZo1tpjhc9CHQzNv+FM6lgy/n53kpTDYpGJgYN1I+lqU1qN29WHKaMNHXBj3GT9u +Z64e4IPmbCIn+U3+KWZACaD2HbDq8QLcTFxT3kyETH27UPkETDa56pPHgqRWziaN +bwgScZx5AgMBAAECggEAGaBQNfEeRkxavnGykYcSb6ERvB9twfDuABqRMNhwouFI +7JO9VxfXCpkw2L3zXh9BsZ8nLbSCyUo2JbmXFLTmzNK5W5eJt4nK1MDs0yi6xyVO +46lyK44FFuhfxBQi8fstyjy4n/gY66hdC2a67o0lT5XPCMyjgqM1CDv2Mj3oqSDE +QXxQtT3sSVLWGT+ztQhcLBdUpIG6Q3qaXr/JTLDDNn3kIAB9XOw21tDibRPGdw/P +54b4fx7x9K/0bYZg0STh6xWUBTM3geUEW3tRUMkaqtbjXltu12j6rf6FfBOip397 +pdER/YCFn23nIHAn44jp60S4eT2p9QYPxPcAeFnIcQKBgQD/VYO+G3peH7fKI9FO +kY8bLIr9aiF4F8AzPBeUgJjK3MrhkV2wZULT/VD0JMJubAICfSwYgBvQXiDNwD82 +CeMasapzlolnMTa7zYyjIYZSeBXvJpOcSyuPNy8DCPp5mwfEXeoGcpbuUjPBIBsD +rHO45gFS75kf6YBO8/h3AuJNOwKBgQDvUZSqTDDF3sF/Z2C7Kn2cBgoB6tsUqTQV +ZdKRjSoIjSI3XoPzyCQdLrnq1bn7aUXt6IlQySZNjJ4hXr/yduf141l8j4XTNMPe +kisPNNwIPvsDOVO/27+emn44Py4IMIr3kdwoO7YnVHXu4IM6DEhbVC3Pi0glSxol +ydODQh/x2wKBgQCsog6+vClR9jP3MZxUeMm+37DhgZ47aiODAIAY4ZFspzdspzIn +D2/NkJnpV+k1a0U4lZT4w7UKfnnDYtXaHXk1FSZfnEouQPH2rBUIPqRoodSCqxxm +MdSzseXRMYLYMV9g/vY5gcRWQbHIQ4LASxq6ypfekSyAjQk5WG6HWKXU/QKBgQDl +ejqtmWVjNxggDIbKshHEHF5YPFVa2Gyi4AIro0rc7EgVA8JPbmiCux13Ov2dP/LY +EBQrrNXXorC2mt4/pxkBxME4GX9faMcwksRLTop2Nb4H916BKDvz33yMfrirDbET +d3+97JPb3rc/GXV7oe93854B1zKU4BDwjzkMMcnj5QKBgHsko7YzcZKjmaEV9ecr +/9wrBA5OkckoxeJo5qlqxg7p63V7gEZ6/QjfJcuCvDMEYMKjhgb8bbq+JgCyjCHB +0dll5cH6Foe7RTePT07zhAEutLxUU32XiwKtN9dyBQlXoMmJl8o+G+pfcWb59jJx +Rv22/ufIlLl6Z4JZ9RWM3/Ka +-----END PRIVATE KEY----- diff --git a/deploy/dockerephemeral/docker/redis-node-2.conf b/deploy/dockerephemeral/docker/redis-node-2.conf index fa2850e9234..f95904911fe 100644 --- a/deploy/dockerephemeral/docker/redis-node-2.conf +++ b/deploy/dockerephemeral/docker/redis-node-2.conf @@ -1,7 +1,16 @@ -port 6374 +port 0 +tls-port 6374 +tls-cert-file /usr/local/etc/redis/cert.pem +tls-key-file /usr/local/etc/redis/key.pem +tls-ca-cert-file /usr/local/etc/redis/ca.pem +tls-auth-clients no +tls-cluster yes + cluster-enabled yes cluster-config-file nodes.conf cluster-node-timeout 5000 + appendonly yes + requirepass very-secure-redis-cluster-password masterauth very-secure-redis-cluster-password \ No newline at end of file diff --git a/deploy/dockerephemeral/docker/redis-node-3-cert.pem b/deploy/dockerephemeral/docker/redis-node-3-cert.pem new file mode 100644 index 00000000000..f676a744e30 --- /dev/null +++ b/deploy/dockerephemeral/docker/redis-node-3-cert.pem @@ -0,0 +1,19 @@ +-----BEGIN CERTIFICATE----- +MIIDGDCCAgCgAwIBAgIBADANBgkqhkiG9w0BAQsFADAfMR0wGwYDVQQDDBRyZWRp +cy5jYS5leGFtcGxlLmNvbTAeFw0yNDA2MTcxMzE1MzNaFw0yNDA3MTcxMzE1MzNa +MAAwggEiMA0GCSqGSIb3DQEBAQUAA4IBDwAwggEKAoIBAQDYU44MmK1l+2zjBrHY +/ORzWNWNsM9cMuh31KuNBDf1yD8Wg4YxfRgrqI2la88qRVNz3bUr5P8P/ubk1UH2 +agK5Drta7fYkvDPhveeTIOKz9l/ojxb4mXQ5aNmRZThtftokSbnPj8rCLRTvwpxW +wtZGBPAOTHcIRAZs3w8XPIFY/2FnOILHMpGUD6MrG0texcV05GLi10ZEevVb4tPl +1QF4dvyQdGjpOZ9qVn27xl2GAxX7yOlxC5AgLS7HuzLyCP5eyB4i7hRK06XjrVu+ +VUi1nzrOneDJzBFZLhcY1ktEKnmqvZ9Wh6eZGepXo8lV6QCH77OJ1TNSL2ke8qUb +IMJHAgMBAAGjfjB8MB0GA1UdJQQWMBQGCCsGAQUFBwMBBggrBgEFBQcDAjAbBgNV +HREBAf8EETAPggdyZWRpcy0zhwSsFAAhMB0GA1UdDgQWBBSq82oTIR7xwMx2Cfim +DbOoj8FPajAfBgNVHSMEGDAWgBSHldnboqMeE+DY2VnBYEYkuOMuODANBgkqhkiG +9w0BAQsFAAOCAQEATue+pKPQpi+RUUNsxi7REOmKjVwvEOUePqsovmXzE8aC3P8v +akpVDDggA7JeAgWcFfFng8SimNTq+TqfNRx06E7MYc0Fcekqa1wfTe7eEdaHrekd +vR/HvKONaenxQ0jDD7PLQi+8dZAvValb9avw8howkrQlt0lLt3KVUHepO9ErDJ3P +ymhAl1Dc/8PiwH0wicXmJSnxSpIttv1WHW1wj31G8f6D8W8k6i8fQYPeMI/OyGu6 +tpSe8SXZ/P/trEVFCWISYaq861jufkaTdHGKVMv+rL0E+Ow+zmLmeBRLq+rrmTT7 +gWCV/wl41D9nrzWYtSmBEnwcDHK7eRqb5NiGmA== +-----END CERTIFICATE----- diff --git a/deploy/dockerephemeral/docker/redis-node-3-key.pem b/deploy/dockerephemeral/docker/redis-node-3-key.pem new file mode 100644 index 00000000000..0264fce611d --- /dev/null +++ b/deploy/dockerephemeral/docker/redis-node-3-key.pem @@ -0,0 +1,28 @@ +-----BEGIN PRIVATE KEY----- +MIIEvAIBADANBgkqhkiG9w0BAQEFAASCBKYwggSiAgEAAoIBAQDYU44MmK1l+2zj +BrHY/ORzWNWNsM9cMuh31KuNBDf1yD8Wg4YxfRgrqI2la88qRVNz3bUr5P8P/ubk +1UH2agK5Drta7fYkvDPhveeTIOKz9l/ojxb4mXQ5aNmRZThtftokSbnPj8rCLRTv +wpxWwtZGBPAOTHcIRAZs3w8XPIFY/2FnOILHMpGUD6MrG0texcV05GLi10ZEevVb +4tPl1QF4dvyQdGjpOZ9qVn27xl2GAxX7yOlxC5AgLS7HuzLyCP5eyB4i7hRK06Xj +rVu+VUi1nzrOneDJzBFZLhcY1ktEKnmqvZ9Wh6eZGepXo8lV6QCH77OJ1TNSL2ke +8qUbIMJHAgMBAAECggEAMnVG2GRSacu8CbZZjHHsfYU2hq67p1dOhwjpnOJjhSZY +pNE331o85Y4SwAeGEmeKQCfyJtNqtRnxVGXz1VzD1tN7WwnPVKE7fsezeMt+ZZit +pUqfAoyUogF1YicYgt3IVxeFSkdRdXpbfFNJ8SjQHxPuxH8McrafQwzCcdqQlyfI +fnhNYxHt9lL262lywRLkuAwXB69cUdLXaemfvNVcTW9+QUnz+Emx3KnlhRyRlMNn +hgkwsp4NB4nElHKHntYaoVlEqrDRJyz7mCXNviHb/WC7kNznLEArzPJJa4YjAedy +P9kXTlYEkUcmrv/furc7wrAYeJ/+qQ27ToGk+JI9UQKBgQD0LsPKfD/ep8Y7Qcvl +VOSYqUrjQ9azW2IXkK8L5U5IOZbXScsB3gdxhLhSk2MDz2R8n0BUlYEihdzRBA4K +aH+4qW0OipwjQD+qUU5oW9SJ6SaHRp8Mpq7d/mSR7HnNfXCz60YjYPID+71nK+6q +FcBvFvLxopQt7ZDFaONHMWNodwKBgQDiy6wP5b3ncfG3LzapKM73X765scTUXuZa +ow0aHMJ9nRi0aiLnlGzIPwh3QU5L5mpG+gAIUlaguI29x08BtkeorKhOJ0M/taT1 +nbf0FLIQBm2uzpm4ICTlGEi/drUwssw5kFou4AA3pscdY7dam7BRb7eMcaABECz9 +WlJldDC4sQKBgA4vNUJq607k0hgZH14IC2tu0iHXi/5JPa5+whxfyqdZaRDCgZ9v +JWGLwyVQ2HydLIosuhDvyluWCRi/Mo2aOmkgtmwU0zMdBVXAeVyIkRUdzRYonQ6g +FCJjJ7ZuVTkBo21gKmfdttFSa1M18xxAPTh2zdAJkLAGT9WX3TQCg3LLAoGAXQKE +LPzeNdXP+H0/YH5g6qh0cnlKLIJC3Db0P5o91QAhSpQgfnKrbjATi7zXnF8BhNww +OTlzV3R4hLUBXMVhe/ZbC7okZTNcVHJ7J3l5UQMh5kfKWO2t09pyszq+shsRkCX4 +JjMtQ6V9ETt8zYb991fmoY1TvjvhB4IMOpk9BfECgYBZ6TaBR81zK0bX2dJpvWBu +ECwG9vg80NuM8UIjeQ7iCzfSD/6MsYDedU8+u7seV7LZx01DISUFu6q4rWpncJ/1 +W3+LU/apgy7+jeJmUjN0lFCEbf7f0h4x4GGXYbDCiPdzcrL7g5gcwaaf0+0PO4bZ +t7SfNCX7wVFT8ipYG2vTNQ== +-----END PRIVATE KEY----- diff --git a/deploy/dockerephemeral/docker/redis-node-3.conf b/deploy/dockerephemeral/docker/redis-node-3.conf index 81d01b5421f..4a190e10f96 100644 --- a/deploy/dockerephemeral/docker/redis-node-3.conf +++ b/deploy/dockerephemeral/docker/redis-node-3.conf @@ -1,7 +1,16 @@ -port 6375 +port 0 +tls-port 6375 +tls-cert-file /usr/local/etc/redis/cert.pem +tls-key-file /usr/local/etc/redis/key.pem +tls-ca-cert-file /usr/local/etc/redis/ca.pem +tls-auth-clients no +tls-cluster yes + cluster-enabled yes cluster-config-file nodes.conf cluster-node-timeout 5000 + appendonly yes + requirepass very-secure-redis-cluster-password masterauth very-secure-redis-cluster-password diff --git a/deploy/dockerephemeral/docker/redis-node-4-cert.pem b/deploy/dockerephemeral/docker/redis-node-4-cert.pem new file mode 100644 index 00000000000..e8ebd88bce0 --- /dev/null +++ b/deploy/dockerephemeral/docker/redis-node-4-cert.pem @@ -0,0 +1,19 @@ +-----BEGIN CERTIFICATE----- +MIIDGDCCAgCgAwIBAgIBADANBgkqhkiG9w0BAQsFADAfMR0wGwYDVQQDDBRyZWRp +cy5jYS5leGFtcGxlLmNvbTAeFw0yNDA2MTcxMzE1MzNaFw0yNDA3MTcxMzE1MzNa +MAAwggEiMA0GCSqGSIb3DQEBAQUAA4IBDwAwggEKAoIBAQCvitE2tBIZ5zco7Acg +zZXive6YAUJTrsyfLAFWWJo7rOZJ3vlVvKlGgRLcDRTqS7Rjs5ZiKKjO+vbCo9GH +akHz1hzDQpXUoSeyRlu/AausQbBB1ZhDOzlcg2bmhhG3CYswrSSXM6GdV7C1J4wS +0pmXoZJO9QKvgdskkgHn4I8RGGIshtKRA040yoRQPNJeC7QUOZj94YC+pyR0Yb0e +pawKDllkhpCIosg9TWqEeOFTdm4ibN+g4M5xihqsHTkBlQjvb4U45ybZyJdT3bw2 +inN2f/FZsyOp8as4JoMbXnp/Bwd01Ze/cQ5pVVz4pnvW9jaUzJ5yRi4du3v70Ft0 +mP4TAgMBAAGjfjB8MB0GA1UdJQQWMBQGCCsGAQUFBwMBBggrBgEFBQcDAjAbBgNV +HREBAf8EETAPggdyZWRpcy00hwSsFAAiMB0GA1UdDgQWBBR2P9NFa+sluP6Ic0su +lqWSIP2i4zAfBgNVHSMEGDAWgBSHldnboqMeE+DY2VnBYEYkuOMuODANBgkqhkiG +9w0BAQsFAAOCAQEAjInARY3/TdhAT0RJDdDLyxfx/NF3VD+L0GlA5YGAqj9lLyr9 +rE96N7y6/imhc8r+zecHKcJVNZ+NkA9YHhK0NqkC8UXcV/te6KWxe8KbvrFfuhep +BlWQ0RhQYUDDoFuyZ9FoH+gdynz3OU1J1LyGZG280O5/QQL+ON5t9rD1wYCcTRM6 +zlUyWtbUWxrGVvGClRn6lrTNphOTxBtKM0cqXD6jnnGUqLhCY1y801HHzfJ07jIY +b5iLW+kRiwdnDIvuiJ8gRmqHgr+rHwpv15HfumedQBUuZsVTPpcFiAqs1wrT8BFn +EWPtolHtCOwd57X4UP/LpPnUAHwQJPmloDaL8g== +-----END CERTIFICATE----- diff --git a/deploy/dockerephemeral/docker/redis-node-4-key.pem b/deploy/dockerephemeral/docker/redis-node-4-key.pem new file mode 100644 index 00000000000..5da453ec076 --- /dev/null +++ b/deploy/dockerephemeral/docker/redis-node-4-key.pem @@ -0,0 +1,28 @@ +-----BEGIN PRIVATE KEY----- +MIIEvQIBADANBgkqhkiG9w0BAQEFAASCBKcwggSjAgEAAoIBAQCvitE2tBIZ5zco +7AcgzZXive6YAUJTrsyfLAFWWJo7rOZJ3vlVvKlGgRLcDRTqS7Rjs5ZiKKjO+vbC +o9GHakHz1hzDQpXUoSeyRlu/AausQbBB1ZhDOzlcg2bmhhG3CYswrSSXM6GdV7C1 +J4wS0pmXoZJO9QKvgdskkgHn4I8RGGIshtKRA040yoRQPNJeC7QUOZj94YC+pyR0 +Yb0epawKDllkhpCIosg9TWqEeOFTdm4ibN+g4M5xihqsHTkBlQjvb4U45ybZyJdT +3bw2inN2f/FZsyOp8as4JoMbXnp/Bwd01Ze/cQ5pVVz4pnvW9jaUzJ5yRi4du3v7 +0Ft0mP4TAgMBAAECggEACYE2L8STQFTNH0mcXzHSfkrzasaSrU5HJQ0wa1jzzOxh +MbnBfVtwPPGLMGAC9Gax9z4Hk/wIm+Bp0QMmurLNrGK4/veRfkhVimkV2aNBBNwv +q3jhvC4uPmyc+zliJyt8nl+Znhg9FXRkjIJ+Kpy9lUC5182bXh5lW7cOJFx70pyM +5+UZ3+ogNnGqEtTSRSEKR0TzCLC6hORmlWCbnyYCaVG/H3tKAjg8Mwb7vFpreXSQ +QXqeRT8i/wVcWGvnuYyhkIfuLWOFXMswazLPyf1H8pF6xAxqeaX5QKhv19mE6xf3 +A7ZdBgsCigWcKuNDb9Fx2s/5xZM5SygzbStOvH27xQKBgQDbcZr3mZx2NaYLbDWX +Rk9b/plm7sYBCbenUXHZVE4px2DJ+r4V5XjVvzHM8cLRcNmSPhZJjamhVNsLNUOS +L39ouxuSqarLd7bxB5i2vCUEqnqVs2JhgVAjucIuOhtEGhk1yR9gGIgadXYhO93Q +bdHbop2qgxut7XWPWhuqe/u5zwKBgQDMyP0dOpElgmpzJ9mzgNNvwtxzA4uqllEH +Mst1I+8mQRRVEaqmB+TpfeoR/OUKKKk3XcziDTLCCkwyplahDW7AHbYeizevg++6 +G/09Z0XyZZ51L7LxjVi1ORWyCDrTFMASjPzUGedcIANKkCHZ5q3971iSyjFmXrKa +G/i6pyF8fQKBgQDIuDQf7/CuK0oyvoqSUOx73/ger56LCoFi2NtDB5rrGgRNGz3N +N3T8RgLeS/B/tDI+Uu3930beW4hzyweAalOmzyZcUzb3HwxFkUY9NwDBMNIppcgC +Gc7crqePsvSHqTuP9+Pr+ORdFz2zDlhIsnq25BpFAeFKiJ30Pl555SgN/wKBgGV/ +UISGHJ58rwn4PFxNg34nFGAk57pa2jo5IMIkV0mcg9lN8khsLTbU44ia0WJhmM0K +Ppvjcr7dn7qS2ujj4Xpyv2sQET96ovyZFsCySObFGu51/7jdF5RqgKhGj/FCnZgU +LNNrK1Jrw3XXTg/T13S+hiXq9OUKFndvWa4ZW+15AoGABGPWL6H0hQWyzYq1CZl6 +kdCW0b1cZeuJyl8C3MCFq5f20myvTehua0DdROT+MaLJQ+20etJ9TRHpKiUKhcgq +gJ9y/8tcMG0hMPjQkFzFsHuDiIE3UOtJd9kUwLbl97WUZX1EZ5jmIVdCpcsx6WcU +PFoetX5NdFoY2jhfWym5WcY= +-----END PRIVATE KEY----- diff --git a/deploy/dockerephemeral/docker/redis-node-4.conf b/deploy/dockerephemeral/docker/redis-node-4.conf index 50361d22810..d3c0c57d4ac 100644 --- a/deploy/dockerephemeral/docker/redis-node-4.conf +++ b/deploy/dockerephemeral/docker/redis-node-4.conf @@ -1,7 +1,16 @@ -port 6376 +port 0 +tls-port 6376 +tls-cert-file /usr/local/etc/redis/cert.pem +tls-key-file /usr/local/etc/redis/key.pem +tls-ca-cert-file /usr/local/etc/redis/ca.pem +tls-auth-clients no +tls-cluster yes + cluster-enabled yes cluster-config-file nodes.conf cluster-node-timeout 5000 + appendonly yes + requirepass very-secure-redis-cluster-password masterauth very-secure-redis-cluster-password diff --git a/deploy/dockerephemeral/docker/redis-node-5-cert.pem b/deploy/dockerephemeral/docker/redis-node-5-cert.pem new file mode 100644 index 00000000000..d771a21b461 --- /dev/null +++ b/deploy/dockerephemeral/docker/redis-node-5-cert.pem @@ -0,0 +1,19 @@ +-----BEGIN CERTIFICATE----- +MIIDGDCCAgCgAwIBAgIBADANBgkqhkiG9w0BAQsFADAfMR0wGwYDVQQDDBRyZWRp +cy5jYS5leGFtcGxlLmNvbTAeFw0yNDA2MTcxMzE1MzNaFw0yNDA3MTcxMzE1MzNa +MAAwggEiMA0GCSqGSIb3DQEBAQUAA4IBDwAwggEKAoIBAQCiYYwsg3+qF8hXrp0A +ni/h4oySwTN7JBsElWzipzoY5k5VLZWdYITaYc+mypys1OSHiVsDff12FGWAsKMD +ItoFC2jnMGx9FQcXMokNRmEdmvcOMEx6Y314U/63HzAKYC7XCrV6TdK12zmVxiCc +pZ7Iz8Ch7bzeFTQQY4cdvA9sJJeJ5oJ5Tm/JJGgSzNPBOHbdeDuprQayihA3Hfac +19oM7tZGEqvjk/otzxmi0X7qMKFO43cxD4URqHWa6So2T2g//HvwMoq0AUajmXUI +9DYgownjfZNJ0ISEouuPLHe4C3jdG8ku24r25cugpkY57zN7BlDU0trOFk4TeeyM +HXD1AgMBAAGjfjB8MB0GA1UdJQQWMBQGCCsGAQUFBwMBBggrBgEFBQcDAjAbBgNV +HREBAf8EETAPggdyZWRpcy01hwSsFAAjMB0GA1UdDgQWBBTM1a20hY1IgokeC3tT +zg6shjIA7TAfBgNVHSMEGDAWgBSHldnboqMeE+DY2VnBYEYkuOMuODANBgkqhkiG +9w0BAQsFAAOCAQEABtQ69VGkEHPkIotuB6kqtz7LtDAf4D7N1lIE3pib02n+5wHi +ITzzv0uuNpdzAPfvaR8OU3/8uNzA6GvrspNLaDbhRnXdTI4eDpFro+vRGvsqaLPa +FWpooa+zNgoIqPzQ/3exN6nA0APYqvxRUcAdsaP3C4clecBvHWOpZya3Q1sdvCH9 +b0Fidfb24D0B6arHrx3hEwufmamkMxOnvUFh7mqyEwuyb2lF2x0VKT5/u8+rfOSj ++xmv0A5gsc/Q1jIkzdfGco7i+BWbINS8dj77ajDykpxvbdP1mGzXCqJdBkxaFhO+ +iLUAqbXLDw47wCi3Pe7wDaWFqQfgs97j585lUA== +-----END CERTIFICATE----- diff --git a/deploy/dockerephemeral/docker/redis-node-5-key.pem b/deploy/dockerephemeral/docker/redis-node-5-key.pem new file mode 100644 index 00000000000..6167a8e8275 --- /dev/null +++ b/deploy/dockerephemeral/docker/redis-node-5-key.pem @@ -0,0 +1,28 @@ +-----BEGIN PRIVATE KEY----- +MIIEvAIBADANBgkqhkiG9w0BAQEFAASCBKYwggSiAgEAAoIBAQCiYYwsg3+qF8hX +rp0Ani/h4oySwTN7JBsElWzipzoY5k5VLZWdYITaYc+mypys1OSHiVsDff12FGWA +sKMDItoFC2jnMGx9FQcXMokNRmEdmvcOMEx6Y314U/63HzAKYC7XCrV6TdK12zmV +xiCcpZ7Iz8Ch7bzeFTQQY4cdvA9sJJeJ5oJ5Tm/JJGgSzNPBOHbdeDuprQayihA3 +Hfac19oM7tZGEqvjk/otzxmi0X7qMKFO43cxD4URqHWa6So2T2g//HvwMoq0AUaj +mXUI9DYgownjfZNJ0ISEouuPLHe4C3jdG8ku24r25cugpkY57zN7BlDU0trOFk4T +eeyMHXD1AgMBAAECggEAHJX6IIr8wkOiDgeMFaQDb2tbzmkLKFI8nGO20bbZRDFl +GFsoQ9aORMijzuvLxaRL3+1nE5gOMweXr95IsEBmK62sx8hPTPzS7PtFQ8xAQ/84 +H2wSxpf1qmV1CaVIpob0sAAvXwrMvZ2Mh2ij7Je+eoESWx9YWKtYaUswKeSlvWZy +2OQVQ72eX3MTMTjwXBTqo7cVC+j0/yMxAha6lRRd4BlWDuUi9VZIRS2LC934sPbx +dDDm3qkP9zXF4xg/8MrWe5BTA9pxVcAT+RMIhnk5g+mjHxKL3B7Klbhzn+SLWc9A +1TWRntwbUC+8RYWqCNesAdoLIlEJrNUncOhY+CrPgQKBgQDVFO9yUbp0uMeAJFD2 +qQEwnybIWyB0SWUEq91kFQ3cSFoVSiIvaLYZM6n9lSRwxdXS/KtLnhdyUbkOR0rD +VOJmPf136MwlTHMud3YPxku7YWEDH40BIbFvBNUYj9y4GpPGANen7NgF4Vnn8T6G +7SInfx79y+JhQ+Oxd2DFikQXgQKBgQDDFljiqPQeGUz6B/y4CHBfc+e8eagdt3km +NXsgFuGmu3ksy5uBcgCebXthh3coKPeP2cIwob4sfnjq8vuOWSsIqquLZmidyyb9 +ARBQ/CtSnBXAyakoOnI4usPQmrbFq58xIh6I0MRk1N1L1D2MTz4i6QZzRekxAFdc +nBpaclAzdQKBgFfvadm9zLr6vqotUpRYrrsIExNAOCaFW4EQBC+XWL79xN9gVrdF ++VBxN8gE0qMPoeyOhYqRVY/CFiLEXSA7WatkDcR8eDM0V5xnhHuCFCLiTwzg6mn7 +I6RzVBXs2OPJZA6krlsIrSXQGDBWKL26AwxVs859Y5FMWR0V7QPYyb0BAoGAJZ4A +g6wqbkdYpXm2zFGsQWubCqe2uAwxyyFS3Ywr9Ld/lRipops17VaVDOhPHKpRmiZW +IIR/pBq6/CrgQMGG38PxEg8sKwkKOozi9Yq6W9KHC0aXXI9wiOnSaj368kC2kIXQ +t3bx97Nn/IAvYgfBpn+iY8XeQjmbntrm5fvW5SUCgYBmqOIT2yiFGjJybTvwcDr8 +Lz9QpCnP2mHYiTmzXnPZGCaLIeSmXxCr4YDTgKajKcx0NVZmX/iGm9VDrfZn593w +EVy/oxg+vpME2RnnBLDstO8dVMOuSs8/ao0PZWylkuC+5bMvYO8iaGk3EZSX2fmY +AH0a1dtdGMveeGsFqnQyjg== +-----END PRIVATE KEY----- diff --git a/deploy/dockerephemeral/docker/redis-node-5.conf b/deploy/dockerephemeral/docker/redis-node-5.conf index 68885b25b43..95ed92e53fd 100644 --- a/deploy/dockerephemeral/docker/redis-node-5.conf +++ b/deploy/dockerephemeral/docker/redis-node-5.conf @@ -1,7 +1,16 @@ -port 6377 +port 0 +tls-port 6377 +tls-cert-file /usr/local/etc/redis/cert.pem +tls-key-file /usr/local/etc/redis/key.pem +tls-ca-cert-file /usr/local/etc/redis/ca.pem +tls-auth-clients no +tls-cluster yes + cluster-enabled yes cluster-config-file nodes.conf cluster-node-timeout 5000 + appendonly yes + requirepass very-secure-redis-cluster-password masterauth very-secure-redis-cluster-password diff --git a/deploy/dockerephemeral/docker/redis-node-6-cert.pem b/deploy/dockerephemeral/docker/redis-node-6-cert.pem new file mode 100644 index 00000000000..9e323b2b5cd --- /dev/null +++ b/deploy/dockerephemeral/docker/redis-node-6-cert.pem @@ -0,0 +1,19 @@ +-----BEGIN CERTIFICATE----- +MIIDGDCCAgCgAwIBAgIBADANBgkqhkiG9w0BAQsFADAfMR0wGwYDVQQDDBRyZWRp +cy5jYS5leGFtcGxlLmNvbTAeFw0yNDA2MTcxMzE1MzNaFw0yNDA3MTcxMzE1MzNa +MAAwggEiMA0GCSqGSIb3DQEBAQUAA4IBDwAwggEKAoIBAQC6YjcRhT/CWKdXQXIZ ++qee0UPul0gw+QHPcc8MHsO06bDN8y40//sa2/5fhp80SkFCZSlT99tCBBO+M8Nx +ALADOGvl01aOL9LY9O2nXkya6/6DkIsV+GssBtC1OIBOiSrHfHy+C7ICbV1Ax5Nk +HWEXpkKc8kAZo3ETDqXzCoYq+01qgb12RBBwQxz0yxHDOZcfXFaffIM3+Wv7XnHp +RT22tWJuw7h5TTxx9u1dhZKBWERa2kVUhA6/Ihk/zCpASWbRwOf355jTNAuO+pQT +mXFDwr+/JcenBiwCQzxaTFkUDPwy0UvhrKvK6WsXuySNO6QNFZXPyuus2IOlnXd0 +8+vBAgMBAAGjfjB8MB0GA1UdJQQWMBQGCCsGAQUFBwMBBggrBgEFBQcDAjAbBgNV +HREBAf8EETAPggdyZWRpcy02hwSsFAAkMB0GA1UdDgQWBBR6J2P3AJJ/LRcvVhcE +nrAvvFDyqTAfBgNVHSMEGDAWgBSHldnboqMeE+DY2VnBYEYkuOMuODANBgkqhkiG +9w0BAQsFAAOCAQEAtt28vPDd4DnT9/vIfIAR0xdLVrw6EGBqrsDtGHbF+0SJ0GJA ++2DxQazJGGgBYXqfjZz1+yBImHP3Rio8+gdU84C+K3CKsa6k4N76f2Ym85FrOOjY +nMNVhdPSdlFptq67euCbSJc9fzXE6Aq73Zm9dRtsLQVmYOAMOkw6EPXNLrwVRaCP +FUswJctD0RcRareRsgiDVgRXfPBzfuxMYMYNwWNcQ6R9dL1r0db4O3Py4L2GkB3o +ukPcoemA2FA1ExA+shzzXBIBr2aK79VkaWPzoUuY/TeRmqdxKeDiaFT9F2eUCdez +FbId94n/8E69dSSCtmbEwwQMsxgMxALZEFustA== +-----END CERTIFICATE----- diff --git a/deploy/dockerephemeral/docker/redis-node-6-key.pem b/deploy/dockerephemeral/docker/redis-node-6-key.pem new file mode 100644 index 00000000000..a214d2d810f --- /dev/null +++ b/deploy/dockerephemeral/docker/redis-node-6-key.pem @@ -0,0 +1,28 @@ +-----BEGIN PRIVATE KEY----- +MIIEvAIBADANBgkqhkiG9w0BAQEFAASCBKYwggSiAgEAAoIBAQC6YjcRhT/CWKdX +QXIZ+qee0UPul0gw+QHPcc8MHsO06bDN8y40//sa2/5fhp80SkFCZSlT99tCBBO+ +M8NxALADOGvl01aOL9LY9O2nXkya6/6DkIsV+GssBtC1OIBOiSrHfHy+C7ICbV1A +x5NkHWEXpkKc8kAZo3ETDqXzCoYq+01qgb12RBBwQxz0yxHDOZcfXFaffIM3+Wv7 +XnHpRT22tWJuw7h5TTxx9u1dhZKBWERa2kVUhA6/Ihk/zCpASWbRwOf355jTNAuO ++pQTmXFDwr+/JcenBiwCQzxaTFkUDPwy0UvhrKvK6WsXuySNO6QNFZXPyuus2IOl +nXd08+vBAgMBAAECggEAEori36NaDIO1YkDokR0Wv/4hvALg875SJ8kyyAnnfoAh +Ttv6pNsyqCFq1SYXgKRCidB2pBvsfEzbifisYPmoiSl70omL+ulXGK6FVjlTdbY0 +w/IFZFIql162NNFCMo4C64W/A0k2lHc858zzJOqnVir8RZD0P5i7DyJN8DgD0RKz +uDpulugDgHgWuyfhkve3rmN8RAJkFiSlyJJCKPA1YoSdKrUmqwjZ9WJfV8UrUPPC +PoEksVEiLB0NrE2X0CtcSRuSZV0JDDciCLiCHkwDSWRgLzWnE7ECa8BNgdz+MyUH +WQjAoG5ZNP/9pPtVb2yyHqrC7ekc0wZyzahgiKb+gQKBgQDp8cMdHxf4kBwcJIXq +69OB1/0BwnXs0nXVaWQycy2pEFRC6CGfXkUEG9nT/nnHiQyD2ENcjgR9ATFe4Tx0 +CRfB6LQBmpsBK3fidYyBIUqDypMmrzFfc0Kj00o2v8TlO6bj2cFxYwWiu7VQ4E6i +ACmWfi5Aww+yCVPxzKgbAdkULQKBgQDL9JOjvkFbtFmbOn5yvoiIAOMnVlM6BvAd +vzUxg9Hp+xxYaBLPSEhqqc+kcCUdVzGOKeCZheB+D6OzZ9tAMqv46qBk6gsBdhk0 +uieaD5gNnVJm+l2ziTLNGdIF1StqaqXC/GU58BYqiajZABoePdS9pGK3BprDr1NW +8pcy8laOZQKBgGa3fuq/Zz/8zkrRAnemOcSt9+mY3zwvIAum7ZZ1Gdw8TjLeRzz5 +ICZwsBCzj/a7RuJwxwrRVEkqh+nXzTpJb8P1D2wQ3PQDiOzGnf1oh5YcEMYQcAYv +zleuAszNIH9h1KIATz4gsy3DaxXqlrvshFYOavKGctLB47isGjdZdV21AoGANh2d +8utvUhLHV82scWumtFdv7icUjCf9HBd42Lt+PhQX0ElE/GTUeiC2bI4o+uEA0BTC +eFmyWCB0Mg0TerQ3NyOiDUSgSPH5/CiMi28pzCr7C0HRDOsRZKQ+Orf1/hVwCA2K +GlZeu0itWW6Sf4WuZecxHhkNhXCGr2JMxgLQ/pUCgYAYw3Zvvs1C88geKyugdjtA +RIHPrkU5iPk7N+lr3Fb7HQft063f+ejuUIR6RJUUQsAf1OCsYK2AT9xd6JqAfpZA +AhDHPd8lMy1mepqG7MscICH31pFdLjfyBP9z/aktVgzDgQ5c/VbTxrW/+Zm6vQUC +JAeAbzN4IggEBDj6higxWg== +-----END PRIVATE KEY----- diff --git a/deploy/dockerephemeral/docker/redis-node-6.conf b/deploy/dockerephemeral/docker/redis-node-6.conf index 07da6325790..e727dce17d9 100644 --- a/deploy/dockerephemeral/docker/redis-node-6.conf +++ b/deploy/dockerephemeral/docker/redis-node-6.conf @@ -1,7 +1,16 @@ -port 6378 +port 0 +tls-port 6378 +tls-cert-file /usr/local/etc/redis/cert.pem +tls-key-file /usr/local/etc/redis/key.pem +tls-ca-cert-file /usr/local/etc/redis/ca.pem +tls-auth-clients no +tls-cluster yes + cluster-enabled yes cluster-config-file nodes.conf cluster-node-timeout 5000 + appendonly yes + requirepass very-secure-redis-cluster-password -masterauth very-secure-redis-cluster-password +masterauth very-secure-redis-cluster-password \ No newline at end of file diff --git a/deploy/dockerephemeral/federation-v0.yaml b/deploy/dockerephemeral/federation-v0.yaml index 8ed1179b048..28e50750273 100644 --- a/deploy/dockerephemeral/federation-v0.yaml +++ b/deploy/dockerephemeral/federation-v0.yaml @@ -1,5 +1,3 @@ -version: '2.3' - networks: demo_wire: external: false diff --git a/deploy/dockerephemeral/federation-v0/brig.yaml b/deploy/dockerephemeral/federation-v0/brig.yaml index 6c2216b3c1a..a236c83b90e 100644 --- a/deploy/dockerephemeral/federation-v0/brig.yaml +++ b/deploy/dockerephemeral/federation-v0/brig.yaml @@ -10,8 +10,7 @@ cassandra: # filterNodesByDatacentre: datacenter1 elasticsearch: - # FUTUREWORK: use separate ES v0 instance - url: http://elastic:changeme@demo_wire_elasticsearch:9200 + url: http://nginz-federation-v0:9201 index: directory_test rabbitmq: @@ -201,9 +200,6 @@ optSettings: # To only allow specific email address domains to register, uncomment and update the setting below # setAllowlistEmailDomains: # - wire.com - # To only allow specific phone number prefixes to register uncomment and update the settings below - # setAllowlistPhonePrefixes: - # - "+1555555" # needs to be kept in sync with services/nginz/integration-test/resources/oauth/ed25519_public.jwk setOAuthJwkKeyPair: /etc/wire/brig/conf/oauth-ed25519.jwk setOAuthAuthCodeExpirationTimeSecs: 3 # 3 secs diff --git a/deploy/dockerephemeral/federation-v0/integration-ca.pem b/deploy/dockerephemeral/federation-v0/integration-ca.pem index 10a906c111b..304fc892245 100644 --- a/deploy/dockerephemeral/federation-v0/integration-ca.pem +++ b/deploy/dockerephemeral/federation-v0/integration-ca.pem @@ -1,19 +1,19 @@ -----BEGIN CERTIFICATE----- -MIIDAjCCAeqgAwIBAgIUdsGG4S0KMPKYzS6UNoDuNpvkRFcwDQYJKoZIhvcNAQEL -BQAwGTEXMBUGA1UEAxMOY2EuZXhhbXBsZS5jb20wHhcNMjQwNDIyMTIwNDAwWhcN -MjkwNDIxMTIwNDAwWjAZMRcwFQYDVQQDEw5jYS5leGFtcGxlLmNvbTCCASIwDQYJ -KoZIhvcNAQEBBQADggEPADCCAQoCggEBAJatmwqb8Fabb7JQ916v7QI5ufMEBxhK -VUsnn5frxkAA99LpFRYqs4ycPWQk20tbaNpO2E7pGm0ALuKR5YR5OP69iR6+6JZl -H+c48iryVAXpBZe/PGV1vZRDsOce5YAS0mCNtLEh21FV+6QtnQdgEGbdebBhdQ5l -VN/f8hdkSCPdm56j2K/LUuwOibJYRy5zwJwjmhwuFSurTFN2Y4f6f7AYCgam2q1w -D5dk3JF8RRByvJdJQ8lNmuZbStGLgMTr+Il8Cu+huFUCcGxdDQjM4wKLwS3DgOwV -UXfMsFYxac0I4Z/oMsgE3WVDpTqTFyBGux5nOUzAeCo4iWMKHIypeukCAwEAAaNC -MEAwDgYDVR0PAQH/BAQDAgEGMA8GA1UdEwEB/wQFMAMBAf8wHQYDVR0OBBYEFDnH -CL3yIYkqK51ynDHRQcc6Xc/rMA0GCSqGSIb3DQEBCwUAA4IBAQCUzI4edToGsBTp -qnV2MtXwhoBFnmAa4O8RMsbRZqE+DCzBhPSIl9UMaeIEMoIvXL2KOO+rEw2M1uQc -D4r+dAdUhLbIFEyMNIA5EZfJfimEE0qaLGJqI5X1FFVeCvlvI1UDoSj0KQD9GEsg -VidDnhzg712cGdBY2K4U/BmpLMn8+WZ7+TSVIX8fGylzDCRtCQ36vrD5pkQzblqU -sjO8Apwej/t+BI/Y+T1MFvZhstbJ3mSQpHhnmARXLOrwjcOmLzWVlQa1IJxtxaf9 -gRxVchzH7fQxNlR6/zWtd2av07pFR9k2o9WUn/A5lpoUcVrokvCsOooqqG3UwALU -fZm6IO1I +MIIDEzCCAfugAwIBAgIUQ35aUV70pJjvDTbfgFUj5YmchHQwDQYJKoZIhvcNAQEL +BQAwGTEXMBUGA1UEAwwOY2EuZXhhbXBsZS5jb20wHhcNMjQwNjE3MTMxNTMxWhcN +MzQwNjE1MTMxNTMxWjAZMRcwFQYDVQQDDA5jYS5leGFtcGxlLmNvbTCCASIwDQYJ +KoZIhvcNAQEBBQADggEPADCCAQoCggEBAJQlUOLNmd7Ll7iskcSnsv9xcx/+TnMw +qtqkK17w54/Kto+NJJAkD1L+X5EkSPZ7FDKqt2bGfoETWGnlpH/zsUTUpchlf6Jf +w6TJOejQer5FQNLCtQSnOIchlAFKzFxhGSvcOrRWiBAPjTVIkv9eiCNXcJ5PE9Sk +8+bmn2ztz7LVHcv46PmT/+ihRxKJ01T5CsXWPUHOZQRfGvKZmyGf+iTBuhcxMPYC +nXb7/M3rYCQXL8FQZiaqbIVMqNRpMBVkAqU3l2JnSrlNIjIh6Nqowjog8QYGuIz6 +fxwWkw6EU5ZBwHIr2rOakCnQoKeXVqBJdWZNRMX1Vtqeh7O9zDoW4/0CAwEAAaNT +MFEwHQYDVR0OBBYEFHNgZ4nZQoNKnb0AnDkefTXxxYDqMB8GA1UdIwQYMBaAFHNg +Z4nZQoNKnb0AnDkefTXxxYDqMA8GA1UdEwEB/wQFMAMBAf8wDQYJKoZIhvcNAQEL +BQADggEBAIuLuyF7m1SP6PBu29jXnfGtaGi7j0jlqfcAysn7VmAU3StgWvSatlAl +AO6MIasjSQ+ygAbfIQW6W2Wc/U+NLQq5fRVi1cnmlxH5OULOFeQZCVyux8Maq0fT +jj4mmsz62b/iiA4tyS5r+foY4v1u2siSViBJSbfYbMp/VggIimt26RNV2u/ZV6Kf +UrOxazMx1yyuqARiqoA3VOMV8Byv8SEIiteWUSYni6u7xOT4gucPORhbM1HOSQ/S +CVq95x4FeKQnbEMykHI+bpBdkoadMVtrjCbskU49mOrvl/pli9V44R8KK6C1Nv3E +VLLcoOctdw90aT3sIjaXBcZtDTE6p6g= -----END CERTIFICATE----- diff --git a/deploy/dockerephemeral/federation-v0/integration-leaf-key.pem b/deploy/dockerephemeral/federation-v0/integration-leaf-key.pem index 1a45ba1ea46..1e7a83068de 100644 --- a/deploy/dockerephemeral/federation-v0/integration-leaf-key.pem +++ b/deploy/dockerephemeral/federation-v0/integration-leaf-key.pem @@ -1,27 +1,28 @@ ------BEGIN RSA PRIVATE KEY----- -MIIEowIBAAKCAQEAukRPdjUjKs7P2TgP4VDpb77Rb7KjMMBtcRP525qEnUQzFHPk -Va4cqh6xacgh2NJCyFyDEWDI9pQ03i0HISIldoBngDVvM6kwvbs+kjZ+/t/Jx3aH -zC9dmsLqmCqU+OmofpD1pt8hZWwOtYj58pfqdhrP+M6qQ92/tgmkk9njLFwsAjxY -gMXZCo0IiSIE9BE9NGvR9bp6hvEekCqREPdHi44iFca/5V4A8fSZwBlTHod5Z83r -MpHLnR1ReVVOQgzbIBGcLdmtH8IA9ZgUHy1/HOmf9e0MYOYOKbKvH3cry7WSscPL -47x+JQyFLimidfsJQCY+022rdPg9CdrCWFGxgQIDAQABAoIBAGjeBqK1fewe7XQN -FRu0cwh/tOge+bN70uHj7jrN/rWP7PYp3TbDxM2eZCH7E9s/XWvycbQ5+kqg3Dbt -wOLNl6vk1OCgtM+wBIn9PlgRKGSUV8Tdncy+KgP0kyFCcAbHfh5rvHHLk8DHGmzo -BlinYNBHfilFKST2VnXFbgvzkuuorS1BRAzlVpyJnaen04emBJ+KPIwNyguPQrlv -5duBIO1bzlEjFVufrLkI0IumWqBAPOvHcRy1geSz/MG7LssB9r25k5LA5OEDxqwx -ykSzuniaLL6BGMSCAMpTM3/hF1ijrkTd74cI4cp7k2ufcYT74ZU2lyDKEjBukG/p -H0/1Q8ECgYEAwL7VWIpySGtrJEPZH1FxtpJYg8SE0F4lUxIbIQcc6rzLJfLOLQO5 -ruTVONPTlue6PHrRO8pQTbW9AnjZvHMIiwxidY/RwUVKFuxzfrYZ9ZbKXyVOh48a -WXe5OnpuVodPEHQrKzkl93YWMgMCXNPri1h0jr0fMGXy9jZzoKK5f1kCgYEA92Uw -P4WyBL2hm/5BNUoxCiLyd1dDdQt1h6VByxYM7OXDhXq1iHnhX+NbjMT0QfOFyXBP -uQQCB9IQElmMmWsoEv6uEQCeuCvOxq+Evoz+3fP2te89HjZ1C5SXUMfG7qKfFzbt -WP6e/CqAeQPnnqI89ghw/IerQkeVMoVvHbSXZmkCgYBZPgJ6JGAVt+a7u85j+cm0 -xr3FBNCZyX1uoQt+l1SEOzW0NF/R58+pcrpmvW1SiahpKFSIYnwb/vGsm1f1MS3b -c7iCxjxQSEytoH05Rgdu9ops01Ew4slIc26H7Pf5iFzLOX5jXOp/UWWlck89u8Fr -m2EcVeSC/DEqXrvavH02wQKBgBzVKDhfBo5S44DgswzY5ro9tHCANRZxDXOPqQlY -Oo1pgc4OrRWIzuF0B/lyAt2k2hTOCBySAQKUUtcwpJhEytjb4cGNhvID+Qdi8V+b -4yBPDJPLnB3nTuDYooIBpoetYEk+V48lrbXJ5ks0T0xHsD8kYLatwSHqYdMPhhG6 -OGLxAoGBALZQSuO4fHew4ksMcBy891ZSOFUV9xAtR490EdEQdOiPrQj5vmnSpxEx -QsSVbn+49OYwzjBP+sHtpiTMF4ZlafHvjcNZ5dFIImqyuEugEdnD5UnFd92AQ9Gv -ufa7BMs99BRdkkolCXBZC+Dq4t4Z/+MDSMtjO5mh9V0boDakdJPb ------END RSA PRIVATE KEY----- +-----BEGIN PRIVATE KEY----- +MIIEvwIBADANBgkqhkiG9w0BAQEFAASCBKkwggSlAgEAAoIBAQCZjOHeUnlauuxD +WgrRnh3hj5Fs+uh9vyddMX8rSWJIbWFw4QuYzYKY8CQa3MBb6qK1uUwoJ0W1w47I +RgA5VLvGxI+T1wX8E5vljVgfT3CAXHKRB88NrT8A1urQnWpzlq5sNerL6dqgBrjG +QBmFF7NxrvjGgerC2D8+srWfpQ6Jbl9by8c3JDu+T79PM+pW9ycUgdF1AJQBTz9K +zNQ7ZTlBQvJG8WhTMKioJgQsE60oEXD0C8M5yKBBb7DrqkeZInXqCw2y7DZLWzog +D+jgoAD5/9sk3d/gGNqDibzjjwMiJnH/IqBTkZsQ9OdZZPfx5v/p062hQBlM656P +2jMpJ1xxAgMBAAECggEAS3NBjWgDP4T4EUROaqACWNKeB+nmkdt68T0gGtoNVD+D +EN9UPnpFQPdHFngAgWnzF858UIKzq1Pzdg+HjqRHPK1bS67tvua3xP1GHuR/CGPk +28T1hefqPHRen7GqHDAfdwarYBWCGv4Sjz/yCkcSIrtyfMBb5fAya5GO02pckUSK +19sl7XhkPtHJVirRkjQL29R2TCpkNNpQMjkuYLk7mox+6pNTbxgbk0cnT3eGj1pV +mlPqpwzC5GevRziE/VE/WXFLChY+8KB4fDLRqWnyvabDvQ4coaXgzwbdScJyM5hX ++Dxdfni/P2m7xAZXUyfBsr0VUzqUkJfK3WWvvAGTDQKBgQDNi3RUEjVnU/MN4aDz +iZB2VYGfo/K69xTPNEbLQWs1F4ZMpHVtUVXzTfx/xG9ug989ijEm6ncL9OsnhThn +UldSz2ojSJUxLmhgCHZGYHT72v/9rEqfT9JisWpIj44KXufUHCcl3Cozj1ae3EUp +NVhN1HphB2LsCIJvLYfLIGdBNwKBgQC/PhHQMm/MQe4pOHAbdzDrRZWdG2KSRVxp +9mmJ/aT8LOp7BDjq+Dkct6a56JGqlOTeJirMTTmCKiOiTInuB9S+K7kWJJiYg9g4 +UCiuMU+40Px/1Z4/uxRj3DSdGLXG7S6kPeADx9f9BUNpAytGqOnSnfbDiDVvQVbp +0N0+nIXDlwKBgQC2uZOXrXxGOE4pd/ySpCeF2yvZ1HDTnxWjwlBxHt4Em74rYkR2 +A0mKezjOCL4bHCaYWcKqWuOsAHYQcxEaYQv6NSOg7ESdLSlivgMPO26j+yN5yvGn +wNlCHYBjsyLNu2MSoFh5AsmNfo69uQnOwXqX7h1BJsTdGg+CcJJ4lHzWbwKBgQCD +/CRzGbwKrh3eGPNWIUaDuTxudy3qYTBMeSGReJpa5+zUBa/6imFwLldEyvttTOE/ +Z/v1j/52lPqO0mAHBSSQMsDERXGDIMsi4j+RKLsqhCEfYKCcv1JtMNam7RzXM24T +MBjgwxWPrAg/+03ssDrffuGFRQYLyH5hVCK9SW0P9QKBgQDJ1ZSto+RWxv/uOKNr +7FYeQoKpMb2IvNvnGlnYHC8KS9qRq6wUE+FtuKcdLBQP4M9Cgq71VD/dsawrhEw7 +1rAYk3OqmHxBOU5Dcb152NxYHEf53pfEfWc0x4AEVe+Jzynj2EYixRKNWwODNTEx +LKJOYd0CuWywxg6d9G7A7XbgWQ== +-----END PRIVATE KEY----- diff --git a/deploy/dockerephemeral/federation-v0/integration-leaf.pem b/deploy/dockerephemeral/federation-v0/integration-leaf.pem index 2247758aafd..635d332de70 100644 --- a/deploy/dockerephemeral/federation-v0/integration-leaf.pem +++ b/deploy/dockerephemeral/federation-v0/integration-leaf.pem @@ -1,21 +1,20 @@ -----BEGIN CERTIFICATE----- -MIIDcjCCAlqgAwIBAgIUK9Dix5VZpBYOby63cdmjtfg6RpwwDQYJKoZIhvcNAQEL -BQAwGTEXMBUGA1UEAxMOY2EuZXhhbXBsZS5jb20wHhcNMjQwNDIyMTIwNDAwWhcN -MjUwNDIyMTIwNDAwWjAAMIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEA -ukRPdjUjKs7P2TgP4VDpb77Rb7KjMMBtcRP525qEnUQzFHPkVa4cqh6xacgh2NJC -yFyDEWDI9pQ03i0HISIldoBngDVvM6kwvbs+kjZ+/t/Jx3aHzC9dmsLqmCqU+Omo -fpD1pt8hZWwOtYj58pfqdhrP+M6qQ92/tgmkk9njLFwsAjxYgMXZCo0IiSIE9BE9 -NGvR9bp6hvEekCqREPdHi44iFca/5V4A8fSZwBlTHod5Z83rMpHLnR1ReVVOQgzb -IBGcLdmtH8IA9ZgUHy1/HOmf9e0MYOYOKbKvH3cry7WSscPL47x+JQyFLimidfsJ -QCY+022rdPg9CdrCWFGxgQIDAQABo4HKMIHHMA4GA1UdDwEB/wQEAwIFoDAdBgNV -HSUEFjAUBggrBgEFBQcDAQYIKwYBBQUHAwIwDAYDVR0TAQH/BAIwADAdBgNVHQ4E -FgQUaJdzHC5JsdIEKTYxqAWoSHvFCNgwHwYDVR0jBBgwFoAUOccIvfIhiSornXKc -MdFBxzpdz+swSAYDVR0RAQH/BD4wPIIZKi5pbnRlZ3JhdGlvbi5leGFtcGxlLmNv -bYIUaG9zdC5kb2NrZXIuaW50ZXJuYWyCCWxvY2FsaG9zdDANBgkqhkiG9w0BAQsF -AAOCAQEAcoUcdwgoAiFJcoS/t1IU2axEJeWncctYyVHt/ZfoZ8y/23XDA+kIfgSt -DZEqteGyVDSBbI/B45IzrKQuJzdT8B+9iDcOzLrA2R1432ASlMhHC5l3STBru0jl -oL9M8fJU6BwciCqY0Y2wFcCfVthN1rC8vNNSpwSwF74q87MMLZ/65Mi3hAB4177s -uNL6MXGta9fBK9MQxM3S/Kr7fmxOTQBlQtcA2Ha3Yog2+dkMXosoapjoMwWj36DS -j9v25/dFmS3dnCfhRHBSh9iUSnbOVZ/M+5Bv5hBPYbeSw24DXD1w9soEYL941D+c -enXV719UPw5bpBxhXjl9Hu0TQ2uoIw== +MIIDQTCCAimgAwIBAgIBADANBgkqhkiG9w0BAQsFADAZMRcwFQYDVQQDDA5jYS5l +eGFtcGxlLmNvbTAeFw0yNDA2MTcxMzE1MzFaFw0yNDA3MTcxMzE1MzFaMAAwggEi +MA0GCSqGSIb3DQEBAQUAA4IBDwAwggEKAoIBAQCZjOHeUnlauuxDWgrRnh3hj5Fs ++uh9vyddMX8rSWJIbWFw4QuYzYKY8CQa3MBb6qK1uUwoJ0W1w47IRgA5VLvGxI+T +1wX8E5vljVgfT3CAXHKRB88NrT8A1urQnWpzlq5sNerL6dqgBrjGQBmFF7NxrvjG +gerC2D8+srWfpQ6Jbl9by8c3JDu+T79PM+pW9ycUgdF1AJQBTz9KzNQ7ZTlBQvJG +8WhTMKioJgQsE60oEXD0C8M5yKBBb7DrqkeZInXqCw2y7DZLWzogD+jgoAD5/9sk +3d/gGNqDibzjjwMiJnH/IqBTkZsQ9OdZZPfx5v/p062hQBlM656P2jMpJ1xxAgMB +AAGjgawwgakwHQYDVR0lBBYwFAYIKwYBBQUHAwEGCCsGAQUFBwMCMEgGA1UdEQEB +/wQ+MDyCGSouaW50ZWdyYXRpb24uZXhhbXBsZS5jb22CFGhvc3QuZG9ja2VyLmlu +dGVybmFsgglsb2NhbGhvc3QwHQYDVR0OBBYEFPowAfmLPCmdCMdSxQjsR6UQSoyH +MB8GA1UdIwQYMBaAFHNgZ4nZQoNKnb0AnDkefTXxxYDqMA0GCSqGSIb3DQEBCwUA +A4IBAQCMJwbLzUsrkQkgdGKVi/Mb5XAAV0sfkwZch1Fx0vhJI072cZSow5A2ZUHa +LScFNTPmilPKEr6MS4xIKtRQaMHInbfxSsyNViKhpzkSOKoAiJjIJ2xPKFPnbTDI +uV74nxxyf9q/p3SLQfJFk7fxbvNeLqg5bYSrMeklHj4bpMJ9fybS8/mZVc8AkTFK +fsXSu9CW1B3GF+jP3E2GrFF3Zh9MgvWjMlSYg4ljPf5FoMCUq6GmQ17hQeJFvb5h +Jqk6TcgUrp082bcVlPW17XzFwVe3n6uzvWMtwI62EztVUj98+YkBiFL3i4+OQwAU +/noc22fq20OyJtCPJY4FIK7xUcgD -----END CERTIFICATE----- diff --git a/deploy/dockerephemeral/federation-v0/nginz/conf/README.md b/deploy/dockerephemeral/federation-v0/nginz/conf/README.md index c8e81957c62..8e614e99d1b 100644 --- a/deploy/dockerephemeral/federation-v0/nginz/conf/README.md +++ b/deploy/dockerephemeral/federation-v0/nginz/conf/README.md @@ -3,5 +3,5 @@ Run from this directory: ```bash -../../../../../hack/bin/selfsigned.sh +../../../../../hack/bin/gen-certs.sh ``` diff --git a/deploy/dockerephemeral/federation-v0/nginz/conf/integration.conf b/deploy/dockerephemeral/federation-v0/nginz/conf/integration.conf index baae352c92a..12c49ccfe88 100644 --- a/deploy/dockerephemeral/federation-v0/nginz/conf/integration.conf +++ b/deploy/dockerephemeral/federation-v0/nginz/conf/integration.conf @@ -3,7 +3,7 @@ listen 8080; listen 8081; # for nginx-without-tls, we need to use a separate port for http2 traffic, -# as nginx cannot handle unencrypted http1 and http2 trafic on the same +# as nginx cannot handle unencrypted http1 and http2 traffic on the same # port. # This port is only used for trying out nginx http2 forwarding without TLS locally and should not # be ported to any production nginz config. diff --git a/deploy/dockerephemeral/federation-v0/nginz/conf/nginx.conf b/deploy/dockerephemeral/federation-v0/nginz/conf/nginx.conf index a604e9ab199..cd4ec97a1a7 100644 --- a/deploy/dockerephemeral/federation-v0/nginz/conf/nginx.conf +++ b/deploy/dockerephemeral/federation-v0/nginz/conf/nginx.conf @@ -47,7 +47,6 @@ http { large_client_header_buffers 4 8k; - # # Security # @@ -99,16 +98,34 @@ http { default ''; } - - # # Locations # + server { + # elastic search does not support running http and https listeners + # at the same time. so our instance only runs https, but + # federation-v0 only supports http. this proxy rule helps with + # that. + # + # see also: git grep -Hn 'elasticsearch:' ../../brig.yaml + listen 9201; + + zauth_keystore /etc/wire/zauth-pubkeys.txt; + zauth_acl /etc/wire/nginz/conf/zauth_acl.txt; + + location "" { + zauth off; + + proxy_pass https://demo_wire_elasticsearch:9200; + proxy_set_header Authorization "Basic ZWxhc3RpYzpjaGFuZ2VtZQ=="; + } + } + server { include integration.conf; - # self-signed certificates generated using wire-server/hack/bin/selfsigned.sh + # self-signed certificates generated using wire-server/hack/bin/gen-certs.sh ssl_certificate /etc/wire/integration-leaf.pem; ssl_certificate_key /etc/wire/integration-leaf-key.pem; diff --git a/deploy/dockerephemeral/init_vhosts.sh b/deploy/dockerephemeral/init_vhosts.sh index 9323e6f5a43..688d635e0a5 100755 --- a/deploy/dockerephemeral/init_vhosts.sh +++ b/deploy/dockerephemeral/init_vhosts.sh @@ -4,13 +4,17 @@ exec_until_ready() { until $1; do echo 'service not ready yet'; sleep 1; done } +create_vhost() { + exec_until_ready "curl --cacert /etc/rabbitmq-ca.pem -u $RABBITMQ_USERNAME:$RABBITMQ_PASSWORD -X PUT https://rabbitmq:15671/api/vhosts/$1" +} + echo 'Creating RabbitMQ resources' -exec_until_ready "curl -u $RABBITMQ_USERNAME:$RABBITMQ_PASSWORD -X PUT http://rabbitmq:15672/api/vhosts/backendA" -exec_until_ready "curl -u $RABBITMQ_USERNAME:$RABBITMQ_PASSWORD -X PUT http://rabbitmq:15672/api/vhosts/backendB" -exec_until_ready "curl -u $RABBITMQ_USERNAME:$RABBITMQ_PASSWORD -X PUT http://rabbitmq:15672/api/vhosts/d1.example.com" -exec_until_ready "curl -u $RABBITMQ_USERNAME:$RABBITMQ_PASSWORD -X PUT http://rabbitmq:15672/api/vhosts/d2.example.com" -exec_until_ready "curl -u $RABBITMQ_USERNAME:$RABBITMQ_PASSWORD -X PUT http://rabbitmq:15672/api/vhosts/d3.example.com" -exec_until_ready "curl -u $RABBITMQ_USERNAME:$RABBITMQ_PASSWORD -X PUT http://rabbitmq:15672/api/vhosts/federation-v0" +create_vhost backendA +create_vhost backendB +create_vhost d1.example.com +create_vhost d2.example.com +create_vhost d3.example.com +create_vhost federation-v0 echo 'RabbitMQ resources created successfully!' diff --git a/deploy/dockerephemeral/rabbitmq-config/certificates/ca-key.pem b/deploy/dockerephemeral/rabbitmq-config/certificates/ca-key.pem new file mode 100644 index 00000000000..406f6d9ed97 --- /dev/null +++ b/deploy/dockerephemeral/rabbitmq-config/certificates/ca-key.pem @@ -0,0 +1,28 @@ +-----BEGIN PRIVATE KEY----- +MIIEvAIBADANBgkqhkiG9w0BAQEFAASCBKYwggSiAgEAAoIBAQC/vE2Cea18UZ1J +J0a3IkIoXl2JPSJp7y/bPXsN6sk44F5Dv9mt5hxVERyCQSMiuM6dXfzkRcMAZ7dx +5nQ7GpSEJksqe4h+WFHWDQjaoxrOYVg9UAa6q0rq5h+uHZEpBWwJWNlwRgzyf5zf +IZnjttVD2mu4Gp2xRqtNkEbAOgMJp7ijb76foKsGLFrxJNA3khNjsnDlwRuoffVS +LafF0CA7cW2FYxjwKM/IymCaRVUS18IftCtm3KCl5ou+1aD0/rMsLMKEY1HYCyGo +ZSOnvd5xhRPj6upk3MpWUUyULSkpkQtVPy+RZKUNXb3CGVNJz3UgvMwNXKpW9FdG +Suze9HxdAgMBAAECggEAEU8SKZA10tOaAQue/P4GaOyJQdAXYObV3tNAXkjux3Ks +hS3hnIBPLc1wpxWdnWR/n9c8nZg/+rO3l3xiy8nM1IKR0JD8Xnjh/RKKKmqvtdKL +NmXDZcCm775nPRRa5rrK6QEbXWEFiYgZr6Rckcu57vkzNkM42dMeYyR+Lpujazs6 +Um3Z7rPXevX/gVr9XHjxJ5bX9WYB7sJfZTHLqkO7VGwrXf7HGrtT1ES+iXqjGLpH +5Sg55V5XJfxsqhq+TQgEnorzp8+LEXms2HYTP3G47wP51IWbHa54BUBwkwhiNYV7 +os71j5mrZbUnJ/2KvQPMjiF7uHKlKYjxXiAoj9wRZQKBgQD4e4RuFVaLtF1+khNI +uEgmY4AfakeCB9D2Do1/fhLDTT6EdAxFeSx62VyY3wTG5Pi8DyrFIUNbIYbO8vRx +u8XpzCPxn9TnPnLZ9BRf1+GrCuyQWaFZOnnfAovk3KK4D3vWD9Yn38aTYpTd+3Hg +AEIzd7Bd4dozKtKW7+wI9uOm0wKBgQDFiUih6D0TYrS4T+cM5KhI+ErqTTiFpZ/L +BvA2hyRZTbP+erII9A+IqRNlwidGc1UF4xGu9Ei5QBVfFFbch6C1IRwIoog0hqsH +7s47VIcDuoASq52DHoUABbw9SrfsLjAZz5bLNPmvrEorwIImHNwDG/yOgpT8z7PV +z4/MhoWyDwKBgB+8FrPAgechx/cMTO4yqvRMLObWOf+/Y86pGSU5Qsgyq1NbRt3w +ld+ytwLHKOMGB0ZtYXb/wox3AbKYkOOdqa8sZULMuPI3pY90fs2m0ql3obLl35d3 +wmza9GbsTtPXFmfGagF5sPDN3FllbavAHLRaCupSl/2E8JRaW/jhHz4FAoGAfL4H +Ggd4mkdY7JO4ytGS3BG/7Vo6eVtwH1wQUb7h22tQYUHGMBU/wgNTdo03FCw84uzT ++/HUAvhPBq3ndHhJqlhwRZut+82XL/lETv9AC8C4pBGv9F9PigYVK3eF0iYQxhvr +lAOuMZvRcvOsvLi4z1XbFXus7kGTxU+/9V52C00CgYBY5SgRETt5kgbH/rm36SsE +4x58yK8uYF8MgtBCLxn7E0vnZ2cAMmmDC9wWCHtuq2QhqL/pB+fPI8ri4XNPMXJC +faAxJ0VNmz8fYTzliAWy3Sqp/kgeXdrX9KJkN24LP345LocDBcaML+thDFevmXBW +mahBgoa1ZWxnLJe5XweVkg== +-----END PRIVATE KEY----- diff --git a/deploy/dockerephemeral/rabbitmq-config/certificates/ca.pem b/deploy/dockerephemeral/rabbitmq-config/certificates/ca.pem new file mode 100644 index 00000000000..cb18742fab2 --- /dev/null +++ b/deploy/dockerephemeral/rabbitmq-config/certificates/ca.pem @@ -0,0 +1,19 @@ +-----BEGIN CERTIFICATE----- +MIIDJTCCAg2gAwIBAgIUaJxRWt/eEYHgz+Rs5QNWVHMfk5swDQYJKoZIhvcNAQEL +BQAwIjEgMB4GA1UEAwwXcmFiYml0bXEuY2EuZXhhbXBsZS5jb20wHhcNMjQwNjE3 +MTQwMjE0WhcNMzQwNjE1MTQwMjE0WjAiMSAwHgYDVQQDDBdyYWJiaXRtcS5jYS5l +eGFtcGxlLmNvbTCCASIwDQYJKoZIhvcNAQEBBQADggEPADCCAQoCggEBAL+8TYJ5 +rXxRnUknRrciQiheXYk9ImnvL9s9ew3qyTjgXkO/2a3mHFURHIJBIyK4zp1d/ORF +wwBnt3HmdDsalIQmSyp7iH5YUdYNCNqjGs5hWD1QBrqrSurmH64dkSkFbAlY2XBG +DPJ/nN8hmeO21UPaa7ganbFGq02QRsA6AwmnuKNvvp+gqwYsWvEk0DeSE2OycOXB +G6h99VItp8XQIDtxbYVjGPAoz8jKYJpFVRLXwh+0K2bcoKXmi77VoPT+sywswoRj +UdgLIahlI6e93nGFE+Pq6mTcylZRTJQtKSmRC1U/L5FkpQ1dvcIZU0nPdSC8zA1c +qlb0V0ZK7N70fF0CAwEAAaNTMFEwHQYDVR0OBBYEFN8gWZGKR0/K/e+qyGcN+8Ae +IokuMB8GA1UdIwQYMBaAFN8gWZGKR0/K/e+qyGcN+8AeIokuMA8GA1UdEwEB/wQF +MAMBAf8wDQYJKoZIhvcNAQELBQADggEBAKTpmSYDx+Fabe/idnMlC9+5KaQmD/dp +x1BW8HZT+ZK+NuadPUVyUx1xHOw+wh1u5G8docGkrCsA/hvgyIRSyycJRCaySt1y +zjml3s3T4wRktgx6Z5X3kfw612/tZ5NE4QyQuN9A7DC9Fh4Z520fMDel15D+t70z +nNjZdp5gxpJPUJCebJ7+OhSUhtgr6g4hXwNqDR7DLwXyhp90UFdjfx4kBYFE8Vnk +nA9ZwC7GhUioMV/yXOuekyiJBv9LtaSuc/Y29EbLufLAwZJD1lA7WN254nNmZgAE +hAhTqL6dgvIIhuKHQ6f4vqAWi4FsrRy6cvh7S80+ldcchMBDcIgh1BA= +-----END CERTIFICATE----- diff --git a/deploy/dockerephemeral/rabbitmq-config/certificates/cert.pem b/deploy/dockerephemeral/rabbitmq-config/certificates/cert.pem new file mode 100644 index 00000000000..6d5744d1f7d --- /dev/null +++ b/deploy/dockerephemeral/rabbitmq-config/certificates/cert.pem @@ -0,0 +1,20 @@ +-----BEGIN CERTIFICATE----- +MIIDPTCCAiWgAwIBAgIBADANBgkqhkiG9w0BAQsFADAiMSAwHgYDVQQDDBdyYWJi +aXRtcS5jYS5leGFtcGxlLmNvbTAeFw0yNDA2MTcxNDAyMTRaFw0yNDA3MTcxNDAy +MTRaMBQxEjAQBgNVBAMMCWxvY2FsaG9zdDCCASIwDQYJKoZIhvcNAQEBBQADggEP +ADCCAQoCggEBAJZ3b8mfnf8XuUJmFQ8xN9V8N1PiMe5X+WMqOKduZXqPeW9rECmC +B3opcDVMQ3iyRtc+fXYSJiCllMeCCwzIWQw+k1PcFZ6zXWsvtEFQRCN91vcShZm0 +v8YlNcYl3wxsnIcZ5/IAZTiyX2U/hTBkgOszJcfe8cBOZsI9QzRuLRzE3kkpA+U7 +/3ekPsIxk/g0NtbRA4BgSrcKl3iAI4CMJTJlsezQbF6LZqW7yIOyvaQzT0kyJ564 +0X7YCT5QozL09ZdbQY5b6pphNNfXqY1KEP/aje+UrzQm2R3e9BUGMM4o14pQOU7Q +cxWRjPSPL3nDKUxI3kI9etrluFLH9lQ1uT8CAwEAAaOBizCBiDAdBgNVHSUEFjAU +BggrBgEFBQcDAQYIKwYBBQUHAwIwJwYDVR0RAQH/BB0wG4IJbG9jYWxob3N0gghy +YWJiaXRtcYcEfwAAATAdBgNVHQ4EFgQUf53Mqv9QZmcO5uwUUNZcMQA05cAwHwYD +VR0jBBgwFoAU3yBZkYpHT8r976rIZw37wB4iiS4wDQYJKoZIhvcNAQELBQADggEB +ABXBCl+jy+EeDPLwFlHX/DTJrce3VQMAG+x5WxbuKr68zS8uwJFfqmb4dK01RiSe +QAaISp/vr4KRbbNc5f/TA5dOhc2qXf8dZ0rILWE0u1I+1y9DFuNnymIywbodo6ho +ln7bj2wNl1vZ1A6Tm9fH6MJhavCCM18AHZuz+ml9b8SSVnL3XfPUWuZjYnElSXWj +qTJUF+o/1QC3E+ILj5iiwaAgp8kJJezr5m90RC/DTchYS/CRtz79jYMY8IMdOpN6 +JC92KzpO0jKZ4qWkDi4ZgszPTNcUdnjUc4botJrfZhioA26skUiuacyqfpvnspno +y5DFD+Od2XpBCCwgeYk6IPM= +-----END CERTIFICATE----- diff --git a/deploy/dockerephemeral/rabbitmq-config/certificates/key.pem b/deploy/dockerephemeral/rabbitmq-config/certificates/key.pem new file mode 100644 index 00000000000..6471c8d1781 --- /dev/null +++ b/deploy/dockerephemeral/rabbitmq-config/certificates/key.pem @@ -0,0 +1,28 @@ +-----BEGIN PRIVATE KEY----- +MIIEvQIBADANBgkqhkiG9w0BAQEFAASCBKcwggSjAgEAAoIBAQCWd2/Jn53/F7lC +ZhUPMTfVfDdT4jHuV/ljKjinbmV6j3lvaxApggd6KXA1TEN4skbXPn12EiYgpZTH +ggsMyFkMPpNT3BWes11rL7RBUEQjfdb3EoWZtL/GJTXGJd8MbJyHGefyAGU4sl9l +P4UwZIDrMyXH3vHATmbCPUM0bi0cxN5JKQPlO/93pD7CMZP4NDbW0QOAYEq3Cpd4 +gCOAjCUyZbHs0Gxei2alu8iDsr2kM09JMieeuNF+2Ak+UKMy9PWXW0GOW+qaYTTX +16mNShD/2o3vlK80Jtkd3vQVBjDOKNeKUDlO0HMVkYz0jy95wylMSN5CPXra5bhS +x/ZUNbk/AgMBAAECggEAFSsQawktrSmlQpYh+FUwSbSEBCUaaTGvQCg8eDGrzSZK +K0agq3ZDnwgdZSIpi91o4fdEp0u+WXFyEO9WpqG5BWP4Th/0WrNZPS8k6Ntl+qhF +idTtPsaTBElP22SQkKrnCoq2evFbTDKsAQ6CqmA5Ut2LPyc6U5e0FTeRMNsfNaC1 +e+60J5yjxYWfZQdU5F+uiycWWiqabOafJfbN0gdLeuIICG+Z8AuWoUjLg2v55itw +X9T3AWZ2+/kdUY8j5FXFoK2MfuzW7Ys+Y1JeLMHrquy2hicSMbJE7vnxNsv1VMPc +IZzlgS+N/Lqre0S0NQAKqTGxe4PcUw+Mp5ZqXHtBwQKBgQDEViEeOAAtfvpK4pFv +drXmv2KacieEtUeEVfgbzMY4tL2q7RfFGxC4iiLklvwhQSGyfRamtut+t+eR4eFx +XKHaZxobwwfW5sMi6Ye/iyuL3YXvtWiaOz6XNImFTeWUPLnrX5qtMuVbx4UGiKa7 +kjg/214A8Zf/qoVJxzAJwp1E6QKBgQDEMOM+dnUlUc8FrllXmlsGYMxwWdQ+vvvw +BdKrm6Q61z3+C5189VwQQ1+ruIcmfVqCm1BKa0J76evgdqHo/pgiAaGEhItVt8cN +3IVnpQu9Fhphgd/iFYxyTOCW2d1Nze30H1oqwpgmZsw2vE/6WrU8e1j279+SUevS +2+rx7i1T5wKBgE6rhFGrdsbEHl5rMoNLOc/f2A6ytwsB6EoqeGQLRVHreiRHJEMi +eSy4jQqzRQu+IVZ3sN/UY8A+yFc3/zGBQIlWzqtZFocRqBcRJAeoKCa++K/4LJXA +L3A+6Ou1LsybGJQrlrrXrfd8ltzrXIPELy3HJH+UTqdvGEFbwu/mP0YhAoGBAINX +Pyp33yDmzbM97y3Idhuk/fhRCtgev0cGfuzHu4BwzF2gpQQctk9k601osYHA9bDu +DShk+hM+nNyeTvJOTsalVN4EZcsyxx2ufdjPEza471xLt/gA+Q8kDE6w94i4zg5a +VuC9eWJr+1bBZsFxrFcbNInMOF4aXcfB1l20V8ANAoGAXZcAv5zU5Cj4ktoe0uqi +7p9zR8mgW2oXU0orgdQ3Ce2Z2qy4yFU5AfHPmn1RuRFsQCxX8RpUqLDHOvpn6gyt +/u9GBqlCqYG4KAbGKGVjodEIXilbIVNEbCIi4kGcRO038fzZJawwhrXg3FuMd6EV +G92A1vtGnTZYkatPK4LRnBk= +-----END PRIVATE KEY----- diff --git a/deploy/dockerephemeral/rabbitmq-config/rabbitmq.conf b/deploy/dockerephemeral/rabbitmq-config/rabbitmq.conf new file mode 100644 index 00000000000..fe1756e9285 --- /dev/null +++ b/deploy/dockerephemeral/rabbitmq-config/rabbitmq.conf @@ -0,0 +1,14 @@ +default_user = $(RABBITMQ_USERNAME) +default_pass = $(RABBITMQ_PASSWORD) + +listeners.tcp.default = 5672 +listeners.ssl.default = 5671 +ssl_options.cacertfile = /etc/rabbitmq/certificates/ca.pem +ssl_options.certfile = /etc/rabbitmq/certificates/cert.pem +ssl_options.keyfile = /etc/rabbitmq/certificates/key.pem + +management.tcp.port = 15672 +management.ssl.port = 15671 +management.ssl.cacertfile = /etc/rabbitmq/certificates/ca.pem +management.ssl.certfile = /etc/rabbitmq/certificates/cert.pem +management.ssl.keyfile = /etc/rabbitmq/certificates/key.pem diff --git a/docs/src/developer/reference/config-options.md b/docs/src/developer/reference/config-options.md index fc137633541..1c90bdfcc57 100644 --- a/docs/src/developer/reference/config-options.md +++ b/docs/src/developer/reference/config-options.md @@ -315,6 +315,10 @@ When a client first tries to fetch or renew a certificate, they may need to logi The client enrolls using the Automatic Certificate Management Environment (ACME) protocol [RFC 8555](https://www.rfc-editor.org/rfc/rfc8555.html). The `acmeDiscoveryUrl` parameter must be set to the HTTPS URL of the ACME server discovery endpoint for this team. It is of the form "https://acme.{backendDomain}/acme/{provisionerName}/discovery". For example: `https://acme.example.com/acme/provisioner1/discovery`. +`useProxyOnMobile` is an optional field. If `true`, mobile clients should use the CRL proxy. If missing, null or false, mobile clients should not use the CRL proxy. + +`crlProxy` contains the URL to the CRL proxy. (Not that this field is optional in the server config, but mandatory when the team feature is updated via the team feature API.) + ```yaml # galley.yaml mlsE2EId: @@ -323,6 +327,8 @@ mlsE2EId: config: verificationExpiration: 86400 acmeDiscoveryUrl: null + useProxyOnMobile: true + crlProxy: https://example.com lockStatus: unlocked ``` @@ -1028,3 +1034,94 @@ gundeck: **NOTE**: `redisAddtiionalWriteUsername` follows same restrictions as `redisUsername` when using legacy auth. + + +## Configure TLS for Redis + +If the redis instance requires TLS, it can be configured like this: + +```yaml +gundeck: + config: + redis: + enableTls: true +``` + +In case a custom CA certificate is required it can be provided like this: + +```yaml +gundeck: + config: + redis: + tlsCa: +``` + +There is another way to provide this, in case there already exists a kubernetes +secret containing the CA certificate(s): + +```yaml +gundeck: + config: + redis: + tlsCaSecretRef: + name: + key: +``` + +For configuring `redisAdditionalWrite` in gundeck (this is required during a +migration from one redis instance to another), the settings need to be like +this: + +```yaml +gundeck: + config: + redisAdditionalWrite: + enableTls: true + # One or none of these: + # tlsCa: + # tlsCaSecretRef: +``` + + +**WARNING:** Please do this only if you know what you're doing. + +In case it is not possible to verify TLS certificate of the redis +server, it can be turned off without tuning off TLS like this: + +```yaml +gundeck: + config: + redis: + insecureSkipVerifyTls: true + redisAdditionalWrite: + insecureSkipVerifyTls: true +``` + +## Configure RabbitMQ + +RabbitMQ authentication must be configured on brig, galley and background-worker. For example: + +```yaml +rabbitmq: + host: localhost + port: 5672 + vHost: / + adminPort: 15672 # for background-worker +``` + +the `adminPort` setting is only needed by background-worker. + +In order to enable TLS when connecting to RabbitMQ, the following settings need to be added: + +```yaml +rabbitmq: + enableTls: true + caCert: test/resources/rabbitmq-ca.pem + insecureSkipVerifyTls: false +``` + +**WARNING:** Please do this only if you know what you're doing. + +In case it is not possible to verify the TLS certificate of the RabbitMQ +server, verification can be turned off by settings `insecureSkipVerifyTls` to +`true`. diff --git a/docs/src/developer/reference/user/activation.md b/docs/src/developer/reference/user/activation.md index 373b2c190d3..a98a3fe48a2 100644 --- a/docs/src/developer/reference/user/activation.md +++ b/docs/src/developer/reference/user/activation.md @@ -6,7 +6,8 @@ _Author: Artyom Kazak_ --- -A user is called _activated_ they have a verified identity -- e.g. a phone number that has been verified via a text message, or an email address that has been verified by sending an activation code to it. +A user is called _activated_ when they have a verified identity -- an email +address that has been verified by sending an activation code to it. A user that has been provisioned via single sign-on is always considered to be activated. @@ -25,14 +26,17 @@ The only flow where it makes sense for non-activated users to exist is the [wire ### Requesting an activation code (RefActivationRequest)= -During the [standard registration flow](RefRegistrationStandard), the user submits an email address or phone number by making a request to `POST /activate/send`. A six-digit activation code will be sent to that email address / phone number. Sample request and response: +During the [standard registration flow](RefRegistrationStandard), the user +submits an email address by making a request to `POST /activate/send`. A +six-digit activation code will be sent to that email address. Sample request and +response: ``` POST /activate/send { - // Either 'email' or 'phone' - "phone": "+1234567890" + // the user's 'email' address + "email": "pink@example.com" } ``` @@ -40,9 +44,13 @@ POST /activate/send 200 OK ``` -The user can submit the activation code during registration to prove that they own the email address / phone number. +The user can submit the activation code during registration to prove that they +own the email address. -The same `POST /activate/send` endpoint can be used to re-request an activation code. Please use this ability sparingly! To avoid unnecessary activation code requests, users should be warned that it might take up to a few minutes for an email or text message to arrive. +The same `POST /activate/send` endpoint can be used to re-request an activation +code. Please use this ability sparingly! To avoid unnecessary activation code +requests, users should be warned that it might take up to a few minutes for an +email to arrive. ### Activating an existing account (RefActivationSubmit)= @@ -53,8 +61,8 @@ If the account [has not been activated during verification](RefRegistrationNoPre POST /activate { - // One of 'phone', 'email', or 'key' - "phone": "+1234567890", + // One of 'email', 'key' + "email": "pink@example.com", // 6-digit activation code "code": "123456", @@ -69,14 +77,16 @@ POST /activate 200 OK { - "phone": "+1234567890", + "email": "pink@example.com", // Whether it is the first successful activation for the user "first": true } ``` -If the email or phone has been verified already, `POST /activate` will return status code `204 No Content`. If the code is invalid, `POST /activate` will return status code `404 Not Found` with `"label": "invalid-code"`. +If the email has been verified already, `POST /activate` will return status code +`204 No Content`. If the code is invalid, `POST /activate` will return status +code `404 Not Found` with `"label": "invalid-code"`. There is a maximum of 3 activation attempts per activation code. On the third failed attempt the code is invalidated and a new one must be requested. @@ -112,7 +122,7 @@ GET /self } ``` -If the profile includes `"email"` or `"phone"`, the account is activated. +If the profile includes `"email"`, the account is activated. ## Automating activation via email (RefActivationEmailHeaders)= @@ -134,10 +144,10 @@ X-Zeta-Key: ... X-Zeta-Code: 123456 ``` -## Phone/email whitelist +## Email whitelist (RefActivationAllowlist)= -The backend can be configured to only allow specific phone number prefixes and email address domains to register. The following options have to be set in `brig.yaml`: +The backend can be configured to only allow specific email address domains to register. The following option has to be set in `brig.yaml`: ```yaml optSettings: @@ -145,19 +155,16 @@ optSettings: - wire.com - example.com - notagoodexample.com - setAllowlistPhonePrefixes: - - "+49" - - "+1555555" ``` When those options are present, the backend will match every activation request against these lists. -If an email address or phone number are rejected by the whitelist, `POST /activate/send` or `POST /register` will return `403 Forbidden`: +If an email address is rejected by the whitelist, `POST /activate/send` or `POST /register` will return `403 Forbidden`: ```json { "code": 403, "label": "unauthorized", - "message": "Unauthorized e-mail address or phone number." + "message": "Unauthorized e-mail address" } ``` diff --git a/docs/src/developer/reference/user/registration.md b/docs/src/developer/reference/user/registration.md index 90fb353d583..b598d4ac365 100644 --- a/docs/src/developer/reference/user/registration.md +++ b/docs/src/developer/reference/user/registration.md @@ -12,16 +12,17 @@ This page describes the "normal" user registration flow. Autoprovisioning is cov The vast majority of our API is only available to Wire users. Unless a user is autoprovisioned, they have to register an account by calling the `POST /register` endpoint. -Most users also go through [activation](activation.md) -- sharing and verifying an email address and/or phone number with Wire. This can happen either before or after registration. [Certain functionality](RefActivationBenefits) is only available to activated users. +Most users also go through [activation](activation.md) -- sharing and verifying +an email address with Wire. This can happen either before or after registration. +[Certain functionality](RefActivationBenefits) is only available to activated +users. ## Standard registration flow (RefRegistrationStandard)= -During the standard registration flow, the user first calls [`POST /activate/send`](RefActivationRequest) to pre-verify their email address or phone number. Phone numbers must be in [E.164][] format. +During the standard registration flow, the user first calls [`POST /activate/send`](RefActivationRequest) to pre-verify their email address. -[E.164]: https://en.wikipedia.org/wiki/E.164 - -After receiving a six-digit activation code via email/text message, it can be submitted with the registration request via `POST /register`. If the code is correct, the account will be activated immediately. Here is a sample request and response: +After receiving a six-digit activation code via email message, it can be submitted with the registration request via `POST /register`. If the code is correct, the account will be activated immediately. Here is a sample request and response: ``` POST /register @@ -30,13 +31,13 @@ POST /register // The name is mandatory "name": "Pink", - // 'email', 'phone', or both have to be provided + // 'email' has to be provided "email": "pink@example.com", // The password is optional "password": "secret", - // 6-digit 'email_code' or 'phone_code' + // 6-digit 'email_code' "email_code": "123456" } ``` @@ -76,7 +77,9 @@ If the code is incorrect or if an incorrect code has been tried enough times, th _NOTE: This flow is currently not used by any clients. At least this was the state on 2020-05-28_ -It is also possible to call `POST /register` without verifying the email address or phone number, in which case the account will have to be activated later by calling [`POST /activate`](RefActivationSubmit). Sample API request and response: +It is also possible to call `POST /register` without verifying the email +address, in which case the account will have to be activated later by calling +[`POST /activate`](RefActivationSubmit). Sample API request and response: ``` POST /register @@ -85,7 +88,7 @@ POST /register // The name is mandatory "name": "Pink", - // 'email', 'phone', or both have to be provided + // 'email' has to be provided "email": "pink@example.com", // The password is optional @@ -109,13 +112,15 @@ Set-Cookie: zuid=... } ``` -A verification email will be sent to the email address (if provided), and a verification text message will be sent to the phone number (also, if provided). +A verification email will be sent to the email address (if provided). ## Anonymous registration, aka "Wireless" (RefRegistrationWireless)= -A user can be created without either email or phone number, in which case only `"name"` is required. The `"name"` does not have to be unique. This feature is used for [guest rooms](https://wire.com/en/features/encrypted-guest-rooms/). +A user can be created without email, in which case only `"name"` is required. +The `"name"` does not have to be unique. This feature is used for [guest +rooms](https://wire.com/en/features/encrypted-guest-rooms/). An anonymous, non-activated account is only usable for a period of time specified in `brig.yaml` at `zauth.authSettings.sessionTokenTimeout`, which is set to 1 day for Wire production. (The access cookie returned by `/register` can not be refreshed, and an anonymous user can not use `/login` to get a new cookie.) @@ -172,7 +177,7 @@ These end-points support 5 flows: We need an option to block 1, 2, 5 on-prem; 3, 4 should remain available (no block option). There are also provisioning flows via SAML or SCIM, which are not critical. In short, this could refactored into: - * Allow team members to register (via email/phone or SSO) + * Allow team members to register (via email or SSO) * Allow ephemeral users During registration, we can take advantage of [NewUserOrigin](https://github.com/wireapp/wire-server/blob/a89b9cd818997e7837e5d0938ecfd90cf8dd9e52/libs/wire-api/src/Wire/API/User.hs#L625); we're particularly interested in `NewUserOriginTeamUser` --> only `NewTeamMember` or `NewTeamMemberSSO` should be accepted. In case this is a `Nothing`, we need to check if the user expires, i.e., if the user has no identity (and thus `Ephemeral`). diff --git a/docs/src/how-to/install/infrastructure-configuration.md b/docs/src/how-to/install/infrastructure-configuration.md index 14e00853828..35821dd9c5c 100644 --- a/docs/src/how-to/install/infrastructure-configuration.md +++ b/docs/src/how-to/install/infrastructure-configuration.md @@ -527,23 +527,6 @@ Additionally, you may wish to build, sign, and host your own docker images to have increased confidence in those images. We haved "signed container images" on our roadmap. -## Sign up with a phone number (Sending SMS) - -**Provides**: - -- Registering accounts with a phone number - -**You need**: - -- a [Nexmo](https://www.nexmo.com/) account -- a [Twilio](https://www.twilio.com/) account - -**How to configure**: - -See the `brig` chart for configuration. - -(rd-party-proxying)= - ## 3rd-party proxying You need Giphy/Google/Spotify/Soundcloud API keys (if you want to @@ -581,19 +564,15 @@ In case of a demo install, replace `prod` with `demo`. First set the option under the `team-settings` section, `envVars` sub-section: ```yaml -# NOTE: Only relevant if you want team-settings -team-settings: - envVars: - IS_SELF_HOSTED: "true" +envVars: + IS_SELF_HOSTED: "true" ``` -Second, also set the option under the `account-pages` section: +Second, also set the option for `account-pages` helm chart: ```yaml -# NOTE: Only relevant if you want account-pages -account-pages: - envVars: - IS_SELF_HOSTED: "true" +envVars: + IS_SELF_HOSTED: "true" ``` (auth-cookie-config)= diff --git a/docs/src/how-to/install/sft.md b/docs/src/how-to/install/sft.md index dec1f3bf113..a8b7bfeaf86 100644 --- a/docs/src/how-to/install/sft.md +++ b/docs/src/how-to/install/sft.md @@ -8,28 +8,23 @@ Please refer to the following {ref}`section to better understand SFT and how it ### As part of the wire-server umbrella chart -`` sftd` `` will be installed as part of the `wire-server` umbrella chart if you set `tags.sftd: true` +The `sftd` is packaged as its own Helm chart. -In your `./values/wire-server/values.yaml` file you should set the following settings: +In your `./values/sftd/values.yaml` file you should set the following settings: ```yaml -tags: - sftd: true - -sftd: - host: sftd.example.com # Replace example.com with your domain - allowOrigin: https://webapp.example.com # Should be the address you used for the webapp deployment (Note: you must include the uri scheme "https://") +host: sftd.example.com # Replace example.com with your domain +allowOrigin: https://webapp.example.com # Should be the address you used for the webapp deployment (Note: you must include the uri scheme "https://") ``` In your `secrets.yaml` you should set the TLS keys for sftd domain: ```yaml -sftd: - tls: - crt: | - - key: | - +tls: + crt: | + + key: | + ``` You should also make sure that you configure brig to know about the SFT server in your `./values/wire-server/values.yaml` file: @@ -46,23 +41,6 @@ Now you can deploy as usual: helm upgrade wire-server wire/wire-server --values ./values/wire-server/values.yaml ``` -### Standalone - -The SFT component is also shipped as a separate helm chart. Installation is similar to installing -the charts as in {ref}`helm-prod`. - -Some people might want to run SFT separately, because the deployment lifecycle for the SFT is a bit more intricate. For example, -if you want to avoid dropping calls during an upgrade, you'd set the `terminationGracePeriodSeconds` of the SFT to a high number, to wait -for calls to drain before updating to the new version (See [technical documentation](https://github.com/wireapp/wire-server/blob/develop/charts/sftd/README.md)). that would cause your otherwise snappy upgrade of the `wire-server` chart to now take a long time, as it waits for all -the SFT servers to drain. If this is a concern for you, we advice installing `sftd` as a separate chart. - -It is important that you disable `sftd` in the `wire-server` umbrella chart, by setting this in your `./values/wire-server/values.yaml` file - -```yaml -tags: - sftd: false -``` - By default `sftd` doesn't need to set that many options, so we define them inline. However, you could of course also set these values in a `values.yaml` file. SFT will deploy a Kubernetes Ingress on `$SFTD_HOST`. Make sure that the domain name `$SFTD_HOST` points to your ingress IP as set up in {ref}`helm-prod`. The SFT also needs to be made aware of the domain name of the webapp that you set up in {ref}`helm-prod` for setting up the appropriate CSP headers. @@ -75,8 +53,7 @@ export WEBAPP_HOST=webapp.example.com Now you can install the chart: ```shell -helm upgrade --install sftd wire/sftd --set -helm install sftd wire/sftd \ +helm install sftd sftd \ --set host=$SFTD_HOST \ --set allowOrigin=https://$WEBAPP_HOST \ --set-file tls.crt=/path/to/tls.crt \ diff --git a/docs/src/how-to/install/troubleshooting.md b/docs/src/how-to/install/troubleshooting.md index b4220bd45f9..3eb1fe2a64f 100644 --- a/docs/src/how-to/install/troubleshooting.md +++ b/docs/src/how-to/install/troubleshooting.md @@ -7,22 +7,21 @@ If you have installed wire-server, but the web application page in your browser In the file that you use as override when running `helm install/update -f ` (using the webapp as an example): ```yaml -webapp: - # ... other settings... - envVars: - # ... other environment variables ... - CSP_EXTRA_CONNECT_SRC: "https://*.example.com, wss://*.example.com" - CSP_EXTRA_IMG_SRC: "https://*.example.com" - CSP_EXTRA_SCRIPT_SRC: "https://*.example.com" - CSP_EXTRA_DEFAULT_SRC: "https://*.example.com" - CSP_EXTRA_FONT_SRC: "https://*.example.com" - CSP_EXTRA_FRAME_SRC: "https://*.example.com" - CSP_EXTRA_MANIFEST_SRC: "https://*.example.com" - CSP_EXTRA_OBJECT_SRC: "https://*.example.com" - CSP_EXTRA_MEDIA_SRC: "https://*.example.com" - CSP_EXTRA_PREFETCH_SRC: "https://*.example.com" - CSP_EXTRA_STYLE_SRC: "https://*.example.com" - CSP_EXTRA_WORKER_SRC: "https://*.example.com" +# ... other settings... +envVars: + # ... other environment variables ... + CSP_EXTRA_CONNECT_SRC: "https://*.example.com, wss://*.example.com" + CSP_EXTRA_IMG_SRC: "https://*.example.com" + CSP_EXTRA_SCRIPT_SRC: "https://*.example.com" + CSP_EXTRA_DEFAULT_SRC: "https://*.example.com" + CSP_EXTRA_FONT_SRC: "https://*.example.com" + CSP_EXTRA_FRAME_SRC: "https://*.example.com" + CSP_EXTRA_MANIFEST_SRC: "https://*.example.com" + CSP_EXTRA_OBJECT_SRC: "https://*.example.com" + CSP_EXTRA_MEDIA_SRC: "https://*.example.com" + CSP_EXTRA_PREFETCH_SRC: "https://*.example.com" + CSP_EXTRA_STYLE_SRC: "https://*.example.com" + CSP_EXTRA_WORKER_SRC: "https://*.example.com" ``` For more info, you can have a look at respective charts values files, i.e.: diff --git a/docs/src/how-to/install/web-app-settings.md b/docs/src/how-to/install/web-app-settings.md index 5746780c13b..4dbc66da3a5 100644 --- a/docs/src/how-to/install/web-app-settings.md +++ b/docs/src/how-to/install/web-app-settings.md @@ -6,14 +6,13 @@ Wire desktop app is based on Electron and renders Wire web app in a chromium-bas When this flag is set to true it will prevent the web app from running in a standard browser and require the Wire desktop app for running Wire web app. -To enforce desktop application only add the following to your Helm overrides in `values/wire-server/values.yaml`: +To enforce desktop application only add the following to your configuration of the `webapp` chart: ```yaml -webapp: +# ... +envVars: # ... - envVars: - # ... - FEATURE_ENABLE_ENFORCE_DESKTOP_APPLICATION_ONLY: "true" + FEATURE_ENABLE_ENFORCE_DESKTOP_APPLICATION_ONLY: "true" ``` ## Enforce constant bit rate @@ -22,40 +21,36 @@ By default Wire users can choose, whether to use constant bit rate (CBR) or vari Since there is a theoretical risk of information leakage through packet size analysis when using Opus with variable bitrate encoding during audio calls, CBR can be fully enforced for 1:1 calls in the web app, too. -To enforce CBR add the following to your Helm overrides in `values/wire-server/values.yaml`: +To enforce CBR add the following to your config: ```yaml -webapp: +envVars: # ... - envVars: - # ... - FEATURE_ENFORCE_CONSTANT_BITRATE: "true" + FEATURE_ENFORCE_CONSTANT_BITRATE: "true" ``` ## Disable media plugins Wire is built for media plugins to be active in the chat windows so that users don't have to click the link and leave the app. In some cases it may be desired that these plugins get disabled by default. With this setting all media plugins, including but not limited to YouTube, Spotify, Soundcloud, and Vimeo can be disabled. -To disable media plugins add the following to your Helm overrides in `values/wire-server/values.yaml`: +To disable media plugins add the following to your configuration: ```yaml -webapp: +# ... +envVars: # ... - envVars: - # ... - FEATURE_ENABLE_MEDIA_EMBEDS: "false" + FEATURE_ENABLE_MEDIA_EMBEDS: "false" ``` ## Enable extra entropy (only on Windows) The Wire desktop application uses system-dependent source of random bits as an internal entropy source when generating cryptographic keys. In certain cases it may be desired to enable externally generated entropy derived from mouse movement. This option only affects Windows users. -To enable additional entropy during client creation add the following to your Helm overrides in `values/wire-server/values.yaml`: +To enable additional entropy during client creation add the following to your configuration: ```yaml -webapp: +# ... +envVars: # ... - envVars: - # ... - FEATURE_ENABLE_EXTRA_CLIENT_ENTROPY: "true" + FEATURE_ENABLE_EXTRA_CLIENT_ENTROPY: "true" ``` diff --git a/docs/src/understand/api-client-perspective/authentication.md b/docs/src/understand/api-client-perspective/authentication.md index 8a734146546..a3e2efadb06 100644 --- a/docs/src/understand/api-client-perspective/authentication.md +++ b/docs/src/understand/api-client-perspective/authentication.md @@ -53,11 +53,10 @@ be removed in the future. ## Login - `POST /login` -A login is the process of authenticating a user either through a known secret in -a {ref}`password login ` or by proving ownership of a verified -phone number associated with an account in an {ref}`SMS login `. The -response to a successful login contains an access cookie in a `Set-Cookie` -header and an access token in the JSON response body. +A login is the process of authenticating a user either through a known +secret in a {ref}`password login `. The response to a +successful login contains an access cookie in a `Set-Cookie` header and an +access token in the JSON response body. (login-cookies)= @@ -92,8 +91,8 @@ The corresponding backend configuration settings are described in: ### Password Login To perform a password login, send a `POST` request to the `/login` -endpoint, providing either a verified email address or phone number and -the corresponding password. For example: +endpoint, providing either a verified email address and the corresponding +password. For example: ``` POST /login HTTP/1.1 @@ -105,11 +104,10 @@ POST /login HTTP/1.1 } ``` -If a phone number is used, the `phone` field is used instead of -`email`. If a @handle is used, the `handle` field is used instead of -`email` (note that the handle value should be sent *without* the `@` -symbol). Assuming the credentials are correct, the API will respond with -a `200 OK` and an access token and cookie: +If a @handle is used, the `handle` field is used instead of `email` (note +that the handle value should be sent *without* the `@` symbol). Assuming +the credentials are correct, the API will respond with a `200 OK` and an +access token and cookie: ``` HTTP/1.1 200 OK @@ -133,39 +131,6 @@ The value of `expires_in` is the number of seconds that the As of yet, the `token_type` is always `Bearer`. -(login-sms)= - -### SMS Login - -To perform an SMS login, first request an SMS code to be sent to a -verified phone number: - -``` -POST /login/send HTTP/1.1 -[headers omitted] - -{ - "phone": "+1234567890" -} -``` - -An SMS with a short-lived login code will be sent. Upon receiving the -SMS and extracting the code from it, the login can be performed using -the `phone` and `code` as follows: - -``` -POST /login HTTP/1.1 -[headers omitted] - -{ - "phone": "+1234567890", - "code": "123456" -} -``` - -A successful response is identical to that of a {ref}`password -login `. - (login-persistent)= ### Persistent Logins @@ -182,7 +147,7 @@ POST /login?persist=true HTTP/1.1 [headers omitted] { - "phone": "+1234567890", + "email": "alice@example.com", "code": "123456" } ``` @@ -282,7 +247,7 @@ POST /login?persist=true HTTP/1.1 [headers omitted] { - "phone": "+1234567890", + "email": "alice@example.com", "code": "123456", "label": "Google Nexus 5" } @@ -361,49 +326,42 @@ if you suspect your current password to be compromised. ### Initiate a Password Reset -To initiate a password reset, send a `POST` request to -`/password-reset`, specifying either a verified email address or phone -number for the account in question: +To initiate a password reset, send a `POST` request to `/password-reset`, +specifying a verified email address for the account in question: ``` POST /password-reset HTTP/1.1 [headers omitted] { - "phone": "+1234567890" + "email": "alice@example.com" } ``` -For a phone number, the `phone` field would be used instead. As a -result of a successful request, either a password reset key and code is -sent via email or a password reset code is sent via SMS, depending on -whether an email address or a phone number was provided. Password reset -emails will contain a link to the [wire.com](https://www.wire.com/) -website which will guide the user through the completion of the password -reset, which means that the website will perform the necessary requests -to complete the password reset. To complete a password reset initiated -with a phone number, the completion of the password reset has to happen -from the mobile client application itself. - -Once a password reset has been initiated for an email address or phone -number, no further password reset can be initiated for the same email -address or phone number before the prior reset is completed or times -out. The current timeout for an initiated password reset is -`10 minutes`. +As a result of a successful request, a password reset key and code are sent +via email. Password reset emails will contain a link to the +[wire.com](https://www.wire.com/) website which will guide the user through +the completion of the password reset, which means that the website will +perform the necessary requests to complete the password reset. + +Once a password reset has been initiated for an email address, no further +password reset can be initiated for the same email address before the prior +reset is completed or times out. The current timeout for an initiated +password reset is `10 minutes`. ### Complete a Password Reset To complete a password reset, the password reset code, together with the -new password and the `email` or `phone` used when initiating the -reset (or the opaque `key` sent by mail) are sent to -`/password-reset/complete` in a `POST` request: +new password and the `email` used when initiating the reset (or the opaque +`key` sent by mail) are sent to `/password-reset/complete` in a `POST` +request: ``` POST /password-reset/complete HTTP/1.1 [headers omitted] { - "phone": "+1234567890", + "email": "alice@example.com", "code": "123456", "password": "new-secret-password" } diff --git a/docs/src/understand/mls.md b/docs/src/understand/mls.md index a762741eacf..99e26c2f2dd 100644 --- a/docs/src/understand/mls.md +++ b/docs/src/understand/mls.md @@ -49,22 +49,19 @@ brig: setEnableMLS: true ``` -Finally, the web applications need to be made aware of *MLS*. This is done by +Finally, the webapp needs to enable made aware of *MLS*. This is done by setting the following environment variable for the web application: ```yaml -webapp: - envVars: - FEATURE_ENABLE_MLS: "true" +envVars: + FEATURE_ENABLE_MLS: "true" ``` and for the team settings web application: ```yaml -# NOTE: Only relevant if you want team-settings -team-settings: - envVars: - FEATURE_ENABLE_MLS: "true" +envVars: + FEATURE_ENABLE_MLS: "true" ``` As long as *MLS* is still an opt-in feature, please remember that in order to be able diff --git a/docs/src/understand/searchability.md b/docs/src/understand/searchability.md index b1608e0d6a1..b1727b3324a 100644 --- a/docs/src/understand/searchability.md +++ b/docs/src/understand/searchability.md @@ -25,22 +25,24 @@ Search visibility is controlled by three parameters on the backend: - A team out-bound configuration flag, `TeamSearchVisibility` with possible values `SearchVisibilityStandard`, `SearchVisibilityNoNameOutsideTeam` - `SearchVisibilityStandard` means that the user can find other people outside of the team, if the searched-person inbound search allows it - - `SearchVisibilityNoNameOutsideTeam` means that the user can not find any user outside the team by full text search (but exact handle search still works) + - `SearchVisibilityNoNameOutsideTeam` means that the user can’t find any user outside the team by full text search (but exact username search still works) - A team inbound configuration flag, `SearchVisibilityInbound` with possible values `SearchableByOwnTeam`, `SearchableByAllTeams` - - `SearchableByOwnTeam` means that the user can be found only by users in their own team. - - `SearchableByAllTeams` means that the user can be found by users in any/all teams. + - `SearchableByOwnTeam` means that the user can be found with full text search only by users in their own team + - `SearchableByAllTeams` means that the user can be found with full text search by all users in any/all teams. - A server configuration flag `searchSameTeamOnly` with possible values true, false. - `Note`: For the same backend, this affects inbound and out-bound searches (simply because all teams will be subject to this behavior) - - Setting this to `true` means that the all teams on that backend can only find users that belong to their team + - Setting this to `true` means that all teams on that backend can only find users that belong to their team These flag are set on the backend and the clients do not need to be aware of them. The flags will influence the behavior of the search API endpoint; clients will only need to parse the results, that are already filtered for them by the backend. +Some configuration values supersede others. The table below clarifies how the various values interact with each other, highlighting the outcome of each search for the various combinations of values. + ### Table of possible outcomes ```{eval-rst} diff --git a/docs/src/understand/team-feature-settings.md b/docs/src/understand/team-feature-settings.md index 0b92daa829a..35e57eb2dcb 100644 --- a/docs/src/understand/team-feature-settings.md +++ b/docs/src/understand/team-feature-settings.md @@ -94,6 +94,10 @@ When a client first tries to fetch or renew a certificate, they may need to logi The client enrolls using the Automatic Certificate Management Environment (ACME) protocol [RFC 8555](https://www.rfc-editor.org/rfc/rfc8555.html). The `acmeDiscoveryUrl` parameter must be set to the HTTPS URL of the ACME server discovery endpoint for this team. It is of the form "https://acme.{backendDomain}/acme/{provisionerName}/discovery". For example: `https://acme.example.com/acme/provisioner1/discovery`. +`useProxyOnMobile` is an optional field. If `true`, mobile clients should use the CRL proxy. If missing, null or false, mobile clients should not use the CRL proxy. + +`crlProxy` contains the URL to the CRL proxy. (Not that this field is optional in the server config, but mandatory when the team feature is updated via the team feature API.) + ```yaml galley: # ... @@ -109,6 +113,8 @@ galley: config: verificationExpiration: 86400 acmeDiscoveryUrl: null + useProxyOnMobile: true + crlProxy: https://example.com lockStatus: unlocked ``` diff --git a/hack/bin/Sbom.hs b/hack/bin/Sbom.hs index 74a1783a3a4..2944b188fb1 100644 --- a/hack/bin/Sbom.hs +++ b/hack/bin/Sbom.hs @@ -51,6 +51,7 @@ how this relates to bombon: module Sbom where +import Control.Applicative ((<|>)) import Control.Arrow ((&&&)) import Data.Aeson import Data.Aeson.Key qualified as KM @@ -73,6 +74,7 @@ import Data.Text (Text) import Data.Text qualified as T import Data.Text.IO qualified as T import Data.Time.Clock.POSIX +import Data.Time.Format.ISO8601 (iso8601Show) import Data.Traversable (for) import Data.Tree import Data.UUID qualified as UUID @@ -193,8 +195,9 @@ mkPurl meta = maybe "" ("@" <>) meta.version ] where + checks = meta.homepage : meta.urls repo - | any (maybe False (T.isInfixOf "hackage.haskell.org")) meta.urls = "hackage" + | any (maybe False (T.isInfixOf "hackage.haskell.org")) checks = "hackage" | otherwise = "nixpkgs" -- | serializes an SBom to JSON format @@ -206,13 +209,17 @@ serializeSBom settings bom = do curTime <- getCurrentTime -- FUTUREWORK(mangoiv): "tools" (the tools used in the creation of the bom) let mkDependencies :: SBomMeta Identity -> Array - mkDependencies meta = do - let d = - object - [ "ref" .= meta.outPath, - "dependsOn" .= runIdentity meta.directDeps - ] - [d] + mkDependencies meta = + [object ["ref" .= meta.outPath, "dependsOn" .= runIdentity meta.directDeps]] + + serializeLicense :: Maybe License -> Maybe Value + serializeLicense ml = do + l <- ml + idOrName <- + (\i -> ["id" .= i]) <$> l.id + <|> (\n -> ["name" .= n]) <$> l.name + pure (object idOrName) + mkComponents :: SBomMeta Identity -> Array mkComponents meta = do let c :: Value @@ -220,17 +227,18 @@ serializeSBom settings bom = do -- FUTUREWORK(mangoiv): swid? https://www.iso.org/standard/65666.html -- FUTUREWORK(mangoiv): CPE? -- FUTUREWORK(mangoiv): more information in the supplier section - object - [ "type" .= meta.typ, - "bom-ref" .= String (runIdentity meta.outPath), - "supplier" .= object ["url" .= nubOrd (maybeToList meta.homepage <> catMaybes meta.urls)], - "name" .= String (fromMaybe (st'name $ splitStorePath $ runIdentity meta.outPath) meta.name), - "version" .= meta.version, - "description" .= meta.description, - "scope" .= String "required", - "licenses" .= ((\ln -> object ["license" .= ln]) <$> filter (isJust . (>>= (.id))) meta.licenseSpdxId), - "purl" .= mkPurl meta - ] + Object $ + mconcat + [ "type" .= String (fromMaybe "library" meta.typ), + "bom-ref" .= String (runIdentity meta.outPath), + "supplier" .= object ["url" .= nubOrd (maybeToList meta.homepage <> catMaybes meta.urls)], + "name" .= String (fromMaybe (st'name $ splitStorePath $ runIdentity meta.outPath) meta.name), + "version" .?= meta.version, + "description" .?= meta.description, + "scope" .= String "required", + "licenses" .= ((\ln -> object ["license" .= ln]) <$> mapMaybe serializeLicense meta.licenseSpdxId), + "purl" .= mkPurl meta + ] [c] (dependencies, components) = foldMap (mkDependencies &&& mkComponents) bom @@ -243,7 +251,7 @@ serializeSBom settings bom = do "version" .= Number (fromIntegral settings.sbom'version), "metadata" .= object - [ "timestamp" .= String (T.pack (show curTime)), + [ "timestamp" .= String (T.pack (iso8601Show curTime)), "component" .= object [ "name" .= String settings.sbom'component, @@ -253,7 +261,7 @@ serializeSBom settings bom = do -- FUTUREWORK(mangoiv): "manufacture" can also have url "manufacture" .= object ["name" .= String settings.sbom'manufacture], "supplier" .= object ["name" .= String (fromMaybe settings.sbom'manufacture settings.sbom'supplier)], - "licenses" .= Array (fromList $ object . (\n -> ["id" .= n]) . String <$> settings.sbom'licenses) + "licenses" .= Array (fromList $ (\n -> object ["license" .= object ["id" .= String n]]) <$> settings.sbom'licenses) ], "components" .= Array components, -- FUTUREWORK(mangoiv): services: allow to tell the program the name of the services like brig, galley, ... diff --git a/hack/bin/bombon.hs b/hack/bin/bombon.hs index d4bc7fdec0b..ec716202539 100755 --- a/hack/bin/bombon.hs +++ b/hack/bin/bombon.hs @@ -1,4 +1,4 @@ -#!/usr/bin/env -S nix -Lv run github:wireapp/ghc-flakr/6311bb166bf835d4a587fe1661b86c9a1426f212 +#!/usr/bin/env -S nix -Lv run github:wireapp/ghc-flakr/74d6dd639d1da35a8d361e8cd2274b1cfbe8381c {-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -Wall #-} diff --git a/hack/bin/cabal-project-local-template.sh b/hack/bin/cabal-project-local-template.sh deleted file mode 100755 index de45ddfd694..00000000000 --- a/hack/bin/cabal-project-local-template.sh +++ /dev/null @@ -1,16 +0,0 @@ -#!/usr/bin/env bash -set -euo pipefail - -DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )" -TOP_LEVEL="$(cd "$DIR/../.." && pwd)" - -cd "$TOP_LEVEL" - -package_options=$1 - -local_projects=$(find . -name '*.cabal' | grep -v dist-newstyle | xargs -n 1 basename | sed 's|.cabal||g' | sort) - -for project in $local_projects; do - echo "package $project - $package_options" -done diff --git a/hack/bin/cabal.project.local.template b/hack/bin/cabal.project.local.template new file mode 100644 index 00000000000..9264d3a48f4 --- /dev/null +++ b/hack/bin/cabal.project.local.template @@ -0,0 +1,6 @@ +test-show-details: direct +profiling: False +profiling-detail: late +optimization: False +program-options + ghc-options: -O0 diff --git a/hack/bin/certchain.sh b/hack/bin/certchain.sh new file mode 100755 index 00000000000..5ae241fb990 --- /dev/null +++ b/hack/bin/certchain.sh @@ -0,0 +1,41 @@ +#!/usr/bin/env bash +set -euo pipefail +set -x + +## Custom CA root certificate +CANAME=Example-RootCA +CADIR=/tmp/ca/$CANAME +mkdir -p $CADIR + +openssl genrsa -out $CADIR/$CANAME.key 4096 +openssl rsa -in $CADIR/$CANAME.key -pubout -out $CADIR/$CANAME.pub + +openssl req -x509 -new -noenc -out $CADIR/$CANAME.crt -key $CADIR/$CANAME.key \ + -sha256 -subj '/CN=Example Root CA/C=DE/ST=Berlin/L=Berlin/O=Example' + +## Intermediate certificate +INTNAME=Example-IntermediateCA +INTDIR=$CADIR/intermediate +mkdir -p $INTDIR + +openssl genrsa -out $INTDIR/$INTNAME.key +openssl rsa -in $INTDIR/$INTNAME.key -pubout -out $INTDIR/$INTNAME.pub +openssl req -new -key $INTDIR/$INTNAME.key -out $INTDIR/$INTNAME.csr \ + -sha256 -subj '/CN=Example Root CA/C=DE/ST=Berlin/L=Berlin/O=Example' + +openssl x509 -req -in $INTDIR/$INTNAME.csr -CA $CADIR/$CANAME.crt \ + -CAkey $CADIR/$CANAME.key -CAcreateserial -sha256 -out $INTDIR/$INTNAME.crt + +## leaf certificate + +LEAFNAME=Example-Leaf +LEAFDIR=$INTDIR/leaf +mkdir -p $LEAFDIR + +openssl genrsa -out $LEAFDIR/$LEAFNAME.key +openssl rsa -in $LEAFDIR/$LEAFNAME.key -pubout -out $LEAFDIR/$LEAFNAME.pub +openssl req -new -key $LEAFDIR/$LEAFNAME.key -out $LEAFDIR/$LEAFNAME.csr \ + -sha256 -subj '/CN=example-leaf/C=DE/ST=Berlin/L=Berlin/O=Example' + +openssl x509 -req -in $LEAFDIR/$LEAFNAME.csr -CA $INTDIR/$INTNAME.crt \ + -CAkey $INTDIR/$INTNAME.key -CAcreateserial -sha256 -out $LEAFDIR/$LEAFNAME.crt diff --git a/hack/bin/gen-certs.sh b/hack/bin/gen-certs.sh new file mode 100755 index 00000000000..a2a33a26253 --- /dev/null +++ b/hack/bin/gen-certs.sh @@ -0,0 +1,86 @@ +#!/usr/bin/env bash +set -eo pipefail + +# Create certificates needed for running integration tests. + +SCRIPT_DIR=$(cd -- "$(dirname -- "${BASH_SOURCE[0]}" )" &> /dev/null && pwd ) +ROOT_DIR=$(cd -- "$SCRIPT_DIR/../../" &> /dev/null && pwd) + +TEMP=$(mktemp -d wire-server-self-signed-XXXXXX --tmpdir) + +cleanup() { + rm -fr "$TEMP" +} +trap cleanup EXIT + +# usage: gen_ca root name +# +# Generate self-signed CA certificate and key at root/ca.pem and +# root/ca-key.pem respectively. +gen_ca() { + echo "generating CA: $2" + openssl req -x509 -newkey rsa:2048 -keyout "$1/ca-key.pem" -out "$1/ca.pem" -sha256 -days 3650 -nodes -subj "/CN=$2" 2>/dev/null + +} + +# usage: gen_cert root san name +# +# Generate leaf certificate in the given root directory. Assumes that ca.pem +# and ca-key.pem exist in the same directory. The generated certificate and +# private key will end up in root/cert.pem and root/key.pem. +gen_cert() { + echo "generating certificate: $2" + subj=() + if [ -n "$3" ]; then + subj=(-subj "/CN=$3") + fi + openssl x509 -req -in <(openssl req -nodes -newkey rsa:2048 -keyout "$1/key.pem" -out /dev/stdout -subj "/" 2>/dev/null) -CA "$1/ca.pem" -CAkey "$1/ca-key.pem" "${subj[@]}" -out "$1/cert.pem" -set_serial 0 -extfile <( echo "extendedKeyUsage = serverAuth, clientAuth"; echo "subjectAltName = critical, $2" ) 2>/dev/null +} + +# usage: install_certs source_dir target_dir ca ca-key cert key +# +# Copy certificates into the target directory, using the given file names. If a +# name is empty, the corresponding certificate is skipped. +install_certs() { + if [ -n "$3" ]; then cp "$1/ca.pem" "$2/$3.pem"; fi + if [ -n "$4" ]; then cp "$1/ca-key.pem" "$2/$4.pem"; fi + if [ -n "$5" ]; then cp "$1/cert.pem" "$2/$5.pem"; fi + if [ -n "$6" ]; then cp "$1/key.pem" "$2/$6.pem"; fi +} + +# federation +mkdir -p "$TEMP/federation" +gen_ca "$TEMP/federation" ca.example.com +gen_cert "$TEMP/federation" "DNS:*.integration.example.com, DNS:host.docker.internal, DNS:localhost" +install_certs "$TEMP/federation" "$ROOT_DIR/services/nginz/integration-test/conf/nginz" \ + integration-ca integration-ca-key integration-leaf integration-leaf-key +install_certs "$TEMP/federation" "$ROOT_DIR/deploy/dockerephemeral/federation-v0" \ + integration-ca "" integration-leaf integration-leaf-key + +# elasticsearch +mkdir -p "$TEMP/es" +gen_ca "$TEMP/es" elasticsearch.ca.example.com +gen_cert "$TEMP/es" "DNS:localhost" localhost +install_certs "$TEMP/es" "$ROOT_DIR/deploy/dockerephemeral/docker" \ + elasticsearch-ca "" elasticsearch-cert elasticsearch-key +install_certs "$TEMP/es" "$ROOT_DIR/hack/helm_vars/certs" \ + elasticsearch-ca elasticsearch-ca-key + +# redis +mkdir -p "$TEMP/redis" +gen_ca "$TEMP/redis" redis.ca.example.com +REDIS="$ROOT_DIR/deploy/dockerephemeral/docker" +cp "$TEMP/redis/ca.pem" "$REDIS/redis-ca.pem" +for redis_node in $(seq 1 6); do + gen_cert "$TEMP/redis" "DNS:redis-${redis_node}, IP:172.20.0.3${redis_node}" + chmod 0644 "$TEMP/redis/key.pem" + install_certs "$TEMP/redis" "$REDIS" "" "" \ + "redis-node-${redis_node}-cert" \ + "redis-node-${redis_node}-key" +done + +# rabbitmq +RABBITMQ="$ROOT_DIR/deploy/dockerephemeral/rabbitmq-config/certificates" +gen_ca "$RABBITMQ" rabbitmq.ca.example.com +gen_cert "$RABBITMQ" "DNS:localhost, DNS:rabbitmq, IP:127.0.0.1" localhost +chmod a+r "$RABBITMQ/key.pem" diff --git a/hack/bin/selfsigned.sh b/hack/bin/selfsigned.sh deleted file mode 100755 index 73e507358fc..00000000000 --- a/hack/bin/selfsigned.sh +++ /dev/null @@ -1,93 +0,0 @@ -#!/usr/bin/env bash - -# Create a self-signed x509 certificate in the current working directory. -# Requires 'cfssl' to be on your PATH (see https://github.com/cloudflare/cfssl) -# These certificates are only meant for integration tests that explicitly disable certificate checking - -set -euo pipefail - -SCRIPT_DIR=$(cd -- "$(dirname -- "${BASH_SOURCE[0]}" )" &> /dev/null && pwd ) -ROOT_DIR=$(cd -- "$SCRIPT_DIR/../../" &> /dev/null && pwd) - -TEMP=$(mktemp -d wire-server-self-signed-XXXXXX --tmpdir) -CSR_FEDERATION="$TEMP/csr-federation.json" -CSR_FEDERATION_CA="$TEMP/csr-federation-ca.json" -CSR_ELASTICSEARCH="$TEMP/csr-elasitcsearch.json" -CSR_ELASTICSEARCH_CA="$TEMP/csr-elasticsearch-ca.json" -FEDERATION_CA="$TEMP/integration-ca" -FEDERATION_LEAF_CERT="$TEMP/integration-leaf" -ELASTICSEARCH_CA="$TEMP/elasticsearch-ca" -ELASTICSEARCH_LEAF_CERT="$TEMP/elasticsearch-leaf" - -command -v cfssl >/dev/null 2>&1 || { echo >&2 "cfssl is not installed, aborting. See https://github.com/cloudflare/cfssl"; exit 1; } -command -v cfssljson >/dev/null 2>&1 || { echo >&2 "cfssljson is not installed, aborting. See https://github.com/cloudflare/cfssl"; exit 1; } - -echo '{ - "CN": "ca.example.com", - "key": { - "algo": "rsa", - "size": 2048 - } -}' > "$CSR_FEDERATION_CA" - -# generate CA key and cert -cfssl gencert -initca "$CSR_FEDERATION_CA" | cfssljson -bare "$FEDERATION_CA" - -echo '{ - "key": { - "algo": "rsa", - "size": 2048 - } -}' > "$CSR_FEDERATION" - -# generate cert and key based on CA given comma-separated hostnames as SANs -cfssl gencert \ - -ca "$FEDERATION_CA.pem" \ - -ca-key "$FEDERATION_CA-key.pem" \ - -hostname=*.integration.example.com,host.docker.internal,localhost \ - "$CSR_FEDERATION" \ - | cfssljson -bare "$FEDERATION_LEAF_CERT" - -cp "$FEDERATION_CA.pem" "$ROOT_DIR/services/nginz/integration-test/conf/nginz/" -cp "$FEDERATION_CA-key.pem" "$ROOT_DIR/services/nginz/integration-test/conf/nginz/" -cp "$FEDERATION_LEAF_CERT.pem" "$ROOT_DIR/services/nginz/integration-test/conf/nginz/" -cp "$FEDERATION_LEAF_CERT-key.pem" "$ROOT_DIR/services/nginz/integration-test/conf/nginz/" - -cp "$FEDERATION_CA.pem" "$ROOT_DIR/deploy/dockerephemeral/federation-v0/" -cp "$FEDERATION_LEAF_CERT.pem" "$ROOT_DIR/deploy/dockerephemeral/federation-v0/" -cp "$FEDERATION_LEAF_CERT-key.pem" "$ROOT_DIR/deploy/dockerephemeral/federation-v0/" - -echo '{ - "CN": "elasticsearch.ca.example.com", - "key": { - "algo": "rsa", - "size": 2048 - } -}' > "$CSR_ELASTICSEARCH_CA" - -# generate CA key and cert -cfssl gencert -initca "$CSR_ELASTICSEARCH_CA" | cfssljson -bare "$ELASTICSEARCH_CA" - -echo '{ - "key": { - "algo": "rsa", - "size": 2048 - } -}' > "$CSR_ELASTICSEARCH" - -# generate cert and key based on CA given comma-separated hostnames as SANs -cfssl gencert \ - -ca "$ELASTICSEARCH_CA.pem" \ - -ca-key "$ELASTICSEARCH_CA-key.pem" \ - -hostname=localhost \ - "$CSR_ELASTICSEARCH" \ - | cfssljson -bare "$ELASTICSEARCH_LEAF_CERT" - -cp "$ELASTICSEARCH_CA.pem" "$ROOT_DIR/deploy/dockerephemeral/docker/elasticsearch-ca.pem" -cp "$ELASTICSEARCH_LEAF_CERT.pem" "$ROOT_DIR/deploy/dockerephemeral/docker/elasticsearch-cert.pem" -cp "$ELASTICSEARCH_LEAF_CERT-key.pem" "$ROOT_DIR/deploy/dockerephemeral/docker/elasticsearch-key.pem" - -cp "$ELASTICSEARCH_CA.pem" "$ROOT_DIR/hack/helm_vars/elasticsearch-certs/elasticsearch-ca.pem" -cp "$ELASTICSEARCH_CA-key.pem" "$ROOT_DIR/hack/helm_vars/elasticsearch-certs/elasticsearch-ca-key.pem" - -rm -rf "$TEMP" diff --git a/hack/helm_vars/certs/elasticsearch-ca-key.pem b/hack/helm_vars/certs/elasticsearch-ca-key.pem new file mode 100644 index 00000000000..53785fe3292 --- /dev/null +++ b/hack/helm_vars/certs/elasticsearch-ca-key.pem @@ -0,0 +1,28 @@ +-----BEGIN PRIVATE KEY----- +MIIEvgIBADANBgkqhkiG9w0BAQEFAASCBKgwggSkAgEAAoIBAQC/oFJpJMdyG9FT +pNw4K9f1pdkNikwbQsx4dokiQBMTu89IMTnNfsHz2IDrxCKTCKC3oPupniaEPNpr +YpV6RMz1UPvUYu/IpvOXGeIGlVd9ixcoYN6763R2nZhMlFS8Tma9mV+e/B0jr9Db +V1pUWIPufuPrYXcOotxDO/W5I+GpKVTz/ZGD//O5odX1mJzkwqjeqGa1WNdg+/AL +iDtVZ/YAKGdfjx81uqc16fYuYRDw3BYImBp5MyNu/jxdgNxFB1edcVowvcKXVs5p +Slay2ad0eQSa0Ux8n3RjfisjTLAHks/4dkPa3hQyBYzmxwBhMcMDc06yxiCkXsVn +lXRn9nf/AgMBAAECggEABQZr3GzMSImPaRvqPnrZdFkMb30QVw94YMxS9xf3dOc4 +hB8hi4PNPqf1yx9e/Lx9yNleE1BqmCf0XltWdvKPVJUlrw5TiJwZyGOZ+F9tAB81 +CA6j29YZcFoPoJDfOMghjGVIpNjdqfSC8jP0BXQ3LK22xZLOIw8eqypLKYPvkTA3 +OfuJ/1doiHl+geZkXaKcLSpCCddLKCaWSbLyqYMJxbQ5SSZ9bPUeQ7aQppb5M/wO +1B4+oMmRLcmG81QnL0kU9JiAtYaGsrP22qGuEGVjEZE8RXJz3iQ1KvSlj0xerqi7 +/LY0HLixkx4n3Qtpm9FFaT3rzeDlJIE54qmI73sdYQKBgQDw6KJJIxmQScLZb4ml +yjd+pBvPuUe9cM9KMRNk2C7Z1QMxORXsIbgCPqpkJ96XUquta2ii7rxt/sXAkrh1 +c8IYU3Qp03+585J+6lZF6yaH9TrwYfDCRqKoSgAEwhJlvtoWHSMI6YguWsaczdgH +czd+0OzJl1w4vQqQBuXFwz4eEQKBgQDLoVzk+z/1//CJUfAe/Z6WYFHmTh+M9RGP +vC7GCQVCjIFUNsXqrWLl6DL5UeipYVhqu5eB7vOo/gNnb6J1vMOO0j9e1cY1Q2lG +BdSIHUD7P1Lly1/K+pn2QqIIHp+72H5qsX+8R5Tkln00jwQ0t5DrMVgJvWBW7/GC +lach4BZlDwKBgQDjfdraE8ItJepRJ+mk3GtBNLlqk/0x4FhvKB63SQoc+/Dyx4Rz +Ing/7ms6/wdMgG3L6rS5v5XCjSayrhpwFyr/i7cTVDy2HVOGc8Waau9Mzf+lRedz +nf41ywNvetCisfIBlewim1zU4TXSlvNcPan3IFWqHDui/Kj/zvOlp7R98QKBgQCn +fdi89/TKUXT2XpFVzGLvadazyrqk5MdHJRCMD8tly9BtBoiQ2YEpfm6/KKJpAAsL +77VVSMjezeDa6bYFhfiMt18skEXydbpXwF/qfbV/c7yqCziF6s9NAc3pQ9c7WX3S +IKHiqjZMN4RRAPoCqqLm8bVqfXyKxd4u/Q12Da4d/QKBgByVkmAoFVF1iYkb5b/0 +cPRXMnn5Xw5C6CRWpEwl3dSlt/uVACcFyxKsUP7QDTbqN7DSl/RX6DxkDIR6GBEz +vt0yXsdFx8y9Lzw1TNj2zhPVrtyslX/GFmi0R7/oyTEuVOMNy1rl/wftRqRX90md +JLSFJ4QslRlPwYOWGPDjJZVe +-----END PRIVATE KEY----- diff --git a/hack/helm_vars/certs/elasticsearch-ca.pem b/hack/helm_vars/certs/elasticsearch-ca.pem new file mode 100644 index 00000000000..f17e9cb41ac --- /dev/null +++ b/hack/helm_vars/certs/elasticsearch-ca.pem @@ -0,0 +1,20 @@ +-----BEGIN CERTIFICATE----- +MIIDLzCCAhegAwIBAgIUMGKU64YSPkGrWyHiXiLsuoKC/9owDQYJKoZIhvcNAQEL +BQAwJzElMCMGA1UEAwwcZWxhc3RpY3NlYXJjaC5jYS5leGFtcGxlLmNvbTAeFw0y +NDA2MTcxMzE1MzFaFw0zNDA2MTUxMzE1MzFaMCcxJTAjBgNVBAMMHGVsYXN0aWNz +ZWFyY2guY2EuZXhhbXBsZS5jb20wggEiMA0GCSqGSIb3DQEBAQUAA4IBDwAwggEK +AoIBAQC/oFJpJMdyG9FTpNw4K9f1pdkNikwbQsx4dokiQBMTu89IMTnNfsHz2IDr +xCKTCKC3oPupniaEPNprYpV6RMz1UPvUYu/IpvOXGeIGlVd9ixcoYN6763R2nZhM +lFS8Tma9mV+e/B0jr9DbV1pUWIPufuPrYXcOotxDO/W5I+GpKVTz/ZGD//O5odX1 +mJzkwqjeqGa1WNdg+/ALiDtVZ/YAKGdfjx81uqc16fYuYRDw3BYImBp5MyNu/jxd +gNxFB1edcVowvcKXVs5pSlay2ad0eQSa0Ux8n3RjfisjTLAHks/4dkPa3hQyBYzm +xwBhMcMDc06yxiCkXsVnlXRn9nf/AgMBAAGjUzBRMB0GA1UdDgQWBBSGMhy1Uvrs +lmdHKAGQ9avMSWhz2jAfBgNVHSMEGDAWgBSGMhy1UvrslmdHKAGQ9avMSWhz2jAP +BgNVHRMBAf8EBTADAQH/MA0GCSqGSIb3DQEBCwUAA4IBAQA4vndI6NRcMgzba1y3 +lUPxy40bs/jQajR3A5fmCCX4c0ZeRc4YqE9cdYgeGffCZvPogyYjWDlavOma2uAQ ++3lZ35k0wG9GsU2g3fDIXpUuoSUjfYRLBQ3oqD7VRKYs1rDD87c+91DrsfIVZKF1 +W1RzOOvcW9QX2RHghFS4IluX6LEboo48cKtycA/nfmYDT/L9I4oYjaxc9l+HMUSH +gkQUU1xZnQ9GCqdhL3+2dmn0jvdgJLiFuefMGkE0oP/kFD/bhuOmDhpIDb10Cuck +Nw/nOSbBLINx2qDOa1f3Kox/PesQO4tp0dMp6XqZCOPTQ95vHsIOxuX1d+pxhX2V +ToWP +-----END CERTIFICATE----- diff --git a/hack/helm_vars/certs/values.yaml.gotmpl b/hack/helm_vars/certs/values.yaml.gotmpl new file mode 100644 index 00000000000..2d771907e65 --- /dev/null +++ b/hack/helm_vars/certs/values.yaml.gotmpl @@ -0,0 +1,123 @@ +resources: + - apiVersion: v1 + kind: Secret + metadata: + name: elasticsearch-ca + namespace: '{{ .Release.Namespace }}' + data: + tls.crt: {{ readFile "./elasticsearch-ca.pem" | b64enc | quote }} + tls.key: {{ readFile "./elasticsearch-ca-key.pem" | b64enc | quote }} + - apiVersion: cert-manager.io/v1 + kind: Issuer + metadata: + name: elasticsearch + namespace: '{{ .Release.Namespace }}' + spec: + ca: + secretName: elasticsearch-ca + + # redis CA and certificate + - apiVersion: cert-manager.io/v1 + kind: Issuer + metadata: + name: redis-ca-issuer + namespace: '{{ .Release.Namespace }}' + spec: + selfSigned: {} + - apiVersion: cert-manager.io/v1 + kind: Certificate + metadata: + name: redis-ca + namespace: '{{ .Release.Namespace }}' + spec: + secretName: redis-ca-certificate + isCA: true + duration: 2160h # 90d + renewBefore: 360h # 15d + commonName: redis.example.com + privateKey: + algorithm: RSA + encoding: PKCS1 + size: 2048 + issuerRef: + name: redis-ca-issuer + kind: Issuer + - apiVersion: cert-manager.io/v1 + kind: Issuer + metadata: + name: redis-issuer + namespace: '{{ .Release.Namespace }}' + spec: + ca: + secretName: redis-ca-certificate + - apiVersion: cert-manager.io/v1 + kind: Certificate + metadata: + name: redis + namespace: '{{ .Release.Namespace }}' + spec: + secretName: redis-certificate + isCA: false + duration: 2160h # 90d + renewBefore: 360h # 15d + commonName: redis-ephemeral-master + privateKey: + algorithm: RSA + encoding: PKCS1 + size: 2048 + issuerRef: + name: redis-issuer + kind: Issuer + + # RabbitMQ CA and certificate + - apiVersion: cert-manager.io/v1 + kind: Issuer + metadata: + name: rabbitmq-ca-issuer + namespace: '{{ .Release.Namespace }}' + spec: + selfSigned: {} + - apiVersion: cert-manager.io/v1 + kind: Certificate + metadata: + name: rabbitmq-ca + namespace: '{{ .Release.Namespace }}' + spec: + secretName: rabbitmq-ca-certificate + isCA: true + duration: 2160h # 90d + renewBefore: 360h # 15d + commonName: rabbitmq.example.com + privateKey: + algorithm: RSA + encoding: PKCS1 + size: 2048 + issuerRef: + name: rabbitmq-ca-issuer + kind: Issuer + - apiVersion: cert-manager.io/v1 + kind: Issuer + metadata: + name: rabbitmq-issuer + namespace: '{{ .Release.Namespace }}' + spec: + ca: + secretName: rabbitmq-ca-certificate + - apiVersion: cert-manager.io/v1 + kind: Certificate + metadata: + name: rabbitmq + namespace: '{{ .Release.Namespace }}' + spec: + secretName: rabbitmq-certificate + isCA: false + duration: 2160h # 90d + renewBefore: 360h # 15d + commonName: rabbitmq + privateKey: + algorithm: RSA + encoding: PKCS1 + size: 2048 + issuerRef: + name: rabbitmq-issuer + kind: Issuer diff --git a/hack/helm_vars/elasticsearch-certs/elasticsearch-ca-key.pem b/hack/helm_vars/elasticsearch-certs/elasticsearch-ca-key.pem deleted file mode 100644 index 0b9246b7ecb..00000000000 --- a/hack/helm_vars/elasticsearch-certs/elasticsearch-ca-key.pem +++ /dev/null @@ -1,27 +0,0 @@ ------BEGIN RSA PRIVATE KEY----- -MIIEpAIBAAKCAQEAtEfj7ZOOh3fEq0fkv3TO5xr4WANhK1lBYaclA1ou1aVKU4LZ -ck85jYMQJYfUFp/Brqr8KghQZ24iy/jlehLE9f3yrf94mFb/psoOYAUzx7f0DWh2 -eRO8DHcA0R0bgCkCPZAnWWWe/6a1T00A8dBNdssTFmxPjYL2HzZpCV0ht2OUuYoR -PETviWWHnAFn3N4sBGXg+3fVp1bG9LDPoicDDjk5cSkiPAsPrpHF3U4faZsckDWV -XdbUhl/zR9vNRCq6CDy6iAMYMtXdnFKogiiH+KRhG4o2/JvzpKBXs/u745g+ewPL -krsMl8+/sRNrkSRQIrLoOc3W/ClgCQZRJIIFmwIDAQABAoIBAQCtn7L/IqYZB5rs -ToAad5ewcYQN16tkgUB7mOsHsHn8noTXquRat7w48qnBS3BSHaf93YSfwoQVKLfw -c5QmHh98vgdT1f/Bz7/FVUHE7h2xUhOEOkAnWX85Df9GZd8Pbe9PdR7AdSNNGbPy -XLn1KWUBbJDEfqmbIy6AXvmH4B7Rq0K/8nRdTJsZiGBwR3TZINWkVv43b4LMlqdn -QavTm2cO7wylN6QWtWbutFs2YrbG7LCdn1qOyMQgNAwzHbzatQjWl8M7K9xoNaec -pjIS7/Oobs4OVlMxLn/QWF2wCWt+r3i+USqoAw7qgPXMQ1b6h4vaKHJw8UCTeI42 -Xi5vvfC5AoGBAOIfQ8kNHFI+7/5aPa7SQC0tqwBT+HkAZY4DZsFeCe7aKIrvqwCj -/6ioGrfLhtjQTUnxN5D9DyJnbNAKSGwbuylVcJiARPv5NxXS9ES3QmgK/mqz+Ds3 -8SVM48tI4jAfeSuDW/qztVOXpzZYJmnjVO1Qu0pNnmTMAB3WE2vqZlRvAoGBAMwa -AxkI4O2CUeaOug+eG/+ztlpX79lU+DDLYtM8CH8MVBfqQtLg5UxUGE7eVkSZyOYN -STz6eKIh5tvPc91l9xSrL5wwGmSl48f3xxycJVF2UfD7LmlcvRHthLCQPWHcCAne -6RWinCiS4ATPU6p9DzR6XYyALB0vODr84qTb9a+VAoGASPP9UqhAMujLVSyYKgb7 -XZgWS4zL5X4TRbYjOM+2NLF90xVv/kzq9ucFd7baUqkhxnFklAqRD3B+0r/+jaKE -x9kg8pKvrvvAofHljSXy7s5dNt/JfpGV44rjE3r4Pr5owXkn+8JvBgEvmYDnI9KM -W+RoCJjyOWL3xqiCq5Z8XVECgYB3vD7a/fFuhIhlmI+gv+GvFY/B2lrUBdwATCDy -yQI2/lWLHhwLuHHsYF1OT3MOlaVdCKhRhKMmgnr7su1HEh1sW6z3lOS27Pb/BeYi -a5wc+SvDEqg8mXI1xUCVkFjiQwHYQJQ+5AF2cAvJ5pMvrmQwJiUhWsQGbwAu4tJX -Ys70LQKBgQC3jOZpW5MrBdyGRJwkGYrJ3oGvgM5HGqD/9088b42i7EoDroh43e1r -rX+6mkocXd1LU2+zRaCqxA58dNuqXvU1dESW0gLgUoe3ubIlfoaD9MBwlE0trBDw -iO3tSUQ3zzYh+Uu7xBywvDEGnRhJTBs1AuwdxsdSte2WrQ7KLHwncQ== ------END RSA PRIVATE KEY----- diff --git a/hack/helm_vars/elasticsearch-certs/elasticsearch-ca.pem b/hack/helm_vars/elasticsearch-certs/elasticsearch-ca.pem deleted file mode 100644 index d4ef94d4d2a..00000000000 --- a/hack/helm_vars/elasticsearch-certs/elasticsearch-ca.pem +++ /dev/null @@ -1,19 +0,0 @@ ------BEGIN CERTIFICATE----- -MIIDHjCCAgagAwIBAgIUXd/KjPrGXSmRyZ4Q/9O3LPGB70owDQYJKoZIhvcNAQEL -BQAwJzElMCMGA1UEAxMcZWxhc3RpY3NlYXJjaC5jYS5leGFtcGxlLmNvbTAeFw0y -NDA0MjIxMjA0MDBaFw0yOTA0MjExMjA0MDBaMCcxJTAjBgNVBAMTHGVsYXN0aWNz -ZWFyY2guY2EuZXhhbXBsZS5jb20wggEiMA0GCSqGSIb3DQEBAQUAA4IBDwAwggEK -AoIBAQC0R+Ptk46Hd8SrR+S/dM7nGvhYA2ErWUFhpyUDWi7VpUpTgtlyTzmNgxAl -h9QWn8GuqvwqCFBnbiLL+OV6EsT1/fKt/3iYVv+myg5gBTPHt/QNaHZ5E7wMdwDR -HRuAKQI9kCdZZZ7/prVPTQDx0E12yxMWbE+NgvYfNmkJXSG3Y5S5ihE8RO+JZYec -AWfc3iwEZeD7d9WnVsb0sM+iJwMOOTlxKSI8Cw+ukcXdTh9pmxyQNZVd1tSGX/NH -281EKroIPLqIAxgy1d2cUqiCKIf4pGEbijb8m/OkoFez+7vjmD57A8uSuwyXz7+x -E2uRJFAisug5zdb8KWAJBlEkggWbAgMBAAGjQjBAMA4GA1UdDwEB/wQEAwIBBjAP -BgNVHRMBAf8EBTADAQH/MB0GA1UdDgQWBBQ1/LWQ/Ckxpc7HdBp6mNBfZNQssDAN -BgkqhkiG9w0BAQsFAAOCAQEAfGo1ONgSfTwRtT/ZsZgAnseqZSQCuvUQ4nrg2dDe -cFZtC05EczfmPx7G7Q2VeF9ZU56m/Ep57gE4W2wwVIwoG3Zam0kG4HirkgLNPagf -j3RkDrCvrjeESYFj7qwdnmgFNxotlC0KjHkGrfdT7gTDSWoNE3tobxyFaT1YQyBB -L6oRVlKa6O0ivgADUw/VMIARqFgCni/PhaHd4UlR9bgLVQ4MEVb463MMpGAdK4ZZ -l1bYVRf0pTeYnEiUG2HXt/1JFzSowFoZD8wVOXa0kcxy9SK/UCX8PVzMx06G4Ion -NNkzz9uSme9hAQlVsW6gxzl0NhwOtClpPIlvEqHwgF54KQ== ------END CERTIFICATE----- diff --git a/hack/helm_vars/elasticsearch-certs/es-cert-issuer.yaml.gotmpl b/hack/helm_vars/elasticsearch-certs/es-cert-issuer.yaml.gotmpl deleted file mode 100644 index a9ef90fd0e8..00000000000 --- a/hack/helm_vars/elasticsearch-certs/es-cert-issuer.yaml.gotmpl +++ /dev/null @@ -1,17 +0,0 @@ -resources: - - apiVersion: v1 - kind: Secret - metadata: - name: elasticsearch-ca - namespace: '{{ .Release.Namespace }}' - data: - tls.crt: {{ readFile "./elasticsearch-ca.pem" | b64enc | quote }} - tls.key: {{ readFile "./elasticsearch-ca-key.pem" | b64enc | quote }} - - apiVersion: cert-manager.io/v1 - kind: Issuer - metadata: - name: elasticsearch - namespace: '{{ .Release.Namespace }}' - spec: - ca: - secretName: elasticsearch-ca diff --git a/hack/helm_vars/rabbitmq/values.yaml.gotmpl b/hack/helm_vars/rabbitmq/values.yaml.gotmpl index a8a4a81dee2..710e9b0d338 100644 --- a/hack/helm_vars/rabbitmq/values.yaml.gotmpl +++ b/hack/helm_vars/rabbitmq/values.yaml.gotmpl @@ -4,3 +4,20 @@ rabbitmq: auth: username: {{ .Values.rabbitmqUsername }} password: {{ .Values.rabbitmqPassword }} + tls: + enabled: true + failIfNoPeerCert: false + existingSecret: rabbitmq-certificate + service: + extraPorts: + - name: http-stats-ssl + port: 15671 + protocol: TCP + targetPort: 15671 + extraConfiguration: |- + listeners.tcp = none + management.tcp.port = 15672 + management.ssl.port = 15671 + management.ssl.cacertfile = /opt/bitnami/rabbitmq/certs/ca_certificate.pem + management.ssl.certfile = /opt/bitnami/rabbitmq/certs/server_certificate.pem + management.ssl.keyfile = /opt/bitnami/rabbitmq/certs/server_key.pem diff --git a/hack/helm_vars/redis-cluster/values.yaml.gotmpl b/hack/helm_vars/redis-cluster/values.yaml.gotmpl index 9d81712a59d..d43a704323b 100644 --- a/hack/helm_vars/redis-cluster/values.yaml.gotmpl +++ b/hack/helm_vars/redis-cluster/values.yaml.gotmpl @@ -7,3 +7,6 @@ redis-cluster: volumePermissions: enabled: true password: very-secure-redis-cluster-password + tls: + enabled: true + existingSecret: redis-certificate diff --git a/hack/helm_vars/wire-server/values.yaml.gotmpl b/hack/helm_vars/wire-server/values.yaml.gotmpl index 11cf79753cd..452b3864685 100644 --- a/hack/helm_vars/wire-server/values.yaml.gotmpl +++ b/hack/helm_vars/wire-server/values.yaml.gotmpl @@ -75,6 +75,13 @@ brig: additionalTlsCaSecretRef: name: "elasticsearch-ephemeral-certificate" key: "ca.crt" + rabbitmq: + port: 5671 + enableTls: true + insecureSkipVerifyTls: false + tlsCaSecretRef: + name: rabbitmq-certificate + key: "ca.crt" authSettings: userTokenTimeout: 120 sessionTokenTimeout: 20 @@ -142,12 +149,6 @@ brig: secret: rPrUbws7PQZlfN2GG8Ggi7g5iOYPk7BiCoKHl3VoFZ awsKeyId: dummykey awsSecretKey: dummysecret - setTwilio: | - sid: "dummy" - token: "dummy" - setNexmo: |- - key: "dummy" - secret: "dummy" smtpPassword: dummy-smtp-password dpopSigKeyBundle: | -----BEGIN PRIVATE KEY----- @@ -233,6 +234,13 @@ galley: name: "cassandra-jks-keystore" key: "ca.crt" {{- end }} + rabbitmq: + port: 5671 + enableTls: true + insecureSkipVerifyTls: false + tlsCaSecretRef: + name: rabbitmq-certificate + key: "ca.crt" enableFederation: true # keep in sync with brig.config.enableFederation, cargohold.config.enableFederation and tags.federator! settings: maxConvAndTeamSize: 16 @@ -330,6 +338,10 @@ gundeck: redis: host: redis-ephemeral-master connectionMode: master + enableTls: true + tlsCaSecretRef: + name: "redis-certificate" + key: "ca.crt" aws: account: "123456789012" region: eu-west-1 @@ -467,6 +479,14 @@ background-worker: pushBackoffMinWait: 1000 # 1ms pushBackoffMaxWait: 500000 # 0.5s remotesRefreshInterval: 1000000 # 1s + rabbitmq: + port: 5671 + adminPort: 15671 + enableTls: true + insecureSkipVerifyTls: false + tlsCaSecretRef: + name: rabbitmq-certificate + key: "ca.crt" secrets: rabbitmq: username: {{ .Values.rabbitmqUsername }} @@ -489,6 +509,14 @@ integration: tlsCaSecretRef: name: "elasticsearch-ephemeral-certificate" key: "ca.crt" + redis: + tlsCaSecretRef: + name: "redis-certificate" + key: "ca.crt" + rabbitmq: + tlsCaSecretRef: + name: "rabbitmq-certificate" + key: "ca.crt" {{- if .Values.uploadXml }} uploadXml: baseUrl: {{ .Values.uploadXml.baseUrl }} diff --git a/hack/helmfile.yaml b/hack/helmfile.yaml index c8a9824ec8b..a7ed6861883 100644 --- a/hack/helmfile.yaml +++ b/hack/helmfile.yaml @@ -71,11 +71,11 @@ releases: values: - './helm_vars/fake-aws/values.yaml' - - name: 'elasticsearch-certs' + - name: 'certs' namespace: '{{ .Values.namespace1 }}' chart: bedag/raw values: - - './helm_vars/elasticsearch-certs/es-cert-issuer.yaml.gotmpl' + - './helm_vars/certs/values.yaml.gotmpl' - name: 'databases-ephemeral' namespace: '{{ .Values.namespace1 }}' @@ -85,6 +85,13 @@ releases: redis-ephemeral: usePassword: true password: very-secure-redis-master-password + tls: + enabled: true + certificatesSecret: redis-certificate + certFilename: "tls.crt" + certKeyFilename: "tls.key" + certCAFilename: "ca.crt" + authClients: false elasticsearch-ephemeral: tls: enabled: true @@ -92,7 +99,7 @@ releases: name: elasticsearch kind: Issuer needs: - - elasticsearch-certs + - certs # Required for testing redis migration - name: 'redis-ephemeral-2' @@ -104,11 +111,11 @@ releases: usePassword: true password: very-secure-redis-master-password-2 - - name: 'elasticsearch-certs' + - name: 'certs' namespace: '{{ .Values.namespace2 }}' chart: bedag/raw values: - - './helm_vars/elasticsearch-certs/es-cert-issuer.yaml.gotmpl' + - './helm_vars/certs/values.yaml.gotmpl' - name: 'databases-ephemeral' namespace: '{{ .Values.namespace2 }}' @@ -118,6 +125,13 @@ releases: redis-ephemeral: usePassword: true password: very-secure-redis-master-password + tls: + enabled: true + certificatesSecret: redis-certificate + certFilename: "tls.crt" + certKeyFilename: "tls.key" + certCAFilename: "ca.crt" + authClients: false elasticsearch-ephemeral: tls: enabled: true @@ -125,7 +139,7 @@ releases: name: elasticsearch kind: Issuer needs: - - elasticsearch-certs + - certs - name: k8ssandra-test-cluster chart: '../.local/charts/k8ssandra-test-cluster' diff --git a/integration/default.nix b/integration/default.nix index 6abbb50c753..040ab8db6f5 100644 --- a/integration/default.nix +++ b/integration/default.nix @@ -7,6 +7,8 @@ , aeson-diff , aeson-pretty , array +, asn1-encoding +, asn1-types , async , attoparsec , base @@ -20,6 +22,8 @@ , cql , cql-io , crypton +, crypton-x509 +, cryptostore , data-default , data-timeout , deriving-aeson @@ -32,6 +36,7 @@ , gitignoreSource , haskell-src-exts , hex +, hourglass , HsOpenSSL , http-client , http-types @@ -70,6 +75,7 @@ , uuid , vector , wai +, wai-route , warp , warp-tls , websockets @@ -97,6 +103,8 @@ mkDerivation { aeson-diff aeson-pretty array + asn1-encoding + asn1-types async attoparsec base @@ -109,6 +117,8 @@ mkDerivation { cql cql-io crypton + crypton-x509 + cryptostore data-default data-timeout deriving-aeson @@ -119,6 +129,7 @@ mkDerivation { extra filepath hex + hourglass HsOpenSSL http-client http-types @@ -156,6 +167,7 @@ mkDerivation { uuid vector wai + wai-route warp warp-tls websockets diff --git a/integration/integration.cabal b/integration/integration.cabal index 15fd4c7a8d6..0c4c2f93b6c 100644 --- a/integration/integration.cabal +++ b/integration/integration.cabal @@ -108,6 +108,7 @@ library Test.AssetDownload Test.AssetUpload Test.B2B + Test.Bot Test.Brig Test.Cargohold.API Test.Cargohold.API.Federation @@ -122,6 +123,7 @@ library Test.Errors Test.ExternalPartner Test.FeatureFlags + Test.FeatureFlags.Util Test.Federation Test.Federator Test.LegalHold @@ -137,6 +139,7 @@ library Test.MLS.Unreachable Test.Notifications Test.Presence + Test.Provider Test.PushToken Test.Roles Test.Search @@ -149,6 +152,7 @@ library Testlib.App Testlib.Assertions Testlib.Cannon + Testlib.Certs Testlib.Env Testlib.HTTP Testlib.JSON @@ -173,6 +177,8 @@ library , aeson-diff , aeson-pretty , array + , asn1-encoding + , asn1-types , async , attoparsec , base @@ -185,6 +191,8 @@ library , cql , cql-io , crypton + , crypton-x509 + , cryptostore , data-default , data-timeout , deriving-aeson @@ -195,6 +203,7 @@ library , extra , filepath , hex + , hourglass , HsOpenSSL , http-client , http-types @@ -232,6 +241,7 @@ library , uuid , vector , wai + , wai-route , warp , warp-tls , websockets diff --git a/integration/scripts/integration-dynamic-backends-vhosts.sh b/integration/scripts/integration-dynamic-backends-vhosts.sh index f919f6b9121..5478a68b03a 100755 --- a/integration/scripts/integration-dynamic-backends-vhosts.sh +++ b/integration/scripts/integration-dynamic-backends-vhosts.sh @@ -7,7 +7,6 @@ DOMAIN=$2 echo 'Creating RabbitMQ resources' -curl -u "$RABBITMQ_USERNAME":"$RABBITMQ_PASSWORD" -X PUT "$ENDPOINT_URL/$DOMAIN" +curl --cacert /certs/rabbitmq-ca/ca.pem -u "$RABBITMQ_USERNAME:$RABBITMQ_PASSWORD" -X PUT "$ENDPOINT_URL/$DOMAIN" echo "RabbitMQ vhost created successfully for $DOMAIN" - diff --git a/integration/test/API/Brig.hs b/integration/test/API/Brig.hs index ff825f0aa90..c41865273e9 100644 --- a/integration/test/API/Brig.hs +++ b/integration/test/API/Brig.hs @@ -181,7 +181,7 @@ instance Default UpdateClient where } updateClient :: - HasCallStack => + (HasCallStack) => ClientIdentity -> UpdateClient -> App Response @@ -368,7 +368,7 @@ getSelfWithVersion v user = baseRequest user Brig v "/self" >>= submit "GET" -- | https://staging-nginz-https.zinfra.io/v6/api/swagger-ui/#/default/get_self -- this is a low-level version of `getSelf` for testing some error conditions. -getSelf' :: HasCallStack => String -> String -> App Response +getSelf' :: (HasCallStack) => String -> String -> App Response getSelf' domain uid = getSelfWithVersion Versioned $ object ["domain" .= domain, "id" .= uid] data PutSelf = PutSelf @@ -462,45 +462,45 @@ postInvitation user inv = do submit "POST" $ req & addJSONObject ["email" .= email] -getApiVersions :: HasCallStack => App Response +getApiVersions :: (HasCallStack) => App Response getApiVersions = do req <- rawBaseRequest OwnDomain Brig Unversioned $ joinHttpPath ["api-version"] submit "GET" req -getSwaggerPublicTOC :: HasCallStack => App Response +getSwaggerPublicTOC :: (HasCallStack) => App Response getSwaggerPublicTOC = do req <- rawBaseRequest OwnDomain Brig Unversioned $ joinHttpPath ["api", "swagger-ui"] submit "GET" req -getSwaggerInternalTOC :: HasCallStack => App Response +getSwaggerInternalTOC :: (HasCallStack) => App Response getSwaggerInternalTOC = error "FUTUREWORK: this API end-point does not exist." -getSwaggerPublicAllUI :: HasCallStack => Int -> App Response +getSwaggerPublicAllUI :: (HasCallStack) => Int -> App Response getSwaggerPublicAllUI version = do req <- rawBaseRequest OwnDomain Brig (ExplicitVersion version) $ joinHttpPath ["api", "swagger-ui"] submit "GET" req -getSwaggerPublicAllJson :: HasCallStack => Int -> App Response +getSwaggerPublicAllJson :: (HasCallStack) => Int -> App Response getSwaggerPublicAllJson version = do req <- rawBaseRequest OwnDomain Brig (ExplicitVersion version) $ joinHttpPath ["api", "swagger.json"] submit "GET" req -getSwaggerInternalUI :: HasCallStack => String -> App Response +getSwaggerInternalUI :: (HasCallStack) => String -> App Response getSwaggerInternalUI service = do req <- rawBaseRequest OwnDomain Brig Unversioned $ joinHttpPath ["api-internal", "swagger-ui", service] submit "GET" req -getSwaggerInternalJson :: HasCallStack => String -> App Response +getSwaggerInternalJson :: (HasCallStack) => String -> App Response getSwaggerInternalJson service = do req <- rawBaseRequest OwnDomain Nginz Unversioned $ @@ -541,6 +541,12 @@ activateProvider dom key code = do submit "GET" (addQueryParams ps req) `bindResponse` \resp -> do resp.status `shouldMatchOneOf` [Number 200, Number 204] +activateUserV5 :: (HasCallStack, MakesValue dom, MakesValue bdy) => dom -> bdy -> App Response +activateUserV5 dom bdy = do + b <- make bdy + req <- rawBaseRequest dom Brig (ExplicitVersion 5) $ joinHttpPath ["activate", "send"] + submit "POST" $ (addJSON b req) + -- | Returns the value of the Set-Cookie header that is to be used to -- authenticate to provider endpoints. loginProvider :: @@ -601,14 +607,33 @@ updateService dom providerId serviceId mAcceptHeader newName = do rawBaseRequest domain Brig Versioned $ joinHttpPath ["provider", "services", sId] let addHdrs = - addHeader "Z-Type" "provider" - . addHeader "Z-Provider" providerId + zType "provider" + . zProvider providerId . maybe id (addHeader "Accept") mAcceptHeader submit "PUT" . addHdrs . addJSONObject ["name" .= n | n <- maybeToList newName] $ req +updateServiceConn :: + (MakesValue conn) => + -- | providerId + String -> + -- | serviceId + String -> + -- | connection update as a Json object, with an obligatory "password" field + conn -> + App Response +updateServiceConn providerId serviceId connectionUpdate = do + req <- baseRequest OwnDomain Brig Versioned do + joinHttpPath ["provider", "services", serviceId, "connection"] + upd <- make connectionUpdate + submit "PUT" + . zType "provider" + . zProvider providerId + . addJSON upd + $ req + -- | https://staging-nginz-https.zinfra.io/v5/api/swagger-ui/#/default/get_users__uid_domain___uid__prekeys__client_ getUsersPrekeysClient :: (HasCallStack, MakesValue caller, MakesValue targetUser) => caller -> targetUser -> String -> App Response getUsersPrekeysClient caller targetUser targetClient = do @@ -642,3 +667,11 @@ getCallsConfigV2 :: (HasCallStack, MakesValue user) => user -> App Response getCallsConfigV2 user = do req <- baseRequest user Brig Versioned $ joinHttpPath ["calls", "config", "v2"] submit "GET" req + +addBot :: (MakesValue user) => user -> String -> String -> String -> App Response +addBot user providerId serviceId convId = do + req <- baseRequest user Brig Versioned $ joinHttpPath ["conversations", convId, "bots"] + submit "POST" $ + req + & zType "access" + & addJSONObject ["provider" .= providerId, "service" .= serviceId] diff --git a/integration/test/API/BrigInternal.hs b/integration/test/API/BrigInternal.hs index 71bde9877dd..5fbfd5cf2e5 100644 --- a/integration/test/API/BrigInternal.hs +++ b/integration/test/API/BrigInternal.hs @@ -242,7 +242,8 @@ getClientsFull :: (HasCallStack, MakesValue users, MakesValue uid) => uid -> use getClientsFull user users = do val <- make users baseRequest user Brig Unversioned do joinHttpPath ["i", "clients", "full"] - >>= submit "POST" . addJSONObject ["users" .= val] + >>= submit "POST" + . addJSONObject ["users" .= val] -- | https://staging-nginz-https.zinfra.io/api-internal/swagger-ui/brig/#/brig/post_i_ejpd_request getEJPDInfo :: (HasCallStack, MakesValue dom) => dom -> [String] -> String -> App Response @@ -252,7 +253,7 @@ getEJPDInfo dom handles mode = do "" -> [] "include_contacts" -> [("include_contacts", "true")] bad -> error $ show bad - submit "POST" $ req & addJSONObject ["ejpd_request" .= handles] & addQueryParams query + submit "POST" $ req & addJSONObject ["EJPDRequest" .= handles] & addQueryParams query -- https://staging-nginz-https.zinfra.io/api-internal/swagger-ui/brig/#/brig/get_i_users__uid__verification_code__action_ getVerificationCode :: (HasCallStack, MakesValue user) => user -> String -> App Response diff --git a/integration/test/API/Cargohold.hs b/integration/test/API/Cargohold.hs index 0fe767fea35..e21e26fed81 100644 --- a/integration/test/API/Cargohold.hs +++ b/integration/test/API/Cargohold.hs @@ -19,51 +19,58 @@ getFederationAsset :: (HasCallStack, MakesValue asset) => asset -> App Response getFederationAsset ga = do req <- rawBaseRequestF OwnDomain cargohold "federation/get-asset" bdy <- make ga - submit "POST" $ - req - & addBody (HTTP.RequestBodyLBS $ encode bdy) "application/json" + submit "POST" + $ req + & addBody (HTTP.RequestBodyLBS $ encode bdy) "application/json" uploadAssetV3 :: (HasCallStack, MakesValue user, MakesValue assetRetention) => user -> Bool -> assetRetention -> MIME.MIMEType -> LByteString -> App Response uploadAssetV3 user isPublic retention mimeType bdy = do uid <- user & objId req <- baseRequest user Cargohold (ExplicitVersion 1) "/assets/v3" body <- buildUploadAssetRequestBody isPublic retention bdy mimeType - submit "POST" $ - req - & zUser uid - & addBody body multipartMixedMime - where - multipartMixedMime :: String - multipartMixedMime = "multipart/mixed; boundary=" <> multipartBoundary + submit "POST" + $ req + & zUser uid + & addBody body multipartMixedMime uploadAsset :: (HasCallStack, MakesValue user) => user -> App Response uploadAsset = flip uploadFreshAsset "Hello World!" +uploadProviderAsset :: (HasCallStack, MakesValue domain) => domain -> String -> String -> App Response +uploadProviderAsset domain pid payload = do + req <- rawBaseRequest domain Cargohold Versioned $ joinHttpPath ["provider", "assets"] + bdy <- txtAsset payload + submit "POST" + $ req + & zProvider pid + & zType "provider" + & addBody bdy multipartMixedMime + uploadFreshAsset :: (HasCallStack, MakesValue user) => user -> String -> App Response uploadFreshAsset user payload = do uid <- user & objId req <- baseRequest user Cargohold Versioned "/assets" - bdy <- txtAsset - submit "POST" $ - req - & zUser uid - & addBody bdy multipartMixedMime - where - txtAsset :: HasCallStack => App HTTP.RequestBody - txtAsset = - buildUploadAssetRequestBody - True - (Nothing :: Maybe String) - (LBSC.pack payload) - textPlainMime - - textPlainMime :: MIME.MIMEType - textPlainMime = MIME.Text $ T.pack "plain" - - -- This case is a bit special and doesn't fit to MIMEType: We need to define - -- the boundary. - multipartMixedMime :: String - multipartMixedMime = "multipart/mixed; boundary=" <> multipartBoundary + bdy <- txtAsset payload + submit "POST" + $ req + & zUser uid + & addBody bdy multipartMixedMime + +txtAsset :: (HasCallStack) => String -> App HTTP.RequestBody +txtAsset payload = + buildUploadAssetRequestBody + True + (Nothing :: Maybe String) + (LBSC.pack payload) + textPlainMime + +textPlainMime :: MIME.MIMEType +textPlainMime = MIME.Text $ T.pack "plain" + +-- This case is a bit special and doesn't fit to MIMEType: We need to define +-- the boundary. +multipartMixedMime :: String +multipartMixedMime = "multipart/mixed; boundary=" <> multipartBoundary mimeTypeToString :: MIME.MIMEType -> String mimeTypeToString = T.unpack . MIME.showMIMEType @@ -92,7 +99,7 @@ instance {-# OVERLAPS #-} IsAssetLocation String where locationPathFragment = pure -- Pick out a path from the value -instance MakesValue loc => IsAssetLocation loc where +instance (MakesValue loc) => IsAssetLocation loc where locationPathFragment v = qualifiedFrag `catch` (\(_e :: SomeException) -> unqualifiedFrag) where @@ -130,7 +137,7 @@ downloadAsset user assetDomain key zHostHeader trans = do domain <- objDomain assetDomain key' <- asString key req <- baseRequest user Cargohold Versioned $ "/assets/" ++ domain ++ "/" ++ key' - submit "GET" $ - req - & zHost zHostHeader - & trans + submit "GET" + $ req + & zHost zHostHeader + & trans diff --git a/integration/test/API/Common.hs b/integration/test/API/Common.hs index cdc4b11c2d4..c07816cc5b4 100644 --- a/integration/test/API/Common.hs +++ b/integration/test/API/Common.hs @@ -66,11 +66,11 @@ randomClientId = do mkArray :: [a] -> Array.Array Int a mkArray l = Array.listArray (0, length l - 1) l -recipient :: MakesValue u => u -> App Value +recipient :: (MakesValue u) => u -> App Value recipient u = do uid <- u %. "id" - pure $ - object + pure + $ object [ "user_id" .= uid, "route" .= "any", "clients" .= ([] :: [String]) diff --git a/integration/test/API/Galley.hs b/integration/test/API/Galley.hs index f169e341cb7..d4c4b6e366e 100644 --- a/integration/test/API/Galley.hs +++ b/integration/test/API/Galley.hs @@ -59,9 +59,9 @@ allowGuests cc = instance MakesValue CreateConv where make cc = do quids <- for (cc.qualifiedUsers) objQidObject - pure $ - Aeson.object $ - ( [ "qualified_users" .= quids, + pure + $ Aeson.object + $ ( [ "qualified_users" .= quids, "conversation_role" .= cc.newUsersRole, "protocol" .= cc.protocol ] @@ -158,8 +158,8 @@ getSubConversation :: getSubConversation user conv sub = do (cnvDomain, cnvId) <- objQid conv req <- - baseRequest user Galley Versioned $ - joinHttpPath + baseRequest user Galley Versioned + $ joinHttpPath [ "conversations", cnvDomain, cnvId, @@ -179,8 +179,8 @@ deleteSubConversation user sub = do groupId <- sub %. "group_id" & asString epoch :: Int <- sub %. "epoch" & asIntegral req <- - baseRequest user Galley Versioned $ - joinHttpPath ["conversations", domain, convId, "subconversations", subId] + baseRequest user Galley Versioned + $ joinHttpPath ["conversations", domain, convId, "subconversations", subId] submit "DELETE" $ req & addJSONObject ["group_id" .= groupId, "epoch" .= epoch] leaveSubConversation :: @@ -192,8 +192,8 @@ leaveSubConversation user sub = do (conv, Just subId) <- objSubConv sub (domain, convId) <- objQid conv req <- - baseRequest user Galley Versioned $ - joinHttpPath ["conversations", domain, convId, "subconversations", subId, "self"] + baseRequest user Galley Versioned + $ joinHttpPath ["conversations", domain, convId, "subconversations", subId, "self"] submit "DELETE" req getSelfConversation :: (HasCallStack, MakesValue user) => user -> App Response @@ -206,34 +206,34 @@ data ListConversationIds = ListConversationIds {pagingState :: Maybe String, siz instance Default ListConversationIds where def = ListConversationIds Nothing Nothing -listConversationIds :: MakesValue user => user -> ListConversationIds -> App Response +listConversationIds :: (MakesValue user) => user -> ListConversationIds -> App Response listConversationIds user args = do req <- baseRequest user Galley Versioned "/conversations/list-ids" - submit "POST" $ - req - & addJSONObject - ( ["paging_state" .= s | s <- toList args.pagingState] - <> ["size" .= s | s <- toList args.size] - ) + submit "POST" + $ req + & addJSONObject + ( ["paging_state" .= s | s <- toList args.pagingState] + <> ["size" .= s | s <- toList args.size] + ) -listConversations :: MakesValue user => user -> [Value] -> App Response +listConversations :: (MakesValue user) => user -> [Value] -> App Response listConversations user cnvs = do req <- baseRequest user Galley Versioned "/conversations/list" - submit "POST" $ - req - & addJSONObject ["qualified_ids" .= cnvs] + submit "POST" + $ req + & addJSONObject ["qualified_ids" .= cnvs] getMLSPublicKeys :: (HasCallStack, MakesValue user) => user -> App Response getMLSPublicKeys user = do req <- baseRequest user Galley Versioned "/mls/public-keys" submit "GET" req -postMLSMessage :: HasCallStack => ClientIdentity -> ByteString -> App Response +postMLSMessage :: (HasCallStack) => ClientIdentity -> ByteString -> App Response postMLSMessage cid msg = do req <- baseRequest cid Galley Versioned "/mls/messages" submit "POST" (addMLS msg req) -postMLSCommitBundle :: HasCallStack => ClientIdentity -> ByteString -> App Response +postMLSCommitBundle :: (HasCallStack) => ClientIdentity -> ByteString -> App Response postMLSCommitBundle cid msg = do req <- baseRequest cid Galley Versioned "/mls/commit-bundles" submit "POST" (addMLS msg req) @@ -253,24 +253,24 @@ mkProteusRecipients :: (HasCallStack, MakesValue domain, MakesValue user, MakesV mkProteusRecipients dom userClients msg = do userDomain <- asString =<< objDomain dom userEntries <- mapM mkUserEntry userClients - pure $ - Proto.defMessage - & #domain .~ fromString userDomain - & #entries .~ userEntries + pure + $ Proto.defMessage + & #domain .~ fromString userDomain + & #entries .~ userEntries where mkUserEntry (user, clients) = do userId <- LBS.toStrict . UUID.toByteString . fromJust . UUID.fromString <$> objId user clientEntries <- mapM mkClientEntry clients - pure $ - Proto.defMessage - & #user . #uuid .~ userId - & #clients .~ clientEntries + pure + $ Proto.defMessage + & #user . #uuid .~ userId + & #clients .~ clientEntries mkClientEntry client = do clientId <- (^?! hex) <$> objId client - pure $ - Proto.defMessage - & #client . #client .~ clientId - & #text .~ fromString msg + pure + $ Proto.defMessage + & #client . #client .~ clientId + & #text .~ fromString msg getGroupInfo :: (HasCallStack, MakesValue user, MakesValue conv) => @@ -330,8 +330,8 @@ getMLSOne2OneConversation :: getMLSOne2OneConversation self other = do (domain, uid) <- objQid other req <- - baseRequest self Galley Versioned $ - joinHttpPath ["conversations", "one2one", domain, uid] + baseRequest self Galley Versioned + $ joinHttpPath ["conversations", "one2one", domain, uid] submit "GET" req getGroupClients :: @@ -375,12 +375,12 @@ addMembers usr qcnv opts = do Galley (maybe Versioned ExplicitVersion opts.version) (joinHttpPath path) - submit "POST" $ - req - & addJSONObject - ( ["qualified_users" .= qUsers] - <> ["conversation_role" .= r | r <- toList opts.role] - ) + submit "POST" + $ req + & addJSONObject + ( ["qualified_users" .= qUsers] + <> ["conversation_role" .= r | r <- toList opts.role] + ) removeMember :: (HasCallStack, MakesValue remover, MakesValue conv, MakesValue removed) => remover -> conv -> removed -> App Response removeMember remover qcnv removed = do @@ -681,7 +681,7 @@ putLegalholdStatus tid usr status = do baseRequest usr Galley Versioned (joinHttpPath ["teams", tidStr, "features", "legalhold"]) >>= submit "PUT" - . addJSONObject ["status" .= status, "ttl" .= "unlimited"] + . addJSONObject ["status" .= status, "ttl" .= "unlimited"] -- | https://staging-nginz-https.zinfra.io/v5/api/swagger-ui/#/default/get_feature_configs getFeatureConfigs :: (HasCallStack, MakesValue user) => user -> App Response @@ -701,3 +701,14 @@ getTeamFeature user tid featureName = do tidStr <- asString tid req <- baseRequest user Galley Versioned (joinHttpPath ["teams", tidStr, "features", featureName]) submit "GET" req + +setTeamFeatureConfig :: (HasCallStack, MakesValue user, MakesValue team, MakesValue featureName, MakesValue payload) => user -> team -> featureName -> payload -> App Response +setTeamFeatureConfig = setTeamFeatureConfigVersioned Versioned + +setTeamFeatureConfigVersioned :: (HasCallStack, MakesValue user, MakesValue team, MakesValue featureName, MakesValue payload) => Versioned -> user -> team -> featureName -> payload -> App Response +setTeamFeatureConfigVersioned versioned user team featureName payload = do + tid <- asString team + fn <- asString featureName + p <- make payload + req <- baseRequest user Galley versioned $ joinHttpPath ["teams", tid, "features", fn] + submit "PUT" $ req & addJSON p diff --git a/integration/test/API/GalleyInternal.hs b/integration/test/API/GalleyInternal.hs index 281c86e6a18..ef0f773d426 100644 --- a/integration/test/API/GalleyInternal.hs +++ b/integration/test/API/GalleyInternal.hs @@ -37,16 +37,11 @@ getTeamFeature domain_ tid featureName = do req <- baseRequest domain_ Galley Unversioned $ joinHttpPath ["i", "teams", tid, "features", featureName] submit "GET" $ req -setTeamFeatureStatus :: (HasCallStack, MakesValue domain, MakesValue team) => domain -> team -> String -> String -> App () +setTeamFeatureStatus :: (HasCallStack, MakesValue domain, MakesValue team) => domain -> team -> String -> String -> App Response setTeamFeatureStatus domain team featureName status = do - setTeamFeatureStatusExpectHttpStatus domain team featureName status 200 - -setTeamFeatureStatusExpectHttpStatus :: (HasCallStack, MakesValue domain, MakesValue team) => domain -> team -> String -> String -> Int -> App () -setTeamFeatureStatusExpectHttpStatus domain team featureName status httpStatus = do tid <- asString team req <- baseRequest domain Galley Unversioned $ joinHttpPath ["i", "teams", tid, "features", featureName] - bindResponse (submit "PATCH" $ req & addJSONObject ["status" .= status]) $ \res -> do - res.status `shouldMatchInt` httpStatus + submit "PATCH" $ req & addJSONObject ["status" .= status] setTeamFeatureLockStatus :: (HasCallStack, MakesValue domain, MakesValue team) => domain -> team -> String -> String -> App () setTeamFeatureLockStatus domain team featureName status = do @@ -68,7 +63,8 @@ getFederationStatus user domains = req <- baseRequest user Galley Unversioned $ joinHttpPath ["i", "federation-status"] submit "GET" - $ req & addJSONObject ["domains" .= domainList] + $ req + & addJSONObject ["domains" .= domainList] -- | https://staging-nginz-https.zinfra.io/api-internal/swagger-ui/galley/#/galley/put_i_legalhold_whitelisted_teams__tid_ legalholdWhitelistTeam :: (HasCallStack, MakesValue uid, MakesValue tid) => tid -> uid -> App Response @@ -101,3 +97,24 @@ generateVerificationCode' domain email = do req <- baseRequest domain Brig Versioned "/verification-code/send" emailStr <- asString email submit "POST" $ req & addJSONObject ["email" .= emailStr, "action" .= "login"] + +setTeamFeatureConfig :: (HasCallStack, MakesValue domain, MakesValue team, MakesValue featureName, MakesValue payload) => domain -> team -> featureName -> payload -> App Response +setTeamFeatureConfig domain team featureName payload = do + tid <- asString team + fn <- asString featureName + p <- make payload + req <- baseRequest domain Galley Unversioned $ joinHttpPath ["i", "teams", tid, "features", fn] + submit "PUT" $ req & addJSON p + +-- https://staging-nginz-https.zinfra.io/api-internal/swagger-ui/galley/#/galley/post_i_features_multi_teams_searchVisibilityInbound +getFeatureStatusMulti :: (HasCallStack, MakesValue domain, MakesValue featureName) => domain -> featureName -> [String] -> App Response +getFeatureStatusMulti domain featureName tids = do + fn <- asString featureName + req <- baseRequest domain Galley Unversioned $ joinHttpPath ["i", "features-multi-teams", fn] + submit "POST" $ req & addJSONObject ["teams" .= tids] + +patchTeamFeature :: (HasCallStack, MakesValue domain, MakesValue team) => domain -> team -> String -> Value -> App Response +patchTeamFeature domain team featureName payload = do + tid <- asString team + req <- baseRequest domain Galley Unversioned $ joinHttpPath ["i", "teams", tid, "features", featureName] + submit "PATCH" $ req & addJSON payload diff --git a/integration/test/API/Gundeck.hs b/integration/test/API/Gundeck.hs index d44603ca2aa..15af3905074 100644 --- a/integration/test/API/Gundeck.hs +++ b/integration/test/API/Gundeck.hs @@ -47,8 +47,8 @@ getNotification :: getNotification user opts nid = do n <- nid & asString req <- - baseRequest user Gundeck Versioned $ - joinHttpPath ["notifications", n] + baseRequest user Gundeck Versioned + $ joinHttpPath ["notifications", n] submit "GET" $ req & addQueryParams [("client", c) | c <- toList opts.client] getLastNotification :: @@ -126,8 +126,8 @@ postPushToken user token = do listPushTokens :: (MakesValue user) => user -> App Response listPushTokens user = do req <- - baseRequest user Gundeck Versioned $ - joinHttpPath ["/push/tokens"] + baseRequest user Gundeck Versioned + $ joinHttpPath ["/push/tokens"] submit "GET" req unregisterClient :: @@ -138,6 +138,6 @@ unregisterClient :: unregisterClient user client = do cid <- asString client req <- - baseRequest user Gundeck Unversioned $ - joinHttpPath ["/i/clients", cid] + baseRequest user Gundeck Unversioned + $ joinHttpPath ["/i/clients", cid] submit "DELETE" req diff --git a/integration/test/API/GundeckInternal.hs b/integration/test/API/GundeckInternal.hs index 907331a98ef..a120734c17f 100644 --- a/integration/test/API/GundeckInternal.hs +++ b/integration/test/API/GundeckInternal.hs @@ -22,8 +22,9 @@ getPresence :: getPresence u = do uid <- u %. "id" & asString req <- - baseRequest u Gundeck Unversioned $ - "/i/presences/" <> uid + baseRequest u Gundeck Unversioned + $ "/i/presences/" + <> uid submit "GET" req unregisterUser :: diff --git a/integration/test/API/Nginz.hs b/integration/test/API/Nginz.hs index b4c2f08db5b..ac248fd544f 100644 --- a/integration/test/API/Nginz.hs +++ b/integration/test/API/Nginz.hs @@ -1,5 +1,12 @@ module API.Nginz where +import qualified Codec.MIME.Type as MIME +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Lazy.Char8 as LBSC +import qualified Data.Text as T +import qualified Network.HTTP.Client as HTTP +import Test.Cargohold.API.Util (buildMultipartBody, multipartBoundary) import Testlib.Prelude getSystemSettingsUnAuthorized :: (HasCallStack, MakesValue domain) => domain -> App Response @@ -41,3 +48,45 @@ getConversation user qcnv t = do token <- make t & asString req <- rawBaseRequest user Nginz Versioned (joinHttpPath ["conversations", domain, cnv]) submit "GET" (req & addHeader "Authorization" ("Bearer " <> token)) + +uploadProviderAsset :: (HasCallStack, MakesValue domain) => domain -> String -> String -> App Response +uploadProviderAsset domain cookie payload = do + req <- rawBaseRequest domain Nginz Versioned $ joinHttpPath ["provider", "assets"] + bdy <- txtAsset payload + submit "POST" + $ req + & setCookie cookie + & addBody bdy multipartMixedMime + +txtAsset :: (HasCallStack) => String -> App HTTP.RequestBody +txtAsset payload = + buildUploadAssetRequestBody + True + (Nothing :: Maybe String) + (LBSC.pack payload) + textPlainMime + +textPlainMime :: MIME.MIMEType +textPlainMime = MIME.Text $ T.pack "plain" + +-- This case is a bit special and doesn't fit to MIMEType: We need to define +-- the boundary. +multipartMixedMime :: String +multipartMixedMime = "multipart/mixed; boundary=" <> multipartBoundary + +buildUploadAssetRequestBody :: + (HasCallStack, MakesValue assetRetention) => + Bool -> + assetRetention -> + LBS.ByteString -> + MIME.MIMEType -> + App HTTP.RequestBody +buildUploadAssetRequestBody isPublic retention body mimeType = do + mbRetention <- make retention + let header' :: Aeson.Value + header' = + Aeson.object + [ "public" .= isPublic, + "retention" .= mbRetention + ] + HTTP.RequestBodyLBS <$> buildMultipartBody header' body mimeType diff --git a/integration/test/MLS/Util.hs b/integration/test/MLS/Util.hs index 2a59f980579..e8417123bad 100644 --- a/integration/test/MLS/Util.hs +++ b/integration/test/MLS/Util.hs @@ -122,7 +122,7 @@ mlscli cid args mbstdin = do pure out -runCli :: HasCallStack => FilePath -> [String] -> Maybe ByteString -> App ByteString +runCli :: (HasCallStack) => FilePath -> [String] -> Maybe ByteString -> App ByteString runCli store args mStdin = spawn ( proc @@ -180,7 +180,7 @@ uploadNewKeyPackage cid = do pure ref -generateKeyPackage :: HasCallStack => ClientIdentity -> App (ByteString, String) +generateKeyPackage :: (HasCallStack) => ClientIdentity -> App (ByteString, String) generateKeyPackage cid = do suite <- (.ciphersuite) <$> getMLSState kp <- mlscli cid ["key-package", "create", "--ciphersuite", suite.code] Nothing @@ -575,7 +575,7 @@ consumeMessageWithPredicate p cid mmp ws = do consumeMessage :: (HasCallStack) => ClientIdentity -> Maybe MessagePackage -> WebSocket -> App Value consumeMessage = consumeMessageWithPredicate isNewMLSMessageNotif --- | like 'consumeMessage' but but will not consume a message where the sender is the backend +-- | like 'consumeMessage' but will not consume a message where the sender is the backend consumeMessageNoExternal :: (HasCallStack) => ClientIdentity -> Maybe MessagePackage -> WebSocket -> App Value consumeMessageNoExternal cid = consumeMessageWithPredicate isNewMLSMessageNotifButNoProposal cid where @@ -592,7 +592,7 @@ consumeMessageNoExternal cid = consumeMessageWithPredicate isNewMLSMessageNotifB pure $ sender /= Just backendSender else pure False -mlsCliConsume :: ClientIdentity -> ByteString -> App ByteString +mlsCliConsume :: (HasCallStack) => ClientIdentity -> ByteString -> App ByteString mlsCliConsume cid msgData = mlscli cid @@ -757,7 +757,7 @@ createApplicationMessage cid messageContent = do setMLSCiphersuite :: Ciphersuite -> App () setMLSCiphersuite suite = modifyMLSState $ \mls -> mls {ciphersuite = suite} -withCiphersuite :: HasCallStack => Ciphersuite -> App a -> App a +withCiphersuite :: (HasCallStack) => Ciphersuite -> App a -> App a withCiphersuite suite action = do suite0 <- (.ciphersuite) <$> getMLSState setMLSCiphersuiteIO <- appToIOKleisli setMLSCiphersuite @@ -785,7 +785,7 @@ leaveCurrentConv cid = do { members = Set.difference mls.members (Set.singleton cid) } -getCurrentConv :: HasCallStack => ClientIdentity -> App Value +getCurrentConv :: (HasCallStack) => ClientIdentity -> App Value getCurrentConv cid = do mls <- getMLSState (conv, mSubId) <- objSubConv mls.convId diff --git a/integration/test/Notifications.hs b/integration/test/Notifications.hs index 9186f325f07..13dd5a0fb35 100644 --- a/integration/test/Notifications.hs +++ b/integration/test/Notifications.hs @@ -27,8 +27,8 @@ assertNoNotifications u uc since0 p = do notifs <- getNotifications u def {client = Just ucid, since = since} `bindResponse` asList - . (%. "notifications") - . (.json) + . (%. "notifications") + . (.json) partitionM p notifs >>= \case ([], nonMatching) -> threadDelay 1_000 *> case nonMatching of @@ -36,8 +36,8 @@ assertNoNotifications u uc since0 p = do _ -> go Nothing (matching, _) -> do pj <- prettyJSON matching - assertFailure $ - unlines + assertFailure + $ unlines [ "Expected no matching events but got:", pj ] @@ -96,23 +96,27 @@ awaitNotification user client lastNotifId selector = do since0 <- mapM objId lastNotifId head <$> awaitNotifications user client since0 1 selector -isDeleteUserNotif :: MakesValue a => a -> App Bool +isDeleteUserNotif :: (MakesValue a) => a -> App Bool isDeleteUserNotif n = nPayload n %. "type" `isEqual` "user.delete" -isNewMessageNotif :: MakesValue a => a -> App Bool +isFeatureConfigUpdateNotif :: (MakesValue a) => a -> App Bool +isFeatureConfigUpdateNotif n = + nPayload n %. "type" `isEqual` "feature-config.update" + +isNewMessageNotif :: (MakesValue a) => a -> App Bool isNewMessageNotif n = fieldEquals n "payload.0.type" "conversation.otr-message-add" -isNewMLSMessageNotif :: MakesValue a => a -> App Bool +isNewMLSMessageNotif :: (MakesValue a) => a -> App Bool isNewMLSMessageNotif n = fieldEquals n "payload.0.type" "conversation.mls-message-add" -isWelcomeNotif :: MakesValue a => a -> App Bool +isWelcomeNotif :: (MakesValue a) => a -> App Bool isWelcomeNotif n = fieldEquals n "payload.0.type" "conversation.mls-welcome" -isMemberJoinNotif :: MakesValue a => a -> App Bool +isMemberJoinNotif :: (MakesValue a) => a -> App Bool isMemberJoinNotif n = fieldEquals n "payload.0.type" "conversation.member-join" -isConvLeaveNotif :: MakesValue a => a -> App Bool +isConvLeaveNotif :: (MakesValue a) => a -> App Bool isConvLeaveNotif n = fieldEquals n "payload.0.type" "conversation.member-leave" isConvLeaveNotifWithLeaver :: (MakesValue user, MakesValue a) => user -> a -> App Bool @@ -147,46 +151,46 @@ isConvAccessUpdateNotif :: (HasCallStack, MakesValue n) => n -> App Bool isConvAccessUpdateNotif n = fieldEquals n "payload.0.type" "conversation.access-update" -isConvCreateNotif :: MakesValue a => a -> App Bool +isConvCreateNotif :: (MakesValue a) => a -> App Bool isConvCreateNotif n = fieldEquals n "payload.0.type" "conversation.create" -- | like 'isConvCreateNotif' but excludes self conversations -isConvCreateNotifNotSelf :: MakesValue a => a -> App Bool +isConvCreateNotifNotSelf :: (MakesValue a) => a -> App Bool isConvCreateNotifNotSelf n = fieldEquals n "payload.0.type" "conversation.create" &&~ do not <$> fieldEquals n "payload.0.data.access" ["private"] -isConvDeleteNotif :: MakesValue a => a -> App Bool +isConvDeleteNotif :: (MakesValue a) => a -> App Bool isConvDeleteNotif n = fieldEquals n "payload.0.type" "conversation.delete" -notifTypeIsEqual :: MakesValue a => String -> a -> App Bool +notifTypeIsEqual :: (MakesValue a) => String -> a -> App Bool notifTypeIsEqual typ n = nPayload n %. "type" `isEqual` typ -isTeamMemberLeaveNotif :: MakesValue a => a -> App Bool +isTeamMemberLeaveNotif :: (MakesValue a) => a -> App Bool isTeamMemberLeaveNotif = notifTypeIsEqual "team.member-leave" -isUserActivateNotif :: MakesValue a => a -> App Bool +isUserActivateNotif :: (MakesValue a) => a -> App Bool isUserActivateNotif = notifTypeIsEqual "user.activate" -isUserClientAddNotif :: MakesValue a => a -> App Bool +isUserClientAddNotif :: (MakesValue a) => a -> App Bool isUserClientAddNotif = notifTypeIsEqual "user.client-add" -isUserClientRemoveNotif :: MakesValue a => a -> App Bool +isUserClientRemoveNotif :: (MakesValue a) => a -> App Bool isUserClientRemoveNotif = notifTypeIsEqual "user.client-remove" -isUserLegalholdRequestNotif :: MakesValue a => a -> App Bool +isUserLegalholdRequestNotif :: (MakesValue a) => a -> App Bool isUserLegalholdRequestNotif = notifTypeIsEqual "user.legalhold-request" -isUserLegalholdEnabledNotif :: MakesValue a => a -> App Bool +isUserLegalholdEnabledNotif :: (MakesValue a) => a -> App Bool isUserLegalholdEnabledNotif = notifTypeIsEqual "user.legalhold-enable" -isUserLegalholdDisabledNotif :: MakesValue a => a -> App Bool +isUserLegalholdDisabledNotif :: (MakesValue a) => a -> App Bool isUserLegalholdDisabledNotif = notifTypeIsEqual "user.legalhold-disable" -isUserConnectionNotif :: MakesValue a => a -> App Bool +isUserConnectionNotif :: (MakesValue a) => a -> App Bool isUserConnectionNotif = notifTypeIsEqual "user.connection" -isConnectionNotif :: MakesValue a => String -> a -> App Bool +isConnectionNotif :: (MakesValue a) => String -> a -> App Bool isConnectionNotif status n = -- NB: -- (&&) <$> (print "hello" *> pure False) <*> fail "bla" === _|_ @@ -208,8 +212,8 @@ assertLeaveNotification :: kickedUser -> App () assertLeaveNotification fromUser conv user client leaver = - void $ - awaitNotification + void + $ awaitNotification user client noValue @@ -221,7 +225,7 @@ assertLeaveNotification fromUser conv user client leaver = ] ) -assertConvUserDeletedNotif :: MakesValue leaverId => WebSocket -> leaverId -> App () +assertConvUserDeletedNotif :: (MakesValue leaverId) => WebSocket -> leaverId -> App () assertConvUserDeletedNotif ws leaverId = do n <- awaitMatch isConvLeaveNotif ws nPayload n %. "data.qualified_user_ids.0" `shouldMatch` leaverId diff --git a/integration/test/SetupHelpers.hs b/integration/test/SetupHelpers.hs index 341505a11de..63e4c61b786 100644 --- a/integration/test/SetupHelpers.hs +++ b/integration/test/SetupHelpers.hs @@ -93,8 +93,8 @@ connectTwoUsers :: bob -> App () connectTwoUsers alice bob = do - bindResponse (postConnection alice bob) (\resp -> resp.status `shouldMatchInt` 201) - bindResponse (putConnection bob alice "accepted") (\resp -> resp.status `shouldMatchInt` 200) + postConnection alice bob >>= assertSuccess + putConnection bob alice "accepted" >>= assertSuccess connectUsers :: (HasCallStack, MakesValue usr) => [usr] -> App () connectUsers users = traverse_ (uncurry connectTwoUsers) $ do @@ -103,6 +103,12 @@ connectUsers users = traverse_ (uncurry connectTwoUsers) $ do b <- others pure (a, b) +assertConnection :: (HasCallStack, MakesValue alice, MakesValue bob) => alice -> bob -> String -> App () +assertConnection alice bob status = + getConnection alice bob `bindResponse` \resp -> do + resp.status `shouldMatchInt` 200 + resp.json %. "status" `shouldMatch` status + createAndConnectUsers :: (HasCallStack, MakesValue domain) => [domain] -> App [Value] createAndConnectUsers domains = do users <- for domains (flip randomUser def) @@ -167,7 +173,7 @@ addUserToTeam u = do -- | Create a user on the given domain, such that the 1-1 conversation with -- 'other' resides on 'convDomain'. This connects the two users as a side-effect. -createMLSOne2OnePartner :: MakesValue user => Domain -> user -> Domain -> App Value +createMLSOne2OnePartner :: (MakesValue user) => Domain -> user -> Domain -> App Value createMLSOne2OnePartner domain other convDomain = loop where loop = do @@ -183,22 +189,22 @@ createMLSOne2OnePartner domain other convDomain = loop else loop -- Copied from `src/CargoHold/API/V3.hs` and inlined to avoid pulling in `types-common` -randomToken :: HasCallStack => App String +randomToken :: (HasCallStack) => App String randomToken = unpack . B64Url.encode <$> liftIO (getRandomBytes 16) data TokenLength = GCM | APNS -randomSnsToken :: HasCallStack => TokenLength -> App String +randomSnsToken :: (HasCallStack) => TokenLength -> App String randomSnsToken = \case GCM -> mkTok 16 APNS -> mkTok 32 where mkTok = fmap (Text.unpack . decodeUtf8 . Base16.encode) . randomBytes -randomId :: HasCallStack => App String +randomId :: (HasCallStack) => App String randomId = liftIO (show <$> nextRandom) -randomUUIDv1 :: HasCallStack => App String +randomUUIDv1 :: (HasCallStack) => App String randomUUIDv1 = liftIO (show . fromJust <$> nextUUID) randomUserId :: (HasCallStack, MakesValue domain) => domain -> App Value @@ -207,7 +213,7 @@ randomUserId domain = do uid <- randomId pure $ object ["id" .= uid, "domain" .= d] -withFederatingBackendsAllowDynamic :: HasCallStack => ((String, String, String) -> App a) -> App a +withFederatingBackendsAllowDynamic :: (HasCallStack) => ((String, String, String) -> App a) -> App a withFederatingBackendsAllowDynamic k = do let setFederationConfig = setField "optSettings.setFederationStrategy" "allowDynamic" @@ -222,7 +228,7 @@ withFederatingBackendsAllowDynamic k = do -- | Create two users on different domains such that the one-to-one -- conversation, once finalised, will be hosted on the backend given by the -- input domain. -createOne2OneConversation :: HasCallStack => Domain -> App (Value, Value, Value) +createOne2OneConversation :: (HasCallStack) => Domain -> App (Value, Value, Value) createOne2OneConversation owningDomain = do owningUser <- randomUser owningDomain def domainName <- owningUser %. "qualified_id.domain" @@ -257,7 +263,7 @@ toConvType = \case -- | Fetch the one-to-one conversation between the two users that is in one of -- two possible states. -getOne2OneConversation :: HasCallStack => Value -> Value -> One2OneConvState -> App Value +getOne2OneConversation :: (HasCallStack) => Value -> Value -> One2OneConvState -> App Value getOne2OneConversation user1 user2 cnvState = do l <- getAllConvs user1 let isWith users c = do @@ -282,7 +288,9 @@ setupProvider :: setupProvider u np@(NewProvider {..}) = do dom <- objDomain u provider <- newProvider u np - pass <- provider %. "password" & asString + pass <- case newProviderPassword of + Nothing -> provider %. "password" & asString + Just pass -> pure pass (key, code) <- do pair <- getProviderActivationCodeInternal dom newProviderEmail `bindResponse` \resp -> do @@ -318,14 +326,14 @@ setUpLHDevice tid alice bob lhPort = do approveLegalHoldDevice tid bob defPassword >>= assertStatus 200 -lhDeviceIdOf :: MakesValue user => user -> App String +lhDeviceIdOf :: (MakesValue user) => user -> App String lhDeviceIdOf bob = do bobId <- objId bob getClientsFull bob [bobId] `bindResponse` \resp -> do resp.json %. bobId & asList - >>= filterM \val -> (== "legalhold") <$> (val %. "type" & asString) + >>= filterM \val -> (== "legalhold") <$> (val %. "type" & asString) >>= assertOne >>= (%. "id") >>= asString diff --git a/integration/test/Test/AccessUpdate.hs b/integration/test/Test/AccessUpdate.hs index 1d9ad94ad23..ad2f12a978b 100644 --- a/integration/test/Test/AccessUpdate.hs +++ b/integration/test/Test/AccessUpdate.hs @@ -42,7 +42,7 @@ testBaz = pure () -- The test asserts that, among others, remote users are removed from a -- conversation when an access update occurs that disallows guests from -- accessing. -testAccessUpdateGuestRemoved :: HasCallStack => App () +testAccessUpdateGuestRemoved :: (HasCallStack) => App () testAccessUpdateGuestRemoved = do (alice, tid, [bob]) <- createTeam OwnDomain 2 charlie <- randomUser OwnDomain def @@ -73,7 +73,7 @@ testAccessUpdateGuestRemoved = do res.status `shouldMatchInt` 200 res.json %. "members.others.0.qualified_id" `shouldMatch` objQidObject bob -testAccessUpdateGuestRemovedUnreachableRemotes :: HasCallStack => App () +testAccessUpdateGuestRemovedUnreachableRemotes :: (HasCallStack) => App () testAccessUpdateGuestRemovedUnreachableRemotes = do resourcePool <- asks resourcePool (alice, tid, [bob]) <- createTeam OwnDomain 2 @@ -109,7 +109,7 @@ testAccessUpdateGuestRemovedUnreachableRemotes = do res.status `shouldMatchInt` 200 res.json %. "members.others.0.qualified_id" `shouldMatch` objQidObject bob -testAccessUpdateWithRemotes :: HasCallStack => App () +testAccessUpdateWithRemotes :: (HasCallStack) => App () testAccessUpdateWithRemotes = do [alice, bob, charlie] <- createUsers [OwnDomain, OtherDomain, OwnDomain] connectTwoUsers alice bob diff --git a/integration/test/Test/AssetDownload.hs b/integration/test/Test/AssetDownload.hs index 68b60c85453..97fc9c94ff5 100644 --- a/integration/test/Test/AssetDownload.hs +++ b/integration/test/Test/AssetDownload.hs @@ -5,7 +5,7 @@ import GHC.Stack import SetupHelpers import Testlib.Prelude -testDownloadAsset :: HasCallStack => App () +testDownloadAsset :: (HasCallStack) => App () testDownloadAsset = do user <- randomUser OwnDomain def @@ -19,7 +19,7 @@ testDownloadAsset = do ("Expect 'Hello World!' as text asset content. Got: " ++ show resp.body) (resp.body == fromString "Hello World!") -testDownloadAssetMultiIngressS3DownloadUrl :: HasCallStack => App () +testDownloadAssetMultiIngressS3DownloadUrl :: (HasCallStack) => App () testDownloadAssetMultiIngressS3DownloadUrl = do user <- randomUser OwnDomain def @@ -63,14 +63,14 @@ testDownloadAssetMultiIngressS3DownloadUrl = do modifyConfig = def { cargoholdCfg = - setField "aws.multiIngress" $ - object + setField "aws.multiIngress" + $ object [ "red.example.com" .= "http://s3-download.red.example.com", "green.example.com" .= "http://s3-download.green.example.com" ] } - doUploadAsset :: HasCallStack => Value -> App Value + doUploadAsset :: (HasCallStack) => Value -> App Value doUploadAsset user = bindResponse (uploadAsset user) $ \resp -> do resp.status `shouldMatchInt` 201 resp.json %. "key" diff --git a/integration/test/Test/AssetUpload.hs b/integration/test/Test/AssetUpload.hs index d55eadc83c1..c581fd03b2f 100644 --- a/integration/test/Test/AssetUpload.hs +++ b/integration/test/Test/AssetUpload.hs @@ -5,19 +5,19 @@ import API.Cargohold import SetupHelpers import Testlib.Prelude -testAssetUploadUnverifiedUser :: HasCallStack => App () +testAssetUploadUnverifiedUser :: (HasCallStack) => App () testAssetUploadUnverifiedUser = do user <- randomUser OwnDomain $ def {activate = False} bindResponse (uploadAsset user) $ \resp -> do resp.status `shouldMatchInt` 403 -testAssetUploadVerifiedUser :: HasCallStack => App () +testAssetUploadVerifiedUser :: (HasCallStack) => App () testAssetUploadVerifiedUser = do user <- randomUser OwnDomain def bindResponse (uploadAsset user) $ \resp -> do resp.status `shouldMatchInt` 201 -testAssetUploadUnknownUser :: HasCallStack => App () +testAssetUploadUnknownUser :: (HasCallStack) => App () testAssetUploadUnknownUser = do uid <- randomId domain <- make OwnDomain diff --git a/integration/test/Test/Bot.hs b/integration/test/Test/Bot.hs new file mode 100644 index 00000000000..b635b9e0acd --- /dev/null +++ b/integration/test/Test/Bot.hs @@ -0,0 +1,152 @@ +module Test.Bot where + +import API.Brig +import API.Common +import API.Galley +import Control.Lens hiding ((.=)) +import qualified Data.Aeson as Aeson +import qualified Data.ProtoLens as Proto +import Data.String.Conversions (cs) +import Network.HTTP.Types (status200, status201) +import Network.Wai (responseLBS) +import qualified Network.Wai as Wai +import qualified Network.Wai.Route as Wai +import Numeric.Lens (hex) +import qualified Proto.Otr as Proto +import qualified Proto.Otr_Fields as Proto +import SetupHelpers +import Testlib.Certs +import Testlib.MockIntegrationService +import Testlib.Prelude +import UnliftIO + +{- FUTUREWORK(mangoiv): + - + - In general the situation is as follows: we only support self-signed certificates, and there's no + - way of testing we support anything but self-signed certs due to the simple reason of not being able + - to obtain a valid certificate for testing reasons without modifying brig to accept some root cert + - generated by us. + - + - These tests exist to document this behaviour. If, in the future, some situation would arise that + - makes us add the certificate validation for PKI, there are already helpers in place in the 'Testlib.Certs' + - module. + - + - In more long form: + - + - The issue is as follows: + - + - certificate validation should work only for self-signed certs, this is checked by the signature + - verification function; so this test fails if there's any unknown entity (CA) involved who + - signed the cert. (a cert can only have one signatory, a CA or self) + - + - this test succeeds if the signature verification fails (because it's not self signed), however, + - even if Brig starts to do signature verification, the test would still succeed, because brig + - doesn't know (or trust) the CA, anyway, even if it does signature verification. + - + - For this test to make sense, we would have to make sure that the brig we're testing against + - *would* trust the CA, *if* it did verification, because only in that case it would now succeed + - with verification and not return a "PinInvalidCert" error. + - + - -} +testBotUnknownSignatory :: App () +testBotUnknownSignatory = do + (_, rootPrivKey) <- mkKeyPair primesA + (ownerPubKey, privateKeyToString -> ownerPrivKey) <- mkKeyPair primesB + let rootSignedLeaf = signedCertToString $ intermediateCert "Kabel" ownerPubKey "Example-Root" rootPrivKey + settings = MkMockServerSettings rootSignedLeaf ownerPrivKey (publicKeyToString ownerPubKey) + withBotWithSettings settings \resp' -> withResponse resp' \resp -> do + resp.status `shouldMatchInt` 502 + resp.json %. "label" `shouldMatch` "bad-gateway" + resp.json %. "message" `shouldMatch` "The upstream service returned an invalid response: PinInvalidCert" + +testBotSelfSigned :: App () +testBotSelfSigned = do + keys@(publicKeyToString -> pub, privateKeyToString -> priv) <- mkKeyPair primesA + let cert = signedCertToString $ selfSignedCert "Kabel" keys + withBotWithSettings MkMockServerSettings {certificate = cert, privateKey = priv, publicKey = pub} \resp' -> do + resp <- withResponse resp' \resp -> do + resp.status `shouldMatchInt` 201 + pure resp + + -- If self signed, we should be able to exchange messages + -- with the bot conversation. + botClient <- resp.json %. "client" + botId <- resp.json %. "id" + aliceQid <- resp.json %. "event.qualified_from" + conv <- resp.json %. "event.qualified_conversation" + + aliceC <- getJSON 201 =<< addClient aliceQid def + aliceCid <- objId aliceC + + msg <- + mkProteusRecipients + aliceQid + [(botId, [botClient])] + "hi bot" + let aliceBotMessage = + Proto.defMessage @Proto.QualifiedNewOtrMessage + & #sender . Proto.client .~ (aliceCid ^?! hex) + & #recipients .~ [msg] + & #reportAll .~ Proto.defMessage + assertStatus 201 + =<< postProteusMessage aliceQid conv aliceBotMessage + +withBotWithSettings :: + MockServerSettings -> + (Response -> App ()) -> + App () +withBotWithSettings settings k = do + alice <- randomUser OwnDomain def + + withMockServer settings mkBotService \(host, port) _chan -> do + email <- randomEmail + provider <- setupProvider alice def {newProviderEmail = email, newProviderPassword = Just defPassword} + providerId <- provider %. "id" & asString + service <- + newService OwnDomain providerId + $ def {newServiceUrl = "https://" <> host <> ":" <> show port, newServiceKey = cs settings.publicKey} + serviceId <- asString $ service %. "id" + conv <- getJSON 201 =<< postConversation alice defProteus + convId <- conv %. "id" & asString + assertStatus 200 =<< updateServiceConn providerId serviceId do + object ["enabled" .= True, "password" .= defPassword] + addBot alice providerId serviceId convId >>= k + +data BotEvent + = BotCreated + | BotMessage String + deriving stock (Eq, Ord, Show) + +mkBotService :: Chan BotEvent -> LiftedApplication +mkBotService chan = + Wai.route + [ (cs "/bots", onBotCreate chan), + (cs "/bots/:bot/messages", onBotMessage chan), + (cs "/alive", onBotAlive chan) + ] + +onBotCreate, + onBotMessage, + onBotAlive :: + Chan BotEvent -> + [(ByteString, ByteString)] -> + Wai.Request -> + (Wai.Response -> App Wai.ResponseReceived) -> + App Wai.ResponseReceived +onBotCreate chan _headers _req k = do + ((: []) -> pks) <- getPrekey + writeChan chan BotCreated + lpk <- getLastPrekey + k $ responseLBS status201 mempty do + Aeson.encode + $ object + [ "prekeys" .= pks, + "last_prekey" .= lpk + ] +onBotMessage chan _headers req k = do + body <- liftIO $ Wai.strictRequestBody req + writeChan chan (BotMessage (cs body)) + liftIO $ putStrLn $ cs body + k (responseLBS status200 mempty mempty) +onBotAlive _chan _headers _req k = do + k (responseLBS status200 mempty (cs "success")) diff --git a/integration/test/Test/Brig.hs b/integration/test/Test/Brig.hs index 0feb154388e..4839e36b286 100644 --- a/integration/test/Test/Brig.hs +++ b/integration/test/Test/Brig.hs @@ -15,17 +15,17 @@ import Testlib.Assertions import Testlib.Prelude import UnliftIO.Temporary -testCrudFederationRemotes :: HasCallStack => App () +testCrudFederationRemotes :: (HasCallStack) => App () testCrudFederationRemotes = do otherDomain <- asString OtherDomain withModifiedBackend def $ \ownDomain -> do - let parseFedConns :: HasCallStack => Response -> App [Value] + let parseFedConns :: (HasCallStack) => Response -> App [Value] parseFedConns resp = -- Pick out the list of federation domain configs getJSON 200 resp %. "remotes" & asList - -- Enforce that the values are objects and not something else - >>= traverse (fmap Object . asObject) + -- Enforce that the values are objects and not something else + >>= traverse (fmap Object . asObject) addTest :: (MakesValue fedConn, Ord fedConn2, ToJSON fedConn2, MakesValue fedConn2, HasCallStack) => fedConn -> [fedConn2] -> App () addTest fedConn want = do @@ -61,7 +61,7 @@ testCrudFederationRemotes = do -- update updateTest (BrigI.domain remote1) remote1' [cfgRemotesExpect, remote1'] -testCrudOAuthClient :: HasCallStack => App () +testCrudOAuthClient :: (HasCallStack) => App () testCrudOAuthClient = do user <- randomUser OwnDomain def let appName = "foobar" @@ -84,7 +84,7 @@ testCrudOAuthClient = do bindResponse (BrigI.getOAuthClient user clientId) $ \resp -> do resp.status `shouldMatchInt` 404 -testCrudFederationRemoteTeams :: HasCallStack => App () +testCrudFederationRemoteTeams :: (HasCallStack) => App () testCrudFederationRemoteTeams = do (_, tid, _) <- createTeam OwnDomain 1 (_, tid2, _) <- createTeam OwnDomain 1 @@ -129,7 +129,7 @@ testCrudFederationRemoteTeams = do remoteTeams <- forM l (\e -> e %. "team_id" & asString) when (any (\t -> t `notElem` remoteTeams) tids) $ assertFailure "Expected response to contain all of the teams" -testSFTCredentials :: HasCallStack => App () +testSFTCredentials :: (HasCallStack) => App () testSFTCredentials = do let ttl = (60 :: Int) withSystemTempFile "sft-secret" $ \secretFile secretHandle -> do @@ -164,7 +164,7 @@ testSFTCredentials = do when (take 2 (parts !! 4) /= "r=") $ assertFailure "missing random data identifier" for_ parts $ \part -> when (length part < 3) $ assertFailure ("value missing for " <> part) -testSFTNoCredentials :: HasCallStack => App () +testSFTNoCredentials :: (HasCallStack) => App () testSFTNoCredentials = withModifiedBackend ( def { brigCfg = @@ -184,7 +184,7 @@ testSFTNoCredentials = withModifiedBackend usrM <- lookupField s "username" when (isJust usrM) $ assertFailure "should not generate username" -testSFTFederation :: HasCallStack => App () +testSFTFederation :: (HasCallStack) => App () testSFTFederation = do withModifiedBackend ( def diff --git a/integration/test/Test/Cargohold/API.hs b/integration/test/Test/Cargohold/API.hs index 25f3c4956d9..c6984bf57ee 100644 --- a/integration/test/Test/Cargohold/API.hs +++ b/integration/test/Test/Cargohold/API.hs @@ -42,14 +42,14 @@ import UnliftIO.Concurrent -------------------------------------------------------------------------------- -- Simple (single-step) uploads -testSimpleRoundtrip :: HasCallStack => App () +testSimpleRoundtrip :: (HasCallStack) => App () testSimpleRoundtrip = do let def' = ["public" .= False] rets = ["eternal", "persistent", "volatile", "eternal-infrequent_access", "expiring"] sets' = fmap object $ def' : fmap (\r -> "retention" .= r : def') rets mapM_ simpleRoundtrip sets' where - simpleRoundtrip :: HasCallStack => Value -> App () + simpleRoundtrip :: (HasCallStack) => Value -> App () simpleRoundtrip sets = do uid <- randomUser OwnDomain def userId1 <- uid %. "id" & asString @@ -75,8 +75,8 @@ testSimpleRoundtrip = do Just r -> do r' <- asString r -- These retention policies never expire, so an expiration date isn't sent back - unless (r' == "eternal" || r' == "persistent" || r' == "eternal-infrequent_access") $ - assertBool "invalid expiration" (Just utc < expires') + unless (r' == "eternal" || r' == "persistent" || r' == "eternal-infrequent_access") + $ assertBool "invalid expiration" (Just utc < expires') _ -> pure () -- Lookup with token and download via redirect. r2 <- downloadAsset' uid loc tok @@ -98,7 +98,7 @@ testSimpleRoundtrip = do utc' = parseTimeOrError False defaultTimeLocale rfc822DateFormat date' :: UTCTime assertBool "bad date" (utc' >= utc) -testDownloadWithAcceptHeader :: HasCallStack => App () +testDownloadWithAcceptHeader :: (HasCallStack) => App () testDownloadWithAcceptHeader = do assetId <- randomId uid <- randomUser OwnDomain def @@ -117,7 +117,7 @@ queryItem k v r = get' :: HTTP.Request -> (HTTP.Request -> HTTP.Request) -> App Response get' r f = submit "GET" $ f r -testSimpleTokens :: HasCallStack => App () +testSimpleTokens :: (HasCallStack) => App () testSimpleTokens = do uid <- randomUser OwnDomain def uid2 <- randomUser OwnDomain def @@ -134,7 +134,8 @@ testSimpleTokens = do (key, tok) <- (,) <$> asString (r1.json %. "key") - <*> r1.json %. "token" + <*> r1.json + %. "token" -- No access without token from other user (opaque 404) downloadAsset' uid2 loc () >>= \r -> r.status `shouldMatchInt` 404 -- No access with empty token query parameter from other user (opaque 404) @@ -199,7 +200,7 @@ defAssetSettings = object defAssetSettings' -- S3 closes idle connections after ~5 seconds, before the http-client 'Manager' -- does. If such a closed connection is reused for an upload, no problems should -- occur (i.e. the closed connection should be detected before sending any data). -testSimpleS3ClosedConnectionReuse :: HasCallStack => App () +testSimpleS3ClosedConnectionReuse :: (HasCallStack) => App () testSimpleS3ClosedConnectionReuse = go >> wait >> go where wait = liftIO $ putStrLn "Waiting for S3 idle timeout ..." >> threadDelay 7000000 @@ -209,7 +210,7 @@ testSimpleS3ClosedConnectionReuse = go >> wait >> go let part2 = (MIME.Text $ cs "plain", cs $ replicate 100000 'c') uploadSimple uid sets part2 >>= \r -> r.status `shouldMatchInt` 201 -testDownloadURLOverride :: HasCallStack => App () +testDownloadURLOverride :: (HasCallStack) => App () testDownloadURLOverride = do -- This is a .example domain, it shouldn't resolve. But it is also not -- supposed to be used by cargohold to make connections. @@ -227,7 +228,8 @@ testDownloadURLOverride = do let loc = decodeHeaderOrFail (mk $ cs "Location") uploadRes :: String (_key, tok, _expires) <- (,,) - <$> uploadRes.json %. "key" + <$> uploadRes.json + %. "key" <*> (uploadRes.json %. "token" & asString) <*> lookupField uploadRes.json "expires" -- Lookup with token and get download URL. Should return the @@ -249,7 +251,7 @@ testDownloadURLOverride = do -- -- The body is taken directly from a request made by the web app -- (just replaced the content with a shorter one and updated the MD5 header). -testUploadCompatibility :: HasCallStack => App () +testUploadCompatibility :: (HasCallStack) => App () testUploadCompatibility = do uid <- randomUser OwnDomain def -- Initial upload @@ -287,7 +289,7 @@ testUploadCompatibility = do -------------------------------------------------------------------------------- -- Federation behaviour -testRemoteDownloadWrongDomain :: HasCallStack => App () +testRemoteDownloadWrongDomain :: (HasCallStack) => App () testRemoteDownloadWrongDomain = do assetId <- randomId uid <- randomUser OwnDomain def @@ -300,7 +302,7 @@ testRemoteDownloadWrongDomain = do res <- downloadAsset' uid qkey () res.status `shouldMatchInt` 422 -testRemoteDownloadNoAsset :: HasCallStack => App () +testRemoteDownloadNoAsset :: (HasCallStack) => App () testRemoteDownloadNoAsset = do assetId <- randomId uid <- randomUser OwnDomain def @@ -314,10 +316,10 @@ testRemoteDownloadNoAsset = do res <- downloadAsset' uid qkey () res.status `shouldMatchInt` 404 -testRemoteDownloadShort :: HasCallStack => App () +testRemoteDownloadShort :: (HasCallStack) => App () testRemoteDownloadShort = remoteDownload "asset content" -testRemoteDownloadLong :: HasCallStack => App () +testRemoteDownloadLong :: (HasCallStack) => App () testRemoteDownloadLong = remoteDownload $ concat $ replicate 20000 $ "hello world\n" remoteDownload :: (HasCallStack, ConvertibleStrings a L8.ByteString, ConvertibleStrings a String) => a -> App () diff --git a/integration/test/Test/Cargohold/API/Federation.hs b/integration/test/Test/Cargohold/API/Federation.hs index 2b0a1da8266..8cb6f4ac26f 100644 --- a/integration/test/Test/Cargohold/API/Federation.hs +++ b/integration/test/Test/Cargohold/API/Federation.hs @@ -27,13 +27,13 @@ import SetupHelpers import Test.Cargohold.API.Util import Testlib.Prelude -testGetAssetAvailablePublic :: HasCallStack => App () +testGetAssetAvailablePublic :: (HasCallStack) => App () testGetAssetAvailablePublic = getAssetAvailable True -testGetAssetAvailablePrivate :: HasCallStack => App () +testGetAssetAvailablePrivate :: (HasCallStack) => App () testGetAssetAvailablePrivate = getAssetAvailable False -getAssetAvailable :: HasCallStack => Bool -> App () +getAssetAvailable :: (HasCallStack) => Bool -> App () getAssetAvailable isPublicAsset = do -- Initial upload let bdy = (applicationOctetStream, cs "Hello World") @@ -53,7 +53,7 @@ getAssetAvailable isPublicAsset = do res <- downloadAsset' uid2 r1.jsonBody tok res.status `shouldMatchInt` 200 -testGetAssetNotAvailable :: HasCallStack => App () +testGetAssetNotAvailable :: (HasCallStack) => App () testGetAssetNotAvailable = do uid <- randomUser OwnDomain def userId <- uid %. "id" & asString @@ -68,7 +68,7 @@ testGetAssetNotAvailable = do r.status `shouldMatchInt` 404 r.jsonBody %. "message" `shouldMatch` "Asset not found" -testGetAssetWrongToken :: HasCallStack => App () +testGetAssetWrongToken :: (HasCallStack) => App () testGetAssetWrongToken = do -- Initial upload let bdy = (applicationOctetStream, cs "Hello World") @@ -95,7 +95,7 @@ testGetAssetWrongToken = do r2.status `shouldMatchInt` 404 r2.jsonBody %. "message" `shouldMatch` "Asset not found" -testLargeAsset :: HasCallStack => App () +testLargeAsset :: (HasCallStack) => App () testLargeAsset = do -- Initial upload let settings = object ["public" .= False, "retention" .= "volatile"] @@ -122,7 +122,7 @@ testLargeAsset = do r2 <- downloadAsset' uid2 ga ga r2.status `shouldMatchInt` 200 -testStreamAsset :: HasCallStack => App () +testStreamAsset :: (HasCallStack) => App () testStreamAsset = do -- Initial upload uid <- randomUser OwnDomain def @@ -140,11 +140,11 @@ testStreamAsset = do r2.status `shouldMatchInt` 200 cs @_ @String r2.body `shouldMatch` (snd bdy :: String) where - bdy :: ConvertibleStrings String a => (MIME.MIMEType, a) + bdy :: (ConvertibleStrings String a) => (MIME.MIMEType, a) bdy = (applicationOctetStream, cs "Hello World") settings = object ["public" .= False, "retention" .= "volatile"] -testStreamAssetNotAvailable :: HasCallStack => App () +testStreamAssetNotAvailable :: (HasCallStack) => App () testStreamAssetNotAvailable = do uid <- randomUser OwnDomain def uid2 <- randomUser OtherDomain def @@ -158,7 +158,7 @@ testStreamAssetNotAvailable = do r.status `shouldMatchInt` 404 r.jsonBody %. "message" `shouldMatch` "Asset not found" -testStreamAssetWrongToken :: HasCallStack => App () +testStreamAssetWrongToken :: (HasCallStack) => App () testStreamAssetWrongToken = do -- Initial upload uid <- randomUser OwnDomain def @@ -176,6 +176,6 @@ testStreamAssetWrongToken = do r2.status `shouldMatchInt` 404 r2.jsonBody %. "message" `shouldMatch` "Asset not found" where - bdy :: ConvertibleStrings String a => (MIME.MIMEType, a) + bdy :: (ConvertibleStrings String a) => (MIME.MIMEType, a) bdy = (applicationOctetStream, cs "Hello World") settings = object ["public" .= False, "retention" .= "volatile"] diff --git a/integration/test/Test/Cargohold/API/Util.hs b/integration/test/Test/Cargohold/API/Util.hs index 16564ea6930..8ffb512da7b 100644 --- a/integration/test/Test/Cargohold/API/Util.hs +++ b/integration/test/Test/Cargohold/API/Util.hs @@ -143,10 +143,10 @@ downloadAssetWithQualifiedAssetKey r user key tok = do dom <- key %. "domain" & asString keyId <- key %. "id" & asString req <- baseRequest user Cargohold (ExplicitVersion 2) $ "assets/" <> dom <> "/" <> keyId - submit "GET" $ - req - & tokenParam tok - & r + submit "GET" + $ req + & tokenParam tok + & r postToken :: (MakesValue user, HasCallStack) => user -> String -> App Response postToken user key = do diff --git a/integration/test/Test/Cargohold/API/V3.hs b/integration/test/Test/Cargohold/API/V3.hs index 04e8797daea..55bc4933f00 100644 --- a/integration/test/Test/Cargohold/API/V3.hs +++ b/integration/test/Test/Cargohold/API/V3.hs @@ -37,14 +37,14 @@ import Testlib.Prelude -------------------------------------------------------------------------------- -- Simple (single-step) uploads -testSimpleRoundtrip :: HasCallStack => App () +testSimpleRoundtrip :: (HasCallStack) => App () testSimpleRoundtrip = do let defSettings = ["public" .= False] rets = ["eternal", "persistent", "volatile", "eternal-infrequent_access", "expiring"] allSets = fmap object $ (defSettings :) $ (\r -> ["retention" .= r]) <$> rets mapM_ simpleRoundtrip allSets where - simpleRoundtrip :: HasCallStack => Value -> App () + simpleRoundtrip :: (HasCallStack) => Value -> App () simpleRoundtrip sets = do uid <- randomUser OwnDomain def uid2 <- randomUser OwnDomain def @@ -55,7 +55,8 @@ testSimpleRoundtrip = do -- use v3 path instead of the one returned in the header (key, tok, expires) <- (,,) - <$> r1.json %. "key" + <$> r1.json + %. "key" <*> (r1.json %. "token" >>= asString) <*> (lookupField r1.json "expires" >>= maybe (pure Nothing) (fmap pure . asString)) -- Check mandatory Date header @@ -74,8 +75,8 @@ testSimpleRoundtrip = do Just r -> do r' <- asString r -- These retention policies never expire, so an expiration date isn't sent back - unless (r' == "eternal" || r' == "persistent" || r' == "eternal-infrequent_access") $ - assertBool "invalid expiration" (Just utc < expires') + unless (r' == "eternal" || r' == "persistent" || r' == "eternal-infrequent_access") + $ assertBool "invalid expiration" (Just utc < expires') _ -> pure () -- Lookup with token and download via redirect. r2 <- downloadAsset' uid r1.jsonBody tok @@ -86,8 +87,9 @@ testSimpleRoundtrip = do req <- liftIO $ parseRequest locReq r3 <- submit "GET" req r3.status `shouldMatchInt` 200 - assertBool "content-type should always be application/octet-stream" $ - getHeader (mk $ cs "content-type") r3 == Just (encodeUtf8 $ showMIMEType applicationOctetStream) + assertBool "content-type should always be application/octet-stream" + $ getHeader (mk $ cs "content-type") r3 + == Just (encodeUtf8 $ showMIMEType applicationOctetStream) assertBool "Token mismatch" $ getHeader (mk $ cs "x-amz-meta-token") r3 == pure (cs tok) uid' <- uid %. "id" >>= asString assertBool "User mismatch" $ getHeader (mk $ cs "x-amz-meta-user") r3 == pure (cs uid') diff --git a/integration/test/Test/Cargohold/Metrics.hs b/integration/test/Test/Cargohold/Metrics.hs index c88d6cff920..aec91ee8c17 100644 --- a/integration/test/Test/Cargohold/Metrics.hs +++ b/integration/test/Test/Cargohold/Metrics.hs @@ -20,7 +20,7 @@ module Test.Cargohold.Metrics where import Data.String.Conversions import Testlib.Prelude -testPrometheusMetrics :: HasCallStack => App () +testPrometheusMetrics :: (HasCallStack) => App () testPrometheusMetrics = do req <- baseRequest OwnDomain Cargohold Unversioned "i/metrics" resp <- submit "GET" req diff --git a/integration/test/Test/Client.hs b/integration/test/Test/Client.hs index b512c08d08c..d00e8174710 100644 --- a/integration/test/Test/Client.hs +++ b/integration/test/Test/Client.hs @@ -17,7 +17,7 @@ import SetupHelpers import Testlib.Prelude import Testlib.ResourcePool -testClientLastActive :: HasCallStack => App () +testClientLastActive :: (HasCallStack) => App () testClientLastActive = do alice <- randomUser OwnDomain def c0 <- addClient alice def >>= getJSON 201 @@ -41,7 +41,7 @@ testClientLastActive = do <$> parseTimeM False defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" tm1 assertBool "last_active is earlier than expected" $ ts1 >= now -testListClientsIfBackendIsOffline :: HasCallStack => App () +testListClientsIfBackendIsOffline :: (HasCallStack) => App () testListClientsIfBackendIsOffline = do resourcePool <- asks (.resourcePool) ownDomain <- asString OwnDomain diff --git a/integration/test/Test/Connection.hs b/integration/test/Test/Connection.hs index f982df677d4..d12feb41f01 100644 --- a/integration/test/Test/Connection.hs +++ b/integration/test/Test/Connection.hs @@ -24,7 +24,7 @@ import SetupHelpers import Testlib.Prelude import UnliftIO.Async (forConcurrently_) -testConnectWithRemoteUser :: HasCallStack => Domain -> App () +testConnectWithRemoteUser :: (HasCallStack) => Domain -> App () testConnectWithRemoteUser owningDomain = do (alice, bob, one2oneId) <- createOne2OneConversation owningDomain aliceId <- alice %. "qualified_id" @@ -40,7 +40,7 @@ testConnectWithRemoteUser owningDomain = do qIds <- for others (%. "qualified_id") qIds `shouldMatchSet` [aliceId] -testRemoteUserGetsDeleted :: HasCallStack => App () +testRemoteUserGetsDeleted :: (HasCallStack) => App () testRemoteUserGetsDeleted = do alice <- randomUser OwnDomain def @@ -94,7 +94,7 @@ testRemoteUserGetsDeleted = do getConnection alice charlie `waitForResponse` \resp -> resp.status `shouldMatchInt` 404 -testInternalGetConStatusesAll :: HasCallStack => App () +testInternalGetConStatusesAll :: (HasCallStack) => App () testInternalGetConStatusesAll = startDynamicBackends [mempty] \[dynBackend] -> do let mkFiveUsers dom = replicateM 5 do @@ -149,7 +149,7 @@ assertConnectionStatus userFrom userTo connStatus = resp.status `shouldMatchInt` 200 resp.json %. "status" `shouldMatch` connStatus -testConnectFromIgnored :: HasCallStack => App () +testConnectFromIgnored :: (HasCallStack) => App () testConnectFromIgnored = do [alice, bob] <- forM [OwnDomain, OtherDomain] $ flip randomUser def void $ postConnection bob alice >>= getBody 201 @@ -168,7 +168,7 @@ testConnectFromIgnored = do resp.status `shouldMatchInt` 200 resp.json %. "status" `shouldMatch` "accepted" -testSentFromIgnored :: HasCallStack => App () +testSentFromIgnored :: (HasCallStack) => App () testSentFromIgnored = do [alice, bob] <- forM [OwnDomain, OtherDomain] $ flip randomUser def -- set up an initial "ignored" state @@ -185,7 +185,7 @@ testSentFromIgnored = do void $ putConnection alice bob "accepted" >>= getBody 200 assertConnectionStatus alice bob "sent" -testConnectFromBlocked :: HasCallStack => App () +testConnectFromBlocked :: (HasCallStack) => App () testConnectFromBlocked = do (alice, bob, one2oneId) <- createOne2OneConversation OwnDomain bobId <- bob %. "qualified_id" @@ -211,7 +211,7 @@ testConnectFromBlocked = do qIds <- for others (%. "qualified_id") qIds `shouldMatchSet` [bobId] -testSentFromBlocked :: HasCallStack => App () +testSentFromBlocked :: (HasCallStack) => App () testSentFromBlocked = do [alice, bob] <- forM [OwnDomain, OtherDomain] $ flip randomUser def -- set up an initial "blocked" state @@ -228,7 +228,7 @@ testSentFromBlocked = do void $ putConnection alice bob "accepted" >>= getBody 200 assertConnectionStatus alice bob "sent" -testCancel :: HasCallStack => App () +testCancel :: (HasCallStack) => App () testCancel = do [alice, bob] <- forM [OwnDomain, OtherDomain] $ flip randomUser def @@ -238,7 +238,7 @@ testCancel = do void $ putConnection alice bob "cancelled" >>= getBody 200 assertConnectionStatus alice bob "cancelled" -testConnectionLimits :: HasCallStack => App () +testConnectionLimits :: (HasCallStack) => App () testConnectionLimits = do let connectionLimit = 16 @@ -308,7 +308,7 @@ testConnectionLimits = do postConnection alice charlie4 `bindResponse` \resp -> resp.status `shouldMatchInt` 201 -testNonFederatingRemoteTeam :: HasCallStack => App () +testNonFederatingRemoteTeam :: (HasCallStack) => App () testNonFederatingRemoteTeam = withFederatingBackendsAllowDynamic $ \(domainA, domainB, _) -> do sequence_ @@ -324,7 +324,7 @@ testNonFederatingRemoteTeam = where defSearchPolicy = "full_search" -testNonMutualFederationConnectionAttempt :: HasCallStack => App () +testNonMutualFederationConnectionAttempt :: (HasCallStack) => App () testNonMutualFederationConnectionAttempt = withFederatingBackendsAllowDynamic $ \(domainA, domainB, _) -> do sequence_ @@ -348,7 +348,7 @@ testNonMutualFederationConnectionAttempt = where defSearchPolicy = "full_search" -testFederationAllowAllConnectWithRemote :: HasCallStack => App () +testFederationAllowAllConnectWithRemote :: (HasCallStack) => App () testFederationAllowAllConnectWithRemote = withFederatingBackendsAllowDynamic $ \(domainA, domainB, _) -> do sequence_ @@ -359,7 +359,7 @@ testFederationAllowAllConnectWithRemote = where defSearchPolicy = "full_search" -testFederationAllowDynamicConnectWithRemote :: HasCallStack => App () +testFederationAllowDynamicConnectWithRemote :: (HasCallStack) => App () testFederationAllowDynamicConnectWithRemote = withFederatingBackendsAllowDynamic $ \(domainA, domainB, _) -> do sequence_ @@ -383,7 +383,7 @@ testFederationAllowDynamicConnectWithRemote = where defSearchPolicy = "full_search" -testFederationAllowMixedConnectWithRemote :: HasCallStack => App () +testFederationAllowMixedConnectWithRemote :: (HasCallStack) => App () testFederationAllowMixedConnectWithRemote = withFederatingBackendsAllowDynamic $ \(domainA, domainB, _) -> do sequence_ @@ -403,7 +403,7 @@ testFederationAllowMixedConnectWithRemote = where defSearchPolicy = "full_search" -testPendingConnectionUserDeleted :: HasCallStack => Domain -> App () +testPendingConnectionUserDeleted :: (HasCallStack) => Domain -> App () testPendingConnectionUserDeleted bobsDomain = do alice <- randomUser OwnDomain def bob <- randomUser bobsDomain def diff --git a/integration/test/Test/Conversation.hs b/integration/test/Test/Conversation.hs index 81a15c7e16f..f44eb9eea2f 100644 --- a/integration/test/Test/Conversation.hs +++ b/integration/test/Test/Conversation.hs @@ -36,7 +36,7 @@ import Testlib.One2One (generateRemoteAndConvIdWithDomain) import Testlib.Prelude import Testlib.ResourcePool -testDynamicBackendsFullyConnectedWhenAllowAll :: HasCallStack => App () +testDynamicBackendsFullyConnectedWhenAllowAll :: (HasCallStack) => App () testDynamicBackendsFullyConnectedWhenAllowAll = do -- The default setting is 'allowAll' startDynamicBackends [def, def, def] $ \dynDomains -> do @@ -56,7 +56,7 @@ testDynamicBackendsFullyConnectedWhenAllowAll = do resp.status `shouldMatchInt` 200 resp.json %. "status" `shouldMatch` "fully-connected" -testDynamicBackendsNotFederating :: HasCallStack => App () +testDynamicBackendsNotFederating :: (HasCallStack) => App () testDynamicBackendsNotFederating = do let overrides = def @@ -72,7 +72,7 @@ testDynamicBackendsNotFederating = do resp.status `shouldMatchInt` 533 resp.json %. "unreachable_backends" `shouldMatchSet` [domainB, domainC] -testDynamicBackendsFullyConnectedWhenAllowDynamic :: HasCallStack => App () +testDynamicBackendsFullyConnectedWhenAllowDynamic :: (HasCallStack) => App () testDynamicBackendsFullyConnectedWhenAllowDynamic = do withFederatingBackendsAllowDynamic $ \(domainA, domainB, domainC) -> do -- Allowing 'full_search' or any type of search is how we enable federation @@ -96,7 +96,7 @@ testDynamicBackendsFullyConnectedWhenAllowDynamic = do retryT $ assertConnected uidB domainA domainC retryT $ assertConnected uidC domainA domainB -testDynamicBackendsNotFullyConnected :: HasCallStack => App () +testDynamicBackendsNotFullyConnected :: (HasCallStack) => App () testDynamicBackendsNotFullyConnected = do withFederatingBackendsAllowDynamic $ \(domainA, domainB, domainC) -> do -- A is connected to B and C, but B and C are not connected to each other @@ -113,7 +113,7 @@ testDynamicBackendsNotFullyConnected = do resp.json %. "status" `shouldMatch` "non-fully-connected" resp.json %. "not_connected" `shouldMatchSet` [domainB, domainC] -testFederationStatus :: HasCallStack => App () +testFederationStatus :: (HasCallStack) => App () testFederationStatus = do uid <- randomUser OwnDomain def {BrigI.team = True} federatingRemoteDomain <- asString OtherDomain @@ -136,7 +136,7 @@ testFederationStatus = do resp.status `shouldMatchInt` 200 resp.json %. "status" `shouldMatch` "fully-connected" -testCreateConversationFullyConnected :: HasCallStack => App () +testCreateConversationFullyConnected :: (HasCallStack) => App () testCreateConversationFullyConnected = do startDynamicBackends [def, def, def] $ \[domainA, domainB, domainC] -> do [u1, u2, u3] <- createUsers [domainA, domainB, domainC] @@ -145,7 +145,7 @@ testCreateConversationFullyConnected = do bindResponse (postConversation u1 (defProteus {qualifiedUsers = [u2, u3]})) $ \resp -> do resp.status `shouldMatchInt` 201 -testCreateConversationNonFullyConnected :: HasCallStack => App () +testCreateConversationNonFullyConnected :: (HasCallStack) => App () testCreateConversationNonFullyConnected = do withFederatingBackendsAllowDynamic $ \(domainA, domainB, domainC) -> do -- A is connected to B and C, but B and C are not connected to each other @@ -165,7 +165,7 @@ testCreateConversationNonFullyConnected = do resp.status `shouldMatchInt` 409 resp.json %. "non_federating_backends" `shouldMatchSet` [domainB, domainC] -testAddMembersFullyConnectedProteus :: HasCallStack => App () +testAddMembersFullyConnectedProteus :: (HasCallStack) => App () testAddMembersFullyConnectedProteus = do startDynamicBackends [def, def, def] $ \[domainA, domainB, domainC] -> do [u1, u2, u3] <- createUsers [domainA, domainB, domainC] @@ -181,7 +181,7 @@ testAddMembersFullyConnectedProteus = do addedUsers <- forM users (%. "qualified_id") addedUsers `shouldMatchSet` members -testAddMembersNonFullyConnectedProteus :: HasCallStack => App () +testAddMembersNonFullyConnectedProteus :: (HasCallStack) => App () testAddMembersNonFullyConnectedProteus = do withFederatingBackendsAllowDynamic $ \(domainA, domainB, domainC) -> do void $ BrigI.createFedConn domainA (BrigI.FedConn domainB "full_search" Nothing) @@ -205,7 +205,7 @@ testAddMembersNonFullyConnectedProteus = do resp.status `shouldMatchInt` 409 resp.json %. "non_federating_backends" `shouldMatchSet` [domainB, domainC] -testAddMember :: HasCallStack => App () +testAddMember :: (HasCallStack) => App () testAddMember = do alice <- randomUser OwnDomain def aliceId <- alice %. "qualified_id" @@ -242,7 +242,7 @@ testAddMember = do mem %. "qualified_id" `shouldMatch` aliceId mem %. "conversation_role" `shouldMatch` "wire_admin" -testAddMemberV1 :: HasCallStack => Domain -> App () +testAddMemberV1 :: (HasCallStack) => Domain -> App () testAddMemberV1 domain = do [alice, bob] <- createAndConnectUsers [OwnDomain, domain] conv <- postConversation alice defProteus >>= getJSON 201 @@ -261,7 +261,7 @@ testAddMemberV1 domain = do users <- resp.json %. "data.users" >>= asList traverse (%. "qualified_id") users `shouldMatchSet` [bobId] -testConvWithUnreachableRemoteUsers :: HasCallStack => App () +testConvWithUnreachableRemoteUsers :: (HasCallStack) => App () testConvWithUnreachableRemoteUsers = do ([alice, alex, bob, charlie, dylan], domains) <- startDynamicBackends [def, def] $ \domains -> do @@ -280,7 +280,7 @@ testConvWithUnreachableRemoteUsers = do regConvs <- filterM (\c -> (==) <$> (c %. "type" & asInt) <*> pure 0) convs regConvs `shouldMatch` ([] :: [Value]) -testAddUserWithUnreachableRemoteUsers :: HasCallStack => App () +testAddUserWithUnreachableRemoteUsers :: (HasCallStack) => App () testAddUserWithUnreachableRemoteUsers = do resourcePool <- asks resourcePool own <- make OwnDomain & asString @@ -312,7 +312,7 @@ testAddUserWithUnreachableRemoteUsers = do resp.status `shouldMatchInt` 533 resp.jsonBody %. "unreachable_backends" `shouldMatchSet` [cDom.berDomain] -testAddUnreachableUserFromFederatingBackend :: HasCallStack => App () +testAddUnreachableUserFromFederatingBackend :: (HasCallStack) => App () testAddUnreachableUserFromFederatingBackend = do resourcePool <- asks resourcePool runCodensity (acquireResources 1 resourcePool) $ \[cDom] -> do @@ -335,7 +335,7 @@ testAddUnreachableUserFromFederatingBackend = do resp.status `shouldMatchInt` 533 resp.jsonBody %. "unreachable_backends" `shouldMatchSet` [cDom.berDomain] -testAddUnreachable :: HasCallStack => App () +testAddUnreachable :: (HasCallStack) => App () testAddUnreachable = do ([alex, charlie], [charlieDomain, dylanDomain], conv) <- startDynamicBackends [def, def] $ \domains -> do @@ -373,7 +373,7 @@ testGetOneOnOneConvInStatusSentFromRemote = do resp <- getConversation d1User d2ConvId resp.status `shouldMatchInt` 200 -testAddingUserNonFullyConnectedFederation :: HasCallStack => App () +testAddingUserNonFullyConnectedFederation :: (HasCallStack) => App () testAddingUserNonFullyConnectedFederation = do let overrides = def @@ -404,7 +404,7 @@ testAddingUserNonFullyConnectedFederation = do resp.status `shouldMatchInt` 409 resp.json %. "non_federating_backends" `shouldMatchSet` [other, dynBackend] -testMultiIngressGuestLinks :: HasCallStack => App () +testMultiIngressGuestLinks :: (HasCallStack) => App () testMultiIngressGuestLinks = do do configuredURI <- readServiceConfig Galley & (%. "settings.conversationCodeURI") & asText @@ -470,7 +470,7 @@ testMultiIngressGuestLinks = do res <- getJSON 403 resp res %. "label" `shouldMatch` "access-denied" -testAddUserWhenOtherBackendOffline :: HasCallStack => App () +testAddUserWhenOtherBackendOffline :: (HasCallStack) => App () testAddUserWhenOtherBackendOffline = do ([alice, alex], conv) <- startDynamicBackends [def] $ \domains -> do @@ -484,7 +484,7 @@ testAddUserWhenOtherBackendOffline = do bindResponse (addMembers alice conv def {users = [alex]}) $ \resp -> do resp.status `shouldMatchInt` 200 -testSynchroniseUserRemovalNotification :: HasCallStack => App () +testSynchroniseUserRemovalNotification :: (HasCallStack) => App () testSynchroniseUserRemovalNotification = do resourcePool <- asks resourcePool [alice, bob] <- createAndConnectUsers [OwnDomain, OtherDomain] @@ -511,7 +511,7 @@ testSynchroniseUserRemovalNotification = do leaveNotif <- awaitNotification charlie client noValue isConvLeaveNotif leaveNotif %. "payload.0.qualified_conversation" `shouldMatch` objQidObject conv -testConvRenaming :: HasCallStack => App () +testConvRenaming :: (HasCallStack) => App () testConvRenaming = do [alice, bob] <- createAndConnectUsers [OwnDomain, OtherDomain] conv <- @@ -525,7 +525,7 @@ testConvRenaming = do nameNotif %. "payload.0.data.name" `shouldMatch` newConvName nameNotif %. "payload.0.qualified_conversation" `shouldMatch` objQidObject conv -testReceiptModeWithRemotesOk :: HasCallStack => App () +testReceiptModeWithRemotesOk :: (HasCallStack) => App () testReceiptModeWithRemotesOk = do [alice, bob] <- createAndConnectUsers [OwnDomain, OtherDomain] conv <- @@ -539,7 +539,7 @@ testReceiptModeWithRemotesOk = do notif %. "payload.0.qualified_from" `shouldMatch` objQidObject alice notif %. "payload.0.data.receipt_mode" `shouldMatchInt` 43 -testReceiptModeWithRemotesUnreachable :: HasCallStack => App () +testReceiptModeWithRemotesUnreachable :: (HasCallStack) => App () testReceiptModeWithRemotesUnreachable = do ownDomain <- asString OwnDomain alice <- randomUser ownDomain def @@ -555,7 +555,7 @@ testReceiptModeWithRemotesUnreachable = do notif %. "payload.0.qualified_from" `shouldMatch` objQidObject alice notif %. "payload.0.data.receipt_mode" `shouldMatchInt` 43 -testDeleteLocalMember :: HasCallStack => App () +testDeleteLocalMember :: (HasCallStack) => App () testDeleteLocalMember = do [alice, alex, bob] <- createUsers [OwnDomain, OwnDomain, OtherDomain] connectTwoUsers alice alex @@ -574,7 +574,7 @@ testDeleteLocalMember = do r.status `shouldMatchInt` 204 r.jsonBody `shouldMatch` (Nothing @Aeson.Value) -testDeleteRemoteMember :: HasCallStack => App () +testDeleteRemoteMember :: (HasCallStack) => App () testDeleteRemoteMember = do [alice, alex, bob] <- createUsers [OwnDomain, OwnDomain, OtherDomain] connectTwoUsers alice alex @@ -593,7 +593,7 @@ testDeleteRemoteMember = do r.status `shouldMatchInt` 204 r.jsonBody `shouldMatch` (Nothing @Aeson.Value) -testDeleteRemoteMemberRemoteUnreachable :: HasCallStack => App () +testDeleteRemoteMemberRemoteUnreachable :: (HasCallStack) => App () testDeleteRemoteMemberRemoteUnreachable = do [alice, bob, bart] <- createUsers [OwnDomain, OtherDomain, OtherDomain] conv <- startDynamicBackends [mempty] $ \[dynBackend] -> do @@ -617,7 +617,7 @@ testDeleteRemoteMemberRemoteUnreachable = do r.status `shouldMatchInt` 204 r.jsonBody `shouldMatch` (Nothing @Aeson.Value) -testDeleteTeamConversationWithRemoteMembers :: HasCallStack => App () +testDeleteTeamConversationWithRemoteMembers :: (HasCallStack) => App () testDeleteTeamConversationWithRemoteMembers = do (alice, team, _) <- createTeam OwnDomain 1 conv <- postConversation alice (defProteus {team = Just team}) >>= getJSON 201 @@ -633,7 +633,7 @@ testDeleteTeamConversationWithRemoteMembers = do notif %. "payload.0.qualified_conversation" `shouldMatch` objQidObject conv notif %. "payload.0.qualified_from" `shouldMatch` objQidObject alice -testDeleteTeamConversationWithUnreachableRemoteMembers :: HasCallStack => App () +testDeleteTeamConversationWithUnreachableRemoteMembers :: (HasCallStack) => App () testDeleteTeamConversationWithUnreachableRemoteMembers = do resourcePool <- asks resourcePool (alice, team, _) <- createTeam OwnDomain 1 @@ -660,7 +660,7 @@ testDeleteTeamConversationWithUnreachableRemoteMembers = do notif <- awaitNotification bob bobClient noValue isConvDeleteNotif assertNotification notif -testDeleteTeamMemberLimitedEventFanout :: HasCallStack => App () +testDeleteTeamMemberLimitedEventFanout :: (HasCallStack) => App () testDeleteTeamMemberLimitedEventFanout = do -- Alex will get removed from the team (alice, team, [alex, alison]) <- createTeam OwnDomain 3 @@ -681,10 +681,10 @@ testDeleteTeamMemberLimitedEventFanout = do -- Only the team admins will get the team-level event about Alex being removed -- from the team - setTeamFeatureStatus OwnDomain team "limitedEventFanout" "enabled" + assertSuccess =<< setTeamFeatureStatus OwnDomain team "limitedEventFanout" "enabled" - withWebSockets [alice, amy, bob, alison, ana] $ - \[wsAlice, wsAmy, wsBob, wsAlison, wsAna] -> do + withWebSockets [alice, amy, bob, alison, ana] + $ \[wsAlice, wsAmy, wsBob, wsAlison, wsAna] -> do void $ deleteTeamMember team alice alex >>= getBody 202 memsAfter <- getMembers team aliceId @@ -719,7 +719,7 @@ testDeleteTeamMemberLimitedEventFanout = do -- is disabled by default. The counterpart test -- 'testDeleteTeamMemberLimitedEventFanout' enables the flag and tests the -- limited fanout. -testDeleteTeamMemberFullEventFanout :: HasCallStack => App () +testDeleteTeamMemberFullEventFanout :: (HasCallStack) => App () testDeleteTeamMemberFullEventFanout = do (alice, team, [alex, alison]) <- createTeam OwnDomain 3 [amy, bob] <- for [OwnDomain, OtherDomain] $ flip randomUser def @@ -749,7 +749,7 @@ testDeleteTeamMemberFullEventFanout = do memIds `shouldMatchSet` [aliceId, alisonId, amyId] assertConvUserDeletedNotif wsBob alexId -testLeaveConversationSuccess :: HasCallStack => App () +testLeaveConversationSuccess :: (HasCallStack) => App () testLeaveConversationSuccess = do [alice, bob, chad, dee] <- createUsers [OwnDomain, OwnDomain, OtherDomain, OtherDomain] [aClient, bClient] <- forM [alice, bob] $ \user -> @@ -771,7 +771,7 @@ testLeaveConversationSuccess = do assertLeaveNotification chad conv bob bClient chad assertLeaveNotification chad conv eve eClient chad -testOnUserDeletedConversations :: HasCallStack => App () +testOnUserDeletedConversations :: (HasCallStack) => App () testOnUserDeletedConversations = do startDynamicBackends [def] $ \[dynDomain] -> do [ownDomain, otherDomain] <- forM [OwnDomain, OtherDomain] asString @@ -803,7 +803,7 @@ testOnUserDeletedConversations = do expectedIds <- for [alex, bart, chad] (%. "qualified_id") memIds `shouldMatchSet` expectedIds -testUpdateConversationByRemoteAdmin :: HasCallStack => App () +testUpdateConversationByRemoteAdmin :: (HasCallStack) => App () testUpdateConversationByRemoteAdmin = do [alice, bob, charlie] <- createUsers [OwnDomain, OtherDomain, OtherDomain] connectTwoUsers alice bob @@ -816,14 +816,14 @@ testUpdateConversationByRemoteAdmin = do void $ updateReceiptMode bob conv (41 :: Int) >>= getBody 200 for_ wss $ \ws -> awaitMatch isReceiptModeUpdateNotif ws -testGuestCreatesConversation :: HasCallStack => App () +testGuestCreatesConversation :: (HasCallStack) => App () testGuestCreatesConversation = do alice <- randomUser OwnDomain def {BrigI.activate = False} bindResponse (postConversation alice defProteus) $ \resp -> do resp.status `shouldMatchInt` 403 resp.json %. "label" `shouldMatch` "operation-denied" -testGuestLinksSuccess :: HasCallStack => App () +testGuestLinksSuccess :: (HasCallStack) => App () testGuestLinksSuccess = do (user, _, tm : _) <- createTeam OwnDomain 2 conv <- postConversation user (allowGuests defProteus) >>= getJSON 201 @@ -836,7 +836,7 @@ testGuestLinksSuccess = do resp.status `shouldMatchInt` 200 resp.json %. "id" `shouldMatch` objId conv -testGuestLinksExpired :: HasCallStack => App () +testGuestLinksExpired :: (HasCallStack) => App () testGuestLinksExpired = do withModifiedBackend def {galleyCfg = setField "settings.guestLinkTTLSeconds" (1 :: Int)} @@ -851,7 +851,7 @@ testGuestLinksExpired = do bindResponse (getJoinCodeConv tm k v) $ \resp -> do resp.status `shouldMatchInt` 404 -testConversationWithFedV0 :: HasCallStack => App () +testConversationWithFedV0 :: (HasCallStack) => App () testConversationWithFedV0 = do alice <- randomUser OwnDomain def bob <- randomUser FedV0Domain def @@ -865,7 +865,7 @@ testConversationWithFedV0 = do void $ changeConversationName alice conv "foobar" >>= getJSON 200 void $ awaitMatch isConvNameChangeNotif ws -testConversationWithoutFederation :: HasCallStack => App () +testConversationWithoutFederation :: (HasCallStack) => App () testConversationWithoutFederation = withModifiedBackend (def {galleyCfg = removeField "federator" >=> removeField "rabbitmq"}) $ \domain -> do diff --git a/integration/test/Test/Demo.hs b/integration/test/Test/Demo.hs index 8b255f1c0d2..85f67354f3c 100644 --- a/integration/test/Test/Demo.hs +++ b/integration/test/Test/Demo.hs @@ -7,13 +7,12 @@ import qualified API.Brig as BrigP import qualified API.BrigInternal as BrigI import qualified API.GalleyInternal as GalleyI import qualified API.Nginz as Nginz -import Control.Monad.Cont import GHC.Stack import SetupHelpers import Testlib.Prelude -- | Deleting unknown clients should fail with 404. -testDeleteUnknownClient :: HasCallStack => App () +testDeleteUnknownClient :: (HasCallStack) => App () testDeleteUnknownClient = do user <- randomUser OwnDomain def let fakeClientId = "deadbeefdeadbeef" @@ -21,7 +20,7 @@ testDeleteUnknownClient = do resp.status `shouldMatchInt` 404 resp.json %. "label" `shouldMatch` "client-not-found" -testModifiedBrig :: HasCallStack => App () +testModifiedBrig :: (HasCallStack) => App () testModifiedBrig = do withModifiedBackend (def {brigCfg = setField "optSettings.setFederationDomain" "overridden.example.com"}) @@ -31,7 +30,7 @@ testModifiedBrig = do resp.status `shouldMatchInt` 200 (resp.json %. "domain") `shouldMatch` "overridden.example.com" -testModifiedGalley :: HasCallStack => App () +testModifiedGalley :: (HasCallStack) => App () testModifiedGalley = do (_user, tid, _) <- createTeam OwnDomain 1 @@ -49,23 +48,23 @@ testModifiedGalley = do (_user, tid', _) <- createTeam domain 1 getFeatureStatus domain tid' `shouldMatch` "enabled" -testModifiedCannon :: HasCallStack => App () +testModifiedCannon :: (HasCallStack) => App () testModifiedCannon = do withModifiedBackend def $ \_ -> pure () -testModifiedGundeck :: HasCallStack => App () +testModifiedGundeck :: (HasCallStack) => App () testModifiedGundeck = do withModifiedBackend def $ \_ -> pure () -testModifiedCargohold :: HasCallStack => App () +testModifiedCargohold :: (HasCallStack) => App () testModifiedCargohold = do withModifiedBackend def $ \_ -> pure () -testModifiedSpar :: HasCallStack => App () +testModifiedSpar :: (HasCallStack) => App () testModifiedSpar = do withModifiedBackend def $ \_ -> pure () -testModifiedServices :: HasCallStack => App () +testModifiedServices :: (HasCallStack) => App () testModifiedServices = do let serviceMap = def @@ -79,17 +78,17 @@ testModifiedServices = do res.status `shouldMatchInt` 200 res.json %. "status" `shouldMatch` "enabled" - bindResponse (BrigP.getAPIVersion domain) $ - \resp -> do + bindResponse (BrigP.getAPIVersion domain) + $ \resp -> do resp.status `shouldMatchInt` 200 (resp.json %. "domain") `shouldMatch` "overridden.example.com" - bindResponse (Nginz.getSystemSettingsUnAuthorized domain) $ - \resp -> do + bindResponse (Nginz.getSystemSettingsUnAuthorized domain) + $ \resp -> do resp.status `shouldMatchInt` 200 resp.json %. "setRestrictUserCreation" `shouldMatch` False -testDynamicBackend :: HasCallStack => App () +testDynamicBackend :: (HasCallStack) => App () testDynamicBackend = do ownDomain <- objDomain OwnDomain user <- randomUser OwnDomain def @@ -100,8 +99,8 @@ testDynamicBackend = do startDynamicBackends [def] $ \dynDomains -> do [dynDomain] <- pure dynDomains - bindResponse (Nginz.getSystemSettingsUnAuthorized dynDomain) $ - \resp -> do + bindResponse (Nginz.getSystemSettingsUnAuthorized dynDomain) + $ \resp -> do resp.status `shouldMatchInt` 200 resp.json %. "setRestrictUserCreation" `shouldMatch` False @@ -120,16 +119,16 @@ testDynamicBackend = do bindResponse (BrigP.getSelf' ownDomain uidD1) $ \resp -> do resp.status `shouldMatchInt` 404 -testStartMultipleDynamicBackends :: HasCallStack => App () +testStartMultipleDynamicBackends :: (HasCallStack) => App () testStartMultipleDynamicBackends = do let assertCorrectDomain domain = - bindResponse (BrigP.getAPIVersion domain) $ - \resp -> do + bindResponse (BrigP.getAPIVersion domain) + $ \resp -> do resp.status `shouldMatchInt` 200 (resp.json %. "domain") `shouldMatch` domain startDynamicBackends [def, def, def] $ mapM_ assertCorrectDomain -testIndependentESIndices :: HasCallStack => App () +testIndependentESIndices :: (HasCallStack) => App () testIndependentESIndices = do u1 <- randomUser OwnDomain def u2 <- randomUser OwnDomain def @@ -162,14 +161,14 @@ testIndependentESIndices = do [] -> assertFailure "Expected a non empty result, but got an empty one" doc : _ -> doc %. "id" `shouldMatch` uidD2 -testDynamicBackendsFederation :: HasCallStack => App () +testDynamicBackendsFederation :: (HasCallStack) => App () testDynamicBackendsFederation = do startDynamicBackends [def, def] $ \[aDynDomain, anotherDynDomain] -> do [u1, u2] <- createAndConnectUsers [aDynDomain, anotherDynDomain] bindResponse (BrigP.getConnection u1 u2) assertSuccess bindResponse (BrigP.getConnection u2 u1) assertSuccess -testWebSockets :: HasCallStack => App () +testWebSockets :: (HasCallStack) => App () testWebSockets = do user <- randomUser OwnDomain def withWebSocket user $ \ws -> do @@ -195,12 +194,12 @@ testUnrace = do -} retryT $ True `shouldMatch` True -testFedV0Instance :: HasCallStack => App () +testFedV0Instance :: (HasCallStack) => App () testFedV0Instance = do res <- BrigP.getAPIVersion FedV0Domain >>= getJSON 200 res %. "domain" `shouldMatch` FedV0Domain -testFedV0Federation :: HasCallStack => App () +testFedV0Federation :: (HasCallStack) => App () testFedV0Federation = do alice <- randomUser OwnDomain def bob <- randomUser FedV0Domain def diff --git a/integration/test/Test/EJPD.hs b/integration/test/Test/EJPD.hs index 36301a9cb96..db28ccec61b 100644 --- a/integration/test/Test/EJPD.hs +++ b/integration/test/Test/EJPD.hs @@ -1,8 +1,14 @@ {-# OPTIONS -Wno-ambiguous-fields #-} -module Test.EJPD (testEJPDRequest) where + +module Test.EJPD + ( testEJPDRequest, + testEJPDRequestRemote, + ) +where import API.Brig import qualified API.BrigInternal as BI +import API.Galley import API.Gundeck import Control.Lens hiding ((.=)) import Control.Monad.Reader @@ -17,20 +23,23 @@ import Testlib.JSON import Testlib.Prelude -- | Create some teams & users, and return their expected ejpd response values. -setupEJPD :: HasCallStack => App (A.Value, A.Value, A.Value, A.Value, A.Value) +setupEJPD :: (HasCallStack) => App (A.Value, A.Value, A.Value, A.Value, A.Value) setupEJPD = do - (owner1, _tid1, [usr1, usr2]) <- createTeam OwnDomain 3 + (owner1, tid1, [usr1, usr2]) <- createTeam OwnDomain 3 handle1 <- liftIO $ UUID.nextRandom <&> ("usr1-handle-" <>) . UUID.toString handle2 <- liftIO $ UUID.nextRandom <&> ("usr2-handle-" <>) . UUID.toString + owner1Handle <- liftIO $ UUID.nextRandom <&> ("owner1-handle-" <>) . UUID.toString void $ putHandle usr1 handle1 void $ putHandle usr2 handle2 + void $ putHandle owner1 owner1Handle email3 <- liftIO $ UUID.nextRandom <&> \uuid -> "usr3-" <> UUID.toString uuid <> "@example.com" email4 <- liftIO $ UUID.nextRandom <&> \uuid -> "usr4-" <> UUID.toString uuid <> "@example.com" email5 <- liftIO $ UUID.nextRandom <&> \uuid -> "usr5-" <> UUID.toString uuid <> "@example.com" usr3 <- randomUser OwnDomain def {BI.email = Just email3, BI.name = Just "usr3"} usr4 <- randomUser OwnDomain def {BI.email = Just email4, BI.name = Just "usr4"} usr5 <- randomUser OwnDomain def {BI.email = Just email5, BI.name = Just "usr5"} + usrRemote <- randomUser OtherDomain def {BI.email = Nothing, BI.name = Just "usrRemote"} handle3 <- liftIO $ UUID.nextRandom <&> ("usr3-handle-" <>) . UUID.toString handle4 <- liftIO $ UUID.nextRandom <&> ("usr4-handle-" <>) . UUID.toString handle5 <- liftIO $ UUID.nextRandom <&> ("usr5-handle-" <>) . UUID.toString @@ -39,8 +48,7 @@ setupEJPD = void $ putHandle usr5 handle5 connectTwoUsers usr3 usr5 - connectTwoUsers usr2 usr4 - connectTwoUsers usr4 usr5 + connectUsers [usr2, usr4, usr5, usrRemote] toks1 <- do cl11 <- objId $ addClient (usr1 %. "qualified_id") def >>= getJSON 201 @@ -69,85 +77,120 @@ setupEJPD = a1 <- uploadDownloadProfilePicture usr1 a2 <- uploadDownloadProfilePicture usr1 pure $ snd <$> [a1, a2] - assets2 <- do - (: []) . snd <$> uploadDownloadProfilePicture usr2 - assets3 <- do - (: []) . snd <$> uploadDownloadProfilePicture usr3 - assets4 <- do - (: []) . snd <$> uploadDownloadProfilePicture usr4 - - (convs1, convs2, convs4) <- do - -- FUTUREWORKI(fisx): implement this (create both team convs and regular convs) - pure (Nothing, Nothing, Nothing) - - let usr2contacts = Just $ (,"accepted") <$> [ejpd4] + assets2 <- (: []) . snd <$> uploadDownloadProfilePicture usr2 + assets3 <- (: []) . snd <$> uploadDownloadProfilePicture usr3 + assets4 <- (: []) . snd <$> uploadDownloadProfilePicture usr4 + + (convs1, convs2, convs3, convs4, convs5) <- do + let parse :: Response -> App Value + parse resp = + getJSON 201 resp <&> \val -> + object + [ "conv_name" .= do val ^?! key (fromString "name") . _String, + "conv_id" .= do val ^?! key (fromString "qualified_id") . _Object + ] + + conv1 <- + parse + =<< postConversation usr1 do + defMLS {name = Just "11", qualifiedUsers = [], team = Just tid1} + conv12 <- + parse + =<< postConversation usr1 do + defProteus {name = Just "12", qualifiedUsers = [usr2], team = Just tid1} + conv35 <- + parse + =<< postConversation + usr3 + do defProteus {name = Just "35", qualifiedUsers = [usr5]} + conv524 <- + parse + =<< postConversation usr5 do + defProteus {name = Just "524", qualifiedUsers = [usr2, usr4]} + pure (Just ([conv1, conv12]), Just ([conv12, conv524]), Just [conv35], Just [conv524], Just [conv35, conv524]) + + assertSuccess =<< postConversation usrRemote do + defProteus {name = Just "remote245", qualifiedUsers = [usr2, usr4, usr5]} + + let usr2contacts = Just $ (,"accepted") <$> [ejpd4, ejpd5] usr3contacts = Just $ (,"accepted") <$> [ejpd5] usr4contacts = Just $ (,"accepted") <$> [ejpd2, ejpd5] - usr5contacts = Just $ (,"accepted") <$> [ejpd3, ejpd4] + usr5contacts = Just $ (,"accepted") <$> [ejpd2, ejpd3, ejpd4] - ejpd0 = mkUsr owner1 Nothing [] Nothing (Just ([ejpd1, ejpd2], "list_complete")) Nothing Nothing + ejpd0 = mkUsr owner1 (Just owner1Handle) [] Nothing (Just ([ejpd1, ejpd2], "list_complete")) Nothing Nothing ejpd1 = mkUsr usr1 (Just handle1) toks1 Nothing (Just ([ejpd0, ejpd2], "list_complete")) convs1 (Just assets1) ejpd2 = mkUsr usr2 (Just handle2) toks2 usr2contacts (Just ([ejpd0, ejpd1], "list_complete")) convs2 (Just assets2) - ejpd3 = mkUsr usr3 (Just handle3) [] usr3contacts Nothing Nothing (Just assets3) + ejpd3 = mkUsr usr3 (Just handle3) [] usr3contacts Nothing convs3 (Just assets3) ejpd4 = mkUsr usr4 (Just handle4) toks4 usr4contacts Nothing convs4 (Just assets4) - ejpd5 = mkUsr usr5 (Just handle5) [] usr5contacts Nothing Nothing Nothing + ejpd5 = mkUsr usr5 (Just handle5) [] usr5contacts Nothing convs5 Nothing pure (ejpd1, ejpd2, ejpd3, ejpd4, ejpd5) where -- Return value is a 'EJPDResponseItem'. mkUsr :: - HasCallStack => + (HasCallStack) => A.Value {- user -} -> Maybe String {- handle (in case usr is not up to date, we pass this separately) -} -> [String {- push tokens -}] -> + -- contacts Maybe [(A.Value {- ejpd response item of contact -}, String {- relation -})] -> + -- team contacts Maybe ([A.Value {- ejpd response item -}], String {- pagination flag -}) -> - Maybe [(String {- conv name -}, String {- conv id -})] -> + -- conversations + Maybe [A.Value] -> Maybe [String {- asset url -}] -> A.Value - mkUsr usr handle toks contacts teamContacts convs assets = result + mkUsr usr hdl toks contacts teamContacts convs assets = result where result = object [ -- (We know we have "id", but using ^? instead of ^. avoids the need for a Monoid instance for Value.) - "ejpd_response_user_id" .= (usr ^? key (fromString "id")), - "ejpd_response_team_id" .= (usr ^? key (fromString "team")), - "ejpd_response_name" .= (usr ^? key (fromString "name")), - "ejpd_response_handle" .= handle, - "ejpd_response_email" .= (usr ^? key (fromString "email")), - "ejpd_response_phone" .= (usr ^? key (fromString "phone")), - "ejpd_response_push_tokens" .= toks, - "ejpd_response_contacts" .= (trimContacts _1 <$> contacts), - "ejpd_response_team_contacts" .= (teamContacts & _Just . _1 %~ trimContacts id), - "ejpd_response_conversations" .= convs, - "ejpd_response_assets" .= assets + "UserId" .= (usr ^? key (fromString "qualified_id")), + "TeamId" .= (usr ^? key (fromString "team")), + "Name" .= (usr ^? key (fromString "name")), + "Handle" .= hdl, + "Email" .= (usr ^? key (fromString "email")), + "Phone" .= (usr ^? key (fromString "phone")), + "PushTokens" .= toks, + "Contacts" + .= let f (item, relation) = object ["contact_item" .= item, "contact_relation" .= relation] + in (map (f . trimContact _1) <$> contacts), + "TeamContacts" + .= ( teamContacts + & maybe + Null + ( \(tcs, ltyp) -> + object + [ "TeamContacts" .= (trimContact id <$> tcs), + "ListType" .= ltyp + ] + ) + ), + "Conversations" .= convs, + "Assets" .= assets ] - trimContacts :: forall x. Lens' x A.Value -> [x] -> [x] - trimContacts lns = - fmap - ( lns - %~ ( \case - trimmable@(A.Object _) -> trimItem trimmable - other -> error $ show other - ) - ) + trimContact :: forall x. Lens' x A.Value -> x -> x + trimContact lns = + lns %~ \case + trimmable@(A.Object _) -> trimItem trimmable + other -> error $ show other trimItem :: A.Value -> A.Value trimItem = - (key (fromString "ejpd_response_contacts") .~ A.Null) - . (key (fromString "ejpd_response_team_contacts") .~ A.Null) - . (key (fromString "ejpd_response_conversations") .~ A.Null) + (key (fromString "Contacts") .~ A.Null) + . (key (fromString "TeamContacts") .~ A.Null) + . (key (fromString "Conversations") .~ A.Null) -testEJPDRequest :: HasCallStack => App () +testEJPDRequest :: (HasCallStack) => App () testEJPDRequest = do (usr1, usr2, usr3, usr4, usr5) <- setupEJPD - let check :: HasCallStack => [A.Value] -> App () + let check :: (HasCallStack) => [A.Value] -> App () check want = do - let handle = cs . (^?! (key (fromString "ejpd_response_handle") . _String)) + let handle = cs . (^?! (key (fromString "Handle") . _String)) have <- BI.getEJPDInfo OwnDomain (handle <$> want) "include_contacts" - have.json `shouldMatchSpecial` object ["ejpd_response" .= want] + have.json `shouldMatchSpecial` object ["EJPDResponse" .= want] shouldMatchSpecial :: (MakesValue a, MakesValue b, HasCallStack) => a -> b -> App () shouldMatchSpecial = shouldMatchWithRules [minBound ..] resolveAssetLinks @@ -170,3 +213,12 @@ testEJPDRequest = do check [usr2] check [usr3] check [usr4, usr5] + +testEJPDRequestRemote :: (HasCallStack) => App () +testEJPDRequestRemote = do + usrRemote <- randomUser OtherDomain def {BI.email = Nothing, BI.name = Just "usrRemote"} + handleRemote <- liftIO $ UUID.nextRandom <&> UUID.toString + assertSuccess =<< putHandle usrRemote handleRemote + + have <- BI.getEJPDInfo OwnDomain [handleRemote] "include_contacts" + shouldBeEmpty $ have.json %. "EJPDResponse" diff --git a/integration/test/Test/Errors.hs b/integration/test/Test/Errors.hs index 795c862dedd..4093cf3dc85 100644 --- a/integration/test/Test/Errors.hs +++ b/integration/test/Test/Errors.hs @@ -12,7 +12,7 @@ import Testlib.Mock import Testlib.Prelude import Testlib.ResourcePool -testNestedError :: HasCallStack => App () +testNestedError :: (HasCallStack) => App () testNestedError = do let innerError = object @@ -39,10 +39,10 @@ testNestedError = do { port = Just (fromIntegral res.berFederatorExternal), tls = False } - void $ - startMockServer mockConfig $ - codensityApp $ - \_req -> pure $ Wai.responseLBS HTTP.status400 mempty $ Aeson.encode innerError + void + $ startMockServer mockConfig + $ codensityApp + $ \_req -> pure $ Wai.responseLBS HTTP.status400 mempty $ Aeson.encode innerError -- get remote user lift $ do diff --git a/integration/test/Test/ExternalPartner.hs b/integration/test/Test/ExternalPartner.hs index a35522140b2..ae6381f4187 100644 --- a/integration/test/Test/ExternalPartner.hs +++ b/integration/test/Test/ExternalPartner.hs @@ -25,7 +25,7 @@ import MLS.Util import SetupHelpers import Testlib.Prelude -testExternalPartnerPermissions :: HasCallStack => App () +testExternalPartnerPermissions :: (HasCallStack) => App () testExternalPartnerPermissions = do (owner, tid, u1 : u2 : u3 : _) <- createTeam OwnDomain 4 @@ -55,7 +55,7 @@ testExternalPartnerPermissions = do bindResponse (addMembers partner conv def {users = [u3]}) $ \resp -> do resp.status `shouldMatchInt` 403 -testExternalPartnerPermissionsMls :: HasCallStack => App () +testExternalPartnerPermissionsMls :: (HasCallStack) => App () testExternalPartnerPermissionsMls = do -- external partners should not be able to create (MLS) conversations (owner, tid, _) <- createTeam OwnDomain 2 @@ -64,13 +64,13 @@ testExternalPartnerPermissionsMls = do bindResponse (postConversation bobExtClient defMLS) $ \resp -> do resp.status `shouldMatchInt` 403 -testExternalPartnerPermissionMlsOne2One :: HasCallStack => App () +testExternalPartnerPermissionMlsOne2One :: (HasCallStack) => App () testExternalPartnerPermissionMlsOne2One = do (owner, tid, alice : _) <- createTeam OwnDomain 2 bobExternal <- createTeamMemberWithRole owner tid "partner" void $ getMLSOne2OneConversation alice bobExternal >>= getJSON 200 -testExternalPartnerPermissionsConvName :: HasCallStack => App () +testExternalPartnerPermissionsConvName :: (HasCallStack) => App () testExternalPartnerPermissionsConvName = do (owner, tid, u1 : _) <- createTeam OwnDomain 2 diff --git a/integration/test/Test/FeatureFlags.hs b/integration/test/Test/FeatureFlags.hs index 6d68d58845d..e0943931f9e 100644 --- a/integration/test/Test/FeatureFlags.hs +++ b/integration/test/Test/FeatureFlags.hs @@ -19,13 +19,21 @@ module Test.FeatureFlags where import qualified API.Galley as Public import qualified API.GalleyInternal as Internal +import Control.Concurrent (threadDelay) import Control.Monad.Codensity (Codensity (runCodensity)) import Control.Monad.Reader +import qualified Data.Aeson as A +import qualified Data.Aeson.Key as A +import qualified Data.Aeson.KeyMap as KM +import qualified Data.Set as Set +import Data.String.Conversions (cs) +import Notifications import SetupHelpers +import Test.FeatureFlags.Util import Testlib.Prelude import Testlib.ResourcePool (acquireResources) -testLimitedEventFanout :: HasCallStack => App () +testLimitedEventFanout :: (HasCallStack) => App () testLimitedEventFanout = do let featureName = "limitedEventFanout" (_alice, team, _) <- createTeam OwnDomain 1 @@ -33,22 +41,32 @@ testLimitedEventFanout = do bindResponse (Internal.getTeamFeature OwnDomain team featureName) $ \resp -> do resp.status `shouldMatchInt` 200 resp.json %. "status" `shouldMatch` "disabled" - Internal.setTeamFeatureStatus OwnDomain team featureName "enabled" + assertSuccess =<< Internal.setTeamFeatureStatus OwnDomain team featureName "enabled" bindResponse (Internal.getTeamFeature OwnDomain team featureName) $ \resp -> do resp.status `shouldMatchInt` 200 resp.json %. "status" `shouldMatch` "enabled" -disabled :: Value -disabled = object ["lockStatus" .= "unlocked", "status" .= "disabled", "ttl" .= "unlimited"] - -disabledLocked :: Value -disabledLocked = object ["lockStatus" .= "locked", "status" .= "disabled", "ttl" .= "unlimited"] - -enabled :: Value -enabled = object ["lockStatus" .= "unlocked", "status" .= "enabled", "ttl" .= "unlimited"] +testLegalholdDisabledByDefault :: (HasCallStack) => App () +testLegalholdDisabledByDefault = do + let put uid tid st = Internal.setTeamFeatureConfig uid tid "legalhold" (object ["status" .= st]) >>= assertSuccess + let patch uid tid st = Internal.setTeamFeatureStatus uid tid "legalhold" st >>= assertSuccess + forM_ [put, patch] $ \setFeatureStatus -> do + withModifiedBackend + def {galleyCfg = setField "settings.featureFlags.legalhold" "disabled-by-default"} + $ \domain -> do + (owner, tid, m : _) <- createTeam domain 2 + nonMember <- randomUser domain def + assertForbidden =<< Public.getTeamFeature nonMember tid "legalhold" + -- Test default + checkFeature "legalhold" m tid disabled + -- Test override + setFeatureStatus owner tid "enabled" + checkFeature "legalhold" owner tid enabled + setFeatureStatus owner tid "disabled" + checkFeature "legalhold" owner tid disabled -- always disabled -testLegalholdDisabledPermanently :: HasCallStack => App () +testLegalholdDisabledPermanently :: (HasCallStack) => App () testLegalholdDisabledPermanently = do let cfgLhDisabledPermanently = def @@ -66,35 +84,23 @@ testLegalholdDisabledPermanently = do runCodensity (startDynamicBackend testBackend cfgLhDisabledPermanently) $ \_ -> do (owner, tid, _) <- createTeam domain 1 checkFeature "legalhold" owner tid disabled - Internal.setTeamFeatureStatusExpectHttpStatus domain tid "legalhold" "enabled" 403 + assertStatus 403 =<< Internal.setTeamFeatureStatus domain tid "legalhold" "enabled" + assertStatus 403 =<< Internal.setTeamFeatureConfig domain tid "legalhold" (object ["status" .= "enabled"]) - -- Inteteresting case: The team had LH enabled before backend config was + -- Interesting case: The team had LH enabled before backend config was -- changed to disabled-permanently (owner, tid) <- runCodensity (startDynamicBackend testBackend cfgLhDisabledByDefault) $ \_ -> do (owner, tid, _) <- createTeam domain 1 checkFeature "legalhold" owner tid disabled - Internal.setTeamFeatureStatusExpectHttpStatus domain tid "legalhold" "enabled" 200 + assertSuccess =<< Internal.setTeamFeatureStatus domain tid "legalhold" "enabled" checkFeature "legalhold" owner tid enabled pure (owner, tid) runCodensity (startDynamicBackend testBackend cfgLhDisabledPermanently) $ \_ -> do checkFeature "legalhold" owner tid disabled --- can be enabled for a team, disabled if unset -testLegalholdDisabledByDefault :: HasCallStack => App () -testLegalholdDisabledByDefault = do - withModifiedBackend - (def {galleyCfg = setField "settings.featureFlags.legalhold" "disabled-by-default"}) - $ \domain -> do - (owner, tid, _) <- createTeam domain 1 - checkFeature "legalhold" owner tid disabled - Internal.setTeamFeatureStatus domain tid "legalhold" "enabled" - checkFeature "legalhold" owner tid enabled - Internal.setTeamFeatureStatus domain tid "legalhold" "disabled" - checkFeature "legalhold" owner tid disabled - -- enabled if team is allow listed, disabled in any other case -testLegalholdWhitelistTeamsAndImplicitConsent :: HasCallStack => App () +testLegalholdWhitelistTeamsAndImplicitConsent :: (HasCallStack) => App () testLegalholdWhitelistTeamsAndImplicitConsent = do let cfgLhWhitelistTeamsAndImplicitConsent = def @@ -116,7 +122,8 @@ testLegalholdWhitelistTeamsAndImplicitConsent = do checkFeature "legalhold" owner tid enabled -- Disabling it doesn't work - Internal.setTeamFeatureStatusExpectHttpStatus domain tid "legalhold" "disabled" 403 + assertStatus 403 =<< Internal.setTeamFeatureStatus domain tid "legalhold" "disabled" + assertStatus 403 =<< Internal.setTeamFeatureConfig domain tid "legalhold" (object ["status" .= "disabled"]) checkFeature "legalhold" owner tid enabled pure (owner, tid) @@ -125,13 +132,13 @@ testLegalholdWhitelistTeamsAndImplicitConsent = do -- enabled when the config gets changed. runCodensity (startDynamicBackend testBackend cfgLhDisabledByDefault) $ \_ -> do checkFeature "legalhold" owner tid disabled - Internal.setTeamFeatureStatusExpectHttpStatus domain tid "legalhold" "disabled" 200 + assertSuccess =<< Internal.setTeamFeatureStatus domain tid "legalhold" "disabled" checkFeature "legalhold" owner tid disabled runCodensity (startDynamicBackend testBackend cfgLhWhitelistTeamsAndImplicitConsent) $ \_ -> do checkFeature "legalhold" owner tid enabled -testExposeInvitationURLsToTeamAdminConfig :: HasCallStack => App () +testExposeInvitationURLsToTeamAdminConfig :: (HasCallStack) => App () testExposeInvitationURLsToTeamAdminConfig = do let cfgExposeInvitationURLsTeamAllowlist tids = def @@ -145,8 +152,13 @@ testExposeInvitationURLsToTeamAdminConfig = do (owner, tid, _) <- createTeam domain 1 checkFeature "exposeInvitationURLsToTeamAdmin" owner tid disabledLocked -- here we get a response with HTTP status 200 and feature status unchanged (disabled), which we find weird, but we're just testing the current behavior - Internal.setTeamFeatureStatusExpectHttpStatus domain tid "exposeInvitationURLsToTeamAdmin" "enabled" 200 - Internal.setTeamFeatureStatusExpectHttpStatus domain tid "exposeInvitationURLsToTeamAdmin" "disabled" 200 + -- a team that is not in the allow list cannot enable the feature, it will always be disabled and locked + -- even though the internal API request to enable it succeeds + assertSuccess =<< Internal.setTeamFeatureStatus domain tid "exposeInvitationURLsToTeamAdmin" "enabled" + checkFeature "exposeInvitationURLsToTeamAdmin" owner tid disabledLocked + -- however, a request to the public API will fail + assertStatus 409 =<< Public.setTeamFeatureConfig owner tid "exposeInvitationURLsToTeamAdmin" (object ["status" .= "enabled"]) + assertSuccess =<< Internal.setTeamFeatureStatus domain tid "exposeInvitationURLsToTeamAdmin" "disabled" pure (owner, tid) -- Happy case: DB has no config for the team @@ -154,30 +166,1030 @@ testExposeInvitationURLsToTeamAdminConfig = do -- Interesting case: The team is in the allow list runCodensity (startDynamicBackend testBackend $ cfgExposeInvitationURLsTeamAllowlist [tid]) $ \_ -> do + -- when the team is in the allow list the lock status is implicitly unlocked checkFeature "exposeInvitationURLsToTeamAdmin" owner tid disabled - Internal.setTeamFeatureStatusExpectHttpStatus domain tid "exposeInvitationURLsToTeamAdmin" "enabled" 200 + assertSuccess =<< Internal.setTeamFeatureStatus domain tid "exposeInvitationURLsToTeamAdmin" "enabled" checkFeature "exposeInvitationURLsToTeamAdmin" owner tid enabled - Internal.setTeamFeatureStatusExpectHttpStatus domain tid "exposeInvitationURLsToTeamAdmin" "disabled" 200 + assertSuccess =<< Internal.setTeamFeatureStatus domain tid "exposeInvitationURLsToTeamAdmin" "disabled" checkFeature "exposeInvitationURLsToTeamAdmin" owner tid disabled - Internal.setTeamFeatureStatusExpectHttpStatus domain tid "exposeInvitationURLsToTeamAdmin" "enabled" 200 + assertSuccess =<< Internal.setTeamFeatureStatus domain tid "exposeInvitationURLsToTeamAdmin" "enabled" checkFeature "exposeInvitationURLsToTeamAdmin" owner tid enabled -- Interesting case: The team had the feature enabled but is not in allow list void testNoAllowlistEntry -checkFeature :: (HasCallStack, MakesValue user, MakesValue tid) => String -> user -> tid -> Value -> App () -checkFeature feature user tid expected = do - tidStr <- asString tid - domain <- objDomain user - bindResponse (Internal.getTeamFeature domain tidStr feature) $ \resp -> do +testMlsE2EConfigCrlProxyRequired :: (HasCallStack) => App () +testMlsE2EConfigCrlProxyRequired = do + (owner, tid, _) <- createTeam OwnDomain 1 + let configWithoutCrlProxy = + object + [ "config" + .= object + [ "useProxyOnMobile" .= False, + "verificationExpiration" .= A.Number 86400 + ], + "status" .= "enabled" + ] + + -- From API version 6 onwards, the CRL proxy is required, so the request should fail when it's not provided + bindResponse (Public.setTeamFeatureConfig owner tid "mlsE2EId" configWithoutCrlProxy) $ \resp -> do + resp.status `shouldMatchInt` 400 + resp.json %. "label" `shouldMatch` "mls-e2eid-missing-crl-proxy" + + configWithCrlProxy <- + configWithoutCrlProxy + & setField "config.useProxyOnMobile" True + & setField "config.crlProxy" "https://crl-proxy.example.com" + & setField "status" "enabled" + + -- The request should succeed when the CRL proxy is provided + bindResponse (Public.setTeamFeatureConfig owner tid "mlsE2EId" configWithCrlProxy) $ \resp -> do resp.status `shouldMatchInt` 200 - resp.json `shouldMatch` expected - bindResponse (Public.getTeamFeatures user tid) $ \resp -> do + + -- Assert that the feature config got updated correctly + expectedResponse <- configWithCrlProxy & setField "lockStatus" "unlocked" & setField "ttl" "unlimited" + checkFeature "mlsE2EId" owner tid expectedResponse + +testMlsE2EConfigCrlProxyNotRequiredInV5 :: (HasCallStack) => App () +testMlsE2EConfigCrlProxyNotRequiredInV5 = do + (owner, tid, _) <- createTeam OwnDomain 1 + let configWithoutCrlProxy = + object + [ "config" + .= object + [ "useProxyOnMobile" .= False, + "verificationExpiration" .= A.Number 86400 + ], + "status" .= "enabled" + ] + + -- In API version 5, the CRL proxy is not required, so the request should succeed + bindResponse (Public.setTeamFeatureConfigVersioned (ExplicitVersion 5) owner tid "mlsE2EId" configWithoutCrlProxy) $ \resp -> do resp.status `shouldMatchInt` 200 - resp.json %. feature `shouldMatch` expected - bindResponse (Public.getTeamFeature user tid feature) $ \resp -> do + + -- Assert that the feature config got updated correctly + expectedResponse <- configWithoutCrlProxy & setField "lockStatus" "unlocked" & setField "ttl" "unlimited" + checkFeature "mlsE2EId" owner tid expectedResponse + +testSSODisabledByDefault :: (HasCallStack) => App () +testSSODisabledByDefault = do + let put uid tid = Internal.setTeamFeatureConfig uid tid "sso" (object ["status" .= "enabled"]) >>= assertSuccess + let patch uid tid = Internal.setTeamFeatureStatus uid tid "sso" "enabled" >>= assertSuccess + forM_ [put, patch] $ \enableFeature -> do + withModifiedBackend + def {galleyCfg = setField "settings.featureFlags.sso" "disabled-by-default"} + $ \domain -> do + (owner, tid, m : _) <- createTeam domain 2 + nonMember <- randomUser domain def + assertForbidden =<< Public.getTeamFeature nonMember tid "sso" + -- Test default + checkFeature "sso" m tid disabled + -- Test override + enableFeature owner tid + checkFeature "sso" owner tid enabled + +testSSOEnabledByDefault :: (HasCallStack) => App () +testSSOEnabledByDefault = do + withModifiedBackend + def {galleyCfg = setField "settings.featureFlags.sso" "enabled-by-default"} + $ \domain -> do + (owner, tid, _m : _) <- createTeam domain 2 + nonMember <- randomUser domain def + assertForbidden =<< Public.getTeamFeature nonMember tid "sso" + checkFeature "sso" owner tid enabled + -- check that the feature cannot be disabled + assertLabel 403 "not-implemented" =<< Internal.setTeamFeatureConfig owner tid "sso" (object ["status" .= "disabled"]) + +testSearchVisibilityDisabledByDefault :: (HasCallStack) => App () +testSearchVisibilityDisabledByDefault = do + withModifiedBackend def {galleyCfg = setField "settings.featureFlags.teamSearchVisibility" "disabled-by-default"} $ \domain -> do + (owner, tid, m : _) <- createTeam domain 2 + nonMember <- randomUser domain def + assertForbidden =<< Public.getTeamFeature nonMember tid "searchVisibility" + -- Test default + checkFeature "searchVisibility" m tid disabled + assertSuccess =<< Internal.setTeamFeatureStatus owner tid "searchVisibility" "enabled" + checkFeature "searchVisibility" owner tid enabled + assertSuccess =<< Internal.setTeamFeatureStatus owner tid "searchVisibility" "disabled" + checkFeature "searchVisibility" owner tid disabled + +testSearchVisibilityEnabledByDefault :: (HasCallStack) => App () +testSearchVisibilityEnabledByDefault = do + withModifiedBackend def {galleyCfg = setField "settings.featureFlags.teamSearchVisibility" "enabled-by-default"} $ \domain -> do + (owner, tid, m : _) <- createTeam domain 2 + nonMember <- randomUser domain def + assertForbidden =<< Public.getTeamFeature nonMember tid "searchVisibility" + -- Test default + checkFeature "searchVisibility" m tid enabled + assertSuccess =<< Internal.setTeamFeatureStatus owner tid "searchVisibility" "disabled" + checkFeature "searchVisibility" owner tid disabled + assertSuccess =<< Internal.setTeamFeatureStatus owner tid "searchVisibility" "enabled" + checkFeature "searchVisibility" owner tid enabled + +testSearchVisibilityInbound :: (HasCallStack) => App () +testSearchVisibilityInbound = _testSimpleFlag "searchVisibilityInbound" Public.setTeamFeatureConfig False + +testDigitalSignaturesInternal :: (HasCallStack) => App () +testDigitalSignaturesInternal = _testSimpleFlag "digitalSignatures" Internal.setTeamFeatureConfig False + +testValidateSAMLEmailsInternal :: (HasCallStack) => App () +testValidateSAMLEmailsInternal = _testSimpleFlag "validateSAMLemails" Internal.setTeamFeatureConfig True + +testConferenceCallingInternal :: (HasCallStack) => App () +testConferenceCallingInternal = _testSimpleFlag "conferenceCalling" Internal.setTeamFeatureConfig True + +testSearchVisibilityInboundInternal :: (HasCallStack) => App () +testSearchVisibilityInboundInternal = _testSimpleFlag "searchVisibilityInbound" Internal.setTeamFeatureConfig False + +_testSimpleFlag :: (HasCallStack) => String -> (Value -> String -> String -> Value -> App Response) -> Bool -> App () +_testSimpleFlag featureName setFeatureConfig featureEnabledByDefault = do + let defaultStatus = if featureEnabledByDefault then "enabled" else "disabled" + let defaultValue = if featureEnabledByDefault then enabled else disabled + let otherStatus = if featureEnabledByDefault then "disabled" else "enabled" + let otherValue = if featureEnabledByDefault then disabled else enabled + + (owner, tid, m : _) <- createTeam OwnDomain 2 + nonTeamMember <- randomUser OwnDomain def + assertForbidden =<< Public.getTeamFeature nonTeamMember tid featureName + checkFeature featureName m tid defaultValue + -- should receive an event + void $ withWebSockets [m] $ \wss -> do + assertSuccess =<< setFeatureConfig owner tid featureName (object ["status" .= otherStatus]) + for_ wss $ \ws -> do + notif <- awaitMatch isFeatureConfigUpdateNotif ws + notif %. "payload.0.name" `shouldMatch` featureName + notif %. "payload.0.data" `shouldMatch` otherValue + + checkFeature featureName m tid otherValue + assertSuccess =<< setFeatureConfig owner tid featureName (object ["status" .= defaultStatus]) + for_ wss $ \ws -> do + notif <- awaitMatch isFeatureConfigUpdateNotif ws + notif %. "payload.0.name" `shouldMatch` featureName + notif %. "payload.0.data" `shouldMatch` defaultValue + checkFeature featureName m tid defaultValue + +testConversationGuestLinks :: (HasCallStack) => App () +testConversationGuestLinks = _testSimpleFlagWithLockStatus "conversationGuestLinks" Public.setTeamFeatureConfig True True + +testFileSharing :: (HasCallStack) => App () +testFileSharing = _testSimpleFlagWithLockStatus "fileSharing" Public.setTeamFeatureConfig True True + +testSndFactorPasswordChallenge :: (HasCallStack) => App () +testSndFactorPasswordChallenge = _testSimpleFlagWithLockStatus "sndFactorPasswordChallenge" Public.setTeamFeatureConfig False False + +testOutlookCalIntegration :: (HasCallStack) => App () +testOutlookCalIntegration = _testSimpleFlagWithLockStatus "outlookCalIntegration" Public.setTeamFeatureConfig False False + +testConversationGuestLinksInternal :: (HasCallStack) => App () +testConversationGuestLinksInternal = _testSimpleFlagWithLockStatus "conversationGuestLinks" Internal.setTeamFeatureConfig True True + +testFileSharingInternal :: (HasCallStack) => App () +testFileSharingInternal = _testSimpleFlagWithLockStatus "fileSharing" Internal.setTeamFeatureConfig True True + +testSndFactorPasswordChallengeInternal :: (HasCallStack) => App () +testSndFactorPasswordChallengeInternal = _testSimpleFlagWithLockStatus "sndFactorPasswordChallenge" Internal.setTeamFeatureConfig False False + +testOutlookCalIntegrationInternal :: (HasCallStack) => App () +testOutlookCalIntegrationInternal = _testSimpleFlagWithLockStatus "outlookCalIntegration" Internal.setTeamFeatureConfig False False + +_testSimpleFlagWithLockStatus :: + (HasCallStack) => + String -> + (Value -> String -> String -> Value -> App Response) -> + Bool -> + Bool -> + App () +_testSimpleFlagWithLockStatus featureName setFeatureConfig featureEnabledByDefault featureUnlockedByDefault = do + -- let defaultStatus = if featureEnabledByDefault then "enabled" else "disabled" + defaultValue <- (if featureEnabledByDefault then enabled else disabled) & setField "lockStatus" (if featureUnlockedByDefault then "unlocked" else "locked") + let thisStatus = if featureEnabledByDefault then "enabled" else "disabled" + let otherStatus = if featureEnabledByDefault then "disabled" else "enabled" + + (owner, tid, m : _) <- createTeam OwnDomain 2 + nonTeamMember <- randomUser OwnDomain def + assertForbidden =<< Public.getTeamFeature nonTeamMember tid featureName + + checkFeature featureName m tid defaultValue + + -- unlock feature if it is locked + unless featureUnlockedByDefault $ Internal.setTeamFeatureLockStatus OwnDomain tid featureName "unlocked" + + -- change the status + let otherValue = if featureEnabledByDefault then disabled else enabled + void $ withWebSockets [m] $ \wss -> do + assertSuccess =<< setFeatureConfig owner tid featureName (object ["status" .= otherStatus]) + for_ wss $ \ws -> do + notif <- awaitMatch isFeatureConfigUpdateNotif ws + notif %. "payload.0.name" `shouldMatch` featureName + notif %. "payload.0.data" `shouldMatch` otherValue + + checkFeature featureName m tid otherValue + + bindResponse (setFeatureConfig owner tid featureName (object ["status" .= thisStatus])) $ \resp -> do + resp.status `shouldMatchInt` 200 + checkFeature featureName m tid (object ["status" .= thisStatus, "lockStatus" .= "unlocked", "ttl" .= "unlimited"]) + + bindResponse (setFeatureConfig owner tid featureName (object ["status" .= otherStatus])) $ \resp -> do + resp.status `shouldMatchInt` 200 + checkFeature featureName m tid (object ["status" .= otherStatus, "lockStatus" .= "unlocked", "ttl" .= "unlimited"]) + + -- lock feature + Internal.setTeamFeatureLockStatus OwnDomain tid featureName "locked" + + -- feature status should be the default again + checkFeature featureName m tid =<< setField "lockStatus" "locked" defaultValue + assertStatus 409 =<< setFeatureConfig owner tid featureName (object ["status" .= otherStatus]) + + -- unlock again + Internal.setTeamFeatureLockStatus OwnDomain tid featureName "unlocked" + + -- feature status should be the previously set status again + checkFeature featureName m tid =<< setField "lockStatus" "unlocked" otherValue + +testClassifiedDomainsEnabled :: (HasCallStack) => App () +testClassifiedDomainsEnabled = do + (_, tid, m : _) <- createTeam OwnDomain 2 + expected <- enabled & setField "config.domains" ["example.com"] + checkFeature "classifiedDomains" m tid expected + +testClassifiedDomainsDisabled :: (HasCallStack) => App () +testClassifiedDomainsDisabled = do + withModifiedBackend def {galleyCfg = setField "settings.featureFlags.classifiedDomains" (object ["status" .= "disabled", "config" .= object ["domains" .= ["example.com"]]])} $ \domain -> do + (_, tid, m : _) <- createTeam domain 2 + expected <- disabled & setField "config.domains" ["example.com"] + checkFeature "classifiedDomains" m tid expected + +-- | Call 'GET /teams/:tid/features' and 'GET /feature-configs', and check if all +-- features are there. +testAllFeatures :: (HasCallStack) => App () +testAllFeatures = do + (_, tid, m : _) <- createTeam OwnDomain 2 + let expected = + object + $ [ "legalhold" .= disabled, + "sso" .= disabled, + "searchVisibility" .= disabled, + "validateSAMLemails" .= enabled, + "digitalSignatures" .= disabled, + "appLock" .= object ["lockStatus" .= "unlocked", "status" .= "enabled", "ttl" .= "unlimited", "config" .= object ["enforceAppLock" .= False, "inactivityTimeoutSecs" .= A.Number 60]], + "fileSharing" .= enabled, + "classifiedDomains" .= object ["lockStatus" .= "unlocked", "status" .= "enabled", "ttl" .= "unlimited", "config" .= object ["domains" .= ["example.com"]]], + "conferenceCalling" .= enabled, + "selfDeletingMessages" .= object ["lockStatus" .= "unlocked", "status" .= "enabled", "ttl" .= "unlimited", "config" .= object ["enforcedTimeoutSeconds" .= A.Number 0]], + "conversationGuestLinks" .= enabled, + "sndFactorPasswordChallenge" .= disabledLocked, + "mls" + .= object + [ "lockStatus" .= "unlocked", + "status" .= "disabled", + "ttl" .= "unlimited", + "config" + .= object + [ "protocolToggleUsers" .= ([] :: [String]), + "defaultProtocol" .= "proteus", + "supportedProtocols" .= ["proteus", "mls"], + "allowedCipherSuites" .= ([1] :: [Int]), + "defaultCipherSuite" .= A.Number 1 + ] + ], + "searchVisibilityInbound" .= disabled, + "exposeInvitationURLsToTeamAdmin" .= disabledLocked, + "outlookCalIntegration" .= disabledLocked, + "mlsE2EId" + .= object + [ "lockStatus" .= "unlocked", + "status" .= "disabled", + "ttl" .= "unlimited", + "config" + .= object + [ "verificationExpiration" .= A.Number 86400, + "useProxyOnMobile" .= False + ] + ], + "mlsMigration" + .= object + [ "lockStatus" .= "locked", + "status" .= "enabled", + "ttl" .= "unlimited", + "config" + .= object + [ "startTime" .= "2029-05-16T10:11:12.123Z", + "finaliseRegardlessAfter" .= "2029-10-17T00:00:00Z" + ] + ], + "enforceFileDownloadLocation" .= object ["lockStatus" .= "locked", "status" .= "disabled", "ttl" .= "unlimited", "config" .= object []], + "limitedEventFanout" .= disabled + ] + bindResponse (Public.getTeamFeatures m tid) $ \resp -> do + resp.status `shouldMatchInt` 200 + expected `shouldMatch` resp.json + + -- This block catches potential errors in the logic that reverts to default if there is a distinction made between + -- 1. there is no row for a team_id in galley.team_features + -- 2. there is a row for team_id in galley.team_features but the feature has a no entry (null value) + Internal.setTeamFeatureConfig OwnDomain tid "conversationGuestLinks" enabled >>= assertSuccess + + bindResponse (Public.getTeamFeatures m tid) $ \resp -> do resp.status `shouldMatchInt` 200 - resp.json `shouldMatch` expected - bindResponse (Public.getFeatureConfigs user) $ \resp -> do + expected `shouldMatch` resp.json + + bindResponse (Public.getFeatureConfigs m) $ \resp -> do + resp.status `shouldMatchInt` 200 + expected `shouldMatch` resp.json + + randomPersonalUser <- randomUser OwnDomain def + + bindResponse (Public.getFeatureConfigs randomPersonalUser) $ \resp -> do + resp.status `shouldMatchInt` 200 + expected `shouldMatch` resp.json + +testFeatureConfigConsistency :: (HasCallStack) => App () +testFeatureConfigConsistency = do + (_, tid, m : _) <- createTeam OwnDomain 2 + + allFeaturesRes <- Public.getFeatureConfigs m >>= parseObjectKeys + + allTeamFeaturesRes <- Public.getTeamFeatures m tid >>= parseObjectKeys + + unless (allTeamFeaturesRes `Set.isSubsetOf` allFeaturesRes) + $ assertFailure (show allTeamFeaturesRes <> " is not a subset of " <> show allFeaturesRes) + where + parseObjectKeys :: Response -> App (Set.Set String) + parseObjectKeys res = do + val <- res.json + case val of + (A.Object hm) -> pure (Set.fromList . map (show . A.toText) . KM.keys $ hm) + x -> assertFailure ("JSON was not an object, but " <> show x) + +testSelfDeletingMessages :: (HasCallStack) => App () +testSelfDeletingMessages = + _testLockStatusWithConfig + "selfDeletingMessages" + Public.setTeamFeatureConfig + (object ["lockStatus" .= "unlocked", "status" .= "enabled", "ttl" .= "unlimited", "config" .= object ["enforcedTimeoutSeconds" .= A.Number 0]]) + (object ["status" .= "disabled", "config" .= object ["enforcedTimeoutSeconds" .= A.Number 0]]) + (object ["status" .= "enabled", "config" .= object ["enforcedTimeoutSeconds" .= A.Number 30]]) + (object ["status" .= "enabled", "config" .= object ["enforcedTimeoutSeconds" .= ""]]) + +testSelfDeletingMessagesInternal :: (HasCallStack) => App () +testSelfDeletingMessagesInternal = + _testLockStatusWithConfig + "selfDeletingMessages" + Internal.setTeamFeatureConfig + (object ["lockStatus" .= "unlocked", "status" .= "enabled", "ttl" .= "unlimited", "config" .= object ["enforcedTimeoutSeconds" .= A.Number 0]]) + (object ["status" .= "disabled", "config" .= object ["enforcedTimeoutSeconds" .= A.Number 0]]) + (object ["status" .= "enabled", "config" .= object ["enforcedTimeoutSeconds" .= A.Number 30]]) + (object ["status" .= "enabled", "config" .= object ["enforcedTimeoutSeconds" .= ""]]) + +testMls :: (HasCallStack) => App () +testMls = do + user <- randomUser OwnDomain def + uid <- asString $ user %. "id" + _testLockStatusWithConfig + "mls" + Public.setTeamFeatureConfig + mlsDefaultConfig + (mlsConfig1 uid) + mlsConfig2 + mlsInvalidConfig + +testMlsInternal :: (HasCallStack) => App () +testMlsInternal = do + user <- randomUser OwnDomain def + uid <- asString $ user %. "id" + _testLockStatusWithConfig + "mls" + Internal.setTeamFeatureConfig + mlsDefaultConfig + (mlsConfig1 uid) + mlsConfig2 + mlsInvalidConfig + +mlsDefaultConfig :: Value +mlsDefaultConfig = + object + [ "lockStatus" .= "unlocked", + "status" .= "disabled", + "ttl" .= "unlimited", + "config" + .= object + [ "protocolToggleUsers" .= ([] :: [String]), + "defaultProtocol" .= "proteus", + "supportedProtocols" .= ["proteus", "mls"], + "allowedCipherSuites" .= ([1] :: [Int]), + "defaultCipherSuite" .= A.Number 1 + ] + ] + +mlsConfig1 :: String -> Value +mlsConfig1 uid = + object + [ "status" .= "enabled", + "config" + .= object + [ "protocolToggleUsers" .= [uid], + "defaultProtocol" .= "mls", + "supportedProtocols" .= ["proteus", "mls"], + "allowedCipherSuites" .= ([1] :: [Int]), + "defaultCipherSuite" .= A.Number 1 + ] + ] + +mlsConfig2 :: Value +mlsConfig2 = + object + [ "status" .= "enabled", + "config" + .= object + [ "protocolToggleUsers" .= ([] :: [String]), + "defaultProtocol" .= "mls", + "supportedProtocols" .= ["mls"], + "allowedCipherSuites" .= ([1] :: [Int]), + "defaultCipherSuite" .= A.Number 1 + ] + ] + +mlsInvalidConfig :: Value +mlsInvalidConfig = + object + [ "status" .= "enabled", + "config" + .= object + [ "protocolToggleUsers" .= ([] :: [String]), + "defaultProtocol" .= "mls", + "supportedProtocols" .= ["proteus"], + "allowedCipherSuites" .= ([1] :: [Int]), + "defaultCipherSuite" .= A.Number 1 + ] + ] + +testEnforceDownloadLocation :: (HasCallStack) => App () +testEnforceDownloadLocation = + _testLockStatusWithConfig + "enforceFileDownloadLocation" + Public.setTeamFeatureConfig + (object ["lockStatus" .= "locked", "status" .= "disabled", "ttl" .= "unlimited", "config" .= object []]) + (object ["status" .= "enabled", "config" .= object ["enforcedDownloadLocation" .= "/tmp"]]) + (object ["status" .= "disabled", "config" .= object []]) + (object ["status" .= "enabled", "config" .= object ["enforcedDownloadLocation" .= object []]]) + +testEnforceDownloadLocationInternal :: (HasCallStack) => App () +testEnforceDownloadLocationInternal = + _testLockStatusWithConfig + "enforceFileDownloadLocation" + Internal.setTeamFeatureConfig + (object ["lockStatus" .= "locked", "status" .= "disabled", "ttl" .= "unlimited", "config" .= object []]) + (object ["status" .= "enabled", "config" .= object ["enforcedDownloadLocation" .= "/tmp"]]) + (object ["status" .= "disabled", "config" .= object []]) + (object ["status" .= "enabled", "config" .= object ["enforcedDownloadLocation" .= object []]]) + +testMlsMigration :: (HasCallStack) => App () +testMlsMigration = do + -- first we have to enable mls + (owner, tid, m : _) <- createTeam OwnDomain 2 + assertSuccess =<< Public.setTeamFeatureConfig owner tid "mls" mlsEnableConfig + _testLockStatusWithConfigWithTeam + (owner, tid, m) + "mlsMigration" + Public.setTeamFeatureConfig + mlsMigrationDefaultConfig + mlsMigrationConfig1 + mlsMigrationConfig2 + mlsMigrationInvalidConfig + +testMlsMigrationInternal :: (HasCallStack) => App () +testMlsMigrationInternal = do + -- first we have to enable mls + (owner, tid, m : _) <- createTeam OwnDomain 2 + assertSuccess =<< Public.setTeamFeatureConfig owner tid "mls" mlsEnableConfig + _testLockStatusWithConfigWithTeam + (owner, tid, m) + "mlsMigration" + Internal.setTeamFeatureConfig + mlsMigrationDefaultConfig + mlsMigrationConfig1 + mlsMigrationConfig2 + mlsMigrationInvalidConfig + +mlsEnableConfig :: Value +mlsEnableConfig = + object + [ "status" .= "enabled", + "config" + .= object + [ "protocolToggleUsers" .= ([] :: [String]), + "defaultProtocol" .= "mls", + "supportedProtocols" .= ["mls"], + "allowedCipherSuites" .= ([1] :: [Int]), + "defaultCipherSuite" .= A.Number 1 + ] + ] + +mlsMigrationDefaultConfig :: Value +mlsMigrationDefaultConfig = + object + [ "lockStatus" .= "locked", + "status" .= "enabled", + "ttl" .= "unlimited", + "config" + .= object + [ "startTime" .= "2029-05-16T10:11:12.123Z", + "finaliseRegardlessAfter" .= "2029-10-17T00:00:00Z" + ] + ] + +mlsMigrationConfig1 :: Value +mlsMigrationConfig1 = + object + [ "status" .= "enabled", + "config" + .= object + [ "startTime" .= "2029-05-16T10:11:12.123Z", + "finaliseRegardlessAfter" .= "2030-10-17T00:00:00Z" + ] + ] + +mlsMigrationConfig2 :: Value +mlsMigrationConfig2 = + object + [ "status" .= "enabled", + "config" + .= object + [ "startTime" .= "2030-05-16T10:11:12.123Z", + "finaliseRegardlessAfter" .= "2031-10-17T00:00:00Z" + ] + ] + +mlsMigrationInvalidConfig :: Value +mlsMigrationInvalidConfig = + object + [ "status" .= "enabled", + "config" + .= object + [ "startTime" .= A.Number 1 + ] + ] + +mlsE2EIdConfig :: App (Value, Value, Value, Value) +mlsE2EIdConfig = do + cfg2 <- + mlsE2EIdConfig1 + & setField "config.verificationExpiration" (A.Number 86401) + & setField "config.useProxyOnMobile" True + invalidConfig <- cfg2 & removeField "config.crlProxy" + pure (mlsE2EIdDefConfig, mlsE2EIdConfig1, cfg2, invalidConfig) + where + mlsE2EIdDefConfig :: Value + mlsE2EIdDefConfig = + object + [ "lockStatus" .= "unlocked", + "status" .= "disabled", + "ttl" .= "unlimited", + "config" + .= object + [ "verificationExpiration" .= A.Number 86400, + "useProxyOnMobile" .= False + ] + ] + mlsE2EIdConfig1 :: Value + mlsE2EIdConfig1 = + object + [ "status" .= "enabled", + "config" + .= object + [ "crlProxy" .= "https://example.com", + "verificationExpiration" .= A.Number 86400, + "useProxyOnMobile" .= False + ] + ] + +testMLSE2EId :: (HasCallStack) => App () +testMLSE2EId = do + (defCfg, cfg1, cfg2, invalidCfg) <- mlsE2EIdConfig + _testLockStatusWithConfig + "mlsE2EId" + Public.setTeamFeatureConfig + defCfg + cfg1 + cfg2 + invalidCfg + +testMLSE2EIdInternal :: (HasCallStack) => App () +testMLSE2EIdInternal = do + (defCfg, cfg1, cfg2, invalidCfg) <- mlsE2EIdConfig + -- the internal API is not as strict as the public one, so we need to tweak the invalid config some more + invalidCfg' <- invalidCfg & setField "config.crlProxy" (object []) + _testLockStatusWithConfig + "mlsE2EId" + Internal.setTeamFeatureConfig + defCfg + cfg1 + cfg2 + invalidCfg' + +_testLockStatusWithConfig :: + (HasCallStack) => + String -> + (Value -> String -> String -> Value -> App Response) -> + -- | the default feature config (should include the lock status and ttl, as it is returned by the API) + Value -> + -- | a valid config used to update the feature setting (should not include the lock status and ttl, as these are not part of the request payload) + Value -> + -- | another valid config + Value -> + -- | an invalid config + Value -> + App () +_testLockStatusWithConfig featureName setTeamFeatureConfig defaultFeatureConfig config1 config2 invalidConfig = do + (owner, tid, m : _) <- createTeam OwnDomain 2 + _testLockStatusWithConfigWithTeam (owner, tid, m) featureName setTeamFeatureConfig defaultFeatureConfig config1 config2 invalidConfig + +_testLockStatusWithConfigWithTeam :: + (HasCallStack) => + -- | (owner, tid, member) + (Value, String, Value) -> + String -> + (Value -> String -> String -> Value -> App Response) -> + -- | the default feature config (should include the lock status and ttl, as it is returned by the API) + Value -> + -- | a valid config used to update the feature setting (should not include the lock status and ttl, as these are not part of the request payload) + Value -> + -- | another valid config + Value -> + -- | an invalid config + Value -> + App () +_testLockStatusWithConfigWithTeam (owner, tid, m) featureName setTeamFeatureConfig defaultFeatureConfig config1 config2 invalidConfig = do + -- personal user + randomPersonalUser <- randomUser OwnDomain def + + bindResponse (Public.getFeatureConfigs randomPersonalUser) $ \resp -> do resp.status `shouldMatchInt` 200 - resp.json %. feature `shouldMatch` expected + resp.json %. featureName `shouldMatch` defaultFeatureConfig + + -- team user + nonTeamMember <- randomUser OwnDomain def + assertForbidden =<< Public.getTeamFeature nonTeamMember tid featureName + + checkFeature featureName m tid defaultFeatureConfig + + -- lock the feature + Internal.setTeamFeatureLockStatus OwnDomain tid featureName "locked" + assertStatus 409 =<< setTeamFeatureConfig owner tid featureName config1 + Internal.setTeamFeatureLockStatus OwnDomain tid featureName "unlocked" + + void $ withWebSockets [m] $ \wss -> do + assertSuccess =<< setTeamFeatureConfig owner tid featureName config1 + for_ wss $ \ws -> do + notif <- awaitMatch isFeatureConfigUpdateNotif ws + notif %. "payload.0.name" `shouldMatch` featureName + notif %. "payload.0.data" `shouldMatch` (config1 & setField "lockStatus" "unlocked" & setField "ttl" "unlimited") + + checkFeature featureName m tid =<< (config1 & setField "lockStatus" "unlocked" & setField "ttl" "unlimited") + + Internal.setTeamFeatureLockStatus OwnDomain tid featureName "locked" + checkFeature featureName m tid =<< setField "lockStatus" "locked" defaultFeatureConfig + Internal.setTeamFeatureLockStatus OwnDomain tid featureName "unlocked" + + void $ withWebSockets [m] $ \wss -> do + assertStatus 400 =<< setTeamFeatureConfig owner tid featureName invalidConfig + for_ wss $ assertNoEvent 2 + + checkFeature featureName m tid =<< (config1 & setField "lockStatus" "unlocked" & setField "ttl" "unlimited") + + void $ withWebSockets [m] $ \wss -> do + assertSuccess =<< setTeamFeatureConfig owner tid featureName config2 + for_ wss $ \ws -> do + notif <- awaitMatch isFeatureConfigUpdateNotif ws + notif %. "payload.0.name" `shouldMatch` featureName + notif %. "payload.0.data" `shouldMatch` (config2 & setField "lockStatus" "unlocked" & setField "ttl" "unlimited") + + checkFeature featureName m tid =<< (config2 & setField "lockStatus" "unlocked" & setField "ttl" "unlimited") + +testFeatureNoConfigMultiSearchVisibilityInbound :: (HasCallStack) => App () +testFeatureNoConfigMultiSearchVisibilityInbound = do + (_owner1, team1, _) <- createTeam OwnDomain 0 + (_owner2, team2, _) <- createTeam OwnDomain 0 + + assertSuccess =<< Internal.setTeamFeatureStatus OwnDomain team2 "searchVisibilityInbound" "enabled" + + response <- Internal.getFeatureStatusMulti OwnDomain "searchVisibilityInbound" [team1, team2] + + statuses <- response.json %. "default_status" >>= asList + length statuses `shouldMatchInt` 2 + statuses `shouldMatchSet` [object ["team" .= team1, "status" .= "disabled"], object ["team" .= team2, "status" .= "enabled"]] + +testConferenceCallingTTLIncreaseToUnlimited :: (HasCallStack) => App () +testConferenceCallingTTLIncreaseToUnlimited = _testSimpleFlagTTLOverride "conferenceCalling" True (Just 2) Nothing + +testConferenceCallingTTLIncrease :: (HasCallStack) => App () +testConferenceCallingTTLIncrease = _testSimpleFlagTTLOverride "conferenceCalling" True (Just 2) (Just 4) + +testConferenceCallingTTLReduceFromUnlimited :: (HasCallStack) => App () +testConferenceCallingTTLReduceFromUnlimited = _testSimpleFlagTTLOverride "conferenceCalling" True Nothing (Just 2) + +testConferenceCallingTTLReduce :: (HasCallStack) => App () +testConferenceCallingTTLReduce = _testSimpleFlagTTLOverride "conferenceCalling" True (Just 5) (Just 2) + +testConferenceCallingTTLUnlimitedToUnlimited :: (HasCallStack) => App () +testConferenceCallingTTLUnlimitedToUnlimited = _testSimpleFlagTTLOverride "conferenceCalling" True Nothing Nothing + +_testSimpleFlagTTLOverride :: (HasCallStack) => String -> Bool -> Maybe Int -> Maybe Int -> App () +_testSimpleFlagTTLOverride featureName enabledByDefault mTtl mTtlAfter = do + let ttl = maybe (A.String . cs $ "unlimited") (A.Number . fromIntegral) mTtl + let ttlAfter = maybe (A.String . cs $ "unlimited") (A.Number . fromIntegral) mTtlAfter + (owner, tid, _) <- createTeam OwnDomain 0 + let (defaultValue, otherValue) = if enabledByDefault then ("enabled", "disabled") else ("disabled", "enabled") + + -- Initial value should be the default value + let defFeatureStatus = object ["status" .= defaultValue, "ttl" .= "unlimited", "lockStatus" .= "unlocked"] + checkFeature featureName owner tid defFeatureStatus + + -- Setting should work + assertSuccess =<< Internal.setTeamFeatureConfig OwnDomain tid featureName (object ["status" .= otherValue, "ttl" .= ttl]) + checkFeatureLenientTtl featureName owner tid (object ["status" .= otherValue, "ttl" .= ttl, "lockStatus" .= "unlocked"]) + + case (mTtl, mTtlAfter) of + (Just d, Just d') -> do + -- wait less than expiration, override and recheck. + liftIO $ threadDelay (d * 1000000 `div` 2) -- waiting half of TTL + -- setFlagInternal otherValue ttlAfter + assertSuccess =<< Internal.setTeamFeatureConfig OwnDomain tid featureName (object ["status" .= otherValue, "ttl" .= ttlAfter]) + -- value is still correct + checkFeatureLenientTtl featureName owner tid (object ["status" .= otherValue, "ttl" .= ttlAfter, "lockStatus" .= "unlocked"]) + + liftIO $ threadDelay (d' * 1000000) -- waiting for new TTL + checkFeatureLenientTtl featureName owner tid defFeatureStatus + (Just d, Nothing) -> do + -- wait less than expiration, override and recheck. + liftIO $ threadDelay (d * 1000000 `div` 2) -- waiting half of TTL + assertSuccess =<< Internal.setTeamFeatureConfig OwnDomain tid featureName (object ["status" .= otherValue, "ttl" .= ttlAfter]) + -- value is still correct + checkFeatureLenientTtl featureName owner tid (object ["status" .= otherValue, "ttl" .= ttlAfter, "lockStatus" .= "unlocked"]) + (Nothing, Nothing) -> do + -- overriding in this case should have no effect. + assertSuccess =<< Internal.setTeamFeatureConfig OwnDomain tid featureName (object ["status" .= otherValue, "ttl" .= ttl]) + checkFeatureLenientTtl featureName owner tid (object ["status" .= otherValue, "ttl" .= ttl, "lockStatus" .= "unlocked"]) + (Nothing, Just d) -> do + assertSuccess =<< Internal.setTeamFeatureConfig OwnDomain tid featureName (object ["status" .= otherValue, "ttl" .= ttlAfter]) + checkFeatureLenientTtl featureName owner tid (object ["status" .= otherValue, "ttl" .= ttlAfter, "lockStatus" .= "unlocked"]) + liftIO $ threadDelay (d * 1000000) -- waiting it out + -- value reverts back + checkFeatureLenientTtl featureName owner tid defFeatureStatus + +-------------------------------------------------------------------------------- +-- Simple flags with implicit lock status + +testPatchSearchVisibility :: (HasCallStack) => App () +testPatchSearchVisibility = _testPatch "searchVisibility" False disabled enabled + +testPatchValidateSAMLEmails :: (HasCallStack) => App () +testPatchValidateSAMLEmails = _testPatch "validateSAMLemails" False enabled disabled + +testPatchDigitalSignatures :: (HasCallStack) => App () +testPatchDigitalSignatures = _testPatch "digitalSignatures" False disabled enabled + +testPatchConferenceCalling :: (HasCallStack) => App () +testPatchConferenceCalling = _testPatch "conferenceCalling" False enabled disabled + +-------------------------------------------------------------------------------- +-- Simple flags with explicit lock status + +testPatchFileSharing :: (HasCallStack) => App () +testPatchFileSharing = _testPatch "fileSharing" True enabled disabled + +testPatchGuestLinks :: (HasCallStack) => App () +testPatchGuestLinks = _testPatch "conversationGuestLinks" True enabled disabled + +testPatchSndFactorPasswordChallenge :: (HasCallStack) => App () +testPatchSndFactorPasswordChallenge = _testPatch "sndFactorPasswordChallenge" True disabledLocked enabled + +testPatchOutlookCalIntegration :: (HasCallStack) => App () +testPatchOutlookCalIntegration = _testPatch "outlookCalIntegration" True disabledLocked enabled + +-------------------------------------------------------------------------------- +-- Flags with config & implicit lock status + +testPatchAppLock :: (HasCallStack) => App () +testPatchAppLock = do + let defCfg = + object + [ "lockStatus" .= "unlocked", + "status" .= "enabled", + "ttl" .= "unlimited", + "config" .= object ["enforceAppLock" .= False, "inactivityTimeoutSecs" .= A.Number 60] + ] + _testPatch "appLock" False defCfg (object ["lockStatus" .= "locked"]) + _testPatch "appLock" False defCfg (object ["status" .= "disabled"]) + _testPatch "appLock" False defCfg (object ["lockStatus" .= "locked", "status" .= "disabled"]) + _testPatch "appLock" False defCfg (object ["lockStatus" .= "unlocked", "config" .= object ["enforceAppLock" .= True, "inactivityTimeoutSecs" .= A.Number 120]]) + _testPatch "appLock" False defCfg (object ["config" .= object ["enforceAppLock" .= True, "inactivityTimeoutSecs" .= A.Number 240]]) + +-------------------------------------------------------------------------------- +-- Flags with config & explicit lock status + +testPatchSelfDeletingMessages :: (HasCallStack) => App () +testPatchSelfDeletingMessages = do + let defCfg = + object + [ "lockStatus" .= "unlocked", + "status" .= "enabled", + "ttl" .= "unlimited", + "config" .= object ["enforcedTimeoutSeconds" .= A.Number 0] + ] + _testPatch "selfDeletingMessages" True defCfg (object ["lockStatus" .= "locked"]) + _testPatch "selfDeletingMessages" True defCfg (object ["status" .= "disabled"]) + _testPatch "selfDeletingMessages" True defCfg (object ["lockStatus" .= "locked", "status" .= "disabled"]) + _testPatch "selfDeletingMessages" True defCfg (object ["lockStatus" .= "unlocked", "config" .= object ["enforcedTimeoutSeconds" .= A.Number 30]]) + _testPatch "selfDeletingMessages" True defCfg (object ["config" .= object ["enforcedTimeoutSeconds" .= A.Number 60]]) + +testPatchEnforceFileDownloadLocation :: (HasCallStack) => App () +testPatchEnforceFileDownloadLocation = do + let defCfg = + object + [ "lockStatus" .= "locked", + "status" .= "disabled", + "ttl" .= "unlimited", + "config" .= object [] + ] + _testPatch "enforceFileDownloadLocation" True defCfg (object ["lockStatus" .= "unlocked"]) + _testPatch "enforceFileDownloadLocation" True defCfg (object ["status" .= "enabled"]) + _testPatch "enforceFileDownloadLocation" True defCfg (object ["lockStatus" .= "unlocked", "status" .= "enabled"]) + _testPatch "enforceFileDownloadLocation" True defCfg (object ["lockStatus" .= "locked", "config" .= object []]) + _testPatch "enforceFileDownloadLocation" True defCfg (object ["config" .= object ["enforcedDownloadLocation" .= "/tmp"]]) + +testPatchE2EId :: (HasCallStack) => App () +testPatchE2EId = do + let defCfg = + object + [ "lockStatus" .= "unlocked", + "status" .= "disabled", + "ttl" .= "unlimited", + "config" + .= object + [ "verificationExpiration" .= A.Number 86400, + "useProxyOnMobile" .= False + ] + ] + _testPatch "mlsE2EId" True defCfg (object ["lockStatus" .= "locked"]) + _testPatch "mlsE2EId" True defCfg (object ["status" .= "enabled"]) + _testPatch "mlsE2EId" True defCfg (object ["lockStatus" .= "locked", "status" .= "enabled"]) + _testPatch + "mlsE2EId" + True + defCfg + ( object + [ "lockStatus" .= "unlocked", + "config" + .= object + [ "crlProxy" .= "https://example.com", + "verificationExpiration" .= A.Number 86401, + "useProxyOnMobile" .= True + ] + ] + ) + _testPatch + "mlsE2EId" + True + defCfg + ( object + [ "config" + .= object + [ "crlProxy" .= "https://example.com", + "verificationExpiration" .= A.Number 86401, + "useProxyOnMobile" .= True + ] + ] + ) + +testPatchMLS :: (HasCallStack) => App () +testPatchMLS = do + dom <- asString OwnDomain + (_, tid, _) <- createTeam dom 0 + assertSuccess + =<< Internal.patchTeamFeature + dom + tid + "mlsMigration" + (object ["status" .= "disabled", "lockStatus" .= "unlocked"]) + let defCfg = + object + [ "lockStatus" .= "unlocked", + "status" .= "disabled", + "ttl" .= "unlimited", + "config" + .= object + [ "protocolToggleUsers" .= ([] :: [String]), + "defaultProtocol" .= "proteus", + "supportedProtocols" .= ["proteus", "mls"], + "allowedCipherSuites" .= ([1] :: [Int]), + "defaultCipherSuite" .= A.Number 1 + ] + ] + _testPatchWithSetup mlsMigrationSetup dom "mls" True defCfg (object ["lockStatus" .= "locked"]) + _testPatchWithSetup mlsMigrationSetup dom "mls" True defCfg (object ["status" .= "enabled"]) + _testPatchWithSetup mlsMigrationSetup dom "mls" True defCfg (object ["lockStatus" .= "locked", "status" .= "enabled"]) + _testPatchWithSetup + mlsMigrationSetup + dom + "mls" + True + defCfg + ( object + [ "status" .= "enabled", + "config" + .= object + [ "protocolToggleUsers" .= ([] :: [String]), + "defaultProtocol" .= "mls", + "supportedProtocols" .= ["proteus", "mls"], + "allowedCipherSuites" .= ([1] :: [Int]), + "defaultCipherSuite" .= A.Number 1 + ] + ] + ) + _testPatchWithSetup + mlsMigrationSetup + dom + "mls" + True + defCfg + ( object + [ "config" + .= object + [ "protocolToggleUsers" .= ([] :: [String]), + "defaultProtocol" .= "mls", + "supportedProtocols" .= ["proteus", "mls"], + "allowedCipherSuites" .= ([1] :: [Int]), + "defaultCipherSuite" .= A.Number 1 + ] + ] + ) + where + mlsMigrationSetup :: (HasCallStack) => String -> String -> App () + mlsMigrationSetup dom tid = + assertSuccess + =<< Internal.patchTeamFeature + dom + tid + "mlsMigration" + (object ["status" .= "disabled", "lockStatus" .= "unlocked"]) + +_testPatch :: (HasCallStack) => String -> Bool -> Value -> Value -> App () +_testPatch featureName hasExplicitLockStatus defaultFeatureConfig patch = do + dom <- asString OwnDomain + _testPatchWithSetup + (\_ _ -> pure ()) + dom + featureName + hasExplicitLockStatus + defaultFeatureConfig + patch + +_testPatchWithSetup :: + (HasCallStack) => + (String -> String -> App ()) -> + String -> + String -> + Bool -> + Value -> + Value -> + App () +_testPatchWithSetup setup domain featureName hasExplicitLockStatus defaultFeatureConfig patch = do + (owner, tid, _) <- createTeam domain 0 + -- run a feature-specific setup. For most features this is a no-op. + setup domain tid + + checkFeature featureName owner tid defaultFeatureConfig + assertSuccess =<< Internal.patchTeamFeature domain tid featureName patch + patched <- (.json) =<< Internal.getTeamFeature domain tid featureName + checkFeature featureName owner tid patched + lockStatus <- patched %. "lockStatus" >>= asString + if lockStatus == "locked" + then do + -- if lock status is locked the feature status should fall back to the default + patched `shouldMatch` (defaultFeatureConfig & setField "lockStatus" "locked") + -- if lock status is locked, it was either locked before or changed by the patch + mPatchedLockStatus <- lookupField patch "lockStatus" + case mPatchedLockStatus of + Just ls -> ls `shouldMatch` "locked" + Nothing -> defaultFeatureConfig %. "lockStatus" `shouldMatch` "locked" + else do + patched %. "status" `shouldMatch` valueOrDefault "status" + mPatchedConfig <- lookupField patched "config" + case mPatchedConfig of + Just patchedConfig -> patchedConfig `shouldMatch` valueOrDefault "config" + Nothing -> do + mDefConfig <- lookupField defaultFeatureConfig "config" + assertBool "patch had an unexpected config field" (isNothing mDefConfig) + + when hasExplicitLockStatus $ do + -- if lock status is unlocked, it was either unlocked before or changed by the patch + mPatchedLockStatus <- lookupField patch "lockStatus" + case mPatchedLockStatus of + Just ls -> ls `shouldMatch` "unlocked" + Nothing -> defaultFeatureConfig %. "lockStatus" `shouldMatch` "unlocked" + where + valueOrDefault :: String -> App Value + valueOrDefault key = do + mValue <- lookupField patch key + maybe (defaultFeatureConfig %. key) pure mValue diff --git a/integration/test/Test/FeatureFlags/Util.hs b/integration/test/Test/FeatureFlags/Util.hs new file mode 100644 index 00000000000..92426fd5f4f --- /dev/null +++ b/integration/test/Test/FeatureFlags/Util.hs @@ -0,0 +1,89 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2023 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Test.FeatureFlags.Util where + +import qualified API.Galley as Public +import qualified API.GalleyInternal as Internal +import qualified Data.Aeson as A +import Testlib.Prelude + +disabled :: Value +disabled = object ["lockStatus" .= "unlocked", "status" .= "disabled", "ttl" .= "unlimited"] + +disabledLocked :: Value +disabledLocked = object ["lockStatus" .= "locked", "status" .= "disabled", "ttl" .= "unlimited"] + +enabled :: Value +enabled = object ["lockStatus" .= "unlocked", "status" .= "enabled", "ttl" .= "unlimited"] + +checkFeature :: (HasCallStack, MakesValue user, MakesValue tid) => String -> user -> tid -> Value -> App () +checkFeature = checkFeatureWith shouldMatch + +checkFeatureWith :: (HasCallStack, MakesValue user, MakesValue tid, MakesValue expected) => (App Value -> expected -> App ()) -> String -> user -> tid -> expected -> App () +checkFeatureWith shouldMatch' feature user tid expected = do + tidStr <- asString tid + domain <- objDomain user + bindResponse (Internal.getTeamFeature domain tidStr feature) $ \resp -> do + resp.status `shouldMatchInt` 200 + resp.json `shouldMatch'` expected + bindResponse (Public.getTeamFeatures user tid) $ \resp -> do + resp.status `shouldMatchInt` 200 + resp.json %. feature `shouldMatch'` expected + bindResponse (Public.getTeamFeature user tid feature) $ \resp -> do + resp.status `shouldMatchInt` 200 + resp.json `shouldMatch'` expected + bindResponse (Public.getFeatureConfigs user) $ \resp -> do + resp.status `shouldMatchInt` 200 + resp.json %. feature `shouldMatch'` expected + +checkFeatureLenientTtl :: (HasCallStack, MakesValue user, MakesValue tid) => String -> user -> tid -> Value -> App () +checkFeatureLenientTtl = checkFeatureWith shouldMatchLenientTtl + where + shouldMatchLenientTtl :: App Value -> Value -> App () + shouldMatchLenientTtl actual expected = do + expectedLockStatus <- expected %. "lockStatus" + actual %. "lockStatus" `shouldMatch` expectedLockStatus + expectedStatus <- expected %. "status" + actual %. "status" `shouldMatch` expectedStatus + mExpectedConfig <- lookupField expected "config" + mActualConfig <- lookupField actual "config" + mActualConfig `shouldMatch` mExpectedConfig + expectedTtl <- expected %. "ttl" + actualTtl <- actual %. "ttl" + checkTtl actualTtl expectedTtl + + checkTtl :: Value -> Value -> App () + checkTtl (A.String a) (A.String b) = do + a `shouldMatch` "unlimited" + b `shouldMatch` "unlimited" + checkTtl _ (A.String _) = assertFailure "expected the actual ttl to be unlimited, but it was limited" + checkTtl (A.String _) _ = assertFailure "expected the actual ttl to be limited, but it was unlimited" + checkTtl (A.Number actualTtl) (A.Number expectedTtl) = do + assertBool + ("expected the actual TTL to be greater than 0 and equal to or no more than 2 seconds less than " <> show expectedTtl <> ", but it was " <> show actualTtl) + ( actualTtl + > 0 + && actualTtl + <= expectedTtl + && abs (actualTtl - expectedTtl) + <= 2 + ) + checkTtl _ _ = assertFailure "unexpected ttl value(s)" + +assertForbidden :: (HasCallStack) => Response -> App () +assertForbidden = assertLabel 403 "no-team-member" diff --git a/integration/test/Test/Federation.hs b/integration/test/Test/Federation.hs index 6ac43c3d3c8..ff1f2ae2304 100644 --- a/integration/test/Test/Federation.hs +++ b/integration/test/Test/Federation.hs @@ -17,7 +17,7 @@ import SetupHelpers import Testlib.Prelude import Testlib.ResourcePool -testNotificationsForOfflineBackends :: HasCallStack => App () +testNotificationsForOfflineBackends :: (HasCallStack) => App () testNotificationsForOfflineBackends = do resourcePool <- asks (.resourcePool) -- `delUser` will eventually get deleted. diff --git a/integration/test/Test/Federator.hs b/integration/test/Test/Federator.hs index cabf7a1a522..ff097578bb5 100644 --- a/integration/test/Test/Federator.hs +++ b/integration/test/Test/Federator.hs @@ -18,8 +18,8 @@ runFederatorMetrics getService = do second <- bindResponse (getMetrics OwnDomain getService) handleRes assertBool "Two metric requests should never match" $ first.body /= second.body assertBool "Second metric response should never be 0 length (the first might be)" $ BS.length second.body /= 0 - assertBool "The seconds metric response should have text indicating that it is returning metrics" $ - BS.isInfixOf expectedString second.body + assertBool "The seconds metric response should have text indicating that it is returning metrics" + $ BS.isInfixOf expectedString second.body where expectedString = "# TYPE http_request_duration_seconds histogram" @@ -31,7 +31,7 @@ testFederatorMetricsInternal = runFederatorMetrics federatorInternal testFederatorMetricsExternal :: App () testFederatorMetricsExternal = runFederatorMetrics federatorExternal -testFederatorNumRequestsMetrics :: HasCallStack => App () +testFederatorNumRequestsMetrics :: (HasCallStack) => App () testFederatorNumRequestsMetrics = do u1 <- randomUser OwnDomain def u2 <- randomUser OtherDomain def diff --git a/integration/test/Test/LegalHold.hs b/integration/test/Test/LegalHold.hs index 175721bf399..22195f3afdb 100644 --- a/integration/test/Test/LegalHold.hs +++ b/integration/test/Test/LegalHold.hs @@ -23,9 +23,10 @@ import API.Common import API.Galley import API.GalleyInternal import Control.Error (MaybeT (MaybeT), runMaybeT) -import Control.Lens ((.~), (^?!)) +import Control.Lens ((.~), (^?), (^?!)) import Control.Monad.Reader (asks, local) import Control.Monad.Trans.Class (lift) +import Data.Aeson.Lens import qualified Data.ByteString.Char8 as BS8 import Data.ByteString.Lazy (LazyByteString) import qualified Data.Map as Map @@ -47,7 +48,7 @@ import UnliftIO (Chan, readChan, timeout) testLHPreventAddingNonConsentingUsers :: App () testLHPreventAddingNonConsentingUsers = do - withMockServer lhMockApp $ \lhDomAndPort _chan -> do + withMockServer def lhMockApp $ \lhDomAndPort _chan -> do (owner, tid, [alice, alex]) <- createTeam OwnDomain 3 legalholdWhitelistTeam tid owner >>= assertSuccess @@ -55,9 +56,12 @@ testLHPreventAddingNonConsentingUsers = do postLegalHoldSettings tid owner (mkLegalHoldSettings lhDomAndPort) >>= assertStatus 201 george <- randomUser OwnDomain def - georgeQId <- george %. "qualified_id" - connectUsers =<< forM [alice, george] make - connectUsers =<< forM [alex, george] make + georgeQId <- objQidObject george + hannes <- randomUser OwnDomain def + hannesQId <- objQidObject hannes + + connectUsers [alice, george, hannes] + connectUsers [alex, george, hannes] conv <- postConversation alice (defProteus {qualifiedUsers = [alex], team = Just tid}) >>= getJSON 201 -- the guest should be added to the conversation @@ -71,6 +75,16 @@ testLHPreventAddingNonConsentingUsers = do -- now request legalhold for alex (but not alice) requestLegalHoldDevice tid owner alex >>= assertSuccess + -- the guest should not be removed from the conversation before approving + checkConvHasOtherMembers conv alice [alex, george] + + -- it should be possible to add the another guest while the LH device is not approved + addMembers alex conv def {users = [hannesQId]} `bindResponse` \resp -> do + resp.status `shouldMatchInt` 200 + resp.json %. "type" `shouldMatch` "conversation.member-join" + checkConvHasOtherMembers conv alice [alex, george, hannes] + + approveLegalHoldDevice tid alex defPassword >>= assertSuccess -- the guest should be removed from the conversation checkConvHasOtherMembers conv alice [alex] @@ -81,33 +95,35 @@ testLHPreventAddingNonConsentingUsers = do addMembers alice conv def {users = [georgeQId]} >>= assertLabel 403 "missing-legalhold-consent" where - checkConvHasOtherMembers :: HasCallStack => Value -> Value -> [Value] -> App () + checkConvHasOtherMembers :: (HasCallStack) => Value -> Value -> [Value] -> App () checkConvHasOtherMembers conv u us = bindResponse (getConversation u conv) $ \resp -> do resp.status `shouldMatchInt` 200 mems <- - resp.json %. "members.others" & asList >>= traverse \m -> do - m %. "qualified_id" + resp.json %. "members.others" + & asList >>= traverse \m -> do + m %. "qualified_id" mems `shouldMatchSet` forM us (\m -> m %. "qualified_id") testLHMessageExchange :: - HasCallStack => + (HasCallStack) => TaggedBool "clients1New" -> TaggedBool "clients2New" -> - TaggedBool "consentFrom1" -> - TaggedBool "consentFrom2" -> App () -testLHMessageExchange (TaggedBool clients1New) (TaggedBool clients2New) (TaggedBool consentFrom1) (TaggedBool consentFrom2) = do - withMockServer lhMockApp $ \lhDomAndPort _chan -> do +testLHMessageExchange (TaggedBool clients1New) (TaggedBool clients2New) = do + -- We used to throw LegalholdConflictsOldClients if clients didn't have LH capability, but we + -- don't do that any more because that broke things. + -- Related: https://github.com/wireapp/wire-server/pull/4056 + withMockServer def lhMockApp $ \lhDomAndPort _chan -> do (owner, tid, [mem1, mem2]) <- createTeam OwnDomain 3 let clientSettings :: Bool -> AddClient clientSettings allnew = if allnew - then def -- (`{acapabilities = Just ["legalhold-implicit-consent"]}` is the default) + then def {acapabilities = Just ["legalhold-implicit-consent"]} -- (is should be the default) else def {acapabilities = Nothing} - client1 <- objId $ addClient (mem1 %. "qualified_id") (clientSettings clients1New) >>= getJSON 201 - _client2 <- objId $ addClient (mem2 %. "qualified_id") (clientSettings clients2New) >>= getJSON 201 + void $ addClient (mem1 %. "qualified_id") (clientSettings clients1New) >>= getJSON 201 + void $ addClient (mem2 %. "qualified_id") (clientSettings clients2New) >>= getJSON 201 legalholdWhitelistTeam tid owner >>= assertSuccess legalholdIsTeamInWhitelist tid owner >>= assertSuccess @@ -115,92 +131,64 @@ testLHMessageExchange (TaggedBool clients1New) (TaggedBool clients2New) (TaggedB conv <- postConversation mem1 (defProteus {qualifiedUsers = [mem2], team = Just tid}) >>= getJSON 201 + let getClients :: Value -> App [Value] + getClients mem = do + res <- getClientsQualified mem OwnDomain mem + val <- getJSON 200 res + asList val + + assertMessageSendingWorks :: (HasCallStack) => App () + assertMessageSendingWorks = do + clients1 <- getClients mem1 + clients2 <- getClients mem2 + + clientIds1 <- traverse objId clients1 + clientIds2 <- traverse objId clients2 + + proteusRecipients <- mkProteusRecipients mem1 [(mem1, clientIds1), (mem2, clientIds2)] "hey there" + + let proteusMsg senderClient = + Proto.defMessage @Proto.QualifiedNewOtrMessage + & #sender . Proto.client .~ (senderClient ^?! hex) + & #recipients .~ [proteusRecipients] + & #reportAll .~ Proto.defMessage + + sender clients = + let senderClient = head $ filter (\c -> c ^? key (fromString "type") /= Just (toJSON "legalhold")) clients + in T.unpack $ senderClient ^?! key (fromString "id") . _String + postProteusMessage mem1 (conv %. "qualified_id") (proteusMsg (sender clients1)) >>= assertSuccess + postProteusMessage mem2 (conv %. "qualified_id") (proteusMsg (sender clients2)) >>= assertSuccess + + assertMessageSendingWorks + requestLegalHoldDevice tid owner mem1 >>= assertSuccess + assertMessageSendingWorks + requestLegalHoldDevice tid owner mem2 >>= assertSuccess - when consentFrom1 $ do - approveLegalHoldDevice tid (mem1 %. "qualified_id") defPassword >>= assertSuccess - when consentFrom2 $ do - approveLegalHoldDevice tid (mem2 %. "qualified_id") defPassword >>= assertSuccess + assertMessageSendingWorks - let getCls :: Value -> App [String] - getCls mem = do - res <- getClientsQualified mem OwnDomain mem - val <- getJSON 200 res - cls <- asList val - objId `mapM` cls - cs1 :: [String] <- getCls mem1 -- it's ok to include the sender, backend will filter it out. - cs2 :: [String] <- getCls mem2 - - length cs1 `shouldMatchInt` if consentFrom1 then 2 else 1 - length cs2 `shouldMatchInt` if consentFrom2 then 2 else 1 - - do - successfulMsgForOtherUsers <- mkProteusRecipients mem1 [(mem1, cs1), (mem2, cs2)] "hey there" - let successfulMsg = - Proto.defMessage @Proto.QualifiedNewOtrMessage - & #sender . Proto.client .~ (client1 ^?! hex) - & #recipients .~ [successfulMsgForOtherUsers] - & #reportAll .~ Proto.defMessage - bindResponse (postProteusMessage mem1 (conv %. "qualified_id") successfulMsg) $ \resp -> do - let check :: HasCallStack => Int -> Maybe String -> App () - check status Nothing = do - resp.status `shouldMatchInt` status - check status (Just label) = do - resp.status `shouldMatchInt` status - resp.json %. "label" `shouldMatch` label - - let -- there are two equally valid ways to write this down (feel free to remove one if it gets in your way): - _oneWay = case (clients1New, clients2New, consentFrom1, consentFrom2) of - (_, _, False, False) -> - -- no LH in the picture - check 201 Nothing - (True, True, _, _) -> - if consentFrom1 /= consentFrom2 - then -- no old clients, but users disagree on LH - check 403 (Just "missing-legalhold-consent") - else -- everybody likes LH - check 201 Nothing - _ -> - -- everything else - check 403 (Just "missing-legalhold-consent-old-clients") - - theOtherWay = case (clients1New, clients2New, consentFrom1, consentFrom2) of - -- NB: "consent" always implies "has an active LH device" - (False, False, False, False) -> - -- no LH in the picture - check 201 Nothing - (False, True, False, False) -> - -- no LH in the picture - check 201 Nothing - (True, False, False, False) -> - -- no LH in the picture - check 201 Nothing - (True, True, False, False) -> - -- no LH in the picture - check 201 Nothing - (True, True, False, True) -> - -- all clients new, no consent from sender, recipient has LH device - check 403 (Just "missing-legalhold-consent") - (True, True, True, False) -> - -- all clients new, no consent from recipient, sender has LH device - check 403 (Just "missing-legalhold-consent") - (True, True, True, True) -> - -- everybody happy with LH - check 201 Nothing - _ -> pure () - - -- _oneWay -- run this if you want to make sure both ways are equivalent, but please don't commit! - theOtherWay + approveLegalHoldDevice tid (mem1 %. "qualified_id") defPassword >>= assertSuccess + fmap length (getClients mem1) `shouldMatchInt` 2 + assertMessageSendingWorks + + approveLegalHoldDevice tid (mem2 %. "qualified_id") defPassword >>= assertSuccess + fmap length (getClients mem2) `shouldMatchInt` 2 + assertMessageSendingWorks data TestClaimKeys = TCKConsentMissing -- (team not whitelisted, that is) | TCKConsentAndNewClients deriving (Show, Generic) +data LHApprovedOrPending + = LHApproved + | LHPending + deriving (Show, Generic) + -- | Cannot fetch prekeys of LH users if requester has not given consent or has old clients. -testLHClaimKeys :: TestClaimKeys -> App () -testLHClaimKeys testmode = do - withMockServer lhMockApp $ \lhDomAndPort _chan -> do +testLHClaimKeys :: LHApprovedOrPending -> TestClaimKeys -> App () +testLHClaimKeys approvedOrPending testmode = do + withMockServer def lhMockApp $ \lhDomAndPort _chan -> do (lowner, ltid, [lmem]) <- createTeam OwnDomain 2 (powner, ptid, [pmem]) <- createTeam OwnDomain 2 @@ -209,7 +197,9 @@ testLHClaimKeys testmode = do postLegalHoldSettings ltid lowner (mkLegalHoldSettings lhDomAndPort) >>= assertStatus 201 requestLegalHoldDevice ltid lowner lmem >>= assertSuccess - approveLegalHoldDevice ltid (lmem %. "qualified_id") defPassword >>= assertSuccess + case approvedOrPending of + LHApproved -> approveLegalHoldDevice ltid (lmem %. "qualified_id") defPassword >>= assertSuccess + LHPending -> pure () let addc caps = addClient pmem (settings caps) >>= assertSuccess settings caps = @@ -218,39 +208,49 @@ testLHClaimKeys testmode = do lastPrekey = Just $ head someLastPrekeysRendered, acapabilities = caps } - in case testmode of - TCKConsentMissing -> - addc $ Just ["legalhold-implicit-consent"] - TCKConsentAndNewClients -> do - addc $ Just ["legalhold-implicit-consent"] - legalholdWhitelistTeam ptid powner >>= assertSuccess - legalholdIsTeamInWhitelist ptid powner >>= assertSuccess - - llhdev :: String <- do + in addc $ Just ["legalhold-implicit-consent"] + + case testmode of + TCKConsentMissing -> pure () + TCKConsentAndNewClients -> do + legalholdWhitelistTeam ptid powner >>= assertSuccess + legalholdIsTeamInWhitelist ptid powner >>= assertSuccess + + llhdevs :: [String] <- do let getCls :: Value -> App [String] getCls mem = do res <- getClientsQualified mem OwnDomain mem val <- getJSON 200 res cls <- asList val objId `mapM` cls - getCls lmem <&> \case - [d] -> d - bad -> error $ show bad + getCls lmem - let assertResp :: HasCallStack => Response -> App () - assertResp resp = case testmode of - TCKConsentMissing -> do + let assertResp :: (HasCallStack) => Response -> App () + assertResp resp = case (testmode, llhdevs) of + (TCKConsentMissing, (_ : _)) -> do resp.status `shouldMatchInt` 403 resp.json %. "label" `shouldMatch` "missing-legalhold-consent" - TCKConsentAndNewClients -> do + (TCKConsentAndNewClients, (_ : _)) -> do + resp.status `shouldMatchInt` 200 + (_, []) -> do + -- no lh devices: no reason to be shy! resp.status `shouldMatchInt` 200 - bindResponse (getUsersPrekeysClient pmem (lmem %. "qualified_id") llhdev) $ assertResp - bindResponse (getUsersPrekeyBundle pmem (lmem %. "qualified_id")) $ assertResp + bindResponse (getUsersPrekeyBundle pmem (lmem %. "qualified_id")) assertResp + case llhdevs of + [llhdev] -> + -- retrieve lh client if /a + bindResponse (getUsersPrekeysClient pmem (lmem %. "qualified_id") llhdev) assertResp + [] -> + -- we're probably doing the LHPending thing right now + pure () + bad@(_ : _ : _) -> + -- fail if there is more than one. + assertFailure ("impossible -- more than one LH device: " <> show bad) slmemdom <- asString $ lmem %. "qualified_id.domain" slmemid <- asString $ lmem %. "qualified_id.id" - let userClients = Map.fromList [(slmemdom, Map.fromList [(slmemid, Set.fromList [llhdev])])] + let userClients = Map.fromList [(slmemdom, Map.fromList [(slmemid, Set.fromList llhdevs)])] bindResponse (getMultiUserPrekeyBundle pmem userClients) $ assertResp testLHAddClientManually :: App () @@ -289,7 +289,7 @@ testLHRequestDevice = do lpk <- getLastPrekey pks <- replicateM 3 getPrekey - withMockServer (lhMockAppWithPrekeys MkCreateMock {nextLastPrey = pure lpk, somePrekeys = pure pks}) \lhDomAndPort _chan -> do + withMockServer def (lhMockAppWithPrekeys MkCreateMock {nextLastPrey = pure lpk, somePrekeys = pure pks}) \lhDomAndPort _chan -> do let statusShouldBe :: String -> App () statusShouldBe status = legalholdUserStatus tid alice bob `bindResponse` \resp -> do @@ -324,7 +324,7 @@ testLHRequestDevice = do -- | pops a channel until it finds an event that returns a 'Just' -- upon running the matcher function -checkChan :: HasCallStack => Chan t -> (t -> App (Maybe a)) -> App a +checkChan :: (HasCallStack) => Chan t -> (t -> App (Maybe a)) -> App a checkChan chan match = do tSecs <- asks ((* 1_000_000) . timeOutSeconds) @@ -333,7 +333,7 @@ checkChan chan match = do go -- | like 'checkChan' but throws away the request and decodes the body -checkChanVal :: HasCallStack => Chan (t, LazyByteString) -> (Value -> MaybeT App a) -> App a +checkChanVal :: (HasCallStack) => Chan (t, LazyByteString) -> (Value -> MaybeT App a) -> App a checkChanVal chan match = checkChan chan \(_, bs) -> runMaybeT do MaybeT (pure (decode bs)) >>= match @@ -356,7 +356,7 @@ testLHApproveDevice = do approveLegalHoldDevice tid (bob %. "qualified_id") defPassword >>= assertLabel 412 "legalhold-not-pending" - withMockServer lhMockApp \lhDomAndPort chan -> do + withMockServer def lhMockApp \lhDomAndPort chan -> do legalholdWhitelistTeam tid alice >>= assertStatus 200 postLegalHoldSettings tid alice (mkLegalHoldSettings lhDomAndPort) @@ -367,10 +367,12 @@ testLHApproveDevice = do let uidsAndTidMatch val = do actualTid <- lookupFieldM val "team_id" - >>= lift . asString + >>= lift + . asString actualUid <- lookupFieldM val "user_id" - >>= lift . asString + >>= lift + . asString bobUid <- lift $ objId bob -- we pass the check on equality @@ -391,7 +393,8 @@ testLHApproveDevice = do let matchAuthToken val = lookupFieldM val "refresh_token" - >>= lift . asString + >>= lift + . asString checkChanVal chan matchAuthToken >>= renewToken bob @@ -435,6 +438,7 @@ testLHGetDeviceStatus = do pks <- replicateM 3 getPrekey withMockServer + def do lhMockAppWithPrekeys MkCreateMock {nextLastPrey = pure lpk, somePrekeys = pure pks} \lhDomAndPort _chan -> do legalholdWhitelistTeam tid alice @@ -481,7 +485,7 @@ testLHDisableForUser :: App () testLHDisableForUser = do (alice, tid, [bob]) <- createTeam OwnDomain 2 - withMockServer lhMockApp \lhDomAndPort chan -> do + withMockServer def lhMockApp \lhDomAndPort chan -> do setUpLHDevice tid alice bob lhDomAndPort bobc <- objId $ addClient bob def `bindResponse` getJSON 201 @@ -503,8 +507,10 @@ testLHDisableForUser = do checkChan chan \(req, _) -> runMaybeT do unless do - BS8.unpack req.requestMethod == "POST" - && req.pathInfo == (T.pack <$> ["legalhold", "remove"]) + BS8.unpack req.requestMethod + == "POST" + && req.pathInfo + == (T.pack <$> ["legalhold", "remove"]) mzero void $ local (setTimeoutTo 90) do @@ -516,7 +522,7 @@ testLHDisableForUser = do BrigI.getClientsFull bob [bobId] `bindResponse` \resp -> do resp.json %. bobId & asList - >>= filterM \val -> (== "legalhold") <$> (val %. "type" & asString) + >>= filterM \val -> (== "legalhold") <$> (val %. "type" & asString) shouldBeEmpty lhClients @@ -530,7 +536,7 @@ testLHEnablePerTeam = do resp.json %. "lockStatus" `shouldMatch` "unlocked" resp.json %. "status" `shouldMatch` "disabled" - withMockServer lhMockApp \lhDomAndPort _chan -> do + withMockServer def lhMockApp \lhDomAndPort _chan -> do setUpLHDevice tid alice bob lhDomAndPort legalholdUserStatus tid alice bob `bindResponse` \resp -> do @@ -556,12 +562,13 @@ testLHGetMembersIncludesStatus = do getTeamMembers alice tid `bindResponse` \resp -> do resp.status `shouldMatchInt` 200 [bobMember] <- - resp.json %. "members" & asList >>= filterM \u -> do - (==) <$> asString (u %. "user") <*> objId bob + resp.json %. "members" + & asList >>= filterM \u -> do + (==) <$> asString (u %. "user") <*> objId bob bobMember %. "legalhold_status" `shouldMatch` status statusShouldBe "no_consent" - withMockServer lhMockApp \lhDomAndPort _chan -> do + withMockServer def lhMockApp \lhDomAndPort _chan -> do statusShouldBe "no_consent" legalholdWhitelistTeam tid alice @@ -588,179 +595,114 @@ testLHGetMembersIncludesStatus = do type TB s = TaggedBool s -testLHNoConsentBlockOne2OneConv :: TB "connect first" -> TB "team peer" -> TB "approve LH" -> TB "test pending connection" -> App () -testLHNoConsentBlockOne2OneConv - (MkTagged connectFirst) - (MkTagged teampeer) - (MkTagged approveLH) - (MkTagged testPendingConnection) = do - -- team users - -- alice (team owner) and bob (member) - (alice, tid, []) <- createTeam OwnDomain 1 - bob <- - if teampeer - then do - (walice, _tid, []) <- createTeam OwnDomain 1 - -- FUTUREWORK(mangoiv): creating a team on a second backend - -- causes this bug: https://wearezeta.atlassian.net/browse/WPB-6640 - pure walice - else randomUser OwnDomain def +enableLH :: (MakesValue tid, MakesValue teamAdmin, MakesValue targetUser, HasCallStack) => tid -> teamAdmin -> targetUser -> Bool -> App (Maybe String) +enableLH tid teamAdmin targetUser approveLH = do + -- alice requests a legalhold device for herself + requestLegalHoldDevice tid teamAdmin targetUser + >>= assertStatus 201 - legalholdWhitelistTeam tid alice + when approveLH do + approveLegalHoldDevice tid targetUser defPassword >>= assertStatus 200 + legalholdUserStatus tid targetUser targetUser `bindResponse` \resp -> do + resp.status `shouldMatchInt` 200 + resp.json %. "status" `shouldMatch` if approveLH then "enabled" else "pending" + if approveLH + then Just <$> lhDeviceIdOf targetUser + else pure Nothing + +testLHConnectionsWithNonConsentingUsers :: App () +testLHConnectionsWithNonConsentingUsers = do + (alice, tid, []) <- createTeam OwnDomain 1 + bob <- randomUser OwnDomain def + carl <- randomUser OwnDomain def + dee <- randomUser OwnDomain def + + legalholdWhitelistTeam tid alice + >>= assertStatus 200 + + withMockServer def lhMockApp \lhDomAndPort _chan -> do + postLegalHoldSettings tid alice (mkLegalHoldSettings lhDomAndPort) + >>= assertStatus 201 - let doEnableLH :: HasCallStack => App (Maybe String) - doEnableLH = do - -- alice requests a legalhold device for herself - requestLegalHoldDevice tid alice alice - >>= assertStatus 201 + requestLegalHoldDevice tid alice alice + >>= assertStatus 201 - when approveLH do - approveLegalHoldDevice tid alice defPassword - >>= assertStatus 200 - legalholdUserStatus tid alice alice `bindResponse` \resp -> do - resp.status `shouldMatchInt` 200 - resp.json %. "status" `shouldMatch` if approveLH then "enabled" else "pending" - if approveLH - then Just <$> lhDeviceIdOf alice - else pure Nothing + -- Connections are not blocked before LH is approved by alice + connectTwoUsers alice bob + bobConvId <- getConnection alice bob `bindResponse` \resp -> resp.json %. "qualified_conversation" - doDisableLH :: HasCallStack => App () - doDisableLH = - disableLegalHold tid alice alice defPassword - >>= assertStatus 200 + postConnection dee alice >>= assertSuccess + deeConvId <- getConnection alice dee `bindResponse` \resp -> resp.json %. "qualified_conversation" - withMockServer lhMockApp \lhDomAndPort _chan -> do - postLegalHoldSettings tid alice (mkLegalHoldSettings lhDomAndPort) - >>= assertStatus 201 + approveLegalHoldDevice tid alice defPassword + >>= assertStatus 200 + + -- Connections with bob and dee are now in missing-legalhold-consent state + -- and the 1:1 convs are broken + assertConnection alice bob "missing-legalhold-consent" + assertConnection bob alice "missing-legalhold-consent" + getConversation bob bobConvId + >>= assertLabel 403 "access-denied" - if not connectFirst - then do - void doEnableLH - postConnection alice bob - >>= assertLabel 403 "missing-legalhold-consent" - - postConnection bob alice - >>= assertLabel 403 "missing-legalhold-consent" - else do - alicec <- objId $ addClient alice def >>= getJSON 201 - bobc <- objId $ addClient bob def >>= getJSON 201 - - postConnection alice bob - >>= assertStatus 201 - mbConvId <- - if testPendingConnection - then pure Nothing - else - Just - <$> do - putConnection bob alice "accepted" - >>= getJSON 200 - %. "qualified_conversation" - - -- we need to take away the pending/ sent status for the connections - [lastNotifAlice, lastNotifBob] <- for [(alice, alicec), (bob, bobc)] \(user, client) -> do - -- we get two events if bob accepts alice's request - let numEvents = if testPendingConnection then 1 else 2 - last <$> awaitNotifications user client Nothing numEvents isUserConnectionNotif - - mbLHDevice <- doEnableLH - - let assertConnectionsMissingLHConsent = - for_ [(bob, alice), (alice, bob)] \(a, b) -> - getConnections a `bindResponse` \resp -> do - resp.status `shouldMatchInt` 200 - conn <- assertOne =<< do resp.json %. "connections" & asList - conn %. "status" `shouldMatch` "missing-legalhold-consent" - conn %. "from" `shouldMatch` objId a - conn %. "to" `shouldMatch` objId b - - assertConnectionsMissingLHConsent - - [lastNotifAlice', lastNotifBob'] <- for [(alice, alicec, lastNotifAlice), (bob, bobc, lastNotifBob)] \(user, client, lastNotif) -> do - awaitNotification user client (Just lastNotif) isUserConnectionNotif >>= \notif -> - notif %. "payload.0.connection.status" `shouldMatch` "missing-legalhold-consent" - $> notif - - for_ [(bob, alice), (alice, bob)] \(a, b) -> - putConnection a b "accepted" - >>= assertLabel 403 "bad-conn-update" - - -- putting the connection to "accepted" with 403 doesn't change the - -- connection status - assertConnectionsMissingLHConsent - - bobc2 <- objId $ addClient bob def >>= getJSON 201 - - let -- \| we send a message from bob to alice, but only if - -- we have a conversation id and a legalhold device - -- we first create a message that goes to recipients - -- chosen by the first callback passed - -- then send the message using proteus - -- and in the end running the assertino callback to - -- verify the result - sendMessageFromBobToAlice :: - HasCallStack => - (String -> [String]) -> - -- \^ if we have the legalhold device registered, this - -- callback will be passed the lh device - (Response -> App ()) -> - -- \^ the callback to verify our response (an assertion) - App () - sendMessageFromBobToAlice recipients assertion = - for_ ((,) <$> mbConvId <*> mbLHDevice) \(convId, device) -> do - successfulMsgForOtherUsers <- - mkProteusRecipients - bob -- bob is the sender - [(alice, recipients device), (bob, [bobc])] - -- we send to clients of alice, maybe the legalhold device - -- we need to send to our other clients (bobc) - "hey alice (and eve)" -- the message - let bobaliceMessage = - Proto.defMessage @Proto.QualifiedNewOtrMessage - & #sender . Proto.client .~ (bobc2 ^?! hex) - & #recipients .~ [successfulMsgForOtherUsers] - & #reportAll .~ Proto.defMessage - -- make sure that `convId` is not just the `convId` but also - -- contains the domain because `postProteusMessage` will take the - -- comain from the `convId` json object - postProteusMessage bob convId bobaliceMessage - `bindResponse` assertion - - sendMessageFromBobToAlice (\device -> [alicec, device]) \resp -> do - resp.status `shouldMatchInt` 404 - - -- now we disable legalhold - doDisableLH - - for_ mbLHDevice \lhd -> - local (setTimeoutTo 90) $ - awaitNotification alice alicec noValue isUserClientRemoveNotif >>= \notif -> - notif %. "payload.0.client.id" `shouldMatch` lhd - - let assertStatusFor user status = - getConnections user `bindResponse` \resp -> do - resp.status `shouldMatchInt` 200 - conn <- assertOne =<< do resp.json %. "connections" & asList - conn %. "status" `shouldMatch` status - - if testPendingConnection - then do - assertStatusFor alice "sent" - assertStatusFor bob "pending" - else do - assertStatusFor alice "accepted" - assertStatusFor bob "accepted" - - for_ [(alice, alicec, lastNotifAlice'), (bob, bobc, lastNotifBob')] \(user, client, lastNotif) -> do - awaitNotification user client (Just lastNotif) isUserConnectionNotif >>= \notif -> - notif %. "payload.0.connection.status" `shouldMatchOneOf` ["sent", "pending", "accepted"] - - sendMessageFromBobToAlice (const [alicec]) \resp -> do - resp.status `shouldMatchInt` 201 - - sendMessageFromBobToAlice (\device -> [device]) \resp -> do - resp.status `shouldMatchInt` 412 + assertConnection alice dee "missing-legalhold-consent" + assertConnection dee alice "missing-legalhold-consent" + getConversation dee deeConvId + >>= assertLabel 403 "access-denied" + + -- Connections are blocked after alice approves the LH device + postConnection carl alice + >>= assertLabel 403 "missing-legalhold-consent" + postConnection alice carl + >>= assertLabel 403 "missing-legalhold-consent" + + disableLegalHold tid alice alice defPassword + >>= assertStatus 200 + + -- Disabling LH restores connection status and 1:1 convs + assertConnection alice bob "accepted" + assertConnection bob alice "accepted" + getConversation bob bobConvId `bindResponse` \resp -> do + resp.status `shouldMatchInt` 200 + resp.json %. "members.others.0.qualified_id" `shouldMatch` objQidObject alice + + assertConnection alice dee "pending" + assertConnection dee alice "sent" + getConversation dee deeConvId `bindResponse` \resp -> do + resp.status `shouldMatchInt` 200 + resp.json %. "members.others.0.qualified_id" `shouldMatch` objQidObject alice + +testLHConnectionsWithConsentingUsers :: App () +testLHConnectionsWithConsentingUsers = do + (alice, teamA, []) <- createTeam OwnDomain 1 + (bob, teamB, [barbara]) <- createTeam OwnDomain 2 + + legalholdWhitelistTeam teamA alice + >>= assertStatus 200 + legalholdWhitelistTeam teamB bob + >>= assertStatus 200 + + withMockServer def lhMockApp \lhDomAndPort _chan -> do + postLegalHoldSettings teamA alice (mkLegalHoldSettings lhDomAndPort) + >>= assertStatus 201 + + requestLegalHoldDevice teamA alice alice + >>= assertStatus 201 + + -- Connections are not blocked before LH is approved by alice + connectTwoUsers alice bob + + approveLegalHoldDevice teamA alice defPassword + >>= assertStatus 200 + + -- Connection with bob is now in whatever state + getConnection bob alice `bindResponse` \resp -> do + resp.status `shouldMatchInt` 200 + resp.json %. "status" `shouldMatch` "accepted" + + -- Connections are not blocked after alice approves the LH device because + -- teamB has implicit consent + connectTwoUsers alice barbara data GroupConvAdmin = LegalholderIsAdmin @@ -774,12 +716,12 @@ data GroupConvAdmin -- As to who gets to stay: -- - admins will stay over members -- - local members will stay over remote members. -testLHNoConsentRemoveFromGroup :: GroupConvAdmin -> App () -testLHNoConsentRemoveFromGroup admin = do +testLHNoConsentRemoveFromGroup :: LHApprovedOrPending -> GroupConvAdmin -> App () +testLHNoConsentRemoveFromGroup approvedOrPending admin = do (alice, tidAlice, []) <- createTeam OwnDomain 1 (bob, tidBob, []) <- createTeam OwnDomain 1 legalholdWhitelistTeam tidAlice alice >>= assertStatus 200 - withMockServer lhMockApp \lhDomAndPort _chan -> do + withMockServer def lhMockApp \lhDomAndPort _chan -> do postLegalHoldSettings tidAlice alice (mkLegalHoldSettings lhDomAndPort) >>= assertStatus 201 withWebSockets [alice, bob] \[aws, bws] -> do connectTwoUsers alice bob @@ -804,24 +746,41 @@ testLHNoConsentRemoveFromGroup admin = do getConversation user qConvId >>= assertStatus 200 requestLegalHoldDevice tidAlice alice alice >>= assertStatus 201 - approveLegalHoldDevice tidAlice alice defPassword >>= assertStatus 200 + case approvedOrPending of + LHApproved -> approveLegalHoldDevice tidAlice alice defPassword >>= assertStatus 200 + LHPending -> pure () + legalholdUserStatus tidAlice alice alice `bindResponse` \resp -> do - resp.json %. "status" `shouldMatch` "enabled" resp.status `shouldMatchInt` 200 + resp.json %. "status" `shouldMatch` case approvedOrPending of + LHApproved -> "enabled" + LHPending -> "pending" case admin of LegalholderIsAdmin -> do - for_ [aws, bws] do awaitMatch (isConvLeaveNotifWithLeaver bob) + case approvedOrPending of + LHApproved -> for_ [aws, bws] do awaitMatch (isConvLeaveNotifWithLeaver bob) + LHPending -> pure () getConversation alice qConvId >>= assertStatus 200 - getConversation bob qConvId >>= assertLabel 403 "access-denied" + getConversation bob qConvId >>= case approvedOrPending of + LHApproved -> assertLabel 403 "access-denied" + LHPending -> assertStatus 200 PeerIsAdmin -> do - for_ [aws, bws] do awaitMatch (isConvLeaveNotifWithLeaver alice) + case approvedOrPending of + LHApproved -> for_ [aws, bws] do awaitMatch (isConvLeaveNotifWithLeaver alice) + LHPending -> pure () getConversation bob qConvId >>= assertStatus 200 - getConversation alice qConvId >>= assertLabel 403 "access-denied" + getConversation alice qConvId >>= case approvedOrPending of + LHApproved -> assertLabel 403 "access-denied" + LHPending -> assertStatus 200 BothAreAdmins -> do - for_ [aws, bws] do awaitMatch (isConvLeaveNotifWithLeaver bob) + case approvedOrPending of + LHApproved -> for_ [aws, bws] do awaitMatch (isConvLeaveNotifWithLeaver bob) + LHPending -> pure () getConversation alice qConvId >>= assertStatus 200 - getConversation bob qConvId >>= assertLabel 403 "access-denied" + getConversation bob qConvId >>= case approvedOrPending of + LHApproved -> assertLabel 403 "access-denied" + LHPending -> assertStatus 200 testLHHappyFlow :: App () testLHHappyFlow = do @@ -836,7 +795,7 @@ testLHHappyFlow = do lpk <- getLastPrekey pks <- replicateM 3 getPrekey - withMockServer (lhMockAppWithPrekeys MkCreateMock {nextLastPrey = pure lpk, somePrekeys = pure pks}) \lhDomAndPort _chan -> do + withMockServer def (lhMockAppWithPrekeys MkCreateMock {nextLastPrey = pure lpk, somePrekeys = pure pks}) \lhDomAndPort _chan -> do postLegalHoldSettings tid alice (mkLegalHoldSettings lhDomAndPort) >>= assertStatus 201 -- implicit consent @@ -863,7 +822,8 @@ testLHHappyFlow = do resp.status `shouldMatchInt` 200 resp.json %. "status" `shouldMatch` "enabled" _ <- - resp.json `lookupField` "client.id" + resp.json + `lookupField` "client.id" >>= assertJust "client id is present" resp.json %. "last_prekey" `shouldMatch` lpk @@ -873,7 +833,7 @@ testLHGetStatus = do (charlie, _tidCharlie, [debora]) <- createTeam OwnDomain 2 emil <- randomUser OwnDomain def - let check :: HasCallStack => (MakesValue getter, MakesValue target) => getter -> target -> String -> App () + let check :: (HasCallStack) => (MakesValue getter, MakesValue target) => getter -> target -> String -> App () check getter target status = do profile <- getUser getter target >>= getJSON 200 pStatus <- profile %. "legalhold_status" & asString @@ -883,7 +843,7 @@ testLHGetStatus = do check u bob "no_consent" check u emil "no_consent" legalholdWhitelistTeam tid alice >>= assertStatus 200 - withMockServer lhMockApp \lhDomAndPort _chan -> do + withMockServer def lhMockApp \lhDomAndPort _chan -> do postLegalHoldSettings tid alice (mkLegalHoldSettings lhDomAndPort) >>= assertStatus 201 for_ [alice, bob, charlie, debora, emil] \u -> do check u bob "disabled" @@ -899,7 +859,7 @@ testLHCannotCreateGroupWithUsersInConflict = do legalholdWhitelistTeam tidAlice alice >>= assertStatus 200 connectTwoUsers bob charlie connectTwoUsers bob debora - withMockServer lhMockApp \lhDomAndPort _chan -> do + withMockServer def lhMockApp \lhDomAndPort _chan -> do postLegalHoldSettings tidAlice alice (mkLegalHoldSettings lhDomAndPort) >>= assertStatus 201 postConversation bob defProteus {qualifiedUsers = [charlie, alice], newUsersRole = "wire_member", team = Just tidAlice} >>= assertStatus 201 @@ -912,3 +872,53 @@ testLHCannotCreateGroupWithUsersInConflict = do postConversation bob defProteus {qualifiedUsers = [debora, alice], newUsersRole = "wire_member", team = Just tidAlice} >>= assertLabel 403 "missing-legalhold-consent" + +testLHNoConsentCannotBeInvited :: (HasCallStack) => App () +testLHNoConsentCannotBeInvited = do + -- team that is legalhold whitelisted + (legalholder, tidLH, userLHNotActivated : _) <- createTeam OwnDomain 2 + legalholdWhitelistTeam tidLH legalholder >>= assertStatus 200 + + -- team without legalhold + (peer, _tidPeer, [peer2, peer3]) <- createTeam OwnDomain 3 + + connectUsers [peer, userLHNotActivated] + connectUsers [peer2, userLHNotActivated] + + withMockServer def lhMockApp \lhDomAndPort _chan -> do + postLegalHoldSettings tidLH legalholder (mkLegalHoldSettings lhDomAndPort) >>= assertStatus 201 + cid <- postConversation userLHNotActivated defProteus {qualifiedUsers = [legalholder], newUsersRole = "wire_admin", team = Just tidLH} >>= getJSON 201 + addMembers userLHNotActivated cid (def {users = [peer], role = Just "wire_admin"}) >>= assertSuccess + + -- activate legalhold for legalholder + requestLegalHoldDevice tidLH legalholder legalholder >>= assertSuccess + legalholdUserStatus tidLH legalholder legalholder `bindResponse` \resp -> do + resp.status `shouldMatchInt` 200 + resp.json %. "status" `shouldMatch` "pending" + + addMembers userLHNotActivated cid (def {users = [peer2]}) >>= assertSuccess + + approveLegalHoldDevice tidLH (legalholder %. "qualified_id") defPassword >>= assertSuccess + legalholdUserStatus tidLH legalholder legalholder `bindResponse` \resp -> do + resp.status `shouldMatchInt` 200 + resp.json %. "status" `shouldMatch` "enabled" + + addMembers userLHNotActivated cid (def {users = [peer3]}) >>= assertLabel 403 "not-connected" + +testLHDisableBeforeApproval :: (HasCallStack) => App () +testLHDisableBeforeApproval = do + (alice, tid, [bob]) <- createTeam OwnDomain 2 + legalholdWhitelistTeam tid alice >>= assertStatus 200 + + withMockServer def lhMockApp \lhDomAndPort _chan -> do + postLegalHoldSettings tid alice (mkLegalHoldSettings lhDomAndPort) >>= assertStatus 201 + + -- alice requests a legalhold device for bob and sets his status to "pending" + requestLegalHoldDevice tid alice bob >>= assertSuccess + let getBob'sStatus = (getUser bob bob >>= getJSON 200) %. "legalhold_status" & asString + getBob'sStatus `shouldMatch` "pending" + + -- alice disables legalhold. the status for bob should now not be pending anymore + disableLegalHold tid alice bob defPassword + >>= assertStatus 200 + getBob'sStatus `shouldMatch` "disabled" diff --git a/integration/test/Test/Login.hs b/integration/test/Test/Login.hs index b16f5ec3074..096f441a50f 100644 --- a/integration/test/Test/Login.hs +++ b/integration/test/Test/Login.hs @@ -12,12 +12,12 @@ import SetupHelpers import Testlib.Prelude import Text.Printf (printf) -testLoginVerify6DigitEmailCodeSuccess :: HasCallStack => App () +testLoginVerify6DigitEmailCodeSuccess :: (HasCallStack) => App () testLoginVerify6DigitEmailCodeSuccess = do (owner, team, []) <- createTeam OwnDomain 0 email <- owner %. "email" setTeamFeatureLockStatus owner team "sndFactorPasswordChallenge" "unlocked" - setTeamFeatureStatus owner team "sndFactorPasswordChallenge" "enabled" + assertSuccess =<< setTeamFeatureStatus owner team "sndFactorPasswordChallenge" "enabled" generateVerificationCode owner email code <- getVerificationCode owner "login" >>= getJSON 200 >>= asString bindResponse (loginWith2ndFactor owner email defPassword code) $ \resp -> do @@ -25,12 +25,12 @@ testLoginVerify6DigitEmailCodeSuccess = do -- -- Test that login fails with wrong second factor email verification code -testLoginVerify6DigitWrongCodeFails :: HasCallStack => App () +testLoginVerify6DigitWrongCodeFails :: (HasCallStack) => App () testLoginVerify6DigitWrongCodeFails = do (owner, team, []) <- createTeam OwnDomain 0 email <- owner %. "email" setTeamFeatureLockStatus owner team "sndFactorPasswordChallenge" "unlocked" - setTeamFeatureStatus owner team "sndFactorPasswordChallenge" "enabled" + assertSuccess =<< setTeamFeatureStatus owner team "sndFactorPasswordChallenge" "enabled" generateVerificationCode owner email correctCode <- getVerificationCode owner "login" >>= getJSON 200 >>= asString let wrongCode :: String = printf "%06d" $ (read @Int correctCode) + 1 `mod` 1000000 @@ -40,19 +40,19 @@ testLoginVerify6DigitWrongCodeFails = do -- -- Test that login without verification code fails if SndFactorPasswordChallenge feature is enabled in team -testLoginVerify6DigitMissingCodeFails :: HasCallStack => App () +testLoginVerify6DigitMissingCodeFails :: (HasCallStack) => App () testLoginVerify6DigitMissingCodeFails = do (owner, team, []) <- createTeam OwnDomain 0 email <- owner %. "email" setTeamFeatureLockStatus owner team "sndFactorPasswordChallenge" "unlocked" - setTeamFeatureStatus owner team "sndFactorPasswordChallenge" "enabled" + assertSuccess =<< setTeamFeatureStatus owner team "sndFactorPasswordChallenge" "enabled" bindResponse (login owner email defPassword) $ \resp -> do resp.status `shouldMatchInt` 403 resp.json %. "label" `shouldMatch` "code-authentication-required" -- -- Test that login fails with expired second factor email verification code -testLoginVerify6DigitExpiredCodeFails :: HasCallStack => App () +testLoginVerify6DigitExpiredCodeFails :: (HasCallStack) => App () testLoginVerify6DigitExpiredCodeFails = do withModifiedBackend (def {brigCfg = setField "optSettings.setVerificationTimeout" (Aeson.Number 2)}) @@ -60,7 +60,7 @@ testLoginVerify6DigitExpiredCodeFails = do (owner, team, []) <- createTeam domain 0 email <- owner %. "email" setTeamFeatureLockStatus owner team "sndFactorPasswordChallenge" "unlocked" - setTeamFeatureStatus owner team "sndFactorPasswordChallenge" "enabled" + assertSuccess =<< setTeamFeatureStatus owner team "sndFactorPasswordChallenge" "enabled" bindResponse (getTeamFeature owner team "sndFactorPasswordChallenge") $ \resp -> do resp.status `shouldMatchInt` 200 resp.json %. "status" `shouldMatch` "enabled" @@ -73,12 +73,12 @@ testLoginVerify6DigitExpiredCodeFails = do resp.status `shouldMatchInt` 403 resp.json %. "label" `shouldMatch` "code-authentication-failed" -testLoginVerify6DigitResendCodeSuccessAndRateLimiting :: HasCallStack => App () +testLoginVerify6DigitResendCodeSuccessAndRateLimiting :: (HasCallStack) => App () testLoginVerify6DigitResendCodeSuccessAndRateLimiting = do (owner, team, []) <- createTeam OwnDomain 0 email <- owner %. "email" setTeamFeatureLockStatus owner team "sndFactorPasswordChallenge" "unlocked" - setTeamFeatureStatus owner team "sndFactorPasswordChallenge" "enabled" + assertSuccess =<< setTeamFeatureStatus owner team "sndFactorPasswordChallenge" "enabled" generateVerificationCode owner email fstCode <- getVerificationCode owner "login" >>= getJSON 200 >>= asString bindResponse (generateVerificationCode' owner email) $ \resp -> do @@ -95,12 +95,12 @@ testLoginVerify6DigitResendCodeSuccessAndRateLimiting = do bindResponse (loginWith2ndFactor owner email defPassword mostRecentCode) \resp -> do resp.status `shouldMatchInt` 200 -testLoginVerify6DigitLimitRetries :: HasCallStack => App () +testLoginVerify6DigitLimitRetries :: (HasCallStack) => App () testLoginVerify6DigitLimitRetries = do (owner, team, []) <- createTeam OwnDomain 0 email <- owner %. "email" setTeamFeatureLockStatus owner team "sndFactorPasswordChallenge" "unlocked" - setTeamFeatureStatus owner team "sndFactorPasswordChallenge" "enabled" + assertSuccess =<< setTeamFeatureStatus owner team "sndFactorPasswordChallenge" "enabled" generateVerificationCode owner email correctCode <- getVerificationCode owner "login" >>= getJSON 200 >>= asString let wrongCode :: String = printf "%06d" $ (read @Int correctCode) + 1 `mod` 1000000 diff --git a/integration/test/Test/MLS.hs b/integration/test/Test/MLS.hs index b6df53ab4bb..07534701b85 100644 --- a/integration/test/Test/MLS.hs +++ b/integration/test/Test/MLS.hs @@ -16,7 +16,7 @@ import SetupHelpers import Test.Version import Testlib.Prelude -testSendMessageNoReturnToSender :: HasCallStack => App () +testSendMessageNoReturnToSender :: (HasCallStack) => App () testSendMessageNoReturnToSender = do [alice, bob] <- createAndConnectUsers [OwnDomain, OwnDomain] [alice1, alice2, bob1, bob2] <- traverse (createMLSClient def) [alice, alice, bob, bob] @@ -33,8 +33,8 @@ testSendMessageNoReturnToSender = do for_ wss $ \ws -> do n <- awaitMatch (\n -> nPayload n %. "type" `isEqual` "conversation.mls-message-add") ws nPayload n %. "data" `shouldMatch` T.decodeUtf8 (Base64.encode mp.message) - expectFailure (const $ pure ()) $ - awaitMatch + expectFailure (const $ pure ()) + $ awaitMatch ( \n -> liftM2 (&&) @@ -43,8 +43,8 @@ testSendMessageNoReturnToSender = do ) wsSender -testStaleApplicationMessage :: HasCallStack => Domain -> App () -testStaleApplicationMessage otherDomain = do +testPastStaleApplicationMessage :: (HasCallStack) => Domain -> App () +testPastStaleApplicationMessage otherDomain = do [alice, bob, charlie, dave, eve] <- createAndConnectUsers [OwnDomain, otherDomain, OwnDomain, OwnDomain, OwnDomain] [alice1, bob1, charlie1] <- traverse (createMLSClient def) [alice, bob, charlie] @@ -70,7 +70,33 @@ testStaleApplicationMessage otherDomain = do -- bob's application messages are now rejected void $ postMLSMessage bob1 msg2.message >>= getJSON 409 -testMixedProtocolUpgrade :: HasCallStack => Domain -> App () +testFutureStaleApplicationMessage :: (HasCallStack) => App () +testFutureStaleApplicationMessage = do + [alice, bob, charlie] <- createAndConnectUsers [OwnDomain, OwnDomain, OwnDomain] + [alice1, bob1, charlie1] <- traverse (createMLSClient def) [alice, bob, charlie] + traverse_ uploadNewKeyPackage [bob1, charlie1] + void $ createNewGroup alice1 + + -- alice adds bob + void . sendAndConsumeCommitBundle =<< createAddCommit alice1 [bob] + + -- alice adds charlie and consumes the commit without sending it + void $ createAddCommit alice1 [charlie] + modifyMLSState $ \mls -> + mls + { epoch = epoch mls + 1, + members = members mls <> Set.singleton charlie1, + newMembers = mempty + } + + -- alice's application message is rejected + void + . getJSON 409 + =<< postMLSMessage alice1 + . (.message) + =<< createApplicationMessage alice1 "hi bob" + +testMixedProtocolUpgrade :: (HasCallStack) => Domain -> App () testMixedProtocolUpgrade secondDomain = do (alice, tid, _) <- createTeam OwnDomain 1 [bob, charlie] <- replicateM 2 (randomUser secondDomain def) @@ -113,7 +139,7 @@ testMixedProtocolUpgrade secondDomain = do bindResponse (putConversationProtocol bob qcnv "invalid") $ \resp -> do resp.status `shouldMatchInt` 400 -testMixedProtocolNonTeam :: HasCallStack => Domain -> App () +testMixedProtocolNonTeam :: (HasCallStack) => Domain -> App () testMixedProtocolNonTeam secondDomain = do [alice, bob] <- createAndConnectUsers [OwnDomain, secondDomain] qcnv <- @@ -123,7 +149,7 @@ testMixedProtocolNonTeam secondDomain = do bindResponse (putConversationProtocol bob qcnv "mixed") $ \resp -> do resp.status `shouldMatchInt` 403 -testMixedProtocolAddUsers :: HasCallStack => Domain -> Ciphersuite -> App () +testMixedProtocolAddUsers :: (HasCallStack) => Domain -> Ciphersuite -> App () testMixedProtocolAddUsers secondDomain suite = do setMLSCiphersuite suite (alice, tid, _) <- createTeam OwnDomain 1 @@ -160,7 +186,7 @@ testMixedProtocolAddUsers secondDomain suite = do (suiteCode, _) <- assertOne $ T.hexadecimal (T.pack suite.code) resp.json %. "cipher_suite" `shouldMatchInt` suiteCode -testMixedProtocolUserLeaves :: HasCallStack => Domain -> App () +testMixedProtocolUserLeaves :: (HasCallStack) => Domain -> App () testMixedProtocolUserLeaves secondDomain = do (alice, tid, _) <- createTeam OwnDomain 1 bob <- randomUser secondDomain def @@ -196,7 +222,7 @@ testMixedProtocolUserLeaves secondDomain = do msg %. "message.content.body.Proposal.Remove.removed" `shouldMatchInt` leafIndexBob msg %. "message.content.sender.External" `shouldMatchInt` 0 -testMixedProtocolAddPartialClients :: HasCallStack => Domain -> App () +testMixedProtocolAddPartialClients :: (HasCallStack) => Domain -> App () testMixedProtocolAddPartialClients secondDomain = do (alice, tid, _) <- createTeam OwnDomain 1 bob <- randomUser secondDomain def @@ -235,7 +261,7 @@ testMixedProtocolAddPartialClients secondDomain = do mp <- createAddCommitWithKeyPackages bob1 [kp2] void $ postMLSCommitBundle mp.sender (mkBundle mp) >>= getJSON 201 -testMixedProtocolRemovePartialClients :: HasCallStack => Domain -> App () +testMixedProtocolRemovePartialClients :: (HasCallStack) => Domain -> App () testMixedProtocolRemovePartialClients secondDomain = do (alice, tid, _) <- createTeam OwnDomain 1 bob <- randomUser secondDomain def @@ -261,7 +287,7 @@ testMixedProtocolRemovePartialClients secondDomain = do void $ postMLSCommitBundle mp.sender (mkBundle mp) >>= getJSON 201 -testMixedProtocolAppMessagesAreDenied :: HasCallStack => Domain -> App () +testMixedProtocolAppMessagesAreDenied :: (HasCallStack) => Domain -> App () testMixedProtocolAppMessagesAreDenied secondDomain = do (alice, tid, _) <- createTeam OwnDomain 1 bob <- randomUser secondDomain def @@ -290,7 +316,7 @@ testMixedProtocolAppMessagesAreDenied secondDomain = do resp.status `shouldMatchInt` 422 resp.json %. "label" `shouldMatch` "mls-unsupported-message" -testMLSProtocolUpgrade :: HasCallStack => Domain -> App () +testMLSProtocolUpgrade :: (HasCallStack) => Domain -> App () testMLSProtocolUpgrade secondDomain = do (alice, bob, conv) <- simpleMixedConversationSetup secondDomain charlie <- randomUser OwnDomain def @@ -332,7 +358,7 @@ testMLSProtocolUpgrade secondDomain = do resp.status `shouldMatchInt` 200 resp.json %. "protocol" `shouldMatch` "mls" -testAddUserSimple :: HasCallStack => Ciphersuite -> CredentialType -> App () +testAddUserSimple :: (HasCallStack) => Ciphersuite -> CredentialType -> App () testAddUserSimple suite ctype = do setMLSCiphersuite suite [alice, bob] <- createAndConnectUsers [OwnDomain, OwnDomain] @@ -366,12 +392,12 @@ testAddUserSimple suite ctype = do -- check that bob can now see the conversation convs <- getAllConvs bob convIds <- traverse (%. "qualified_id") convs - void $ - assertBool + void + $ assertBool "Users added to an MLS group should find it when listing conversations" (qcnv `elem` convIds) -testRemoteAddUser :: HasCallStack => App () +testRemoteAddUser :: (HasCallStack) => App () testRemoteAddUser = do [alice, bob, charlie] <- createAndConnectUsers [OwnDomain, OtherDomain, OwnDomain] [alice1, bob1, charlie1] <- traverse (createMLSClient def) [alice, bob, charlie] @@ -388,7 +414,7 @@ testRemoteAddUser = do resp.status `shouldMatchInt` 500 resp.json %. "label" `shouldMatch` "federation-not-implemented" -testRemoteRemoveClient :: HasCallStack => Ciphersuite -> App () +testRemoteRemoveClient :: (HasCallStack) => Ciphersuite -> App () testRemoteRemoveClient suite = do setMLSCiphersuite suite [alice, bob] <- createAndConnectUsers [OwnDomain, OtherDomain] @@ -409,7 +435,7 @@ testRemoteRemoveClient suite = do msg %. "message.content.body.Proposal.Remove.removed" `shouldMatchInt` leafIndexBob msg %. "message.content.sender.External" `shouldMatchInt` 0 -testCreateSubConv :: HasCallStack => Ciphersuite -> App () +testCreateSubConv :: (HasCallStack) => Ciphersuite -> App () testCreateSubConv suite = do setMLSCiphersuite suite [alice, bob] <- createAndConnectUsers [OwnDomain, OwnDomain] @@ -448,7 +474,7 @@ testSelfConversation v = withVersion5 v $ do void $ createExternalCommit newClient Nothing >>= sendAndConsumeCommitBundle -- | FUTUREWORK: Don't allow partial adds, not even in the first commit -testFirstCommitAllowsPartialAdds :: HasCallStack => App () +testFirstCommitAllowsPartialAdds :: (HasCallStack) => App () testFirstCommitAllowsPartialAdds = do alice <- randomUser OwnDomain def @@ -466,7 +492,7 @@ testFirstCommitAllowsPartialAdds = do resp.status `shouldMatchInt` 409 resp.json %. "label" `shouldMatch` "mls-client-mismatch" -testAddUserPartial :: HasCallStack => App () +testAddUserPartial :: (HasCallStack) => App () testAddUserPartial = do [alice, bob, charlie] <- createAndConnectUsers (replicate 3 OwnDomain) @@ -494,7 +520,7 @@ testAddUserPartial = do err %. "label" `shouldMatch` "mls-client-mismatch" -- | admin removes user from a conversation but doesn't list all clients -testRemoveClientsIncomplete :: HasCallStack => App () +testRemoveClientsIncomplete :: (HasCallStack) => App () testRemoveClientsIncomplete = do [alice, bob] <- createAndConnectUsers [OwnDomain, OwnDomain] @@ -507,7 +533,7 @@ testRemoveClientsIncomplete = do err <- postMLSCommitBundle mp.sender (mkBundle mp) >>= getJSON 409 err %. "label" `shouldMatch` "mls-client-mismatch" -testAdminRemovesUserFromConv :: HasCallStack => Ciphersuite -> App () +testAdminRemovesUserFromConv :: (HasCallStack) => Ciphersuite -> App () testAdminRemovesUserFromConv suite = do setMLSCiphersuite suite [alice, bob] <- createAndConnectUsers [OwnDomain, OwnDomain] @@ -539,7 +565,7 @@ testAdminRemovesUserFromConv suite = do "bob is not longer part of conversation after the commit" (qcnv `notElem` convIds) -testLocalWelcome :: HasCallStack => App () +testLocalWelcome :: (HasCallStack) => App () testLocalWelcome = do users@[alice, bob] <- createAndConnectUsers [OwnDomain, OwnDomain] @@ -569,7 +595,7 @@ testLocalWelcome = do addedUser <- (event %. "data.users") >>= asList >>= assertOne objQid addedUser `shouldMatch` objQid bob -testStaleCommit :: HasCallStack => App () +testStaleCommit :: (HasCallStack) => App () testStaleCommit = do (alice : users) <- createAndConnectUsers (replicate 5 OwnDomain) let (users1, users2) = splitAt 2 users @@ -591,7 +617,7 @@ testStaleCommit = do resp.status `shouldMatchInt` 409 resp.json %. "label" `shouldMatch` "mls-stale-message" -testPropInvalidEpoch :: HasCallStack => App () +testPropInvalidEpoch :: (HasCallStack) => App () testPropInvalidEpoch = do users@[_alice, bob, charlie, dee] <- createAndConnectUsers (replicate 4 OwnDomain) [alice1, bob1, charlie1, dee1] <- traverse (createMLSClient def) users @@ -633,7 +659,7 @@ testPropInvalidEpoch = do --- | This test submits a ReInit proposal, which is currently ignored by the -- backend, in order to check that unsupported proposal types are accepted. -testPropUnsupported :: HasCallStack => App () +testPropUnsupported :: (HasCallStack) => App () testPropUnsupported = do users@[_alice, bob] <- createAndConnectUsers (replicate 2 OwnDomain) [alice1, bob1] <- traverse (createMLSClient def) users @@ -646,7 +672,7 @@ testPropUnsupported = do -- we cannot consume this message, because the membership tag is fake void $ postMLSMessage mp.sender mp.message >>= getJSON 201 -testAddUserBareProposalCommit :: HasCallStack => App () +testAddUserBareProposalCommit :: (HasCallStack) => App () testAddUserBareProposalCommit = do [alice, bob] <- createAndConnectUsers (replicate 2 OwnDomain) [alice1, bob1] <- traverse (createMLSClient def) [alice, bob] @@ -663,12 +689,12 @@ testAddUserBareProposalCommit = do -- check that bob can now see the conversation convs <- getAllConvs bob convIds <- traverse (%. "qualified_id") convs - void $ - assertBool + void + $ assertBool "Users added to an MLS group should find it when listing conversations" (qcnv `elem` convIds) -testPropExistingConv :: HasCallStack => App () +testPropExistingConv :: (HasCallStack) => App () testPropExistingConv = do [alice, bob] <- createAndConnectUsers (replicate 2 OwnDomain) [alice1, bob1] <- traverse (createMLSClient def) [alice, bob] @@ -678,7 +704,7 @@ testPropExistingConv = do res <- createAddProposals alice1 [bob] >>= traverse sendAndConsumeMessage >>= assertOne shouldBeEmpty (res %. "events") -testCommitNotReferencingAllProposals :: HasCallStack => App () +testCommitNotReferencingAllProposals :: (HasCallStack) => App () testCommitNotReferencingAllProposals = do users@[_alice, bob, charlie] <- createAndConnectUsers (replicate 3 OwnDomain) @@ -702,7 +728,7 @@ testCommitNotReferencingAllProposals = do resp.status `shouldMatchInt` 400 resp.json %. "label" `shouldMatch` "mls-commit-missing-references" -testUnsupportedCiphersuite :: HasCallStack => App () +testUnsupportedCiphersuite :: (HasCallStack) => App () testUnsupportedCiphersuite = do setMLSCiphersuite (Ciphersuite "0x0003") alice <- randomUser OwnDomain def @@ -715,7 +741,7 @@ testUnsupportedCiphersuite = do resp.status `shouldMatchInt` 400 resp.json %. "label" `shouldMatch` "mls-protocol-error" -testBackendRemoveProposal :: HasCallStack => Ciphersuite -> Domain -> App () +testBackendRemoveProposal :: (HasCallStack) => Ciphersuite -> Domain -> App () testBackendRemoveProposal suite domain = do setMLSCiphersuite suite [alice, bob] <- createAndConnectUsers [OwnDomain, domain] diff --git a/integration/test/Test/MLS/KeyPackage.hs b/integration/test/Test/MLS/KeyPackage.hs index cf6b721db88..507d7ff7eb3 100644 --- a/integration/test/Test/MLS/KeyPackage.hs +++ b/integration/test/Test/MLS/KeyPackage.hs @@ -119,9 +119,9 @@ testKeyPackageSelfClaim = do resp.json %. "key_packages" & asList - -- the keypackage claimed by client 1 should be issued by - -- client 2 - >>= \[v] -> v %. "client" `shouldMatch` alice2.client + -- the keypackage claimed by client 1 should be issued by + -- client 2 + >>= \[v] -> v %. "client" `shouldMatch` alice2.client -- - the keypackages of client 1 (claimer) should still be there -- - two of the keypackages of client 2 (claimee) should be stil @@ -179,7 +179,7 @@ testKeyPackageRemoteClaim = do resp.json %. "count" `shouldMatchInt` 0 resp.status `shouldMatchInt` 200 -testKeyPackageCount :: HasCallStack => Ciphersuite -> App () +testKeyPackageCount :: (HasCallStack) => Ciphersuite -> App () testKeyPackageCount cs = do setMLSCiphersuite cs alice <- randomUser OwnDomain def @@ -197,7 +197,7 @@ testKeyPackageCount cs = do resp.status `shouldMatchInt` 200 resp.json %. "count" `shouldMatchInt` count -testUnsupportedCiphersuite :: HasCallStack => App () +testUnsupportedCiphersuite :: (HasCallStack) => App () testUnsupportedCiphersuite = do let suite = Ciphersuite "0x0003" setMLSCiphersuite suite @@ -208,7 +208,7 @@ testUnsupportedCiphersuite = do resp.status `shouldMatchInt` 400 resp.json %. "label" `shouldMatch` "mls-protocol-error" -testReplaceKeyPackages :: HasCallStack => App () +testReplaceKeyPackages :: (HasCallStack) => App () testReplaceKeyPackages = do alice <- randomUser OwnDomain def [alice1, alice2] <- replicateM 2 $ createMLSClient def alice @@ -220,15 +220,15 @@ testReplaceKeyPackages = do resp.json %. "count" `shouldMatchInt` n -- setup: upload a batch of key packages for each ciphersuite - void $ - replicateM 4 (fmap fst (generateKeyPackage alice1)) - >>= uploadKeyPackages alice1 - >>= getBody 201 + void + $ replicateM 4 (fmap fst (generateKeyPackage alice1)) + >>= uploadKeyPackages alice1 + >>= getBody 201 setMLSCiphersuite suite - void $ - replicateM 5 (fmap fst (generateKeyPackage alice1)) - >>= uploadKeyPackages alice1 - >>= getBody 201 + void + $ replicateM 5 (fmap fst (generateKeyPackage alice1)) + >>= uploadKeyPackages alice1 + >>= getBody 201 checkCount def 4 checkCount suite 5 @@ -245,8 +245,9 @@ testReplaceKeyPackages = do -- claim all key packages one by one claimed <- - replicateM 3 $ - bindResponse (claimKeyPackages suite alice2 alice) $ \resp -> do + replicateM 3 + $ bindResponse (claimKeyPackages suite alice2 alice) + $ \resp -> do resp.status `shouldMatchInt` 200 ks <- resp.json %. "key_packages" & asList k <- assertOne ks @@ -259,10 +260,10 @@ testReplaceKeyPackages = do do -- replenish key packages for the second ciphersuite - void $ - replicateM 5 (fmap fst (generateKeyPackage alice1)) - >>= uploadKeyPackages alice1 - >>= getBody 201 + void + $ replicateM 5 (fmap fst (generateKeyPackage alice1)) + >>= uploadKeyPackages alice1 + >>= getBody 201 checkCount def 4 checkCount suite 5 diff --git a/integration/test/Test/MLS/Keys.hs b/integration/test/Test/MLS/Keys.hs index 64bba22e119..d5ac4867c60 100644 --- a/integration/test/Test/MLS/Keys.hs +++ b/integration/test/Test/MLS/Keys.hs @@ -6,7 +6,7 @@ import qualified Data.ByteString.Char8 as B8 import SetupHelpers import Testlib.Prelude -testPublicKeys :: HasCallStack => App () +testPublicKeys :: (HasCallStack) => App () testPublicKeys = do u <- randomUserId OwnDomain keys <- getMLSPublicKeys u >>= getJSON 200 @@ -48,7 +48,7 @@ testPublicKeys = do pubkeyY <- assertOne . toList . B64U.decodeUnpadded $ B8.pack pubkeyYS B8.length pubkeyY `shouldMatchInt` 66 -testPublicKeysMLSNotEnabled :: HasCallStack => App () +testPublicKeysMLSNotEnabled :: (HasCallStack) => App () testPublicKeysMLSNotEnabled = withModifiedBackend def { galleyCfg = removeField "settings.mlsPrivateKeyPaths" diff --git a/integration/test/Test/MLS/Message.hs b/integration/test/Test/MLS/Message.hs index 3a7c2efc213..e15635f4987 100644 --- a/integration/test/Test/MLS/Message.hs +++ b/integration/test/Test/MLS/Message.hs @@ -27,7 +27,7 @@ import SetupHelpers import Testlib.Prelude -- | Test happy case of federated MLS message sending in both directions. -testApplicationMessage :: HasCallStack => App () +testApplicationMessage :: (HasCallStack) => App () testApplicationMessage = do -- local alice and alex, remote bob [alice, alex, bob, betty] <- @@ -55,7 +55,7 @@ testApplicationMessage = do void $ createApplicationMessage bob1 "hey" >>= sendAndConsumeMessage traverse_ (awaitMatch isNewMLSMessageNotif) wss -testAppMessageSomeReachable :: HasCallStack => App () +testAppMessageSomeReachable :: (HasCallStack) => App () testAppMessageSomeReachable = do alice1 <- startDynamicBackends [mempty] $ \[thirdDomain] -> do ownDomain <- make OwnDomain & asString @@ -75,7 +75,7 @@ testAppMessageSomeReachable = do mp <- createApplicationMessage alice1 "hi, bob!" void $ postMLSMessage mp.sender mp.message >>= getJSON 201 -testMessageNotifications :: HasCallStack => Domain -> App () +testMessageNotifications :: (HasCallStack) => Domain -> App () testMessageNotifications bobDomain = do [alice, bob] <- createAndConnectUsers [OwnDomain, bobDomain] @@ -105,7 +105,7 @@ testMessageNotifications bobDomain = do get def `shouldMatchInt` (numNotifs + 1) get def {client = Just bobClient} `shouldMatchInt` (numNotifsClient + 1) -testMultipleMessages :: HasCallStack => App () +testMultipleMessages :: (HasCallStack) => App () testMultipleMessages = do [alice, bob] <- createAndConnectUsers [OwnDomain, OtherDomain] [alice1, bob1] <- traverse (createMLSClient def) [alice, bob] diff --git a/integration/test/Test/MLS/Notifications.hs b/integration/test/Test/MLS/Notifications.hs index ad0595a48c6..61a0b60d53f 100644 --- a/integration/test/Test/MLS/Notifications.hs +++ b/integration/test/Test/MLS/Notifications.hs @@ -6,7 +6,7 @@ import Notifications import SetupHelpers import Testlib.Prelude -testWelcomeNotification :: HasCallStack => App () +testWelcomeNotification :: (HasCallStack) => App () testWelcomeNotification = do [alice, bob] <- createAndConnectUsers [OwnDomain, OtherDomain] [alice1, alice2, bob1, bob2] <- traverse (createMLSClient def) [alice, alice, bob, bob] diff --git a/integration/test/Test/MLS/One2One.hs b/integration/test/Test/MLS/One2One.hs index c8b5e4deedb..338cae3a7e4 100644 --- a/integration/test/Test/MLS/One2One.hs +++ b/integration/test/Test/MLS/One2One.hs @@ -30,7 +30,7 @@ import SetupHelpers import Test.Version import Testlib.Prelude -testGetMLSOne2One :: HasCallStack => Version5 -> Domain -> App () +testGetMLSOne2One :: (HasCallStack) => Version5 -> Domain -> App () testGetMLSOne2One v otherDomain = withVersion5 v $ do [alice, bob] <- createAndConnectUsers [OwnDomain, otherDomain] @@ -59,7 +59,7 @@ testGetMLSOne2One v otherDomain = withVersion5 v $ do conv2 %. "qualified_id" `shouldMatch` convId assertConvData conv2 -testMLSOne2OneOtherMember :: HasCallStack => One2OneScenario -> App () +testMLSOne2OneOtherMember :: (HasCallStack) => One2OneScenario -> App () testMLSOne2OneOtherMember scenario = do alice <- randomUser OwnDomain def let otherDomain = one2OneScenarioUserDomain scenario @@ -92,14 +92,14 @@ testMLSOne2OneOtherMember scenario = do getMLSOne2OneConversation self other `bindResponse` assertOthers other getConversation self conv `bindResponse` assertOthers other -testGetMLSOne2OneUnconnected :: HasCallStack => Domain -> App () +testGetMLSOne2OneUnconnected :: (HasCallStack) => Domain -> App () testGetMLSOne2OneUnconnected otherDomain = do [alice, bob] <- for [OwnDomain, otherDomain] $ \domain -> randomUser domain def bindResponse (getMLSOne2OneConversation alice bob) $ \resp -> resp.status `shouldMatchInt` 403 -testMLSOne2OneBlocked :: HasCallStack => Domain -> App () +testMLSOne2OneBlocked :: (HasCallStack) => Domain -> App () testMLSOne2OneBlocked otherDomain = do [alice, bob] <- for [OwnDomain, otherDomain] $ flip randomUser def void $ postConnection bob alice >>= getBody 201 @@ -108,7 +108,7 @@ testMLSOne2OneBlocked otherDomain = do void $ getMLSOne2OneConversation bob alice >>= getJSON 403 -- | Alice and Bob are initially connected, but then Alice blocks Bob. -testMLSOne2OneBlockedAfterConnected :: HasCallStack => One2OneScenario -> App () +testMLSOne2OneBlockedAfterConnected :: (HasCallStack) => One2OneScenario -> App () testMLSOne2OneBlockedAfterConnected scenario = do alice <- randomUser OwnDomain def let otherDomain = one2OneScenarioUserDomain scenario @@ -147,7 +147,7 @@ testMLSOne2OneBlockedAfterConnected scenario = do -- | Alice and Bob are initially connected, then Alice blocks Bob, and finally -- Alice unblocks Bob. -testMLSOne2OneUnblocked :: HasCallStack => One2OneScenario -> App () +testMLSOne2OneUnblocked :: (HasCallStack) => One2OneScenario -> App () testMLSOne2OneUnblocked scenario = do alice <- randomUser OwnDomain def let otherDomain = one2OneScenarioUserDomain scenario @@ -230,7 +230,7 @@ one2OneScenarioConvDomain One2OneScenarioLocal = OwnDomain one2OneScenarioConvDomain One2OneScenarioLocalConv = OwnDomain one2OneScenarioConvDomain One2OneScenarioRemoteConv = OtherDomain -testMLSOne2One :: HasCallStack => Ciphersuite -> One2OneScenario -> App () +testMLSOne2One :: (HasCallStack) => Ciphersuite -> One2OneScenario -> App () testMLSOne2One suite scenario = do setMLSCiphersuite suite alice <- randomUser OwnDomain def diff --git a/integration/test/Test/MLS/SubConversation.hs b/integration/test/Test/MLS/SubConversation.hs index d73095030da..11dfdc4e7da 100644 --- a/integration/test/Test/MLS/SubConversation.hs +++ b/integration/test/Test/MLS/SubConversation.hs @@ -26,11 +26,11 @@ testJoinSubConv = do assertBool "Epoch timestamp should not be null" (tm /= Null) -- now alice joins with her own client - void $ - createExternalCommit alice1 Nothing - >>= sendAndConsumeCommitBundle + void + $ createExternalCommit alice1 Nothing + >>= sendAndConsumeCommitBundle -testDeleteParentOfSubConv :: HasCallStack => Domain -> App () +testDeleteParentOfSubConv :: (HasCallStack) => Domain -> App () testDeleteParentOfSubConv secondDomain = do (alice, tid, _) <- createTeam OwnDomain 1 bob <- randomUser secondDomain def @@ -81,7 +81,7 @@ testDeleteParentOfSubConv secondDomain = do resp.status `shouldMatchInt` 404 resp.json %. "label" `shouldMatch` "no-conversation" -testDeleteSubConversation :: HasCallStack => Domain -> App () +testDeleteSubConversation :: (HasCallStack) => Domain -> App () testDeleteSubConversation otherDomain = do [alice, bob] <- createAndConnectUsers [OwnDomain, otherDomain] charlie <- randomUser OwnDomain def @@ -105,7 +105,7 @@ testDeleteSubConversation otherDomain = do data Leaver = Alice | Bob deriving stock (Generic) -testLeaveSubConv :: HasCallStack => Leaver -> App () +testLeaveSubConv :: (HasCallStack) => Leaver -> App () testLeaveSubConv leaver = do [alice, bob, charlie] <- createAndConnectUsers [OwnDomain, OwnDomain, OtherDomain] clients@[alice1, bob1, bob2, charlie1] <- traverse (createMLSClient def) [alice, bob, bob, charlie] @@ -224,7 +224,7 @@ testCreatorRemovesUserFromParent = do ws msg %. "payload.0.data" & asByteString - >>= mlsCliConsume consumer + >>= mlsCliConsume consumer -- remove bob from the child state modifyMLSState $ \s -> s {members = s.members Set.\\ Set.fromList [bob1, bob2]} @@ -239,3 +239,51 @@ testCreatorRemovesUserFromParent = do assertBool "alice and charlie should have access to the conversation" (resp.status == 200) mems <- resp.jsonBody %. "members" & asList mems `shouldMatchSet` ((renameField "id" "user_id" <=< make) `traverse` [alice1, charlie1, charlie2]) + +testResendingProposals :: (HasCallStack) => App () +testResendingProposals = do + [alice, bob, charlie] <- createAndConnectUsers [OwnDomain, OwnDomain, OtherDomain] + [alice1, alice2, bob1, bob2, bob3, charlie1] <- + traverse + (createMLSClient def) + [alice, alice, bob, bob, bob, charlie] + traverse_ uploadNewKeyPackage [alice2, bob1, bob2, bob3, charlie1] + + (_, conv) <- createNewGroup alice1 + void $ createAddCommit alice1 [alice, bob, charlie] >>= sendAndConsumeCommitBundle + + createSubConv alice1 "conference" + + void $ createExternalCommit alice2 Nothing >>= sendAndConsumeCommitBundle + void $ createExternalCommit bob1 Nothing >>= sendAndConsumeCommitBundle + void $ createExternalCommit bob2 Nothing >>= sendAndConsumeCommitBundle + void $ createExternalCommit bob3 Nothing >>= sendAndConsumeCommitBundle + + leaveCurrentConv bob1 + leaveCurrentConv bob2 + leaveCurrentConv bob3 + + mls <- getMLSState + withWebSockets (charlie1 : toList mls.members) \wss -> do + void $ createExternalCommit charlie1 Nothing >>= sendAndConsumeCommitBundle + + -- consume proposals after backend resends them + for_ wss \ws -> do + replicateM 3 do + msg <- consumeMessage (fromJust ws.client) Nothing ws + msg %. "message.content.sender.External" `shouldMatchInt` 0 + + void $ createPendingProposalCommit alice1 >>= sendAndConsumeCommitBundle + + sub <- getSubConversation alice1 conv "conference" >>= getJSON 200 + let members = + map + ( \cid -> + object + [ "client_id" .= cid.client, + "user_id" .= cid.user, + "domain" .= cid.domain + ] + ) + [alice1, alice2, charlie1] + sub %. "members" `shouldMatchSet` members diff --git a/integration/test/Test/MLS/Unreachable.hs b/integration/test/Test/MLS/Unreachable.hs index be8564352f5..4e32d293508 100644 --- a/integration/test/Test/MLS/Unreachable.hs +++ b/integration/test/Test/MLS/Unreachable.hs @@ -26,7 +26,7 @@ import SetupHelpers import Testlib.Prelude import Testlib.ResourcePool -testAddUsersSomeReachable :: HasCallStack => App () +testAddUsersSomeReachable :: (HasCallStack) => App () testAddUsersSomeReachable = do (addCommit, d) <- startDynamicBackends [mempty] $ \[thirdDomain] -> do ownDomain <- make OwnDomain & asString @@ -48,7 +48,7 @@ testAddUsersSomeReachable = do (resp.json %. "unreachable_backends" & asList) `shouldMatch` [d] -- | There is analogous counterpart for Proteus in the 'Test.Conversation' module. -testAddUserWithUnreachableRemoteUsers :: HasCallStack => App () +testAddUserWithUnreachableRemoteUsers :: (HasCallStack) => App () testAddUserWithUnreachableRemoteUsers = do resourcePool <- asks resourcePool runCodensity (acquireResources 1 resourcePool) $ \[cDom] -> do @@ -88,7 +88,7 @@ testAddUserWithUnreachableRemoteUsers = do resp.status `shouldMatchInt` 533 resp.jsonBody %. "unreachable_backends" `shouldMatchSet` [cDom.berDomain] -testAddUnreachableUserFromFederatingBackend :: HasCallStack => App () +testAddUnreachableUserFromFederatingBackend :: (HasCallStack) => App () testAddUnreachableUserFromFederatingBackend = do resourcePool <- asks resourcePool runCodensity (acquireResources 1 resourcePool) $ \[cDom] -> do diff --git a/integration/test/Test/MessageTimer.hs b/integration/test/Test/MessageTimer.hs index 9e2e38d4a66..853876c8632 100644 --- a/integration/test/Test/MessageTimer.hs +++ b/integration/test/Test/MessageTimer.hs @@ -26,7 +26,7 @@ import SetupHelpers import Testlib.Prelude import Testlib.ResourcePool -testMessageTimerChangeWithRemotes :: HasCallStack => App () +testMessageTimerChangeWithRemotes :: (HasCallStack) => App () testMessageTimerChangeWithRemotes = do [alice, bob] <- createAndConnectUsers [OwnDomain, OtherDomain] conv <- postConversation alice defProteus {qualifiedUsers = [bob]} >>= getJSON 201 @@ -37,7 +37,7 @@ testMessageTimerChangeWithRemotes = do notif %. "payload.0.qualified_conversation" `shouldMatch` objQidObject conv notif %. "payload.0.qualified_from" `shouldMatch` objQidObject alice -testMessageTimerChangeWithUnreachableRemotes :: HasCallStack => App () +testMessageTimerChangeWithUnreachableRemotes :: (HasCallStack) => App () testMessageTimerChangeWithUnreachableRemotes = do resourcePool <- asks resourcePool alice <- randomUser OwnDomain def diff --git a/integration/test/Test/Notifications.hs b/integration/test/Test/Notifications.hs index 14078b5b56e..b94060814ca 100644 --- a/integration/test/Test/Notifications.hs +++ b/integration/test/Test/Notifications.hs @@ -9,11 +9,11 @@ import Notifications import SetupHelpers import Testlib.Prelude -examplePush :: MakesValue u => u -> App Value +examplePush :: (MakesValue u) => u -> App Value examplePush u = do r <- recipient u - pure $ - object + pure + $ object [ "recipients" .= [r], "payload" .= [object ["hello" .= "world"]] ] @@ -24,8 +24,9 @@ testFetchAllNotifications = do push <- examplePush user let n = 10 - replicateM_ n $ - bindResponse (postPush user [push]) $ \res -> + replicateM_ n + $ bindResponse (postPush user [push]) + $ \res -> res.status `shouldMatchInt` 200 let c :: Maybe String = Just "deadbeef" @@ -74,23 +75,23 @@ testLastNotification = do lastNotif <- getLastNotification user def {client = Just "c"} >>= getJSON 200 lastNotif %. "payload" `shouldMatch` [object ["client" .= "c"]] -testInvalidNotification :: HasCallStack => App () +testInvalidNotification :: (HasCallStack) => App () testInvalidNotification = do user <- randomUserId OwnDomain -- test uuid v4 as "since" do notifId <- randomId - void $ - getNotifications user def {since = Just notifId} - >>= getJSON 400 + void + $ getNotifications user def {since = Just notifId} + >>= getJSON 400 -- test arbitrary uuid v1 as "since" do notifId <- randomUUIDv1 - void $ - getNotifications user def {since = Just notifId} - >>= getJSON 404 + void + $ getNotifications user def {since = Just notifId} + >>= getJSON 404 -- | Check that client-add notifications use the V5 format: -- @ @@ -98,7 +99,7 @@ testInvalidNotification = do -- @ -- -- Migration plan: clients must be able to parse both old and new schema starting from V6. Once V5 is deprecated, the backend can start sending notifications in the new form. -testAddClientNotification :: HasCallStack => App () +testAddClientNotification :: (HasCallStack) => App () testAddClientNotification = do alice <- randomUser OwnDomain def diff --git a/integration/test/Test/Presence.hs b/integration/test/Test/Presence.hs index e6252ea7e2a..75e45a51e38 100644 --- a/integration/test/Test/Presence.hs +++ b/integration/test/Test/Presence.hs @@ -12,7 +12,7 @@ ensurePresent u n = retryT $ do ps <- getPresence u >>= getJSON 200 >>= asList length ps `shouldMatchInt` n -registerUser :: HasCallStack => App (Value, String) +registerUser :: (HasCallStack) => App (Value, String) registerUser = do alice <- randomUserId OwnDomain c <- randomClientId @@ -20,10 +20,10 @@ registerUser = do ensurePresent alice 1 pure (alice, c) -testAddUser :: HasCallStack => App () +testAddUser :: (HasCallStack) => App () testAddUser = void registerUser -testRemoveUser :: HasCallStack => App () +testRemoveUser :: (HasCallStack) => App () testRemoveUser = do -- register alice and add a push token (alice, c) <- registerUser diff --git a/integration/test/Test/Provider.hs b/integration/test/Test/Provider.hs new file mode 100644 index 00000000000..9eb08ea114e --- /dev/null +++ b/integration/test/Test/Provider.hs @@ -0,0 +1,26 @@ +module Test.Provider where + +import API.Brig +-- import API.Cargohold (uploadProviderAsset) + +import qualified API.Cargohold as Cargohold +import API.Common +import qualified API.Nginz as Nginz +import Data.String.Conversions (cs) +import SetupHelpers +import Testlib.Prelude + +testProviderUploadAsset :: (HasCallStack) => App () +testProviderUploadAsset = do + email <- randomEmail + alice <- randomUser OwnDomain def + provider <- setupProvider alice def {newProviderEmail = email} + pid <- provider %. "id" & asString + -- test cargohold API + bindResponse (Cargohold.uploadProviderAsset OwnDomain pid "profile pic") $ \resp -> do + resp.status `shouldMatchInt` 201 + pw <- provider %. "password" & asString + cookie <- loginProvider OwnDomain email pw + -- test Nginz API + bindResponse (Nginz.uploadProviderAsset OwnDomain (cs cookie) "another profile pic") $ \resp -> do + resp.status `shouldMatchInt` 201 diff --git a/integration/test/Test/Roles.hs b/integration/test/Test/Roles.hs index 34ccaff2eba..53886aae61e 100644 --- a/integration/test/Test/Roles.hs +++ b/integration/test/Test/Roles.hs @@ -18,13 +18,12 @@ module Test.Roles where import API.Galley -import Control.Monad.Reader import GHC.Stack import Notifications import SetupHelpers import Testlib.Prelude -testRoleUpdateWithRemotesOk :: HasCallStack => App () +testRoleUpdateWithRemotesOk :: (HasCallStack) => App () testRoleUpdateWithRemotesOk = do [bob, charlie, alice] <- createUsers [OwnDomain, OwnDomain, OtherDomain] connectTwoUsers bob charlie @@ -45,7 +44,7 @@ testRoleUpdateWithRemotesOk = do notif %. "payload.0.qualified_conversation" `shouldMatch` objQidObject conv notif %. "payload.0.qualified_from" `shouldMatch` objQidObject bob -testRoleUpdateWithRemotesUnreachable :: HasCallStack => App () +testRoleUpdateWithRemotesUnreachable :: (HasCallStack) => App () testRoleUpdateWithRemotesUnreachable = do [bob, charlie] <- createUsers [OwnDomain, OwnDomain] startDynamicBackends [mempty] $ \[dynBackend] -> do diff --git a/integration/test/Test/Search.hs b/integration/test/Test/Search.hs index 7d93b4ff015..af3f00d4e56 100644 --- a/integration/test/Test/Search.hs +++ b/integration/test/Test/Search.hs @@ -14,7 +14,7 @@ import Testlib.Prelude -------------------------------------------------------------------------------- -- LOCAL SEARCH -testSearchContactForExternalUsers :: HasCallStack => App () +testSearchContactForExternalUsers :: (HasCallStack) => App () testSearchContactForExternalUsers = do owner <- randomUser OwnDomain def {BrigI.team = True} tid <- owner %. "team" & asString @@ -74,7 +74,7 @@ data FedUserSearchTestCase = FedUserSearchTestCase } deriving (Eq, Ord, Show) -testFederatedUserSearch :: HasCallStack => App () +testFederatedUserSearch :: (HasCallStack) => App () testFederatedUserSearch = do let tcs = [ -- no search @@ -102,7 +102,7 @@ testFederatedUserSearch = do void $ BrigI.createFedConn d1 (BrigI.FedConn d2 "full_search" Nothing) forM_ tcs (federatedUserSearch d1 d2) -federatedUserSearch :: HasCallStack => String -> String -> FedUserSearchTestCase -> App () +federatedUserSearch :: (HasCallStack) => String -> String -> FedUserSearchTestCase -> App () federatedUserSearch d1 d2 test = do void $ BrigI.updateFedConn d2 d1 (BrigI.FedConn d1 test.searchPolicy (restriction test.restrictionD2D1)) void $ BrigI.updateFedConn d1 d2 (BrigI.FedConn d2 test.searchPolicy (restriction test.restrictionD1D2)) @@ -112,7 +112,7 @@ federatedUserSearch d1 d2 test = do u2 <- randomUser d2 def {BrigI.team = True} uidD2 <- objId u2 team2 <- u2 %. "team" - GalleyI.setTeamFeatureStatus d2 team2 "searchVisibilityInbound" "enabled" + assertSuccess =<< GalleyI.setTeamFeatureStatus d2 team2 "searchVisibilityInbound" "enabled" addTeamRestriction d1 d2 team2 test.restrictionD1D2 addTeamRestriction d2 d1 teamU1 test.restrictionD2D1 @@ -158,7 +158,7 @@ federatedUserSearch d1 d2 test = do TeamAllowed -> do BrigI.addFederationRemoteTeam ownDomain remoteDomain remoteTeam -testFederatedUserSearchNonTeamSearcher :: HasCallStack => App () +testFederatedUserSearchNonTeamSearcher :: (HasCallStack) => App () testFederatedUserSearchNonTeamSearcher = do startDynamicBackends [def, def] $ \[d1, d2] -> do void $ BrigI.createFedConn d2 (BrigI.FedConn d1 "full_search" (Just [])) @@ -167,7 +167,7 @@ testFederatedUserSearchNonTeamSearcher = do u1 <- randomUser d1 def u2 <- randomUser d2 def {BrigI.team = True} team2 <- u2 %. "team" - GalleyI.setTeamFeatureStatus d2 team2 "searchVisibilityInbound" "enabled" + assertSuccess =<< GalleyI.setTeamFeatureStatus d2 team2 "searchVisibilityInbound" "enabled" u2Handle <- API.randomHandle bindResponse (BrigP.putHandle u2 u2Handle) $ assertSuccess @@ -189,7 +189,7 @@ testFederatedUserSearchNonTeamSearcher = do doc : _ -> assertFailure $ "Expected an empty result, but got " <> show doc <> " for test case " -testFederatedUserSearchForNonTeamUser :: HasCallStack => App () +testFederatedUserSearchForNonTeamUser :: (HasCallStack) => App () testFederatedUserSearchForNonTeamUser = do startDynamicBackends [def, def] $ \[d1, d2] -> do void $ BrigI.createFedConn d2 (BrigI.FedConn d1 "full_search" Nothing) diff --git a/integration/test/Test/Services.hs b/integration/test/Test/Services.hs index 3156a98561f..eea1ced16b3 100644 --- a/integration/test/Test/Services.hs +++ b/integration/test/Test/Services.hs @@ -22,7 +22,7 @@ import API.Common import SetupHelpers import Testlib.Prelude -testUpdateServiceUpdateAcceptHeader :: HasCallStack => App () +testUpdateServiceUpdateAcceptHeader :: (HasCallStack) => App () testUpdateServiceUpdateAcceptHeader = do let dom = OwnDomain email <- randomEmail @@ -31,12 +31,12 @@ testUpdateServiceUpdateAcceptHeader = do pId <- provider %. "id" & asString service <- newService dom pId def sId <- service %. "id" - void $ - updateService dom pId sId (Just "application/json") (Just "brand new service") - >>= getBody 200 - void $ - updateService dom pId sId (Just "text/plain") (Just "even newer service") - >>= getBody 200 - void $ - updateService dom pId sId Nothing (Just "really old service") - >>= getBody 200 + void + $ updateService dom pId sId (Just "application/json") (Just "brand new service") + >>= getBody 200 + void + $ updateService dom pId sId (Just "text/plain") (Just "even newer service") + >>= getBody 200 + void + $ updateService dom pId sId Nothing (Just "really old service") + >>= getBody 200 diff --git a/integration/test/Test/Spar.hs b/integration/test/Test/Spar.hs index d1e14e85984..ab147901071 100644 --- a/integration/test/Test/Spar.hs +++ b/integration/test/Test/Spar.hs @@ -7,7 +7,7 @@ import Control.Concurrent (threadDelay) import SetupHelpers import Testlib.Prelude -testSparUserCreationInvitationTimeout :: HasCallStack => App () +testSparUserCreationInvitationTimeout :: (HasCallStack) => App () testSparUserCreationInvitationTimeout = do (owner, _tid, _) <- createTeam OwnDomain 1 tok <- createScimToken owner >>= \resp -> resp.json %. "token" >>= asString diff --git a/integration/test/Test/Swagger.hs b/integration/test/Test/Swagger.hs index 76cf6ddc381..5836ead12e0 100644 --- a/integration/test/Test/Swagger.hs +++ b/integration/test/Test/Swagger.hs @@ -14,7 +14,7 @@ internalApis :: Set String internalApis = Set.fromList ["brig", "cannon", "cargohold", "cannon", "spar"] -- | See https://docs.wire.com/understand/api-client-perspective/swagger.html -testSwagger :: HasCallStack => App () +testSwagger :: (HasCallStack) => App () testSwagger = do bindResponse BrigP.getApiVersions $ \resp -> do resp.status `shouldMatchInt` 200 @@ -22,11 +22,13 @@ testSwagger = do sup <- resp.json %. "supported" & asSetOf asIntegral dev <- resp.json %. "development" & asSetOf asIntegral pure $ sup <> dev - assertBool ("unexpected actually existing versions: " <> show actualVersions) $ + assertBool ("unexpected actually existing versions: " <> show actualVersions) + $ -- make sure nobody has added a new version without adding it to `existingVersions`. -- ("subset" because blocked versions like v3 are not actually existing, but still -- documented.) - actualVersions `Set.isSubsetOf` existingVersions + actualVersions + `Set.isSubsetOf` existingVersions bindResponse BrigP.getSwaggerPublicTOC $ \resp -> do resp.status `shouldMatchInt` 200 @@ -52,7 +54,7 @@ testSwagger = do resp.status `shouldMatchInt` 200 void resp.json -testSwaggerInternalVersionedNotFound :: HasCallStack => App () +testSwaggerInternalVersionedNotFound :: (HasCallStack) => App () testSwaggerInternalVersionedNotFound = do forM_ internalApis $ \api -> do bindResponse (getSwaggerInternalUI api) $ \resp -> do @@ -63,7 +65,7 @@ testSwaggerInternalVersionedNotFound = do rawBaseRequest OwnDomain Brig (ExplicitVersion 2) (joinHttpPath ["api-internal", "swagger-ui", srv]) >>= submit "GET" -testSwaggerToc :: HasCallStack => App () +testSwaggerToc :: (HasCallStack) => App () testSwaggerToc = do forM_ ["/api/swagger-ui", "/api/swagger-ui/index.html", "/api/swagger.json"] $ \path -> bindResponse (get path) $ \resp -> do diff --git a/integration/test/Test/TeamSettings.hs b/integration/test/Test/TeamSettings.hs index 3be86c60d34..03a667cf78e 100644 --- a/integration/test/Test/TeamSettings.hs +++ b/integration/test/Test/TeamSettings.hs @@ -23,7 +23,7 @@ import API.Galley import SetupHelpers import Testlib.Prelude -testTeamSettingsUpdate :: HasCallStack => App () +testTeamSettingsUpdate :: (HasCallStack) => App () testTeamSettingsUpdate = do (ownerA, tidA, [mem]) <- createTeam OwnDomain 2 partner <- createTeamMemberWithRole ownerA tidA "partner" @@ -42,7 +42,7 @@ testTeamSettingsUpdate = do resp.status `shouldMatchInt` 403 resp.json %. "label" `shouldMatch` "no-team-member" -testTeamPropertiesUpdate :: HasCallStack => App () +testTeamPropertiesUpdate :: (HasCallStack) => App () testTeamPropertiesUpdate = do (ownerA, tidA, [mem]) <- createTeam OwnDomain 2 partner <- createTeamMemberWithRole ownerA tidA "partner" diff --git a/integration/test/Test/User.hs b/integration/test/Test/User.hs index 89af540d2eb..183a391d779 100644 --- a/integration/test/Test/User.hs +++ b/integration/test/Test/User.hs @@ -6,12 +6,13 @@ import API.Brig import API.BrigInternal import API.GalleyInternal import API.Spar +import qualified Data.Aeson as Aeson import qualified Data.UUID as UUID import qualified Data.UUID.V4 as UUID import SetupHelpers import Testlib.Prelude -testSupportedProtocols :: HasCallStack => Domain -> App () +testSupportedProtocols :: (HasCallStack) => Domain -> App () testSupportedProtocols bobDomain = do alice <- randomUser OwnDomain def alice %. "supported_protocols" `shouldMatchSet` ["proteus"] @@ -43,7 +44,7 @@ testSupportedProtocols bobDomain = do resp.status `shouldMatchInt` 400 resp.json %. "label" `shouldMatch` "bad-request" -testCreateUserSupportedProtocols :: HasCallStack => App () +testCreateUserSupportedProtocols :: (HasCallStack) => App () testCreateUserSupportedProtocols = do alice <- randomUser OwnDomain def {supportedProtocols = Just ["proteus", "mls"]} bindResponse (getUserSupportedProtocols alice alice) $ \resp -> do @@ -56,7 +57,7 @@ testCreateUserSupportedProtocols = do -- | For now this only tests attempts to update /self/handle in E2EId-enabled teams. More -- tests can be found under `/services/brig/test/integration` (and should be moved here). -testUpdateHandle :: HasCallStack => App () +testUpdateHandle :: (HasCallStack) => App () testUpdateHandle = do -- create team with one member, without scim, but with `mlsE2EId` enabled. (owner, team, [mem1]) <- createTeam OwnDomain 2 @@ -66,7 +67,7 @@ testUpdateHandle = do bindResponse (getTeamFeature owner team featureName) $ \resp -> do resp.status `shouldMatchInt` 200 resp.json %. "status" `shouldMatch` "disabled" - setTeamFeatureStatus owner team featureName "enabled" + assertSuccess =<< setTeamFeatureStatus owner team featureName "enabled" bindResponse (getTeamFeature owner team featureName) $ \resp -> do resp.status `shouldMatchInt` 200 resp.json %. "status" `shouldMatch` "enabled" @@ -120,7 +121,7 @@ testUpdateHandle = do -- | For now this only tests attempts to update one's own display name, email address, or -- language in E2EId-enabled teams (ie., everything except handle). More tests can be found -- under `/services/brig/test/integration` (and should be moved here). -testUpdateSelf :: HasCallStack => Tagged "mode" TestUpdateSelfMode -> App () +testUpdateSelf :: (HasCallStack) => Tagged "mode" TestUpdateSelfMode -> App () testUpdateSelf (MkTagged mode) = do -- create team with one member, without scim, but with `mlsE2EId` enabled. (owner, team, [mem1]) <- createTeam OwnDomain 2 @@ -129,7 +130,7 @@ testUpdateSelf (MkTagged mode) = do bindResponse (getTeamFeature owner team featureName) $ \resp -> do resp.status `shouldMatchInt` 200 resp.json %. "status" `shouldMatch` "disabled" - setTeamFeatureStatus owner team featureName "enabled" + assertSuccess =<< setTeamFeatureStatus owner team featureName "enabled" bindResponse (getTeamFeature owner team featureName) $ \resp -> do resp.status `shouldMatchInt` 200 resp.json %. "status" `shouldMatch` "enabled" @@ -163,3 +164,12 @@ data TestUpdateSelfMode | TestUpdateEmailAddress | TestUpdateLocale deriving (Eq, Show, Generic) + +testActivateAccountWithPhoneV5 :: (HasCallStack) => App () +testActivateAccountWithPhoneV5 = do + let dom = OwnDomain + let phone = "+4912345678" + let reqBody = Aeson.object ["phone" .= phone] + activateUserV5 dom reqBody `bindResponse` \resp -> do + resp.status `shouldMatchInt` 400 + resp.json %. "label" `shouldMatch` "invalid-phone" diff --git a/integration/test/Test/Version.hs b/integration/test/Test/Version.hs index 40c4dfeb14d..abd59a49958 100644 --- a/integration/test/Test/Version.hs +++ b/integration/test/Test/Version.hs @@ -47,12 +47,12 @@ testVersion (Versioned' v) = withModifiedBackend domain `shouldMatch` dom federation `shouldMatch` True - unless (null (Set.intersection supported dev)) $ - assertFailure "development and supported versions should not overlap" + unless (null (Set.intersection supported dev)) + $ assertFailure "development and supported versions should not overlap" testVersionUnsupported :: App () -testVersionUnsupported = bindResponse (baseRequest OwnDomain Brig (ExplicitVersion 500) "/api-version" >>= submit "GET") $ - \resp -> do +testVersionUnsupported = bindResponse (baseRequest OwnDomain Brig (ExplicitVersion 500) "/api-version" >>= submit "GET") + $ \resp -> do resp.status `shouldMatchInt` 404 resp.json %. "label" `shouldMatch` "unsupported-version" diff --git a/integration/test/Testlib/App.hs b/integration/test/Testlib/App.hs index 904386a791e..38188f9a67e 100644 --- a/integration/test/Testlib/App.hs +++ b/integration/test/Testlib/App.hs @@ -18,7 +18,7 @@ import Testlib.JSON import Testlib.Types import Prelude -failApp :: HasCallStack => String -> App a +failApp :: (HasCallStack) => String -> App a failApp msg = throw (AppFailure msg) getPrekey :: App Value @@ -78,11 +78,11 @@ retryT :: App a -> App a retryT action = Retry.recoverAll (Retry.exponentialBackoff 8000 <> Retry.limitRetries 10) (const action) -- | make Bool lazy -liftBool :: Functor f => f Bool -> BoolT f +liftBool :: (Functor f) => f Bool -> BoolT f liftBool = MaybeT . fmap (bool Nothing (Just ())) -- | make Bool strict -unliftBool :: Functor f => BoolT f -> f Bool +unliftBool :: (Functor f) => BoolT f -> f Bool unliftBool = fmap isJust . runMaybeT -- | lazy (&&) diff --git a/integration/test/Testlib/Assertions.hs b/integration/test/Testlib/Assertions.hs index ac86c962147..f426336b6c7 100644 --- a/integration/test/Testlib/Assertions.hs +++ b/integration/test/Testlib/Assertions.hs @@ -6,6 +6,7 @@ import Control.Applicative ((<|>)) import Control.Exception as E import Control.Lens ((^?)) import qualified Control.Lens.Plated as LP +import Control.Monad import Control.Monad.Reader import Data.Aeson (Value) import qualified Data.Aeson as Aeson @@ -33,7 +34,7 @@ import Testlib.Printing import Testlib.Types import Prelude -assertBool :: HasCallStack => String -> Bool -> App () +assertBool :: (HasCallStack) => String -> Bool -> App () assertBool _ True = pure () assertBool msg False = assertFailure msg @@ -42,7 +43,7 @@ assertOne xs = case toList xs of [x] -> pure x other -> assertFailure ("Expected one, but got " <> show (length other)) -expectFailure :: HasCallStack => (AssertionFailure -> App ()) -> App a -> App () +expectFailure :: (HasCallStack) => (AssertionFailure -> App ()) -> App a -> App () expectFailure checkFailure action = do env <- ask res :: Either AssertionFailure x <- @@ -234,15 +235,24 @@ shouldMatchOneOf a b = do assertFailure $ "Expected:\n" <> pa <> "\n to match at least one of:\n" <> pb shouldContainString :: - HasCallStack => + (HasCallStack) => -- | The actual value String -> -- | The expected value String -> App () -super `shouldContainString` sub = do +shouldContainString = shouldContain + +shouldContain :: + (Eq a, Show a, HasCallStack) => + -- | The actual value + [a] -> + -- | The expected value + [a] -> + App () +super `shouldContain` sub = do unless (sub `isInfixOf` super) $ do - assertFailure $ "String:\n" <> show super <> "\nDoes not contain:\n" <> show sub + assertFailure $ "String or List:\n" <> show super <> "\nDoes not contain:\n" <> show sub printFailureDetails :: AssertionFailure -> IO String printFailureDetails (AssertionFailure stack mbResponse msg) = do diff --git a/integration/test/Testlib/Cannon.hs b/integration/test/Testlib/Cannon.hs index 8ab338df38a..7b69cf60cad 100644 --- a/integration/test/Testlib/Cannon.hs +++ b/integration/test/Testlib/Cannon.hs @@ -38,6 +38,7 @@ module Testlib.Cannon printAwaitResult, printAwaitAtLeastResult, waitForResponse, + assertNoEvent, ) where @@ -60,6 +61,7 @@ import Data.Function import Data.Maybe import Data.Traversable import Data.Word +import GHC.Records import GHC.Stack import qualified Network.HTTP.Client as HTTP import qualified Network.HTTP.Client as Http @@ -77,11 +79,22 @@ import UnliftIO (withRunInIO) import Prelude data WebSocket = WebSocket - { wsChan :: TChan Value, + { wsConnect :: WSConnect, + wsChan :: TChan Value, wsCloseLatch :: MVar (), wsAppThread :: Async () } +instance HasField "client" WebSocket (Maybe ClientIdentity) where + getField ws = do + c <- ws.wsConnect.client + pure + ClientIdentity + { domain = ws.wsConnect.domain, + user = ws.wsConnect.user, + client = c + } + -- Specifies how a Websocket at cannon should be opened data WSConnect = WSConnect { user :: String, @@ -92,12 +105,12 @@ data WSConnect = WSConnect } class ToWSConnect a where - toWSConnect :: HasCallStack => a -> App WSConnect + toWSConnect :: (HasCallStack) => a -> App WSConnect instance {-# OVERLAPPING #-} ToWSConnect WSConnect where toWSConnect = pure -instance {-# OVERLAPPABLE #-} MakesValue user => ToWSConnect user where +instance {-# OVERLAPPABLE #-} (MakesValue user) => ToWSConnect user where toWSConnect u = do (domain, uid) <- objQid u mc <- lookupField u "client_id" @@ -117,14 +130,14 @@ instance (MakesValue user, MakesValue conn, MakesValue client) => ToWSConnect (u conn <- make c & asString pure (WSConnect uid domain (Just client) (Just conn)) -connect :: HasCallStack => WSConnect -> App WebSocket +connect :: (HasCallStack) => WSConnect -> App WebSocket connect wsConnect = do nchan <- liftIO newTChanIO latch <- liftIO newEmptyMVar wsapp <- run wsConnect (clientApp nchan latch) - pure $ WebSocket nchan latch wsapp + pure $ WebSocket wsConnect nchan latch wsapp -clientApp :: HasCallStack => TChan Value -> MVar () -> WS.ClientApp () +clientApp :: (HasCallStack) => TChan Value -> MVar () -> WS.ClientApp () clientApp wsChan latch conn = do r <- async wsRead w <- async wsWrite @@ -142,7 +155,7 @@ clientApp wsChan latch conn = do -- | Start a client thread in 'Async' that opens a web socket to a Cannon, wait -- for the connection to register with Gundeck, and return the 'Async' thread. run :: - HasCallStack => + (HasCallStack) => WSConnect -> WS.ClientApp () -> App (Async ()) @@ -211,7 +224,7 @@ run wsConnect app = do liftIO $ race_ waitForPresence waitForException pure wsapp -close :: MonadIO m => WebSocket -> m () +close :: (MonadIO m) => WebSocket -> m () close ws = liftIO $ do putMVar (wsCloseLatch ws) () void $ waitCatch (wsAppThread ws) @@ -226,7 +239,7 @@ withWebSockets twcs k = do wcs <- for twcs toWSConnect go wcs [] where - go :: HasCallStack => [WSConnect] -> [WebSocket] -> App a + go :: (HasCallStack) => [WSConnect] -> [WebSocket] -> App a go [] wss = k (reverse wss) go (wc : wcs) wss = withWebSocket wc (\ws -> go wcs (ws : wss)) @@ -293,7 +306,7 @@ awaitAnyEvent tSecs = liftIO . timeout (tSecs * 1000 * 1000) . atomically . read -- received. When this functions returns it will push any non-matching -- events back to the websocket. awaitNMatchesResult :: - HasCallStack => + (HasCallStack) => -- | Number of matches Int -> -- | Selection function. Exceptions are *not* caught. @@ -333,7 +346,7 @@ awaitNMatchesResult nExpected checkMatch ws = go nExpected [] [] refill = mapM_ (liftIO . atomically . writeTChan (wsChan ws)) awaitAtLeastNMatchesResult :: - HasCallStack => + (HasCallStack) => -- | Minimum number of matches Int -> -- | Selection function. Exceptions are *not* caught. @@ -365,7 +378,7 @@ awaitAtLeastNMatchesResult nExpected checkMatch ws = go 0 [] [] refill = mapM_ (liftIO . atomically . writeTChan (wsChan ws)) awaitNToMMatchesResult :: - HasCallStack => + (HasCallStack) => -- | Minimum number of matches Int -> -- | Maximum number of matches @@ -399,7 +412,7 @@ awaitNToMMatchesResult nMin nMax checkMatch ws = go 0 [] [] refill = mapM_ (liftIO . atomically . writeTChan (wsChan ws)) awaitNMatches :: - HasCallStack => + (HasCallStack) => -- | Number of matches Int -> -- | Selection function. Should not throw any exceptions @@ -410,7 +423,7 @@ awaitNMatches nExpected checkMatch ws = do res <- awaitNMatchesResult nExpected checkMatch ws assertAwaitResult res -assertAwaitResult :: HasCallStack => AwaitResult -> App [Value] +assertAwaitResult :: (HasCallStack) => AwaitResult -> App [Value] assertAwaitResult res = do if res.success then pure res.matches @@ -420,7 +433,7 @@ assertAwaitResult res = do assertFailure $ unlines [msgHeader, details] awaitAtLeastNMatches :: - HasCallStack => + (HasCallStack) => -- | Minumum number of matches Int -> -- | Selection function. Should not throw any exceptions @@ -437,7 +450,7 @@ awaitAtLeastNMatches nExpected checkMatch ws = do assertFailure $ unlines [msgHeader, details] awaitNToMMatches :: - HasCallStack => + (HasCallStack) => -- | Minimum Number of matches Int -> -- | Maximum Number of matches @@ -456,20 +469,31 @@ awaitNToMMatches nMin nMax checkMatch ws = do assertFailure $ unlines [msgHeader, details] awaitMatch :: - HasCallStack => + (HasCallStack) => -- | Selection function. Should not throw any exceptions (Value -> App Bool) -> WebSocket -> App Value awaitMatch checkMatch ws = head <$> awaitNMatches 1 checkMatch ws -nPayload :: MakesValue a => a -> App Value +assertNoEvent :: + (HasCallStack) => + Int -> + WebSocket -> + App () +assertNoEvent to ws = do + mEvent <- awaitAnyEvent to ws + case mEvent of + Just event -> assertFailure $ "Expected no event, but got: " <> show event + Nothing -> pure () + +nPayload :: (MakesValue a) => a -> App Value nPayload event = do payloads <- event %. "payload" & asList assertOne payloads -- | waits for an http response to satisfy a predicate -waitForResponse :: HasCallStack => App Response -> (Response -> App r) -> App r +waitForResponse :: (HasCallStack) => App Response -> (Response -> App r) -> App r waitForResponse act p = do tSecs <- asks timeOutSeconds r <- withRunInIO \inIO -> diff --git a/integration/test/Testlib/Certs.hs b/integration/test/Testlib/Certs.hs new file mode 100644 index 00000000000..b6fda9b5204 --- /dev/null +++ b/integration/test/Testlib/Certs.hs @@ -0,0 +1,144 @@ +module Testlib.Certs where + +import Crypto.Hash.Algorithms (SHA256 (SHA256)) +import qualified Crypto.PubKey.RSA as RSA +import qualified Crypto.PubKey.RSA.PKCS15 as PKCS15 +import Crypto.Store.PKCS8 (PrivateKeyFormat (PKCS8Format), keyToPEM) +import Crypto.Store.X509 (pubKeyToPEM) +import Data.ASN1.OID (OIDable (getObjectID)) +import Data.Hourglass +import Data.PEM (PEM (PEM), pemWriteBS) +import Data.String.Conversions (cs) +import Data.X509 +import Testlib.Prelude + +type RSAKeyPair = (RSA.PublicKey, RSA.PrivateKey) + +type SignedCert = SignedExact Certificate + +-- | convert a PEM to a string +toPem :: PEM -> String +toPem = cs . pemWriteBS + +-- | convert a signed certificate to a string +signedCertToString :: SignedCert -> String +signedCertToString = toPem . PEM "CERTIFICATE" [] . encodeSignedObject + +-- | convert a private key to string +privateKeyToString :: RSA.PrivateKey -> String +privateKeyToString = toPem . keyToPEM PKCS8Format . PrivKeyRSA + +-- | convert a public key to string +publicKeyToString :: RSA.PublicKey -> String +publicKeyToString = toPem . pubKeyToPEM . PubKeyRSA + +-- | order: publickey, private key +keyPairToString :: RSAKeyPair -> (String, String) +keyPairToString = bimap publicKeyToString privateKeyToString + +-- | the minimum key size is hard coded to be 256 bytes (= 2048 bits) +mkKeyPair :: (HasCallStack) => (Integer, Integer) -> App RSAKeyPair +mkKeyPair primes = + assertJust "key generation failed" + $ RSA.generateWith + primes + 2048 + 65537 + +primesA :: (Integer, Integer) +primesA = + ( 1013416710455617992060044810859399709890835129925648843043641673852539448350775594187007527506724875627885909523835606557173980236290013476205929897072239944138314384631600538474898358198731711608598716779857515154388088878657555928549962380829213547435085854695442354636327047821108802590374275481605077802187415357974963365435650338024405558985202998762641404395411587629314013330411500470203761301812113710962088477051775450894192994742118846780105265558368972170180276350636994878636389758206123738715722878057404540464220733023391993383290494652037274532356460190907090422144536951440069212998822960155765054879900781581263606916652700903953626527029121897494538017122565993895036773799860052414697053960902764894046849087727915659738623914130083281919853081537137782445589156217286369690178786653090799221857147470043219175767249163571686740347462294750028790472737772761949491538873890614496706566060247820117584298845501935064037819052405654373374661838572553244593002834443762478259268799467895951456315647324157054992319938064879914915556645111272573189405077515029783954913337757933225821260787418411247627537065834022908147122036442414923430533383989652364612738513379313521406363716216150953874675705623133860932309998632104801092827841702718992714882139811954467163400593020720191718049863114367363094097654194786896842879463158349468509662084081492854544553121389587671952367596127566679408181243898540691657673709282297206699665271972122876732477153246545187514721891966873910637813569799235783300883640120382296336980469139678449923244327325676463743789034561023783533980749100272005938046751700931286800296518645750336292219055157506140422334232031499441618108378207249469768514341014613604798707882336528213109908520952809254346958192134161621644423814067058523341464457188689237566854457651740962437154879472377563420329379777383724869785437079461381042576932777663816932792106785972722313112138774627384189872028788531464434347861094422498231096686231475413078333450041613628998736286930594422166708703115486915826404578851616898264340560519310655180870217752558303339822824214706404615558734661262111177357709447064658518593459191904042065215329175588893364731436963818899069593653897213811368511785916948261704025900054681973429106441628584851712758726618885443787735678619865846520873765930283904988556631550968487727144405349504203063775775239807234977371854786517646240982498594502233136236903225375658288185007963323167751702824125884605983, + 927336758709169856221729309972684377326012758705584701160913392855296574209188805952293975727392736357355525822682625960867980784906333126250176772633612511280160520450355917665344680820117001909657304528897728644985372222487760541890997744380957145384918405839817509991111341989419216342513467094263440712622240826707558561965237909070383875063686755789716081493927682670013715434239129366779748040394792694841549258598842315715859562294976974200564408338450316192760863885386436881465495436476022429943600686139972778561942722494137924396693749231870673494020761865863446686474725091312431012619078931330640808188498974525508440925548025604310429878232463952454557835744654770844144316962049844107999645072674978011865146180434315809137160022154815275730622923394822959089495198091753080586758917401240837851455881168916390487103230014598246305055773428160686563500509562651266122967947533947385066722712316194439650272469880653336775557226431438158529031941085177895035782278423238393385871537920481620086314516883242108371084035236009476902958675684122414056114458154814623140680549398143962297844269217544119579639388880282746926211911340151495180800938356829417651851575812389707158878607136197574826859775996273379970390171328581948608028025142182853278853363612390290636206287758711077096741448655899931751827724488361988091582792716911972718148392453707898042946671553774030598713651389432173834332238513353580335392843797930178943386918304488493730840967156657148290968957715981554273773737487151449135620952308225431024688393136984555900143424679822610046551196808932727745248865362347785479364187372055325574195459037155066312293273886348144861748982170185415622553571530631513603477602826429579398186262265223153306278304799915076700814229178193555765145764377299909576623617487785999435363105546438656832847240507003602597491108906216981192670279162943412764046303699081784813538920115117298548433198843455119043790372888336933692344328141527872374759669746090941218187034798766305747971923638002946091334202545017363599031086846658957509235784541901412672981937055987278520433029602910026209333275313496848631869151490522436140352421940732910006747478399676998276993458833024795683746787074826108339213690383195100285198326586610540809574097037429381790444840835133521220930836457168264627708965665242143474257229651142989737540001394269465834767510321913987796958346807012067096569096845804007816516090656151634293085062792873308124403242170010908041 + ) + +primesB :: (Integer, Integer) +primesB = + ( 871155632739595756799368259914317757869334272154983889623497899446351035891726950864760818802838595063934628826345508916199957107684222515882852684036230531365663403198038587540738738037375348907830388509196441061498831829580551641232283859846190461640815357339853825341277581978021694268863680319244800913484314268404426052051276279669361259959567803085510055380452465751288284768848270342730747029989822198165263072973301996345116628415172285009118708059077706393593020607784780174671547072573221780144687345051988772069027762089091988339582468302138720780718092405021682721751886066645363782225165192495156519578684200413534356562613176683748354996198186163955382610564385310389118252336135259031274255451291680971631891663534692283032504605093383857083862510210862275042255073696123798884409160503619458509744563163914332600437715745600147161022540996340483674184441810042828159783031479546834467530369264396884330140711499699266924456618312375561602660949586678704688686856427513634257055225556101020484663286239650064186437382802373072023507182933268791570788599931961833813734037134668038054950930969107492644097198321408480575010280891590867974839171422952718717441444733710567680383351516170682903290649975877510922338625322722929191152330381838484770793021720831482560176937010381470742911288685130877749162737215149115897767752780906005531169766158172378124848548236188253951341833337787491191664609190850061976677827193348008151669235627322237835010267056500055155911065051791530775399726348686264567265615592790858074242165758723415045115369812705468997801074923865225034659418948148275742092201647617244926597099611670028261172621565835558819135359344483800612705319426768052233109556067407938461005945571595672934139094853414792890276083259923707564466948103729121571083500502589982253333701218140215063120367647585300928378204225025283637784718810313259064139990414485231379692327258476858053769854028351496526751167792340279523340296200242416054659843844911906831964521310830916452145341389783536384312312436425360442183300971035975855454272571297920101093815174274315270008040800474966896945391435392494085295376492758667434573362418630322524804767037530872608312526851376234941674830096729913417387669746155771937829809497813203635102474604063142988339458080423659799467256308889003645375406858192706500220530718350804807804829694351252086594036332829897567632623034066916145636238868932684508748622471625137517969447341759208173885041127987345267, + 1030843359898456423663521323846594342599509001361505950190458094255790543792826808869649005832755187592625111972154015489882697017782849415061917844274039201990123282710414810809677284498651901967728601289390435426055251344683598043635553930587608961202440578033000424009931449958127951542294372025522185552538021557179009278446615246891375299863655746951224012338422185000952023195927317706092311999889180603374149659663869483313116251085191329801800565556652256960650364631610748235925879940728370511827034946814052737660926604082837303885143652256413187183052924192977324527952882600246973965189570970469037044568259408811931440525775822585332497163319841870179534838043708793539688804501356153704884928847627798172061867373042270416202913078776299057112318300845218218100606684092792088779583532324019862407866255929320869554565576301069075336647916168479092314004711778618335406757602974282533765740790546167166172626995630463716394043281720388344899550856555259477489548509996409954619324524195894460510128676025203769176155038527250084664954695197534485529595784255553806751541708069739004260117122700058054443774458724994738753921481706985581116480802534320353367271370286704034867136678539759260831996400891886615914808935283451835347282009482924185619896114631919985205238905153951336432886954324618000593140640843908517786951586431386674557882396487935889471856924185568502767114186884930347618747984770073080480895996031031971187681573023398782756925726725786964170460286504569090697402674905089317540771910375616350312239688178277204391962835159620450731320465816254229575392846112372636483958055913716148919092913102176828552932292829256960875180097808893909460952573027221089128208000054670526724565994184754244760290009957352237133054978847493874379201323517903544742831961755055100216728931496213920467911320372016970509300894067675803619448926461034580033818298648457643287641768005986812455071220244863874301028965665847375769473444088940776224643189987541019987285740411119351744972645543429351630677554481991322726604779330104110295967482897278840078926508970545806499140537364387530291523697762079684955475417383069988065253583073257131193644210418873929829417895241230927769637328283865111435730810586338426336027745629520975220163350734423915441885289661065494424704587153904031874537230782548938379423349488654701140981815973723582107593419642780372301171156324514852331126462907486017679770773972513376077318418003532168673261819818236071249 + ) + +-- | create a root certificate authority CertificateBundle +createRootCA :: + (HasCallStack) => + -- | the root CA's name + String -> + -- | the root CA's keymaterial + RSAKeyPair -> + SignedCert +createRootCA caName (pubKey, privKey) = + mkSignedCert + pubKey + privKey + caName + caName + +-- | sign an intermediate/ leaf certificate by signing with an intermediate/ root CA's key +intermediateCert :: + (HasCallStack) => + -- | name of the owner of the certificate + String -> + -- | the public key of the owner + RSA.PublicKey -> + -- | name of the signatory (intermediate/ root CA) + String -> + -- | the private (signature) key of the signing (intermediate/ root) CA + RSA.PrivateKey -> + SignedCert +intermediateCert intermediateCaName pubKey rootCaName rootKey = + mkSignedCert + pubKey + rootKey + rootCaName + intermediateCaName + +-- | self sign a certificate +selfSignedCert :: + (HasCallStack) => + -- | name of the owner + String -> + -- | key material of the owner + RSAKeyPair -> + SignedCert +selfSignedCert ownerName (pubKey, privKey) = + mkSignedCert + pubKey + privKey + ownerName + ownerName + +signMsgWithPrivateKey :: (HasCallStack) => RSA.PrivateKey -> ByteString -> ByteString +signMsgWithPrivateKey privKey = fromRight (error "signing unsuccessful") . PKCS15.sign Nothing (Just SHA256) privKey + +-- | create a signed certificate +mkSignedCert :: + (HasCallStack) => + -- | public key of the *owner* + RSA.PublicKey -> + -- | private key of *signatory* + RSA.PrivateKey -> + -- | name of the issuer + String -> + -- | name of the owner + String -> + SignedExact Certificate +mkSignedCert pubKey privKey caName ownerName = + let distinguishedName name = + DistinguishedName + [ (getObjectID DnCommonName, fromString $ name), + (getObjectID DnCountry, fromString "DE") + ] + in fst + $ objectToSignedExact + (\msg -> (signMsgWithPrivateKey privKey msg, SignatureALG HashSHA256 PubKeyALG_RSA, ())) + Certificate + { certVersion = 3, + certSerial = 1, + certSignatureAlg = SignatureALG HashSHA256 PubKeyALG_RSA, + certIssuerDN = distinguishedName caName, + certValidity = (DateTime {dtDate = Date 2000 January 1, dtTime = midNight}, DateTime {dtDate = Date 2049 January 1, dtTime = midNight}), + certSubjectDN = distinguishedName ownerName, + certPubKey = PubKeyRSA pubKey, + certExtensions = Extensions Nothing + } + where + midNight = TimeOfDay 0 0 0 0 diff --git a/integration/test/Testlib/HTTP.hs b/integration/test/Testlib/HTTP.hs index e21b6e3c588..d155a45c46f 100644 --- a/integration/test/Testlib/HTTP.hs +++ b/integration/test/Testlib/HTTP.hs @@ -37,7 +37,7 @@ joinHttpPath = intercalate "/" addJSONObject :: [Aeson.Pair] -> HTTP.Request -> HTTP.Request addJSONObject = addJSON . Aeson.object -addJSON :: Aeson.ToJSON a => a -> HTTP.Request -> HTTP.Request +addJSON :: (Aeson.ToJSON a) => a -> HTTP.Request -> HTTP.Request addJSON obj = addBody (HTTP.RequestBodyLBS (Aeson.encode obj)) "application/json" addBody :: HTTP.RequestBody -> String -> HTTP.Request -> HTTP.Request @@ -83,41 +83,41 @@ contentTypeJSON = addHeader "Content-Type" "application/json" contentTypeMixed :: HTTP.Request -> HTTP.Request contentTypeMixed = addHeader "Content-Type" "multipart/mixed" -bindResponse :: HasCallStack => App Response -> (Response -> App a) -> App a +bindResponse :: (HasCallStack) => App Response -> (Response -> App a) -> App a bindResponse m k = m >>= \r -> withResponse r k infixl 1 `bindResponse` -withResponse :: HasCallStack => Response -> (Response -> App a) -> App a +withResponse :: (HasCallStack) => Response -> (Response -> App a) -> App a withResponse r k = onFailureAddResponse r (k r) -- | Check response status code, then return body. -getBody :: HasCallStack => Int -> Response -> App ByteString +getBody :: (HasCallStack) => Int -> Response -> App ByteString getBody status = flip withResponse \resp -> do resp.status `shouldMatch` status pure resp.body -- | Check response status code, then return JSON body. -getJSON :: HasCallStack => Int -> Response -> App Aeson.Value +getJSON :: (HasCallStack) => Int -> Response -> App Aeson.Value getJSON status = flip withResponse \resp -> do resp.status `shouldMatch` status resp.json -- | assert a response code in the 2** range -assertSuccess :: HasCallStack => Response -> App () +assertSuccess :: (HasCallStack) => Response -> App () assertSuccess = flip withResponse \resp -> resp.status `shouldMatchRange` (200, 299) -- | assert a response status code -assertStatus :: HasCallStack => Int -> Response -> App () +assertStatus :: (HasCallStack) => Int -> Response -> App () assertStatus status = flip withResponse \resp -> resp.status `shouldMatchInt` status -- | assert a failure with some failure code and label -assertLabel :: HasCallStack => Int -> String -> Response -> App () +assertLabel :: (HasCallStack) => Int -> String -> Response -> App () assertLabel status label resp = do j <- getJSON status resp j %. "label" `shouldMatch` label -onFailureAddResponse :: HasCallStack => Response -> App a -> App a +onFailureAddResponse :: (HasCallStack) => Response -> App a -> App a onFailureAddResponse r m = App $ do e <- ask liftIO $ E.catch (runAppWithEnv e m) $ \(AssertionFailure stack _ msg) -> do @@ -160,6 +160,9 @@ baseRequest user service versioned path = do zUser :: String -> HTTP.Request -> HTTP.Request zUser = addHeader "Z-User" +zProvider :: String -> HTTP.Request -> HTTP.Request +zProvider = addHeader "Z-Provider" + zConnection :: String -> HTTP.Request -> HTTP.Request zConnection = addHeader "Z-Connection" diff --git a/integration/test/Testlib/JSON.hs b/integration/test/Testlib/JSON.hs index 62eda62cba2..a62065ed5f4 100644 --- a/integration/test/Testlib/JSON.hs +++ b/integration/test/Testlib/JSON.hs @@ -54,42 +54,42 @@ import Prelude -- 2. has no "user" field -- 3. the nested update fails class MakesValue a where - make :: HasCallStack => a -> App Value + make :: (HasCallStack) => a -> App Value -instance {-# OVERLAPPABLE #-} ToJSON a => MakesValue a where +instance {-# OVERLAPPABLE #-} (ToJSON a) => MakesValue a where make = pure . toJSON -instance {-# OVERLAPPING #-} ToJSON a => MakesValue (App a) where +instance {-# OVERLAPPING #-} (ToJSON a) => MakesValue (App a) where make m = m <&> toJSON -- use this to provide Nothing for MakesValue a => (Maybe a) values. noValue :: Maybe Value noValue = Nothing -(.=) :: ToJSON a => String -> a -> Aeson.Pair +(.=) :: (ToJSON a) => String -> a -> Aeson.Pair (.=) k v = fromString k Aeson..= v -(.=?) :: ToJSON a => String -> Maybe a -> Maybe Aeson.Pair +(.=?) :: (ToJSON a) => String -> Maybe a -> Maybe Aeson.Pair (.=?) k v = (Aeson..=) (fromString k) <$> v -- | Convert JSON null to Nothing. -asOptional :: HasCallStack => MakesValue a => a -> App (Maybe Value) +asOptional :: (HasCallStack) => (MakesValue a) => a -> App (Maybe Value) asOptional x = do v <- make x pure $ case v of Null -> Nothing _ -> Just v -asString :: HasCallStack => MakesValue a => a -> App String +asString :: (HasCallStack) => (MakesValue a) => a -> App String asString x = make x >>= \case (String s) -> pure (T.unpack s) v -> assertFailureWithJSON x ("String" `typeWasExpectedButGot` v) -asText :: HasCallStack => MakesValue a => a -> App T.Text +asText :: (HasCallStack) => (MakesValue a) => a -> App T.Text asText = (fmap T.pack) . asString -asStringM :: HasCallStack => MakesValue a => a -> App (Maybe String) +asStringM :: (HasCallStack) => (MakesValue a) => a -> App (Maybe String) asStringM x = make x >>= \case (String s) -> pure (Just (T.unpack s)) @@ -103,16 +103,16 @@ asByteString x = do Left _ -> assertFailure "Could not base64 decode" Right a -> pure a -asObject :: HasCallStack => MakesValue a => a -> App Object +asObject :: (HasCallStack) => (MakesValue a) => a -> App Object asObject x = make x >>= \case (Object o) -> pure o v -> assertFailureWithJSON x ("Object" `typeWasExpectedButGot` v) -asInt :: HasCallStack => MakesValue a => a -> App Int +asInt :: (HasCallStack) => (MakesValue a) => a -> App Int asInt = asIntegral -asIntegral :: (Integral i, HasCallStack) => MakesValue a => a -> App i +asIntegral :: (Integral i, HasCallStack) => (MakesValue a) => a -> App i asIntegral x = make x >>= \case (Number n) -> @@ -121,23 +121,23 @@ asIntegral x = Right i -> pure i v -> assertFailureWithJSON x ("Number" `typeWasExpectedButGot` v) -asList :: HasCallStack => MakesValue a => a -> App [Value] +asList :: (HasCallStack) => (MakesValue a) => a -> App [Value] asList x = make x >>= \case (Array arr) -> pure (toList arr) v -> assertFailureWithJSON x ("Array" `typeWasExpectedButGot` v) -asListOf :: HasCallStack => (Value -> App b) -> MakesValue a => a -> App [b] +asListOf :: (HasCallStack) => (Value -> App b) -> (MakesValue a) => a -> App [b] asListOf makeElem x = asList x >>= mapM makeElem -asSet :: HasCallStack => MakesValue a => a -> App (Set.Set Value) +asSet :: (HasCallStack) => (MakesValue a) => a -> App (Set.Set Value) asSet = fmap Set.fromList . asList -asSetOf :: (HasCallStack, Ord b) => (Value -> App b) -> MakesValue a => a -> App (Set.Set b) +asSetOf :: (HasCallStack, Ord b) => (Value -> App b) -> (MakesValue a) => a -> App (Set.Set b) asSetOf makeElem x = Set.fromList <$> asListOf makeElem x -asBool :: HasCallStack => MakesValue a => a -> App Bool +asBool :: (HasCallStack) => (MakesValue a) => a -> App Bool asBool x = make x >>= \case (Bool b) -> pure b @@ -301,20 +301,20 @@ removeField selector x = do ob <- asObject v pure $ Object $ KM.insert (KM.fromString k) newValue ob -assertFailureWithJSON :: HasCallStack => MakesValue a => a -> String -> App b +assertFailureWithJSON :: (HasCallStack) => (MakesValue a) => a -> String -> App b assertFailureWithJSON v msg = do msg' <- ((msg <> "\n") <>) <$> prettyJSON v assertFailure msg' -- | Useful for debugging -printJSON :: MakesValue a => a -> App () +printJSON :: (MakesValue a) => a -> App () printJSON = prettyJSON >=> liftIO . putStrLn -- | useful for debugging, same as 'printJSON' but returns input JSON -traceJSON :: MakesValue a => a -> App a +traceJSON :: (MakesValue a) => a -> App a traceJSON a = printJSON a $> a -prettyJSON :: MakesValue a => a -> App String +prettyJSON :: (MakesValue a) => a -> App String prettyJSON x = make x <&> LC8.unpack . Aeson.encodePretty @@ -330,7 +330,7 @@ typeWasExpectedButGot :: String -> Value -> String typeWasExpectedButGot expectedType x = "Expected " <> expectedType <> " but got " <> jsonType x <> ":" -- Get "id" field or - if already string-like return String -objId :: HasCallStack => MakesValue a => a -> App String +objId :: (HasCallStack) => (MakesValue a) => a -> App String objId x = do v <- make x case v of @@ -339,7 +339,7 @@ objId x = do other -> assertFailureWithJSON other (typeWasExpectedButGot "Object or String" other) -- Get "qualified_id" field as (domain, id) or - if already is a qualified id object - return that -objQid :: HasCallStack => MakesValue a => a -> App (String, String) +objQid :: (HasCallStack) => (MakesValue a) => a -> App (String, String) objQid ob = do m <- firstSuccess [select ob, inField] case m of @@ -360,7 +360,7 @@ objQid ob = do Nothing -> pure Nothing Just x -> select x - firstSuccess :: Monad m => [m (Maybe a)] -> m (Maybe a) + firstSuccess :: (Monad m) => [m (Maybe a)] -> m (Maybe a) firstSuccess [] = pure Nothing firstSuccess (x : xs) = x >>= \case @@ -368,7 +368,7 @@ objQid ob = do Just y -> pure (Just y) -- | Get "qualified_id" field as {"id": _, "domain": _} object or - if already is a qualified id object - return that. -objQidObject :: HasCallStack => MakesValue a => a -> App Value +objQidObject :: (HasCallStack) => (MakesValue a) => a -> App Value objQidObject o = do (domain, id_) <- objQid o pure $ object ["domain" .= domain, "id" .= id_] diff --git a/integration/test/Testlib/Mock.hs b/integration/test/Testlib/Mock.hs index 9e957ccd702..6fd346c50cb 100644 --- a/integration/test/Testlib/Mock.hs +++ b/integration/test/Testlib/Mock.hs @@ -47,8 +47,8 @@ startMockServer config app = do let closeSocket sock = catch (Socket.close sock) (\(_ :: SomeException) -> pure ()) (port, sock) <- Codensity $ \k -> do action <- appToIOKleisli k - liftIO $ - bracket + liftIO + $ bracket ( case config.port of Nothing -> bindRandomPortTCP (fromString "*6") Just n -> (n,) <$> bindPortTCP n (fromString "*6") diff --git a/integration/test/Testlib/MockIntegrationService.hs b/integration/test/Testlib/MockIntegrationService.hs index 7e91be4b7b5..95dccb2fff7 100644 --- a/integration/test/Testlib/MockIntegrationService.hs +++ b/integration/test/Testlib/MockIntegrationService.hs @@ -1,4 +1,13 @@ -module Testlib.MockIntegrationService (withMockServer, lhMockAppWithPrekeys, lhMockApp, mkLegalHoldSettings, CreateMock (..)) where +module Testlib.MockIntegrationService + ( withMockServer, + lhMockAppWithPrekeys, + lhMockApp, + mkLegalHoldSettings, + CreateMock (..), + LiftedApplication, + MockServerSettings (..), + ) +where import Control.Monad.Catch import Control.Monad.Reader @@ -20,91 +29,31 @@ import UnliftIO.Chan import UnliftIO.MVar import UnliftIO.Timeout (timeout) -mockServerPubKey :: String -mockServerPubKey = - "-----BEGIN PUBLIC KEY-----\n\ - \MIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEAu+Kg/PHHU3atXrUbKnw0\n\ - \G06FliXcNt3lMwl2os5twEDcPPFw/feGiAKymxp+7JqZDrseS5D9THGrW+OQRIPH\n\ - \WvUBdiLfGrZqJO223DB6D8K2Su/odmnjZJ2z23rhXoEArTplu+Dg9K+c2LVeXTKV\n\ - \VPOaOzgtAB21XKRiQ4ermqgi3/njr03rXyq/qNkuNd6tNcg+HAfGxfGvvCSYBfiS\n\ - \bUKr/BeArYRcjzr/h5m1In6fG/if9GEI6m8dxHT9JbY53wiksowy6ajCuqskIFg8\n\ - \7X883H+LA/d6X5CTiPv1VMxXdBUiGPuC9IT/6CNQ1/LFt0P37ax58+LGYlaFo7la\n\ - \nQIDAQAB\n\ - \-----END PUBLIC KEY-----" - -mockServerPrivKey :: String -mockServerPrivKey = - "-----BEGIN RSA PRIVATE KEY-----\n\ - \MIIEpAIBAAKCAQEAu+Kg/PHHU3atXrUbKnw0G06FliXcNt3lMwl2os5twEDcPPFw\n\ - \/feGiAKymxp+7JqZDrseS5D9THGrW+OQRIPHWvUBdiLfGrZqJO223DB6D8K2Su/o\n\ - \dmnjZJ2z23rhXoEArTplu+Dg9K+c2LVeXTKVVPOaOzgtAB21XKRiQ4ermqgi3/nj\n\ - \r03rXyq/qNkuNd6tNcg+HAfGxfGvvCSYBfiSbUKr/BeArYRcjzr/h5m1In6fG/if\n\ - \9GEI6m8dxHT9JbY53wiksowy6ajCuqskIFg87X883H+LA/d6X5CTiPv1VMxXdBUi\n\ - \GPuC9IT/6CNQ1/LFt0P37ax58+LGYlaFo7lanQIDAQABAoIBAQC0doVy7zgpLsBv\n\ - \Sz0AnbPe1pjxEwRlntRbJSfSULySALqJvs5s4adSVGUBHX3z/LousAP1SRpCppuU\n\ - \8wrLBFgjQVlaAzyQB84EEl+lNtrG8Jrvd2es9R/4sJDkqy50+yuPN5wnzWPFIjhg\n\ - \3jP5CHDu29y0LMzsY5yjkzDe9B0bueXEZVU+guRjhpwHHKOFeAr9J9bugFUwgeAr\n\ - \jF0TztzFAb0fsUNPiQAho1J5PyjSVgItaPfAPv/p30ROG+rz+Rd5NSSvBC5F+yOo\n\ - \azb84zzwCg/knAfIz7SOMRrmBh2qhGZFZ8gXdq65UaYv+cpT/qo28mpAT2vOkyeD\n\ - \aPZp0ysBAoGBAOQROoDipe/5BTHBcXYuUE1qa4RIj3wgql5I8igXr4K6ppYBmaOg\n\ - \DL2rrnqD86chv0P4l/XOomKFwYhVGXtqRkeYnk6mQXwNVkgqcGbY5PSNyMg5+ekq\n\ - \jSOOPHGzzTWKzYuUDUpB/Lf6jbTv8fq2GYW3ZYiqQ/xiugOvglZrTE7NAoGBANLl\n\ - \irjByfxAWGhzCrDx0x5MBpsetadI9wUA8u1BDdymsRg73FDn3z7NipVUAMDXMGVj\n\ - \lqbCRlHESO2yP4GaPEA4FM+MbTZSuhAYV+SY07mEPLHF64/nJas83Zp91r5rhaqJ\n\ - \L9rWCl3KJ5OUnr3YizCnHIW72FxjwtpjxHJLupsRAoGAGIbhy8qUHeKh9F/hW9xP\n\ - \NoQjW+6Rv7+jktA1eqpRbbW1BJzXcQldVWiJMxPNuEOg1iZ98SlvvTi1P3wnaWZc\n\ - \eIapP7wRfs3QYaJuxCC/Pq2g0ieqALFazGAXkALOJtvujvw1Ea9XBlIjuzmyxEuh\n\ - \Iwg+Gxx0g0f6yTquwax4YGECgYEAnpAK3qKFNO1ECzQDo8oNy0ep59MNDPtlDhQK\n\ - \katJus5xdCD9oq7TQKrVOTTxZAvmzTQ1PqfuqueDVYOhD9Zg2n/P1cRlEGTek99Z\n\ - \pfvppB/yak6+r3FA9yBKFS/r1zuMQg3nNweav62QV/tz5pT7AdeDMGFtaPlwtTYx\n\ - \qyWY5aECgYBPySbPccNj+xxQzxcti2y/UXjC04RgOA/Hm1D0exa0vBqS9uxlOdG8\n\ - \F47rKenpBrslvdfTVsCDB1xyP2ebWVzp6EqMycw6OLPxgo3fBfZ4pi6P+rByh0Cc\n\ - \Lhfh+ET0CPnKCxtop3lUrn4ZvqchS0j3J+M0pDuqoWF5hfKxFhkEIw==\n\ - \-----END RSA PRIVATE KEY-----" - -mockServerCert :: String -mockServerCert = - "-----BEGIN CERTIFICATE-----\n\ - \MIIDdjCCAl4CCQCm0AiwERR/qjANBgkqhkiG9w0BAQsFADB9MQswCQYDVQQGEwJE\n\ - \RTEPMA0GA1UECAwGQmVybGluMQ8wDQYDVQQHDAZCZXJsaW4xGDAWBgNVBAoMD1dp\n\ - \cmUgU3dpc3MgR21iSDERMA8GA1UEAwwId2lyZS5jb20xHzAdBgkqhkiG9w0BCQEW\n\ - \EGJhY2tlbmRAd2lyZS5jb20wHhcNMTYwODA0MTMxNDQyWhcNMzYwNzMwMTMxNDQy\n\ - \WjB9MQswCQYDVQQGEwJERTEPMA0GA1UECAwGQmVybGluMQ8wDQYDVQQHDAZCZXJs\n\ - \aW4xGDAWBgNVBAoMD1dpcmUgU3dpc3MgR21iSDERMA8GA1UEAwwId2lyZS5jb20x\n\ - \HzAdBgkqhkiG9w0BCQEWEGJhY2tlbmRAd2lyZS5jb20wggEiMA0GCSqGSIb3DQEB\n\ - \AQUAA4IBDwAwggEKAoIBAQC74qD88cdTdq1etRsqfDQbToWWJdw23eUzCXaizm3A\n\ - \QNw88XD994aIArKbGn7smpkOux5LkP1Mcatb45BEg8da9QF2It8atmok7bbcMHoP\n\ - \wrZK7+h2aeNknbPbeuFegQCtOmW74OD0r5zYtV5dMpVU85o7OC0AHbVcpGJDh6ua\n\ - \qCLf+eOvTetfKr+o2S413q01yD4cB8bF8a+8JJgF+JJtQqv8F4CthFyPOv+HmbUi\n\ - \fp8b+J/0YQjqbx3EdP0ltjnfCKSyjDLpqMK6qyQgWDztfzzcf4sD93pfkJOI+/VU\n\ - \zFd0FSIY+4L0hP/oI1DX8sW3Q/ftrHnz4sZiVoWjuVqdAgMBAAEwDQYJKoZIhvcN\n\ - \AQELBQADggEBAEuwlHElIGR56KVC1dJiw238mDGjMfQzSP76Wi4zWS6/zZwJUuog\n\ - \BkC+vacfju8UAMvL+vdqkjOVUHor84/2wuq0qn91AjOITD7tRAZB+XLXxsikKv/v\n\ - \OXE3A/lCiNi882NegPyXAfFPp/71CIiTQZps1eQkAvhD5t5WiFYPESxDlvEJrHFY\n\ - \XP4+pp8fL8YPS7iZNIq+z+P8yVIw+B/Hs0ht7wFIYN0xACbU8m9+Rs08JMoT16c+\n\ - \hZMuK3BWD3fzkQVfW0yMwz6fWRXB483ZmekGkgndOTDoJQMdJXZxHpI3t2FcxQYj\n\ - \T45GXxRd18neXtuYa/OoAw9UQFDN5XfXN0g=\n\ - \-----END CERTIFICATE-----" - withFreePortAnyAddr :: (MonadMask m, MonadIO m) => ((Warp.Port, Socket) -> m a) -> m a withFreePortAnyAddr = bracket openFreePortAnyAddr (liftIO . Socket.close . snd) -openFreePortAnyAddr :: MonadIO m => m (Warp.Port, Socket) +openFreePortAnyAddr :: (MonadIO m) => m (Warp.Port, Socket) openFreePortAnyAddr = liftIO $ bindRandomPortTCP (fromString "*6") type LiftedApplication = Request -> (Wai.Response -> App ResponseReceived) -> App ResponseReceived +type Host = String + +-- | The channel exists to facilitate out of http comms between the test and the +-- service. Could be used for recording (request, response) pairs. withMockServer :: (HasCallStack) => - -- | the mock server + -- | the mock server settings + MockServerSettings -> + -- | The certificate and key pair (Chan e -> LiftedApplication) -> -- | the test - ((String, Warp.Port) -> Chan e -> App a) -> + ((Host, Warp.Port) -> Chan e -> App a) -> App a -withMockServer mkApp go = withFreePortAnyAddr \(sPort, sock) -> do +withMockServer settings mkApp go = withFreePortAnyAddr \(sPort, sock) -> do serverStarted <- newEmptyMVar host <- asks integrationTestHostName - let tlss = Warp.tlsSettingsMemory (cs mockServerCert) (cs mockServerPrivKey) + let tlss = Warp.tlsSettingsMemory (cs settings.certificate) (cs settings.privateKey) let defs = Warp.defaultSettings {Warp.settingsPort = sPort, Warp.settingsBeforeMainLoop = putMVar serverStarted ()} buf <- newChan srv <- async $ withRunInIO \inIO -> do @@ -118,6 +67,23 @@ withMockServer mkApp go = withFreePortAnyAddr \(sPort, sock) -> do lhMockApp :: Chan (Wai.Request, LBS.ByteString) -> LiftedApplication lhMockApp = lhMockAppWithPrekeys def +data MockServerSettings = MkMockServerSettings + { -- | the certificate the mock service uses + certificate :: String, + -- | the private key the mock service uses + privateKey :: String, + -- | the public key the mock service uses + publicKey :: String + } + +instance Default MockServerSettings where + def = + MkMockServerSettings + { certificate = mockServerCert, + privateKey = mockServerPrivKey, + publicKey = mockServerPubKey + } + data CreateMock f = MkCreateMock { -- | how to obtain the next last prekey of a mock app nextLastPrey :: f Value, @@ -153,10 +119,12 @@ lhMockAppWithPrekeys mks ch req cont = withRunInIO \inIO -> do where initiateResp :: Value -> [Value] -> Wai.Response initiateResp npk pks = - responseLBS status200 [(hContentType, cs "application/json")] . encode . Data.Aeson.object $ - [ "prekeys" .= pks, - "last_prekey" .= npk - ] + responseLBS status200 [(hContentType, cs "application/json")] + . encode + . Data.Aeson.object + $ [ "prekeys" .= pks, + "last_prekey" .= npk + ] respondOk :: Wai.Response respondOk = responseLBS status200 mempty mempty @@ -177,3 +145,69 @@ mkLegalHoldSettings (botHost, lhPort) = "public_key" .= mockServerPubKey, "auth_token" .= "tok" ] + +mockServerPubKey :: String +mockServerPubKey = + "-----BEGIN PUBLIC KEY-----\n\ + \MIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEAu+Kg/PHHU3atXrUbKnw0\n\ + \G06FliXcNt3lMwl2os5twEDcPPFw/feGiAKymxp+7JqZDrseS5D9THGrW+OQRIPH\n\ + \WvUBdiLfGrZqJO223DB6D8K2Su/odmnjZJ2z23rhXoEArTplu+Dg9K+c2LVeXTKV\n\ + \VPOaOzgtAB21XKRiQ4ermqgi3/njr03rXyq/qNkuNd6tNcg+HAfGxfGvvCSYBfiS\n\ + \bUKr/BeArYRcjzr/h5m1In6fG/if9GEI6m8dxHT9JbY53wiksowy6ajCuqskIFg8\n\ + \7X883H+LA/d6X5CTiPv1VMxXdBUiGPuC9IT/6CNQ1/LFt0P37ax58+LGYlaFo7la\n\ + \nQIDAQAB\n\ + \-----END PUBLIC KEY-----" + +mockServerPrivKey :: String +mockServerPrivKey = + "-----BEGIN RSA PRIVATE KEY-----\n\ + \MIIEpAIBAAKCAQEAu+Kg/PHHU3atXrUbKnw0G06FliXcNt3lMwl2os5twEDcPPFw\n\ + \/feGiAKymxp+7JqZDrseS5D9THGrW+OQRIPHWvUBdiLfGrZqJO223DB6D8K2Su/o\n\ + \dmnjZJ2z23rhXoEArTplu+Dg9K+c2LVeXTKVVPOaOzgtAB21XKRiQ4ermqgi3/nj\n\ + \r03rXyq/qNkuNd6tNcg+HAfGxfGvvCSYBfiSbUKr/BeArYRcjzr/h5m1In6fG/if\n\ + \9GEI6m8dxHT9JbY53wiksowy6ajCuqskIFg87X883H+LA/d6X5CTiPv1VMxXdBUi\n\ + \GPuC9IT/6CNQ1/LFt0P37ax58+LGYlaFo7lanQIDAQABAoIBAQC0doVy7zgpLsBv\n\ + \Sz0AnbPe1pjxEwRlntRbJSfSULySALqJvs5s4adSVGUBHX3z/LousAP1SRpCppuU\n\ + \8wrLBFgjQVlaAzyQB84EEl+lNtrG8Jrvd2es9R/4sJDkqy50+yuPN5wnzWPFIjhg\n\ + \3jP5CHDu29y0LMzsY5yjkzDe9B0bueXEZVU+guRjhpwHHKOFeAr9J9bugFUwgeAr\n\ + \jF0TztzFAb0fsUNPiQAho1J5PyjSVgItaPfAPv/p30ROG+rz+Rd5NSSvBC5F+yOo\n\ + \azb84zzwCg/knAfIz7SOMRrmBh2qhGZFZ8gXdq65UaYv+cpT/qo28mpAT2vOkyeD\n\ + \aPZp0ysBAoGBAOQROoDipe/5BTHBcXYuUE1qa4RIj3wgql5I8igXr4K6ppYBmaOg\n\ + \DL2rrnqD86chv0P4l/XOomKFwYhVGXtqRkeYnk6mQXwNVkgqcGbY5PSNyMg5+ekq\n\ + \jSOOPHGzzTWKzYuUDUpB/Lf6jbTv8fq2GYW3ZYiqQ/xiugOvglZrTE7NAoGBANLl\n\ + \irjByfxAWGhzCrDx0x5MBpsetadI9wUA8u1BDdymsRg73FDn3z7NipVUAMDXMGVj\n\ + \lqbCRlHESO2yP4GaPEA4FM+MbTZSuhAYV+SY07mEPLHF64/nJas83Zp91r5rhaqJ\n\ + \L9rWCl3KJ5OUnr3YizCnHIW72FxjwtpjxHJLupsRAoGAGIbhy8qUHeKh9F/hW9xP\n\ + \NoQjW+6Rv7+jktA1eqpRbbW1BJzXcQldVWiJMxPNuEOg1iZ98SlvvTi1P3wnaWZc\n\ + \eIapP7wRfs3QYaJuxCC/Pq2g0ieqALFazGAXkALOJtvujvw1Ea9XBlIjuzmyxEuh\n\ + \Iwg+Gxx0g0f6yTquwax4YGECgYEAnpAK3qKFNO1ECzQDo8oNy0ep59MNDPtlDhQK\n\ + \katJus5xdCD9oq7TQKrVOTTxZAvmzTQ1PqfuqueDVYOhD9Zg2n/P1cRlEGTek99Z\n\ + \pfvppB/yak6+r3FA9yBKFS/r1zuMQg3nNweav62QV/tz5pT7AdeDMGFtaPlwtTYx\n\ + \qyWY5aECgYBPySbPccNj+xxQzxcti2y/UXjC04RgOA/Hm1D0exa0vBqS9uxlOdG8\n\ + \F47rKenpBrslvdfTVsCDB1xyP2ebWVzp6EqMycw6OLPxgo3fBfZ4pi6P+rByh0Cc\n\ + \Lhfh+ET0CPnKCxtop3lUrn4ZvqchS0j3J+M0pDuqoWF5hfKxFhkEIw==\n\ + \-----END RSA PRIVATE KEY-----" + +mockServerCert :: String +mockServerCert = + "-----BEGIN CERTIFICATE-----\n\ + \MIIDdjCCAl4CCQCm0AiwERR/qjANBgkqhkiG9w0BAQsFADB9MQswCQYDVQQGEwJE\n\ + \RTEPMA0GA1UECAwGQmVybGluMQ8wDQYDVQQHDAZCZXJsaW4xGDAWBgNVBAoMD1dp\n\ + \cmUgU3dpc3MgR21iSDERMA8GA1UEAwwId2lyZS5jb20xHzAdBgkqhkiG9w0BCQEW\n\ + \EGJhY2tlbmRAd2lyZS5jb20wHhcNMTYwODA0MTMxNDQyWhcNMzYwNzMwMTMxNDQy\n\ + \WjB9MQswCQYDVQQGEwJERTEPMA0GA1UECAwGQmVybGluMQ8wDQYDVQQHDAZCZXJs\n\ + \aW4xGDAWBgNVBAoMD1dpcmUgU3dpc3MgR21iSDERMA8GA1UEAwwId2lyZS5jb20x\n\ + \HzAdBgkqhkiG9w0BCQEWEGJhY2tlbmRAd2lyZS5jb20wggEiMA0GCSqGSIb3DQEB\n\ + \AQUAA4IBDwAwggEKAoIBAQC74qD88cdTdq1etRsqfDQbToWWJdw23eUzCXaizm3A\n\ + \QNw88XD994aIArKbGn7smpkOux5LkP1Mcatb45BEg8da9QF2It8atmok7bbcMHoP\n\ + \wrZK7+h2aeNknbPbeuFegQCtOmW74OD0r5zYtV5dMpVU85o7OC0AHbVcpGJDh6ua\n\ + \qCLf+eOvTetfKr+o2S413q01yD4cB8bF8a+8JJgF+JJtQqv8F4CthFyPOv+HmbUi\n\ + \fp8b+J/0YQjqbx3EdP0ltjnfCKSyjDLpqMK6qyQgWDztfzzcf4sD93pfkJOI+/VU\n\ + \zFd0FSIY+4L0hP/oI1DX8sW3Q/ftrHnz4sZiVoWjuVqdAgMBAAEwDQYJKoZIhvcN\n\ + \AQELBQADggEBAEuwlHElIGR56KVC1dJiw238mDGjMfQzSP76Wi4zWS6/zZwJUuog\n\ + \BkC+vacfju8UAMvL+vdqkjOVUHor84/2wuq0qn91AjOITD7tRAZB+XLXxsikKv/v\n\ + \OXE3A/lCiNi882NegPyXAfFPp/71CIiTQZps1eQkAvhD5t5WiFYPESxDlvEJrHFY\n\ + \XP4+pp8fL8YPS7iZNIq+z+P8yVIw+B/Hs0ht7wFIYN0xACbU8m9+Rs08JMoT16c+\n\ + \hZMuK3BWD3fzkQVfW0yMwz6fWRXB483ZmekGkgndOTDoJQMdJXZxHpI3t2FcxQYj\n\ + \T45GXxRd18neXtuYa/OoAw9UQFDN5XfXN0g=\n\ + \-----END CERTIFICATE-----" diff --git a/integration/test/Testlib/ModService.hs b/integration/test/Testlib/ModService.hs index f4390d7286f..061acca529e 100644 --- a/integration/test/Testlib/ModService.hs +++ b/integration/test/Testlib/ModService.hs @@ -46,7 +46,7 @@ import Testlib.Types import Text.RawString.QQ import Prelude -withModifiedBackend :: HasCallStack => ServiceOverrides -> (HasCallStack => String -> App a) -> App a +withModifiedBackend :: (HasCallStack) => ServiceOverrides -> ((HasCallStack) => String -> App a) -> App a withModifiedBackend overrides k = startDynamicBackends [overrides] (\domains -> k (head domains)) @@ -64,8 +64,8 @@ copyDirectoryRecursively from to = do -- | Concurrent traverse in the 'Codensity App' monad. traverseConcurrentlyCodensity :: - (HasCallStack => a -> Codensity App ()) -> - (HasCallStack => [a] -> Codensity App ()) + ((HasCallStack) => a -> Codensity App ()) -> + ((HasCallStack) => [a] -> Codensity App ()) traverseConcurrentlyCodensity f args = do -- Create variables for synchronisation of the various threads: -- * @result@ is used to store a possible exception @@ -242,7 +242,7 @@ updateServiceMapInConfig resource forSrv config = [(srv, berInternalServicePorts resource srv :: Int) | srv <- allServices] startBackend :: - HasCallStack => + (HasCallStack) => BackendResource -> ServiceOverrides -> Codensity App () @@ -382,7 +382,7 @@ logToConsole colorize prefix hdl = do `E.catch` (\(_ :: E.IOException) -> pure ()) go -retryRequestUntil :: HasCallStack => App Bool -> String -> App () +retryRequestUntil :: (HasCallStack) => App Bool -> String -> App () retryRequestUntil reqAction err = do isUp <- retrying diff --git a/integration/test/Testlib/One2One.hs b/integration/test/Testlib/One2One.hs index 0ef4ab6ff56..41cacb4949c 100644 --- a/integration/test/Testlib/One2One.hs +++ b/integration/test/Testlib/One2One.hs @@ -43,10 +43,10 @@ generateRemoteAndConvIdWithDomain remoteDomain shouldBeLocal lUserId = do isLocal = localDomain == cDomain if shouldBeLocal == isLocal then - pure $ - ( object ["id" .= (otherUsr), "domain" .= otherDomain], - object ["id" .= (UUID.toString cId), "domain" .= cDomain] - ) + pure + $ ( object ["id" .= (otherUsr), "domain" .= otherDomain], + object ["id" .= (UUID.toString cId), "domain" .= cDomain] + ) else generateRemoteAndConvIdWithDomain remoteDomain shouldBeLocal lUserId one2OneConvId :: (UUID, String) -> (UUID, String) -> (UUID, String) @@ -86,8 +86,8 @@ newtype UuidV5 = UuidV5 {toUuidV5 :: UUID} deriving (Eq, Ord, Show) mkV5 :: UUID -> UuidV5 -mkV5 u = UuidV5 $ - case toWords u of +mkV5 u = UuidV5 + $ case toWords u of (x0, x1, x2, x3) -> fromWords x0 diff --git a/integration/test/Testlib/Ports.hs b/integration/test/Testlib/Ports.hs index 4ca16d06910..29367b64dd8 100644 --- a/integration/test/Testlib/Ports.hs +++ b/integration/test/Testlib/Ports.hs @@ -9,7 +9,7 @@ data PortNamespace | FederatorExternal | ServiceInternal Service -port :: Num a => PortNamespace -> BackendName -> a +port :: (Num a) => PortNamespace -> BackendName -> a port NginzSSL bn = mkPort 8443 bn port NginzHttp2 bn = mkPort 8099 bn port FederatorExternal bn = mkPort 8098 bn @@ -24,10 +24,10 @@ port (ServiceInternal Nginz) bn = mkPort 8080 bn port (ServiceInternal Spar) bn = mkPort 8088 bn port (ServiceInternal Stern) bn = mkPort 8091 bn -portForDyn :: Num a => PortNamespace -> Int -> a +portForDyn :: (Num a) => PortNamespace -> Int -> a portForDyn ns i = port ns (DynamicBackend i) -mkPort :: Num a => Int -> BackendName -> a +mkPort :: (Num a) => Int -> BackendName -> a mkPort basePort bn = let i = case bn of BackendA -> 0 @@ -35,5 +35,5 @@ mkPort basePort bn = (DynamicBackend k) -> 1 + k in fromIntegral basePort + (fromIntegral i) * 1000 -internalServicePorts :: Num a => BackendName -> Service -> a +internalServicePorts :: (Num a) => BackendName -> Service -> a internalServicePorts backend service = port (ServiceInternal service) backend diff --git a/integration/test/Testlib/Prelude.hs b/integration/test/Testlib/Prelude.hs index 4f29605a227..69c3797f54d 100644 --- a/integration/test/Testlib/Prelude.hs +++ b/integration/test/Testlib/Prelude.hs @@ -174,37 +174,37 @@ import qualified Prelude as P ---------------------------------------------------------------------------- -- Lifted functions from Prelude -putChar :: MonadIO m => Char -> m () +putChar :: (MonadIO m) => Char -> m () putChar = liftIO . P.putChar -putStr :: MonadIO m => String -> m () +putStr :: (MonadIO m) => String -> m () putStr = liftIO . P.putStr -putStrLn :: MonadIO m => String -> m () +putStrLn :: (MonadIO m) => String -> m () putStrLn = liftIO . P.putStrLn print :: (Show a, MonadIO m) => a -> m () print = liftIO . P.print -getChar :: MonadIO m => m Char +getChar :: (MonadIO m) => m Char getChar = liftIO P.getChar -getLine :: MonadIO m => m String +getLine :: (MonadIO m) => m String getLine = liftIO P.getLine -getContents :: MonadIO m => m String +getContents :: (MonadIO m) => m String getContents = liftIO P.getContents -interact :: MonadIO m => (String -> String) -> m () +interact :: (MonadIO m) => (String -> String) -> m () interact = liftIO . P.interact -readFile :: MonadIO m => FilePath -> m String +readFile :: (MonadIO m) => FilePath -> m String readFile = liftIO . P.readFile -writeFile :: MonadIO m => FilePath -> String -> m () +writeFile :: (MonadIO m) => FilePath -> String -> m () writeFile = fmap liftIO . P.writeFile -appendFile :: MonadIO m => FilePath -> String -> m () +appendFile :: (MonadIO m) => FilePath -> String -> m () appendFile = fmap liftIO . P.appendFile readIO :: (Read a, MonadIO m) => String -> m a diff --git a/integration/test/Testlib/ResourcePool.hs b/integration/test/Testlib/ResourcePool.hs index 560967c06d0..c67b7031e43 100644 --- a/integration/test/Testlib/ResourcePool.hs +++ b/integration/test/Testlib/ResourcePool.hs @@ -84,7 +84,8 @@ deleteAllRabbitMQQueues rc resource = do { host = rc.host, port = 0, adminPort = fromIntegral rc.adminPort, - vHost = T.pack resource.berVHost + vHost = T.pack resource.berVHost, + tls = Just $ RabbitMqTlsOpts Nothing True } client <- mkRabbitMqAdminClientEnv opts queues <- listQueuesByVHost client (T.pack resource.berVHost) diff --git a/integration/test/Testlib/RunServices.hs b/integration/test/Testlib/RunServices.hs index aca7867aff3..e5c5c7611ce 100644 --- a/integration/test/Testlib/RunServices.hs +++ b/integration/test/Testlib/RunServices.hs @@ -53,8 +53,9 @@ main = do exitWith =<< waitForProcess ph runCodensity (createGlobalEnv cfg >>= mkEnv) $ \env -> - runAppWithEnv env $ - lowerCodensity $ do + runAppWithEnv env + $ lowerCodensity + $ do _modifyEnv <- traverseConcurrentlyCodensity (\r -> startDynamicBackend r mempty) diff --git a/integration/test/Testlib/Types.hs b/integration/test/Testlib/Types.hs index ae166c33b4c..e77e8b0a457 100644 --- a/integration/test/Testlib/Types.hs +++ b/integration/test/Testlib/Types.hs @@ -6,6 +6,7 @@ module Testlib.Types where import Control.Concurrent (QSemN) import Control.Exception as E +import Control.Monad import Control.Monad.Base import Control.Monad.Catch import Control.Monad.Reader @@ -67,7 +68,7 @@ data BackendResource = BackendResource berVHost :: String, berNginzSslPort :: Word16, berNginzHttp2Port :: Word16, - berInternalServicePorts :: forall a. Num a => Service -> a + berInternalServicePorts :: forall a. (Num a) => Service -> a } instance Eq BackendResource where @@ -341,7 +342,7 @@ appToIOKleisli k = do env <- ask pure $ \a -> runAppWithEnv env (k a) -getServiceMap :: HasCallStack => String -> App ServiceMap +getServiceMap :: (HasCallStack) => String -> App ServiceMap getServiceMap fedDomain = do env <- ask assertJust ("Could not find service map for federation domain: " <> fedDomain) (Map.lookup fedDomain env.serviceMap) @@ -375,7 +376,7 @@ instance Exception AppFailure where instance MonadFail App where fail msg = assertFailure ("Pattern matching failure: " <> msg) -assertFailure :: HasCallStack => String -> App a +assertFailure :: (HasCallStack) => String -> App a assertFailure msg = forceList msg $ liftIO $ @@ -384,7 +385,7 @@ assertFailure msg = forceList [] y = y forceList (x : xs) y = seq x (forceList xs y) -assertJust :: HasCallStack => String -> Maybe a -> App a +assertJust :: (HasCallStack) => String -> Maybe a -> App a assertJust _ (Just x) = pure x assertJust msg Nothing = assertFailure msg diff --git a/libs/bilge/src/Bilge/Assert.hs b/libs/bilge/src/Bilge/Assert.hs index 622c945887c..5f44fd9d68b 100644 --- a/libs/bilge/src/Bilge/Assert.hs +++ b/libs/bilge/src/Bilge/Assert.hs @@ -57,10 +57,10 @@ instance Contains ByteString where instance Contains Lazy.ByteString where contains a b = contains (Lazy.toStrict a) (Lazy.toStrict b) -instance Eq a => Contains [a] where +instance (Eq a) => Contains [a] where contains = isInfixOf -instance Contains a => Contains (Maybe a) where +instance (Contains a) => Contains (Maybe a) where contains (Just a) (Just b) = contains a b contains Nothing _ = True contains _ Nothing = False @@ -145,25 +145,25 @@ f =~= g = Assertions $ tell [\r -> test " not in " contains (f r) (g r)] -- | Most generic assertion on a request. If the test function evaluates to -- @(Just msg)@ then the assertion fails with the error message @msg@. -assertResponse :: HasCallStack => (Response (Maybe Lazy.ByteString) -> Maybe String) -> Assertions () +assertResponse :: (HasCallStack) => (Response (Maybe Lazy.ByteString) -> Maybe String) -> Assertions () assertResponse f = Assertions $ tell [f] -- | Generic assertion on a request. The 'String' argument will be printed -- in case the assertion fails. -assertTrue :: HasCallStack => String -> (Response (Maybe Lazy.ByteString) -> Bool) -> Assertions () +assertTrue :: (HasCallStack) => String -> (Response (Maybe Lazy.ByteString) -> Bool) -> Assertions () assertTrue e f = Assertions $ tell [\r -> if f r then Nothing else Just e] -- | Generic assertion on a request. -assertTrue_ :: HasCallStack => (Response (Maybe Lazy.ByteString) -> Bool) -> Assertions () +assertTrue_ :: (HasCallStack) => (Response (Maybe Lazy.ByteString) -> Bool) -> Assertions () assertTrue_ = assertTrue "false" -- | Generic assertion inside the 'Assertions' monad. The 'String' argument -- will be printed in case the assertion fails. -assert :: HasCallStack => String -> Bool -> Assertions () +assert :: (HasCallStack) => String -> Bool -> Assertions () assert m = assertTrue m . const -- | Generic assertion inside the 'Assertions' monad. -assert_ :: HasCallStack => Bool -> Assertions () +assert_ :: (HasCallStack) => Bool -> Assertions () assert_ = assertTrue_ . const -- Internal diff --git a/libs/bilge/src/Bilge/IO.hs b/libs/bilge/src/Bilge/IO.hs index f1fa331ea05..e7abfd750aa 100644 --- a/libs/bilge/src/Bilge/IO.hs +++ b/libs/bilge/src/Bilge/IO.hs @@ -113,10 +113,10 @@ class MonadHttp m where handleRequestWithCont :: Request -> (Response BodyReader -> IO a) -> m a {-# MINIMAL handleRequestWithCont #-} -handleRequest :: MonadHttp m => Request -> m (Response (Maybe LByteString)) +handleRequest :: (MonadHttp m) => Request -> m (Response (Maybe LByteString)) handleRequest req = handleRequestWithCont req consumeBody -instance MonadIO m => MonadHttp (HttpT m) where +instance (MonadIO m) => MonadHttp (HttpT m) where handleRequestWithCont :: Request -> (Response BodyReader -> IO a) -> HttpT m a handleRequestWithCont req h = do m <- ask @@ -138,7 +138,7 @@ trivialBodyReader bodyBytes = do instance MonadHttp WaiTest.Session where handleRequestWithCont req cont = unSessionT $ handleRequestWithCont req cont -instance MonadIO m => MonadHttp (SessionT m) where +instance (MonadIO m) => MonadHttp (SessionT m) where handleRequestWithCont req cont = do reqBody <- liftIO $ getHttpClientRequestBody (Client.requestBody req) -- `srequest` sets the requestBody for us @@ -180,7 +180,7 @@ instance MonadIO m => MonadHttp (SessionT m) where -- | Does not support all constructors, but so far we only use 'RequestBodyLBS'. -- The other ones are slightly less straight-forward, so we can implement them later if needed. -getHttpClientRequestBody :: HasCallStack => Client.RequestBody -> IO LByteString +getHttpClientRequestBody :: (HasCallStack) => Client.RequestBody -> IO LByteString getHttpClientRequestBody = \case Client.RequestBodyLBS lbs -> pure lbs Client.RequestBodyBS bs -> pure (LBS.fromStrict bs) @@ -207,7 +207,7 @@ instance MonadBaseControl IO (HttpT IO) where liftBaseWith = defaultLiftBaseWith restoreM = defaultRestoreM -instance MonadUnliftIO m => MonadUnliftIO (HttpT m) where +instance (MonadUnliftIO m) => MonadUnliftIO (HttpT m) where withRunInIO inner = HttpT . ReaderT $ \r -> withRunInIO $ \run -> @@ -227,7 +227,7 @@ get, options, trace, patch :: - MonadHttp m => + (MonadHttp m) => (Request -> Request) -> m (Response (Maybe LByteString)) get f = httpLbs empty (method GET . f) @@ -247,7 +247,7 @@ get', options', trace', patch' :: - MonadHttp m => + (MonadHttp m) => Request -> (Request -> Request) -> m (Response (Maybe LByteString)) @@ -261,14 +261,14 @@ trace' r f = httpLbs r (method TRACE . f) patch' r f = httpLbs r (method PATCH . f) httpLbs :: - MonadHttp m => + (MonadHttp m) => Request -> (Request -> Request) -> m (Response (Maybe LByteString)) httpLbs r f = http r f consumeBody http :: - MonadHttp m => + (MonadHttp m) => Request -> (Request -> Request) -> (Response BodyReader -> IO a) -> diff --git a/libs/bilge/src/Bilge/RPC.hs b/libs/bilge/src/Bilge/RPC.hs index 386ba6b0279..77edab5326f 100644 --- a/libs/bilge/src/Bilge/RPC.hs +++ b/libs/bilge/src/Bilge/RPC.hs @@ -45,7 +45,7 @@ import System.Logger.Class class HasRequestId m where getRequestId :: m RequestId -instance Monad m => HasRequestId (ReaderT RequestId m) where +instance (Monad m) => HasRequestId (ReaderT RequestId m) where getRequestId = ask data RPCException = RPCException diff --git a/libs/bilge/src/Bilge/Request.hs b/libs/bilge/src/Bilge/Request.hs index 1acd96aa03e..ed4facd59ca 100644 --- a/libs/bilge/src/Bilge/Request.hs +++ b/libs/bilge/src/Bilge/Request.hs @@ -199,7 +199,7 @@ lbytes = body . RequestBodyLBS -- bytestring produced by JSON will get computed and stored as it is in memory -- in order to compute the @Content-Length@ header. For making a request with -- big JSON objects, please use @lbytesRefChunked@ -json :: ToJSON a => a -> Request -> Request +json :: (ToJSON a) => a -> Request -> Request json a = contentJson . lbytes (encode a) -- | Like @lbytesChunkedIO@ but for sending a JSON body @@ -227,7 +227,7 @@ jsonChunkedIO a = do -- This is because the closure for @lbytesPopper@ keeps the reference to @bs@ -- alive. To avoid this, this function allocates an @IORef@ and passes that to -- @lbytesRefChunked@. -lbytesChunkedIO :: MonadIO m => Lazy.ByteString -> m (Request -> Request) +lbytesChunkedIO :: (MonadIO m) => Lazy.ByteString -> m (Request -> Request) lbytesChunkedIO bs = do chunksRef <- newIORef $ Lazy.toChunks bs pure $ lbytesRefChunked chunksRef diff --git a/libs/bilge/src/Bilge/Response.hs b/libs/bilge/src/Bilge/Response.hs index 08c63c5be5d..c199dba9f64 100644 --- a/libs/bilge/src/Bilge/Response.hs +++ b/libs/bilge/src/Bilge/Response.hs @@ -131,7 +131,7 @@ responseJsonUnsafe :: (HasCallStack, Typeable a, FromJSON a) => ResponseLBS -> a -responseJsonUnsafe = responseJsonUnsafeWithMsg "" +responseJsonUnsafe resp = responseJsonUnsafeWithMsg (show resp) resp {-# INLINE responseJsonUnsafeWithMsg #-} responseJsonUnsafeWithMsg :: @@ -147,7 +147,7 @@ responseJsonUnsafeWithMsg userErr = either err id . responseJsonEither <> [userErr | not $ null userErr] <> [parserErr] -showResponse :: Show a => Response a -> String +showResponse :: (Show a) => Response a -> String showResponse r = showString "HTTP/" . shows (httpMajor . responseVersion $ r) diff --git a/libs/bilge/src/Bilge/Retry.hs b/libs/bilge/src/Bilge/Retry.hs index 01f2dc7ab01..055a1ff5219 100644 --- a/libs/bilge/src/Bilge/Retry.hs +++ b/libs/bilge/src/Bilge/Retry.hs @@ -25,10 +25,10 @@ import Imports import Network.HTTP.Client (HttpException (..), HttpExceptionContent (..), responseStatus) import Network.HTTP.Types -httpHandlers :: Monad m => [a -> Handler m Bool] +httpHandlers :: (Monad m) => [a -> Handler m Bool] httpHandlers = [const . Handler $ pure . canRetry] -rpcHandlers :: Monad m => [a -> Handler m Bool] +rpcHandlers :: (Monad m) => [a -> Handler m Bool] rpcHandlers = [ const . Handler $ \(RPCException _ _ cause) -> pure $ maybe False canRetry (fromException cause) diff --git a/libs/bilge/src/Bilge/TestSession.hs b/libs/bilge/src/Bilge/TestSession.hs index b9c8223986e..246b7a17bcb 100644 --- a/libs/bilge/src/Bilge/TestSession.hs +++ b/libs/bilge/src/Bilge/TestSession.hs @@ -33,7 +33,7 @@ newtype SessionT m a = SessionT {unSessionT :: ReaderT Wai.Application (StateT W instance MonadTrans SessionT where lift = SessionT . lift . lift -liftSession :: MonadIO m => WaiTest.Session a -> SessionT m a +liftSession :: (MonadIO m) => WaiTest.Session a -> SessionT m a liftSession session = SessionT $ do app <- ask clientState <- lift ST.get @@ -41,5 +41,5 @@ liftSession session = SessionT $ do let resultInIO = ST.evalStateT resultInState clientState liftIO resultInIO -runSessionT :: Monad m => SessionT m a -> Wai.Application -> m a +runSessionT :: (Monad m) => SessionT m a -> Wai.Application -> m a runSessionT session app = ST.evalStateT (runReaderT (unSessionT session) app) WaiTest.initState diff --git a/libs/brig-types/brig-types.cabal b/libs/brig-types/brig-types.cabal index 4d4d0640dd1..7f294c52fac 100644 --- a/libs/brig-types/brig-types.cabal +++ b/libs/brig-types/brig-types.cabal @@ -13,7 +13,6 @@ build-type: Simple library exposed-modules: Brig.Types.Activation - Brig.Types.Common Brig.Types.Connection Brig.Types.Instances Brig.Types.Intra diff --git a/libs/brig-types/src/Brig/Types/Connection.hs b/libs/brig-types/src/Brig/Types/Connection.hs index f88cc8cd6e2..83345069204 100644 --- a/libs/brig-types/src/Brig/Types/Connection.hs +++ b/libs/brig-types/src/Brig/Types/Connection.hs @@ -19,11 +19,9 @@ -- -- Types for connections between users. module Brig.Types.Connection - ( module C, - UserIds (..), + ( UserIds (..), UpdateConnectionsInternal (..), ) where -import Brig.Types.Common as C import Wire.API.User diff --git a/libs/brig-types/src/Brig/Types/Instances.hs b/libs/brig-types/src/Brig/Types/Instances.hs index 347be2c0192..ca5fb8f6aa0 100644 --- a/libs/brig-types/src/Brig/Types/Instances.hs +++ b/libs/brig-types/src/Brig/Types/Instances.hs @@ -74,7 +74,7 @@ instance Cql ServiceKey where 0 -> pure $! ServiceKey RsaServiceKey s p _ -> Left $ "Unexpected service key type: " ++ show t where - required :: Cql r => Text -> Either String r + required :: (Cql r) => Text -> Either String r required f = maybe (Left ("ServiceKey: Missing required field '" ++ show f ++ "'")) diff --git a/libs/brig-types/src/Brig/Types/Search.hs b/libs/brig-types/src/Brig/Types/Search.hs index 2bf55eb1ea8..2a5006968f6 100644 --- a/libs/brig-types/src/Brig/Types/Search.hs +++ b/libs/brig-types/src/Brig/Types/Search.hs @@ -75,8 +75,10 @@ instance ToByteString SearchVisibilityInbound where instance FromByteString SearchVisibilityInbound where parser = - SearchableByOwnTeam <$ string "searchable-by-own-team" - <|> SearchableByAllTeams <$ string "searchable-by-all-teams" + SearchableByOwnTeam + <$ string "searchable-by-own-team" + <|> SearchableByAllTeams + <$ string "searchable-by-all-teams" instance C.Cql SearchVisibilityInbound where ctype = C.Tagged C.IntColumn diff --git a/libs/brig-types/src/Brig/Types/Test/Arbitrary.hs b/libs/brig-types/src/Brig/Types/Test/Arbitrary.hs index 05fb72d1925..fd00582837d 100644 --- a/libs/brig-types/src/Brig/Types/Test/Arbitrary.hs +++ b/libs/brig-types/src/Brig/Types/Test/Arbitrary.hs @@ -22,15 +22,11 @@ module Brig.Types.Test.Arbitrary ) where -import Brig.Types.Common import Brig.Types.Team.LegalHold import Imports import Test.QuickCheck import Wire.Arbitrary -instance Arbitrary ExcludedPrefix where - arbitrary = ExcludedPrefix <$> arbitrary <*> arbitrary - instance Arbitrary LegalHoldClientRequest where arbitrary = LegalHoldClientRequest diff --git a/libs/brig-types/src/Brig/Types/User/Auth.hs b/libs/brig-types/src/Brig/Types/User/Auth.hs index d6426a1483d..378f49f53bd 100644 --- a/libs/brig-types/src/Brig/Types/User/Auth.hs +++ b/libs/brig-types/src/Brig/Types/User/Auth.hs @@ -51,11 +51,11 @@ instance FromJSON LegalHoldLogin where parseJSON = withObject "LegalHoldLogin" $ \o -> LegalHoldLogin <$> o - .: "user" + .: "user" <*> o - .:? "password" + .:? "password" <*> o - .:? "label" + .:? "label" instance ToJSON LegalHoldLogin where toJSON (LegalHoldLogin uid password label) = diff --git a/libs/brig-types/test/unit/Test/Brig/Types/Common.hs b/libs/brig-types/test/unit/Test/Brig/Types/Common.hs index 6ef039f3cfe..92cdd9b7864 100644 --- a/libs/brig-types/test/unit/Test/Brig/Types/Common.hs +++ b/libs/brig-types/test/unit/Test/Brig/Types/Common.hs @@ -23,7 +23,6 @@ -- galley-types. module Test.Brig.Types.Common where -import Brig.Types.Common import Brig.Types.Team.LegalHold import Brig.Types.Test.Arbitrary () import Test.Brig.Roundtrip (testRoundTrip) @@ -35,7 +34,6 @@ tests :: TestTree tests = testGroup "Common (types vs. aeson)" - [ testRoundTrip @ExcludedPrefix, - testRoundTrip @LegalHoldService, + [ testRoundTrip @LegalHoldService, testRoundTrip @LegalHoldClientRequest ] diff --git a/libs/brig-types/test/unit/Test/Brig/Types/User.hs b/libs/brig-types/test/unit/Test/Brig/Types/User.hs index dee80388143..ee966465ad2 100644 --- a/libs/brig-types/test/unit/Test/Brig/Types/User.hs +++ b/libs/brig-types/test/unit/Test/Brig/Types/User.hs @@ -65,7 +65,7 @@ testCaseUserAccount = testCase "UserAcccount" $ do assertEqual "2" (Just json2) (encode <$> decode @UserAccount json2) where json1 :: LByteString - json1 = "{\"accent_id\":1,\"assets\":[],\"deleted\":true,\"expires_at\":\"1864-05-09T17:20:22.192Z\",\"handle\":\"-ve\",\"id\":\"00000000-0000-0001-0000-000100000000\",\"locale\":\"lu\",\"managed_by\":\"wire\",\"name\":\"bla\",\"phone\":\"+433017355611929\",\"picture\":[],\"qualified_id\":{\"domain\":\"4-o60.j7-i\",\"id\":\"00000000-0000-0001-0000-000100000000\"},\"service\":{\"id\":\"00000000-0000-0001-0000-000000000001\",\"provider\":\"00000001-0000-0001-0000-000000000001\"},\"status\":\"suspended\",\"supported_protocols\":[\"proteus\"],\"team\":\"00000000-0000-0001-0000-000100000001\"}" + json1 = "{\"accent_id\":1,\"assets\":[],\"deleted\":true,\"email\":\"foo@example.com\",\"expires_at\":\"1864-05-09T17:20:22.192Z\",\"handle\":\"-ve\",\"id\":\"00000000-0000-0001-0000-000100000000\",\"locale\":\"lu\",\"managed_by\":\"wire\",\"name\":\"bla\",\"picture\":[],\"qualified_id\":{\"domain\":\"4-o60.j7-i\",\"id\":\"00000000-0000-0001-0000-000100000000\"},\"service\":{\"id\":\"00000000-0000-0001-0000-000000000001\",\"provider\":\"00000001-0000-0001-0000-000000000001\"},\"status\":\"suspended\",\"supported_protocols\":[\"proteus\"],\"team\":\"00000000-0000-0001-0000-000100000001\"}" json2 :: LByteString json2 = "{\"accent_id\":0,\"assets\":[{\"key\":\"3-4-00000000-0000-0001-0000-000000000000\",\"size\":\"preview\",\"type\":\"image\"}],\"email\":\"@\",\"expires_at\":\"1864-05-10T22:45:44.823Z\",\"handle\":\"b8m\",\"id\":\"00000000-0000-0000-0000-000000000001\",\"locale\":\"tk-KZ\",\"managed_by\":\"wire\",\"name\":\"name2\",\"picture\":[],\"qualified_id\":{\"domain\":\"1-8wq0.b22k1.w5\",\"id\":\"00000000-0000-0000-0000-000000000001\"},\"service\":{\"id\":\"00000000-0000-0001-0000-000000000001\",\"provider\":\"00000001-0000-0001-0000-000100000000\"},\"status\":\"pending-invitation\",\"supported_protocols\":[\"proteus\"],\"team\":\"00000000-0000-0001-0000-000000000001\"}" diff --git a/libs/cassandra-util/src/Cassandra/Settings.hs b/libs/cassandra-util/src/Cassandra/Settings.hs index f4b4818dd5a..548019a27da 100644 --- a/libs/cassandra-util/src/Cassandra/Settings.hs +++ b/libs/cassandra-util/src/Cassandra/Settings.hs @@ -43,7 +43,7 @@ import System.Logger qualified as Log -- Given a server name and a url returning a wire-custom "disco" json (AWS describe-instances-like json), e.g. -- { "roles" : { "server_name": [ {"privateIpAddress": "...", ...}, {...} ] } }, -- return a list of IP addresses. -initialContactsDisco :: MonadIO m => String -> String -> m (NonEmpty String) +initialContactsDisco :: (MonadIO m) => String -> String -> m (NonEmpty String) initialContactsDisco (pack -> srv) url = liftIO $ do rs <- asValue =<< get url let srvs = map Key.fromText $ @@ -65,7 +65,7 @@ initialContactsDisco (pack -> srv) url = liftIO $ do _ -> error "initial-contacts: no IP addresses found." -- | Puts the address into a list using the same signature as the other initialContacts -initialContactsPlain :: MonadIO m => Text -> m (NonEmpty String) +initialContactsPlain :: (MonadIO m) => Text -> m (NonEmpty String) initialContactsPlain address = pure $ unpack address :| [] -- | Use dcAwareRandomPolicy if config option filterNodesByDatacentre is set, diff --git a/libs/deriving-swagger2/src/Deriving/Swagger.hs b/libs/deriving-swagger2/src/Deriving/Swagger.hs index 95a0c121a3e..508947a33b5 100644 --- a/libs/deriving-swagger2/src/Deriving/Swagger.hs +++ b/libs/deriving-swagger2/src/Deriving/Swagger.hs @@ -131,13 +131,13 @@ instance (StringModifier a, StringModifier b, StringModifier c, StringModifier d -- | Strips the given prefix, has no effect if the prefix doesn't exist data StripPrefix t -instance KnownSymbol prefix => StringModifier (StripPrefix prefix) where +instance (KnownSymbol prefix) => StringModifier (StripPrefix prefix) where getStringModifier = fromMaybe <*> stripPrefix (symbolVal (Proxy @prefix)) -- | Strips the given suffix, has no effect if the suffix doesn't exist data StripSuffix t -instance KnownSymbol suffix => StringModifier (StripSuffix suffix) where +instance (KnownSymbol suffix) => StringModifier (StripSuffix suffix) where getStringModifier = fromMaybe <*> stripSuffix (symbolVal (Proxy @suffix)) data CamelTo (separator :: Symbol) diff --git a/libs/dns-util/src/Wire/Network/DNS/Effect.hs b/libs/dns-util/src/Wire/Network/DNS/Effect.hs index fa82130f4eb..9910c28ba42 100644 --- a/libs/dns-util/src/Wire/Network/DNS/Effect.hs +++ b/libs/dns-util/src/Wire/Network/DNS/Effect.hs @@ -32,13 +32,13 @@ data DNSLookup m a where makeSem ''DNSLookup -runDNSLookupDefault :: Member (Embed IO) r => Sem (DNSLookup ': r) a -> Sem r a +runDNSLookupDefault :: (Member (Embed IO) r) => Sem (DNSLookup ': r) a -> Sem r a runDNSLookupDefault = interpret $ \action -> embed $ do rs <- DNS.makeResolvSeed DNS.defaultResolvConf DNS.withResolver rs $ flip runLookupIO action -runDNSLookupWithResolver :: Member (Embed IO) r => Resolver -> Sem (DNSLookup ': r) a -> Sem r a +runDNSLookupWithResolver :: (Member (Embed IO) r) => Resolver -> Sem (DNSLookup ': r) a -> Sem r a runDNSLookupWithResolver resolver = interpret $ embed . runLookupIO resolver runLookupIO :: Resolver -> DNSLookup m a -> IO a diff --git a/libs/extended/default.nix b/libs/extended/default.nix index 66687c40075..b47de8057a2 100644 --- a/libs/extended/default.nix +++ b/libs/extended/default.nix @@ -9,6 +9,9 @@ , bytestring , cassandra-util , containers +, crypton-connection +, crypton-x509-store +, data-default , errors , exceptions , extra @@ -16,6 +19,7 @@ , hspec , hspec-discover , http-client +, http-client-tls , http-types , imports , lib @@ -34,6 +38,8 @@ , text , time , tinylog +, tls +, transformers , unliftio , wai }: @@ -48,10 +54,14 @@ mkDerivation { bytestring cassandra-util containers + crypton-connection + crypton-x509-store + data-default errors exceptions extra http-client + http-client-tls http-types imports metrics-wai @@ -67,6 +77,8 @@ mkDerivation { text time tinylog + tls + transformers unliftio wai ]; diff --git a/libs/extended/extended.cabal b/libs/extended/extended.cabal index 087fb75843a..03d180a004a 100644 --- a/libs/extended/extended.cabal +++ b/libs/extended/extended.cabal @@ -85,10 +85,14 @@ library , bytestring , cassandra-util , containers + , crypton-connection + , crypton-x509-store + , data-default , errors , exceptions , extra , http-client + , http-client-tls , http-types , imports , metrics-wai @@ -104,6 +108,8 @@ library , text , time , tinylog + , tls + , transformers , unliftio , wai diff --git a/libs/extended/src/Network/AMQP/Extended.hs b/libs/extended/src/Network/AMQP/Extended.hs index 502cdb95a77..b3131fce2af 100644 --- a/libs/extended/src/Network/AMQP/Extended.hs +++ b/libs/extended/src/Network/AMQP/Extended.hs @@ -1,19 +1,37 @@ {-# LANGUAGE RecordWildCards #-} -module Network.AMQP.Extended where +module Network.AMQP.Extended + ( RabbitMqHooks (..), + RabbitMqAdminOpts (..), + RabbitMqOpts (..), + openConnectionWithRetries, + mkRabbitMqAdminClientEnv, + mkRabbitMqChannelMVar, + demoteOpts, + RabbitMqTlsOpts (..), + ) +where import Control.Exception (throwIO) import Control.Monad.Catch import Control.Monad.Trans.Control +import Control.Monad.Trans.Maybe import Control.Retry import Data.Aeson +import Data.Aeson.Types +import Data.Default import Data.Proxy import Data.Text qualified as Text import Data.Text.Encoding qualified as Text +import Data.X509.CertificateStore qualified as X509 import Imports import Network.AMQP qualified as Q +import Network.Connection as Conn import Network.HTTP.Client qualified as HTTP +import Network.HTTP.Client.TLS qualified as HTTP import Network.RabbitMqAdmin +import Network.TLS +import Network.TLS.Extra.Cipher import Servant import Servant.Client import Servant.Client qualified as Servant @@ -33,22 +51,52 @@ data RabbitMqHooks m = RabbitMqHooks onChannelException :: SomeException -> m () } +data RabbitMqTlsOpts = RabbitMqTlsOpts + { caCert :: !(Maybe FilePath), + insecureSkipVerifyTls :: Bool + } + deriving (Show) + +parseTlsJson :: Object -> Parser (Maybe RabbitMqTlsOpts) +parseTlsJson v = do + enabled <- v .:? "enableTls" .!= False + if enabled + then + Just + <$> ( RabbitMqTlsOpts + <$> v .:? "caCert" + <*> v .:? "insecureSkipVerifyTls" .!= False + ) + else pure Nothing + data RabbitMqAdminOpts = RabbitMqAdminOpts { host :: !String, port :: !Int, vHost :: !Text, + tls :: Maybe RabbitMqTlsOpts, adminPort :: !Int } - deriving (Show, Generic) + deriving (Show) -instance FromJSON RabbitMqAdminOpts +instance FromJSON RabbitMqAdminOpts where + parseJSON = withObject "RabbitMqAdminOpts" $ \v -> + RabbitMqAdminOpts + <$> v .: "host" + <*> v .: "port" + <*> v .: "vHost" + <*> parseTlsJson v + <*> v .: "adminPort" mkRabbitMqAdminClientEnv :: RabbitMqAdminOpts -> IO (AdminAPI (AsClientT IO)) mkRabbitMqAdminClientEnv opts = do (username, password) <- readCredsFromEnv - manager <- HTTP.newManager HTTP.defaultManagerSettings + mTlsSettings <- traverse (mkTLSSettings opts.host) opts.tls + let (protocol, managerSettings) = case mTlsSettings of + Nothing -> (Servant.Http, HTTP.defaultManagerSettings) + Just tlsSettings -> (Servant.Https, HTTP.mkManagerSettings tlsSettings Nothing) + manager <- HTTP.newManager managerSettings let basicAuthData = Servant.BasicAuthData (Text.encodeUtf8 username) (Text.encodeUtf8 password) - clientEnv = Servant.mkClientEnv manager (Servant.BaseUrl Servant.Http opts.host opts.adminPort "") + clientEnv = Servant.mkClientEnv manager (Servant.BaseUrl protocol opts.host opts.adminPort "") pure . fromServant $ hoistClient (Proxy @(ToServant AdminAPI AsApi)) @@ -60,11 +108,18 @@ mkRabbitMqAdminClientEnv opts = do data RabbitMqOpts = RabbitMqOpts { host :: !String, port :: !Int, - vHost :: !Text + vHost :: !Text, + tls :: !(Maybe RabbitMqTlsOpts) } - deriving (Show, Generic) + deriving (Show) -instance FromJSON RabbitMqOpts +instance FromJSON RabbitMqOpts where + parseJSON = withObject "RabbitMqAdminOpts" $ \v -> + RabbitMqOpts + <$> v .: "host" + <*> v .: "port" + <*> v .: "vHost" + <*> parseTlsJson v demoteOpts :: RabbitMqAdminOpts -> RabbitMqOpts demoteOpts RabbitMqAdminOpts {..} = RabbitMqOpts {..} @@ -123,7 +178,15 @@ openConnectionWithRetries l RabbitMqOpts {..} hooks = do ) ( const $ do Log.info l $ Log.msg (Log.val "Trying to connect to RabbitMQ") - liftIO $ Q.openConnection' host (fromIntegral port) vHost username password + mTlsSettings <- traverse (liftIO . (mkTLSSettings host)) tls + liftIO $ + Q.openConnection'' $ + Q.defaultConnectionOpts + { Q.coServers = [(host, fromIntegral port)], + Q.coVHost = vHost, + Q.coAuth = [Q.plain username password], + Q.coTLSSettings = fmap Q.TLSCustom mTlsSettings + } ) bracket getConn (liftIO . Q.closeConnection) $ \conn -> do liftBaseWith $ \runInIO -> @@ -156,6 +219,28 @@ openConnectionWithRetries l RabbitMqOpts {..} hooks = do logException l "RabbitMQ channel closed" e openChan conn +mkTLSSettings :: HostName -> RabbitMqTlsOpts -> IO TLSSettings +mkTLSSettings host opts = do + setCAStore <- runMaybeT $ do + path <- maybe mzero pure opts.caCert + store <- MaybeT $ X509.readCertificateStore path + pure $ \shared -> shared {sharedCAStore = store} + let setHooks = + if opts.insecureSkipVerifyTls + then \h -> h {onServerCertificate = \_ _ _ _ -> pure []} + else id + pure $ + TLSSettings + (defaultParamsClient host "rabbitmq") + { clientShared = fromMaybe id setCAStore def, + clientHooks = setHooks def, + clientSupported = + def + { supportedVersions = [TLS13, TLS12], + supportedCiphers = ciphersuite_strong + } + } + logException :: (MonadIO m) => Logger -> String -> SomeException -> m () logException l m (SomeException e) = do Log.err l $ diff --git a/libs/extended/src/Options/Applicative/Extended.hs b/libs/extended/src/Options/Applicative/Extended.hs index 588fa9668b0..3a44fecb188 100644 --- a/libs/extended/src/Options/Applicative/Extended.hs +++ b/libs/extended/src/Options/Applicative/Extended.hs @@ -32,7 +32,7 @@ import Options.Applicative -- | A reader that accepts either @N@ or @N..M@ (not necessarily just -- numbers). -autoRange :: Read a => ReadM (a, a) +autoRange :: (Read a) => ReadM (a, a) autoRange = eitherReader $ \arg -> case stripInfix ".." arg of Nothing -> (\a -> (a, a)) <$> readEither arg Just (l, r) -> case (readEither l, readEither r) of diff --git a/libs/extended/src/Servant/API/Extended.hs b/libs/extended/src/Servant/API/Extended.hs index a531f141bd7..959249ac48b 100644 --- a/libs/extended/src/Servant/API/Extended.hs +++ b/libs/extended/src/Servant/API/Extended.hs @@ -109,10 +109,10 @@ instance Right v -> pure v instance - HasOpenApi (ReqBody' '[Required, Strict] cts a :> api) => + (HasOpenApi (ReqBody' '[Required, Strict] cts a :> api)) => HasOpenApi (ReqBodyCustomError cts tag a :> api) where toOpenApi Proxy = toOpenApi (Proxy @(ReqBody' '[Required, Strict] cts a :> api)) -instance RoutesToPaths rest => RoutesToPaths (ReqBodyCustomError' mods list tag a :> rest) where +instance (RoutesToPaths rest) => RoutesToPaths (ReqBodyCustomError' mods list tag a :> rest) where getRoutes = getRoutes @rest diff --git a/libs/extended/src/Servant/API/Extended/Endpath.hs b/libs/extended/src/Servant/API/Extended/Endpath.hs index 773230e8509..6e5d5dc40ef 100644 --- a/libs/extended/src/Servant/API/Extended/Endpath.hs +++ b/libs/extended/src/Servant/API/Extended/Endpath.hs @@ -22,5 +22,5 @@ instance (HasServer api context, HasContextEntry (context .++ DefaultErrorFormat hoistServerWithContext _ proxyCtx f s = hoistServerWithContext (Proxy @api) proxyCtx f s -- Endpath :> route -instance RoutesToPaths route => RoutesToPaths (Endpath :> route) where +instance (RoutesToPaths route) => RoutesToPaths (Endpath :> route) where getRoutes = getRoutes @route diff --git a/libs/galley-types/src/Galley/Types/Conversations/One2One.hs b/libs/galley-types/src/Galley/Types/Conversations/One2One.hs index 2101a27a600..4bd74342316 100644 --- a/libs/galley-types/src/Galley/Types/Conversations/One2One.hs +++ b/libs/galley-types/src/Galley/Types/Conversations/One2One.hs @@ -44,7 +44,7 @@ namespace :: BaseProtocolTag -> UUID namespace BaseProtocolProteusTag = UUID.fromWords 0x9a51edb8 0x060c0d9a 0x0c2950a8 0x5d152982 namespace BaseProtocolMLSTag = UUID.fromWords 0x95589dd5 0xb04540dc 0xa6aadd9c 0x4fad1c2f -compareDomains :: Ord a => Qualified a -> Qualified a -> Ordering +compareDomains :: (Ord a) => Qualified a -> Qualified a -> Ordering compareDomains (Qualified a1 dom1) (Qualified a2 dom2) = compare (dom1, a1) (dom2, a2) diff --git a/libs/galley-types/src/Galley/Types/Teams.hs b/libs/galley-types/src/Galley/Types/Teams.hs index 715377e42bb..75d70c0fb14 100644 --- a/libs/galley-types/src/Galley/Types/Teams.hs +++ b/libs/galley-types/src/Galley/Types/Teams.hs @@ -104,11 +104,11 @@ newtype Defaults a = Defaults {_unDefaults :: a} deriving (Eq, Ord, Show, Enum, Bounded, Generic, Functor) deriving newtype (Arbitrary) -instance FromJSON a => FromJSON (Defaults a) where +instance (FromJSON a) => FromJSON (Defaults a) where parseJSON = withObject "default object" $ \ob -> Defaults <$> (ob .: "defaults") -instance ToJSON a => ToJSON (Defaults a) where +instance (ToJSON a) => ToJSON (Defaults a) where toJSON (Defaults x) = object ["defaults" .= toJSON x] @@ -236,10 +236,10 @@ notTeamMember uids tmms = Set.toList $ Set.fromList uids `Set.difference` Set.fromList (map (view userId) tmms) -isTeamMember :: Foldable m => UserId -> m TeamMember -> Bool +isTeamMember :: (Foldable m) => UserId -> m TeamMember -> Bool isTeamMember u = isJust . findTeamMember u -findTeamMember :: Foldable m => UserId -> m TeamMember -> Maybe TeamMember +findTeamMember :: (Foldable m) => UserId -> m TeamMember -> Maybe TeamMember findTeamMember u = find ((u ==) . view userId) isTeamOwner :: TeamMemberOptPerms -> Bool diff --git a/libs/gundeck-types/src/Gundeck/Types/Common.hs b/libs/gundeck-types/src/Gundeck/Types/Common.hs index 388ac6b82ae..1158830d1c8 100644 --- a/libs/gundeck-types/src/Gundeck/Types/Common.hs +++ b/libs/gundeck-types/src/Gundeck/Types/Common.hs @@ -57,5 +57,5 @@ instance ToByteString URI where instance FromByteString URI where parser = takeByteString >>= parse . Bytes.unpack -parse :: MonadFail m => String -> m URI +parse :: (MonadFail m) => String -> m URI parse = maybe (fail "Invalid URI") (pure . URI) . Net.parseURI diff --git a/libs/gundeck-types/src/Gundeck/Types/Push/V2.hs b/libs/gundeck-types/src/Gundeck/Types/Push/V2.hs index b8794553a45..6c0df12d8a5 100644 --- a/libs/gundeck-types/src/Gundeck/Types/Push/V2.hs +++ b/libs/gundeck-types/src/Gundeck/Types/Push/V2.hs @@ -147,9 +147,12 @@ instance FromJSON Recipient where instance ToJSON Recipient where toJSON (Recipient u r c) = object $ - "user_id" .= u - # "route" .= r - # "clients" .= c + "user_id" + .= u + # "route" + .= r + # "clients" + .= c # [] -- "All clients" is encoded in the API as an empty list. @@ -191,10 +194,14 @@ apsData lk la = ApsData lk la Nothing True instance ToJSON ApsData where toJSON (ApsData k a s b) = object $ - "loc_key" .= k - # "loc_args" .= a - # "sound" .= s - # "badge" .= b + "loc_key" + .= k + # "loc_args" + .= a + # "sound" + .= s + # "badge" + .= b # [] instance FromJSON ApsData where @@ -269,7 +276,7 @@ newPush from to pload = singletonRecipient :: Recipient -> Range 1 1024 (Set Recipient) singletonRecipient = Range.unsafeRange . Set.singleton -singletonPayload :: ToJSONObject a => a -> List1 Object +singletonPayload :: (ToJSONObject a) => a -> List1 Object singletonPayload = List1.singleton . toJSONObject instance FromJSON Push where @@ -289,16 +296,26 @@ instance FromJSON Push where instance ToJSON Push where toJSON p = object $ - "recipients" .= _pushRecipients p - # "origin" .= _pushOrigin p - # "connections" .= ifNot Set.null (_pushConnections p) - # "origin_connection" .= _pushOriginConnection p - # "transient" .= ifNot not (_pushTransient p) - # "native_include_origin" .= ifNot id (_pushNativeIncludeOrigin p) - # "native_encrypt" .= ifNot id (_pushNativeEncrypt p) - # "native_aps" .= _pushNativeAps p - # "native_priority" .= ifNot (== HighPriority) (_pushNativePriority p) - # "payload" .= _pushPayload p + "recipients" + .= _pushRecipients p + # "origin" + .= _pushOrigin p + # "connections" + .= ifNot Set.null (_pushConnections p) + # "origin_connection" + .= _pushOriginConnection p + # "transient" + .= ifNot not (_pushTransient p) + # "native_include_origin" + .= ifNot id (_pushNativeIncludeOrigin p) + # "native_encrypt" + .= ifNot id (_pushNativeEncrypt p) + # "native_aps" + .= _pushNativeAps p + # "native_priority" + .= ifNot (== HighPriority) (_pushNativePriority p) + # "payload" + .= _pushPayload p # [] where ifNot f a = if f a then Nothing else Just a diff --git a/libs/hscim/hscim.cabal b/libs/hscim/hscim.cabal index a2a5a9c19b4..46e6f535ac1 100644 --- a/libs/hscim/hscim.cabal +++ b/libs/hscim/hscim.cabal @@ -86,12 +86,12 @@ library aeson >=2.1.2 && <2.2 , aeson-qq >=0.8.4 && <0.9 , attoparsec >=0.14.4 && <0.15 - , base >=4.17.2 && <4.18 + , base >=4.17.2 && <4.19 , bytestring >=0.10.4 && <0.12 , case-insensitive >=1.2.1 && <1.3 , email-validate >=2.3.2 && <2.4 , hashable >=1.4.3 && <1.5 - , hspec >=2.10.10 && <2.11 + , hspec >=2.10.10 && <2.12 , hspec-expectations >=0.8.2 && <0.9 , hspec-wai >=0.11.1 && <0.12 , http-api-data >=0.5 && <0.6 @@ -100,18 +100,18 @@ library , list-t >=1.0.5 && <1.1 , microlens >=0.4.13 && <0.5 , mmorph >=1.2.0 && <1.3 - , mtl >=2.2.2 && <2.3 + , mtl >=2.2.2 && <2.4 , network-uri >=2.6.4 && <2.7 , retry >=0.9.3 && <0.10 , scientific >=0.3.7 && <0.4 - , servant >=0.19.1 && <0.20 - , servant-client >=0.19 && <0.20 - , servant-client-core >=0.19 && <0.20 - , servant-server >=0.19.2 && <0.20 + , servant >=0.19.1 && <0.21 + , servant-client >=0.19 && <0.21 + , servant-client-core >=0.19 && <0.21 + , servant-server >=0.19.2 && <0.21 , stm >=2.5.1 && <2.6 , stm-containers >=1.2.0 && <1.3 , string-conversions >=0.4.0 && <0.5 - , template-haskell >=2.19.0 && <2.20 + , template-haskell >=2.19.0 && <2.21 , text >=2.0.2 && <2.1 , time >=1.12.2 && <1.13 , uuid >=1.3.15 && <1.4 diff --git a/libs/hscim/server/Main.hs b/libs/hscim/server/Main.hs index adcd58a2b86..cfb31664ce0 100644 --- a/libs/hscim/server/Main.hs +++ b/libs/hscim/server/Main.hs @@ -72,8 +72,9 @@ mkUserDB = do (emailAddress "elton@wire.com"), E.primary = Nothing } + let user = - (User.empty [User20] "elton" NoUserExtra) + (User.empty [User20] "elton" NoUserExtra :: User Mock) { name = Just Name diff --git a/libs/hscim/src/Web/Scim/Capabilities/MetaSchema.hs b/libs/hscim/src/Web/Scim/Capabilities/MetaSchema.hs index 77f876ef2ed..4bdaf265af3 100644 --- a/libs/hscim/src/Web/Scim/Capabilities/MetaSchema.hs +++ b/libs/hscim/src/Web/Scim/Capabilities/MetaSchema.hs @@ -54,7 +54,7 @@ data Supported a = Supported } deriving (Show, Eq, Generic) -instance ToJSON a => ToJSON (Supported a) where +instance (ToJSON a) => ToJSON (Supported a) where toJSON (Supported (ScimBool b) v) = case toJSON v of (Object o) -> Object $ KeyMap.insert "supported" (Bool b) o _ -> Object $ KeyMap.fromList [("supported", Bool b)] @@ -134,7 +134,7 @@ empty = } configServer :: - Monad m => + (Monad m) => Configuration -> ConfigSite (AsServerT (ScimHandler m)) configServer config = diff --git a/libs/hscim/src/Web/Scim/Class/Group.hs b/libs/hscim/src/Web/Scim/Class/Group.hs index 2b3f49734e1..83a3c3ac44b 100644 --- a/libs/hscim/src/Web/Scim/Class/Group.hs +++ b/libs/hscim/src/Web/Scim/Class/Group.hs @@ -171,7 +171,7 @@ class (Monad m, GroupTypes tag, AuthDB tag m) => GroupDB tag m where groupServer :: forall tag m. - GroupDB tag m => + (GroupDB tag m) => Maybe (AuthData tag) -> GroupSite tag (AsServerT (ScimHandler m)) groupServer authData = diff --git a/libs/hscim/src/Web/Scim/Client.hs b/libs/hscim/src/Web/Scim/Client.hs index fee613ac875..c80070fb038 100644 --- a/libs/hscim/src/Web/Scim/Client.hs +++ b/libs/hscim/src/Web/Scim/Client.hs @@ -74,28 +74,28 @@ type HasScimClient tag = ToHttpApiData (GroupId tag) ) -scimClients :: HasScimClient tag => ClientEnv -> Site tag (AsClientT IO) +scimClients :: (HasScimClient tag) => ClientEnv -> Site tag (AsClientT IO) scimClients env = genericClientHoist $ \x -> runClientM x env >>= either throwIO pure -- config spConfig :: forall tag. - HasScimClient tag => + (HasScimClient tag) => ClientEnv -> IO MetaSchema.Configuration spConfig env = case config @tag (scimClients env) of ((r :<|> _) :<|> (_ :<|> _)) -> r getSchemas :: forall tag. - HasScimClient tag => + (HasScimClient tag) => ClientEnv -> IO (ListResponse Value) getSchemas env = case config @tag (scimClients env) of ((_ :<|> r) :<|> (_ :<|> _)) -> r schema :: forall tag. - HasScimClient tag => + (HasScimClient tag) => ClientEnv -> Text -> IO Value @@ -103,7 +103,7 @@ schema env = case config @tag (scimClients env) of ((_ :<|> _) :<|> (r :<|> _)) resourceTypes :: forall tag. - HasScimClient tag => + (HasScimClient tag) => ClientEnv -> IO (ListResponse ResourceType.Resource) resourceTypes env = case config @tag (scimClients env) of ((_ :<|> _) :<|> (_ :<|> r)) -> r @@ -111,7 +111,7 @@ resourceTypes env = case config @tag (scimClients env) of ((_ :<|> _) :<|> (_ :< -- users getUsers :: - HasScimClient tag => + (HasScimClient tag) => ClientEnv -> Maybe (AuthData tag) -> Maybe Filter -> @@ -119,7 +119,7 @@ getUsers :: getUsers env tok = case users (scimClients env) tok of ((r :<|> (_ :<|> _)) :<|> (_ :<|> (_ :<|> _))) -> r getUser :: - HasScimClient tag => + (HasScimClient tag) => ClientEnv -> Maybe (AuthData tag) -> UserId tag -> @@ -127,7 +127,7 @@ getUser :: getUser env tok = case users (scimClients env) tok of ((_ :<|> (r :<|> _)) :<|> (_ :<|> (_ :<|> _))) -> r postUser :: - HasScimClient tag => + (HasScimClient tag) => ClientEnv -> Maybe (AuthData tag) -> User tag -> @@ -135,7 +135,7 @@ postUser :: postUser env tok = case users (scimClients env) tok of ((_ :<|> (_ :<|> r)) :<|> (_ :<|> (_ :<|> _))) -> r putUser :: - HasScimClient tag => + (HasScimClient tag) => ClientEnv -> Maybe (AuthData tag) -> UserId tag -> @@ -144,7 +144,7 @@ putUser :: putUser env tok = case users (scimClients env) tok of ((_ :<|> (_ :<|> _)) :<|> (r :<|> (_ :<|> _))) -> r patchUser :: - HasScimClient tag => + (HasScimClient tag) => ClientEnv -> Maybe (AuthData tag) -> UserId tag -> @@ -154,7 +154,7 @@ patchUser env tok = case users (scimClients env) tok of ((_ :<|> (_ :<|> _)) :<| deleteUser :: forall tag. - HasScimClient tag => + (HasScimClient tag) => ClientEnv -> Maybe (AuthData tag) -> UserId tag -> diff --git a/libs/hscim/src/Web/Scim/ContentType.hs b/libs/hscim/src/Web/Scim/ContentType.hs index 81aa5dd10e9..bf79c7df790 100644 --- a/libs/hscim/src/Web/Scim/ContentType.hs +++ b/libs/hscim/src/Web/Scim/ContentType.hs @@ -46,8 +46,8 @@ instance Accept SCIM where "application" // "json" ] -instance ToJSON a => MimeRender SCIM a where +instance (ToJSON a) => MimeRender SCIM a where mimeRender _ = mimeRender (Proxy @JSON) -instance FromJSON a => MimeUnrender SCIM a where +instance (FromJSON a) => MimeUnrender SCIM a where mimeUnrender _ = mimeUnrender (Proxy @JSON) diff --git a/libs/hscim/src/Web/Scim/Handler.hs b/libs/hscim/src/Web/Scim/Handler.hs index 22133a77121..e600d50cd97 100644 --- a/libs/hscim/src/Web/Scim/Handler.hs +++ b/libs/hscim/src/Web/Scim/Handler.hs @@ -22,6 +22,7 @@ module Web.Scim.Handler ) where +import Control.Monad ((<=<)) import Control.Monad.Except import Web.Scim.Schema.Error @@ -29,7 +30,7 @@ import Web.Scim.Schema.Error type ScimHandler m = ExceptT ScimError m -- | Throw a 'ScimError'. -throwScim :: Monad m => ScimError -> ScimHandler m a +throwScim :: (Monad m) => ScimError -> ScimHandler m a throwScim = throwError -- | A natural transformation for Servant handlers. To use it, you need to @@ -42,7 +43,7 @@ throwScim = throwError -- You can either do something custom for 'ScimError', or use -- 'scimToServantErr'. fromScimHandler :: - Monad m => + (Monad m) => (forall a. ScimError -> m a) -> (forall a. ScimHandler m a -> m a) fromScimHandler fromError = either fromError pure <=< runExceptT diff --git a/libs/hscim/src/Web/Scim/Schema/Common.hs b/libs/hscim/src/Web/Scim/Schema/Common.hs index eb95b05d2b0..4bceab55c08 100644 --- a/libs/hscim/src/Web/Scim/Schema/Common.hs +++ b/libs/hscim/src/Web/Scim/Schema/Common.hs @@ -99,7 +99,7 @@ parseOptions = -- -- (FUTUREWORK: The "recursively" part is a bit of a waste and could be dropped, but we would -- have to spend more effort in making sure it is always called manually in nested parsers.) -jsonLower :: forall m. m ~ Either [Text] => Value -> m Value +jsonLower :: forall m. (m ~ Either [Text]) => Value -> m Value jsonLower (Object (KeyMap.toList -> olist)) = Object . KeyMap.fromList <$> (nubCI >> mapM lowerPair olist) where diff --git a/libs/hscim/src/Web/Scim/Schema/ListResponse.hs b/libs/hscim/src/Web/Scim/Schema/ListResponse.hs index 0b9c9ba58a5..78e9a044cf6 100644 --- a/libs/hscim/src/Web/Scim/Schema/ListResponse.hs +++ b/libs/hscim/src/Web/Scim/Schema/ListResponse.hs @@ -58,10 +58,10 @@ fromList list = where len = length list -instance FromJSON a => FromJSON (ListResponse a) where +instance (FromJSON a) => FromJSON (ListResponse a) where parseJSON = either (fail . show) (genericParseJSON parseOptions) . jsonLower -instance ToJSON a => ToJSON (ListResponse a) where +instance (ToJSON a) => ToJSON (ListResponse a) where toJSON ListResponse {..} = object [ "Resources" .= resources, diff --git a/libs/hscim/src/Web/Scim/Schema/PatchOp.hs b/libs/hscim/src/Web/Scim/Schema/PatchOp.hs index 686e58b3ba7..1ac01c3b166 100644 --- a/libs/hscim/src/Web/Scim/Schema/PatchOp.hs +++ b/libs/hscim/src/Web/Scim/Schema/PatchOp.hs @@ -18,6 +18,7 @@ module Web.Scim.Schema.PatchOp where import Control.Applicative +import Control.Monad (guard) import Control.Monad.Except import qualified Data.Aeson.Key as Key import qualified Data.Aeson.KeyMap as KeyMap @@ -85,7 +86,7 @@ rPath (IntoValuePath valuePath subAttr) = rValuePath valuePath <> maybe "" rSubA -- TODO(arianvp): According to the SCIM spec we should throw an InvalidPath -- error when the path is invalid syntax. this is a bit hard to do though as we -- can't control what errors FromJSON throws :/ -instance UserTypes tag => FromJSON (PatchOp tag) where +instance (UserTypes tag) => FromJSON (PatchOp tag) where parseJSON = withObject "PatchOp" $ \v -> do let o = KeyMap.fromList . map (first lowerKey) . KeyMap.toList $ v schemas' :: [Schema] <- o .: "schemas" diff --git a/libs/hscim/src/Web/Scim/Schema/User.hs b/libs/hscim/src/Web/Scim/Schema/User.hs index 84655c898a0..1a37f6dae60 100644 --- a/libs/hscim/src/Web/Scim/Schema/User.hs +++ b/libs/hscim/src/Web/Scim/Schema/User.hs @@ -71,6 +71,7 @@ module Web.Scim.Schema.User ) where +import Control.Monad import Control.Monad.Except import Data.Aeson import qualified Data.Aeson.Key as Key @@ -139,9 +140,9 @@ data User tag = User } deriving (Generic) -deriving instance Show (UserExtra tag) => Show (User tag) +deriving instance (Show (UserExtra tag)) => Show (User tag) -deriving instance Eq (UserExtra tag) => Eq (User tag) +deriving instance (Eq (UserExtra tag)) => Eq (User tag) empty :: -- | Schemas @@ -177,7 +178,7 @@ empty schemas userName extra = extra = extra } -instance FromJSON (UserExtra tag) => FromJSON (User tag) where +instance (FromJSON (UserExtra tag)) => FromJSON (User tag) where parseJSON = withObject "User" $ \obj -> do -- Lowercase all fields let o = KeyMap.fromList . map (over _1 lowerKey) . KeyMap.toList $ obj @@ -208,7 +209,7 @@ instance FromJSON (UserExtra tag) => FromJSON (User tag) where extra <- parseJSON (Object obj) pure User {..} -instance ToJSON (UserExtra tag) => ToJSON (User tag) where +instance (ToJSON (UserExtra tag)) => ToJSON (User tag) where toJSON User {..} = let mainObject = KeyMap.fromList $ diff --git a/libs/hscim/src/Web/Scim/Server.hs b/libs/hscim/src/Web/Scim/Server.hs index db8176ae12d..364f382b0fb 100644 --- a/libs/hscim/src/Web/Scim/Server.hs +++ b/libs/hscim/src/Web/Scim/Server.hs @@ -85,7 +85,7 @@ data Site tag route = Site siteServer :: forall tag m. - DB tag m => + (DB tag m) => Configuration -> Site tag (AsServerT (ScimHandler m)) siteServer conf = @@ -117,7 +117,7 @@ mkapp proxy api nt = app :: forall tag m. - App tag m (SiteAPI tag) => + (App tag m (SiteAPI tag)) => Configuration -> (forall a. ScimHandler m a -> Handler a) -> Application diff --git a/libs/hscim/src/Web/Scim/Server/Mock.hs b/libs/hscim/src/Web/Scim/Server/Mock.hs index 11ffb37f60b..b7c07b2d999 100644 --- a/libs/hscim/src/Web/Scim/Server/Mock.hs +++ b/libs/hscim/src/Web/Scim/Server/Mock.hs @@ -23,6 +23,7 @@ -- ). module Web.Scim.Server.Mock where +import Control.Monad import Control.Monad.Morph import Control.Monad.Reader import Control.Monad.STM (STM, atomically) @@ -88,7 +89,7 @@ emptyTestStorage = -- in-memory implementation of the API for tests type TestServer = ReaderT TestStorage Handler -liftSTM :: MonadIO m => STM a -> m a +liftSTM :: (MonadIO m) => STM a -> m a liftSTM = liftIO . atomically hoistSTM :: (MFunctor t, MonadIO m) => t STM a -> t m a @@ -140,7 +141,7 @@ instance UserDB Mock TestServer where deleteUser () uid = do m <- asks userDB liftSTM (STMMap.lookup uid m) >>= \case - Nothing -> throwScim (notFound "User" (pack (show uid))) + Nothing -> pure () Just _ -> liftSTM $ STMMap.delete uid m -- (there seems to be no readOnly fields in User) diff --git a/libs/hscim/src/Web/Scim/Test/Acceptance.hs b/libs/hscim/src/Web/Scim/Test/Acceptance.hs index c4eea4122a8..e5bb3b995cb 100644 --- a/libs/hscim/src/Web/Scim/Test/Acceptance.hs +++ b/libs/hscim/src/Web/Scim/Test/Acceptance.hs @@ -46,7 +46,7 @@ import Web.Scim.Schema.Meta import Web.Scim.Schema.UserTypes import Web.Scim.Test.Util -ignore :: Monad m => m a -> m () +ignore :: (Monad m) => m a -> m () ignore _ = pure () -- https://docs.microsoft.com/en-us/azure/active-directory/manage-apps/use-scim-to-provision-users-and-groups#step-2-understand-the-azure-ad-scim-implementation @@ -263,7 +263,8 @@ microsoftAzure AcceptanceConfig {..} = do patch' queryConfig ("/Users/" <> testuid) op3 `shouldRespondWith` result3 -- Delete User delete' queryConfig ("/Users/" <> testuid) "" `shouldRespondWith` 204 - delete' queryConfig ("/Users/" <> testuid) "" `shouldEventuallyRespondWith` 404 + -- (... idempotently) + delete' queryConfig ("/Users/" <> testuid) "" `shouldRespondWith` 204 it "Group operations" $ const pending sampleUser1 :: Text -> L.ByteString diff --git a/libs/hscim/src/Web/Scim/Test/Util.hs b/libs/hscim/src/Web/Scim/Test/Util.hs index 601cdaab598..da75b438a47 100644 --- a/libs/hscim/src/Web/Scim/Test/Util.hs +++ b/libs/hscim/src/Web/Scim/Test/Util.hs @@ -83,17 +83,17 @@ import Web.Scim.Schema.User (UserTypes (..)) -- FUTUREWORK: make this a PR upstream. (while we're at it, we can also patch 'WaiSession' -- and 'request' to keep track of the 'SRequest', and add that to the error message here with -- the response.) -shouldRespondWith :: HasCallStack => WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st +shouldRespondWith :: (HasCallStack) => WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st shouldRespondWith action matcher = either (liftIO . expectationFailure) pure =<< doesRespondWith action matcher -doesRespondWith :: HasCallStack => WaiSession st SResponse -> ResponseMatcher -> WaiSession st (Either String ()) +doesRespondWith :: (HasCallStack) => WaiSession st SResponse -> ResponseMatcher -> WaiSession st (Either String ()) doesRespondWith action matcher = do r <- action let extmsg = " details: " <> show r <> "\n" pure $ maybe (Right ()) (Left . (<> extmsg)) (match r matcher) -shouldEventuallyRespondWith :: HasCallStack => WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st +shouldEventuallyRespondWith :: (HasCallStack) => WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st shouldEventuallyRespondWith action matcher = either (liftIO . expectationFailure) pure =<< Retry.retrying diff --git a/libs/hscim/test/Test/Class/UserSpec.hs b/libs/hscim/test/Test/Class/UserSpec.hs index 8bfc45bb945..6a46738dccc 100644 --- a/libs/hscim/test/Test/Class/UserSpec.hs +++ b/libs/hscim/test/Test/Class/UserSpec.hs @@ -383,14 +383,15 @@ spec = with app $ do { matchStatus = 200 } describe "DELETE /Users/:id" $ do - it "responds with 404 for unknown user" $ do - delete "/9999" `shouldRespondWith` 404 + it "responds with 204 for unknown user" $ do + delete "/9999" `shouldRespondWith` 204 it "deletes a stored user" $ do post "/" newBarbara `shouldRespondWith` 201 delete "/0" `shouldRespondWith` 204 -- user should be gone get "/0" `shouldRespondWith` 404 - delete "/0" `shouldRespondWith` 404 + -- delete is idempotent + delete "/0" `shouldRespondWith` 204 smallUser :: ByteString smallUser = diff --git a/libs/hscim/test/Test/FilterSpec.hs b/libs/hscim/test/Test/FilterSpec.hs index 888d84480d6..9fc6588e7f3 100644 --- a/libs/hscim/test/Test/FilterSpec.hs +++ b/libs/hscim/test/Test/FilterSpec.hs @@ -32,7 +32,7 @@ import Web.Scim.Schema.User (NoUserExtra) import Web.Scim.Schema.UserTypes (UserTypes (supportedSchemas)) import Web.Scim.Test.Util (TestTag) -prop_roundtrip :: forall tag. UserTypes tag => Property +prop_roundtrip :: forall tag. (UserTypes tag) => Property prop_roundtrip = property $ do x <- forAll $ genFilter @tag tripping x renderFilter $ parseFilter (supportedSchemas @tag) @@ -45,7 +45,7 @@ spec = do ---------------------------------------------------------------------------- -- Generators -genValuePath :: forall tag. UserTypes tag => Gen ValuePath +genValuePath :: forall tag. (UserTypes tag) => Gen ValuePath genValuePath = ValuePath <$> genAttrPath @tag <*> genFilter @tag genCompValue :: Gen CompValue @@ -72,16 +72,16 @@ genSubAttr = SubAttr <$> genAttrName -- FUTUREWORK: we also may want to factor a bounded enum type out of the 'Schema' type for -- this: @data Schema = Buitin BuitinSchema | Custom Text; data BuiltinSchema = ... deriving -- (Bounded, Enum, ...)@ -genSchema :: forall tag. UserTypes tag => Gen Schema +genSchema :: forall tag. (UserTypes tag) => Gen Schema genSchema = Gen.element (supportedSchemas @tag) -genAttrPath :: forall tag. UserTypes tag => Gen AttrPath +genAttrPath :: forall tag. (UserTypes tag) => Gen AttrPath genAttrPath = AttrPath <$> Gen.maybe (genSchema @tag) <*> genAttrName <*> Gen.maybe genSubAttr genAttrName :: Gen AttrName genAttrName = AttrName <$> (cons <$> Gen.alpha <*> Gen.text (Range.constant 0 50) (Gen.choice [Gen.alphaNum, Gen.constant '-', Gen.constant '_'])) -genFilter :: forall tag. UserTypes tag => Gen Filter +genFilter :: forall tag. (UserTypes tag) => Gen Filter genFilter = Gen.choice [ FilterAttrCompare <$> (genAttrPath @tag) <*> genCompareOp <*> genCompValue diff --git a/libs/hscim/test/Test/Schema/PatchOpSpec.hs b/libs/hscim/test/Test/Schema/PatchOpSpec.hs index dc5323cfa9c..2e9a0415316 100644 --- a/libs/hscim/test/Test/Schema/PatchOpSpec.hs +++ b/libs/hscim/test/Test/Schema/PatchOpSpec.hs @@ -48,28 +48,28 @@ isSuccess :: Result a -> Bool isSuccess (Success _) = True isSuccess (Error _) = False -genPatchOp :: forall tag. UserTypes tag => Gen Value -> Gen (PatchOp tag) +genPatchOp :: forall tag. (UserTypes tag) => Gen Value -> Gen (PatchOp tag) genPatchOp genValue = PatchOp <$> Gen.list (Range.constant 0 20) ((genOperation @tag) genValue) -genSimplePatchOp :: forall tag. UserTypes tag => Gen (PatchOp tag) +genSimplePatchOp :: forall tag. (UserTypes tag) => Gen (PatchOp tag) genSimplePatchOp = genPatchOp @tag (String <$> Gen.text (Range.constant 0 20) Gen.unicode) -genOperation :: forall tag. UserTypes tag => Gen Value -> Gen Operation +genOperation :: forall tag. (UserTypes tag) => Gen Value -> Gen Operation genOperation genValue = Operation <$> Gen.enumBounded <*> Gen.maybe (genPath @tag) <*> Gen.maybe genValue -genPath :: forall tag. UserTypes tag => Gen Path +genPath :: forall tag. (UserTypes tag) => Gen Path genPath = Gen.choice [ IntoValuePath <$> (genValuePath @tag) <*> Gen.maybe genSubAttr, NormalPath <$> (genAttrPath @tag) ] -prop_roundtrip :: forall tag. UserTypes tag => Property +prop_roundtrip :: forall tag. (UserTypes tag) => Property prop_roundtrip = property $ do x <- forAll $ genPath @tag tripping x (encodeUtf8 . rPath) (parseOnly $ pPath (supportedSchemas @tag)) -prop_roundtrip_PatchOp :: forall tag. UserTypes tag => Property +prop_roundtrip_PatchOp :: forall tag. (UserTypes tag) => Property prop_roundtrip_PatchOp = property $ do -- Just some strings for now. However, should be constrained to what the -- PatchOp is operating on in the future... We need better typed PatchOp for diff --git a/libs/hscim/test/Test/Schema/UserSpec.hs b/libs/hscim/test/Test/Schema/UserSpec.hs index deff894b70f..14b7b2ed8fb 100644 --- a/libs/hscim/test/Test/Schema/UserSpec.hs +++ b/libs/hscim/test/Test/Schema/UserSpec.hs @@ -156,7 +156,7 @@ genName = genStoredUser :: Gen (UserClass.StoredUser (TestTag Text () () NoUserExtra)) genStoredUser = do m <- genMeta - i <- Gen.element @_ @Text ["wef", "asdf", "@", "#", "1"] + i <- Gen.element ["wef", "asdf", "@", "#", "1"] WithMeta m . WithId i <$> genUser genMeta :: Gen Meta diff --git a/libs/hscim/test/Test/Schema/Util.hs b/libs/hscim/test/Test/Schema/Util.hs index a03c84d1ea1..83099d72b5b 100644 --- a/libs/hscim/test/Test/Schema/Util.hs +++ b/libs/hscim/test/Test/Schema/Util.hs @@ -60,5 +60,5 @@ mk_prop_caseInsensitive gen = property $ do same@(Bool _) -> same same@Null -> same -keyTextL :: Functor f => (Text -> f Text) -> Key -> f Key +keyTextL :: (Functor f) => (Text -> f Text) -> Key -> f Key keyTextL f key = fmap Key.fromText (f (Key.toText key)) diff --git a/libs/http2-manager/src/HTTP2/Client/Manager/Internal.hs b/libs/http2-manager/src/HTTP2/Client/Manager/Internal.hs index 0dd00173c8c..5ec47c2fff0 100644 --- a/libs/http2-manager/src/HTTP2/Client/Manager/Internal.hs +++ b/libs/http2-manager/src/HTTP2/Client/Manager/Internal.hs @@ -15,6 +15,7 @@ import Control.Monad import Control.Monad.IO.Class import Data.ByteString import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as C8 import Data.IORef import Data.Map import qualified Data.Map as Map @@ -291,9 +292,9 @@ startPersistentHTTP2Connection :: startPersistentHTTP2Connection ctx (tlsEnabled, hostname, port) cl removeTrailingDot tcpConnectTimeout sendReqMVar = do liveReqs <- newIORef mempty let clientConfig = - HTTP2.ClientConfig + HTTP2.defaultClientConfig { HTTP2.scheme = if tlsEnabled then "https" else "http", - HTTP2.authority = hostname, + HTTP2.authority = C8.unpack hostname, HTTP2.cacheLimit = cl } -- Sends error to requests which show up too late, i.e. after the @@ -333,7 +334,7 @@ startPersistentHTTP2Connection ctx (tlsEnabled, hostname, port) cl removeTrailin bracket connectTCPWithTimeout NS.close $ \sock -> do bracket (mkTransport sock transportConfig) cleanupTransport $ \transport -> bracket (allocHTTP2Config transport) HTTP2.freeSimpleConfig $ \http2Cfg -> do - let runAction = HTTP2.run clientConfig http2Cfg $ \sendReq -> do + let runAction = HTTP2.run clientConfig http2Cfg $ \sendReq _aux -> do handleRequests liveReqs sendReq -- Any request threads still hanging about after 'runAction' finishes -- are canceled with 'ConnectionAlreadyClosed'. @@ -445,12 +446,16 @@ allocHTTP2Config (SecureTransport ssl) = do chunk <- SSL.read ssl n `catch` \(_ :: SSL.ConnectionAbruptlyTerminated) -> pure mempty let chunkLen = BS.length chunk if - | chunkLen == 0 || chunkLen == n -> - pure (acc <> chunk) - | chunkLen > n -> - error "openssl: SSL.read returned more bytes than asked for, this is probably a bug" - | otherwise -> - readData (acc <> chunk) (n - chunkLen) + | chunkLen == 0 || chunkLen == n -> + pure (acc <> chunk) + | chunkLen > n -> + error "openssl: SSL.read returned more bytes than asked for, this is probably a bug" + | otherwise -> + readData (acc <> chunk) (n - chunkLen) + let s = fromMaybe (error "http2-manager: SSL without socket") $ SSL.sslSocket ssl + mysa <- NS.getSocketName s + peersa <- NS.getPeerName s + pure HTTP2.Config { HTTP2.confWriteBuffer = buf, @@ -458,5 +463,7 @@ allocHTTP2Config (SecureTransport ssl) = do HTTP2.confSendAll = SSL.write ssl, HTTP2.confReadN = readData mempty, HTTP2.confPositionReadMaker = HTTP2.defaultPositionReadMaker, - HTTP2.confTimeoutManager = timmgr + HTTP2.confTimeoutManager = timmgr, + HTTP2.confMySockAddr = mysa, + HTTP2.confPeerSockAddr = peersa } diff --git a/libs/http2-manager/test/Test/HTTP2/Client/ManagerSpec.hs b/libs/http2-manager/test/Test/HTTP2/Client/ManagerSpec.hs index f839619b9bb..f3498187306 100644 --- a/libs/http2-manager/test/Test/HTTP2/Client/ManagerSpec.hs +++ b/libs/http2-manager/test/Test/HTTP2/Client/ManagerSpec.hs @@ -23,7 +23,7 @@ import qualified Data.ByteString.Lazy.Char8 as LBS import Data.IORef import Data.Map (Map) import qualified Data.Map as Map -import Data.Maybe (isJust) +import Data.Maybe (fromMaybe, isJust) import Data.Streaming.Network (bindPortTCP, bindRandomPortTCP) import Data.Unique import Foreign.Marshal.Alloc (mallocBytes) @@ -33,8 +33,10 @@ import HTTP2.Client.Manager.Internal import Network.HTTP.Types import qualified Network.HTTP2.Client as Client import qualified Network.HTTP2.Client as HTTP2 +import Network.HTTP2.Server (defaultServerConfig) import qualified Network.HTTP2.Server as Server import Network.Socket +import qualified Network.Socket as NS import qualified OpenSSL.Session as SSL import System.Random (randomRIO) import qualified System.TimeManager @@ -287,12 +289,16 @@ allocServerConfig (Right ssl) = do chunk <- SSL.read ssl n `catch` \(_ :: SSL.ConnectionAbruptlyTerminated) -> pure mempty let chunkLen = BS.length chunk if - | chunkLen == 0 || chunkLen == n -> - pure (prevChunk <> chunk) - | chunkLen > n -> - error "openssl: SSL.read returned more bytes than asked for, this is probably a bug" - | otherwise -> - readData (prevChunk <> chunk) (n - chunkLen) + | chunkLen == 0 || chunkLen == n -> + pure (prevChunk <> chunk) + | chunkLen > n -> + error "openssl: SSL.read returned more bytes than asked for, this is probably a bug" + | otherwise -> + readData (prevChunk <> chunk) (n - chunkLen) + + let s = fromMaybe (error "http2-manager: SSL without socket") $ SSL.sslSocket ssl + mysa <- NS.getSocketName s + peersa <- NS.getPeerName s pure Server.Config { Server.confWriteBuffer = buf, @@ -300,7 +306,9 @@ allocServerConfig (Right ssl) = do Server.confSendAll = SSL.write ssl, Server.confReadN = readData mempty, Server.confPositionReadMaker = Server.defaultPositionReadMaker, - Server.confTimeoutManager = timmgr + Server.confTimeoutManager = timmgr, + Server.confMySockAddr = mysa, + Server.confPeerSockAddr = peersa } testServerOnSocket :: Maybe SSL.SSLContext -> Socket -> IORef Int -> IORef (Map Unique (Async ())) -> IO () @@ -322,7 +330,7 @@ testServerOnSocket mCtx listenSock connsCounter conns = do cleanup cfg = do Server.freeSimpleConfig cfg `finally` (shutdownSSL `finally` close sock) thread <- async $ bracket (allocServerConfig serverCfgParam) cleanup $ \cfg -> do - Server.run cfg testServer `finally` modifyIORef conns (Map.delete connKey) + Server.run defaultServerConfig cfg testServer `finally` modifyIORef conns (Map.delete connKey) modifyIORef conns $ Map.insert connKey thread testServer :: Server.Request -> Server.Aux -> (Server.Response -> [Server.PushPromise] -> IO ()) -> IO () diff --git a/libs/imports/src/Imports.hs b/libs/imports/src/Imports.hs index 91841bbdd8c..ef162e09846 100644 --- a/libs/imports/src/Imports.hs +++ b/libs/imports/src/Imports.hs @@ -241,37 +241,37 @@ type LByteString = Data.ByteString.Lazy.ByteString ---------------------------------------------------------------------------- -- Lifted functions from Prelude -putChar :: MonadIO m => Char -> m () +putChar :: (MonadIO m) => Char -> m () putChar = liftIO . P.putChar -putStr :: MonadIO m => String -> m () +putStr :: (MonadIO m) => String -> m () putStr = liftIO . P.putStr -putStrLn :: MonadIO m => String -> m () +putStrLn :: (MonadIO m) => String -> m () putStrLn = liftIO . P.putStrLn print :: (Show a, MonadIO m) => a -> m () print = liftIO . P.print -getChar :: MonadIO m => m Char +getChar :: (MonadIO m) => m Char getChar = liftIO P.getChar -getLine :: MonadIO m => m String +getLine :: (MonadIO m) => m String getLine = liftIO P.getLine -getContents :: MonadIO m => m String +getContents :: (MonadIO m) => m String getContents = liftIO P.getContents -interact :: MonadIO m => (String -> String) -> m () +interact :: (MonadIO m) => (String -> String) -> m () interact = liftIO . P.interact -readFile :: MonadIO m => FilePath -> m String +readFile :: (MonadIO m) => FilePath -> m String readFile = liftIO . P.readFile -writeFile :: MonadIO m => FilePath -> String -> m () +writeFile :: (MonadIO m) => FilePath -> String -> m () writeFile = fmap liftIO . P.writeFile -appendFile :: MonadIO m => FilePath -> String -> m () +appendFile :: (MonadIO m) => FilePath -> String -> m () appendFile = fmap liftIO . P.appendFile readIO :: (Read a, MonadIO m) => String -> m a diff --git a/libs/libzauth/libzauth-c/Cargo.lock b/libs/libzauth/libzauth-c/Cargo.lock index 33cca98de2f..fc577f9994d 100644 --- a/libs/libzauth/libzauth-c/Cargo.lock +++ b/libs/libzauth/libzauth-c/Cargo.lock @@ -4,18 +4,18 @@ version = 3 [[package]] name = "aho-corasick" -version = "1.1.2" +version = "1.1.3" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "b2969dcb958b36655471fc61f7e416fa76033bdd4bfed0678d8fee1e2d07a1f0" +checksum = "8e60d3430d3a69478ad0993f19238d2df97c507009a52b3c10addcd7f6bcb916" dependencies = [ "memchr", ] [[package]] name = "anyhow" -version = "1.0.75" +version = "1.0.86" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "a4668cab20f66d8d020e1fbc0ebe47217433c1b6c8f2040faf858554e394ace6" +checksum = "b3d1d046238990b9cf5bcde22a3fb3584ee5cf65fb2765f454ed428c7a0063da" [[package]] name = "asexp" @@ -25,9 +25,9 @@ checksum = "5e368761ce758947307f1c2db1f46077b1aabb5af7f268b6cededd1b52802652" [[package]] name = "autocfg" -version = "1.1.0" +version = "1.3.0" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "d468802bab17cbc0cc575e9b053f41e72aa36bfa6b7f55e3529ffa43161b97fa" +checksum = "0c4b4d0bd25bd0b74681c0ad21497610ce1b7c91b1022cd21c80c6fbdd9476b0" [[package]] name = "base16ct" @@ -43,9 +43,9 @@ checksum = "4c7f02d4ea65f2c1853089ffd8d2787bdbc63de2f0d29dedbcf8ccdfa0ccd4cf" [[package]] name = "base64" -version = "0.21.5" +version = "0.21.7" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "35636a1494ede3b646cc98f74f8e62c773a38a659ebc777a2cf26b9b74171df9" +checksum = "9d297deb1925b89f2ccc13d7635fa0714f12c87adce1c75356b39ca9b7178567" [[package]] name = "base64ct" @@ -70,9 +70,9 @@ dependencies = [ [[package]] name = "bumpalo" -version = "3.14.0" +version = "3.16.0" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "7f30e7476521f6f8af1a1c4c0b8cc94f0bee37d91763d0ca2665f299b6cd8aec" +checksum = "79296716171880943b8470b5f8d03aa55eb2e645a4874bdbb28adb49162e012c" [[package]] name = "byteorder" @@ -82,12 +82,9 @@ checksum = "1fd0f2584146f6f2ef48085050886acf353beff7305ebd1ae69500e27c67f64b" [[package]] name = "cc" -version = "1.0.83" +version = "1.0.98" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "f1174fb0b6ec23863f8b971027804a42614e347eafb0a95bf0b12cdae21fc4d0" -dependencies = [ - "libc", -] +checksum = "41c270e7540d725e65ac7f1b212ac8ce349719624d7bcff99f8e2e488e8cf03f" [[package]] name = "cfg-if" @@ -97,27 +94,26 @@ checksum = "baf1de4339761588bc0619e3cbc0120ee582ebb74b53b4efbf79117bd2da40fd" [[package]] name = "coarsetime" -version = "0.1.29" +version = "0.1.34" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "a73ef0d00d14301df35d0f13f5ea32344de6b00837485c358458f1e7f2d27db4" +checksum = "13b3839cf01bb7960114be3ccf2340f541b6d0c81f8690b007b2b39f750f7e5d" dependencies = [ "libc", - "once_cell", - "wasi", + "wasix", "wasm-bindgen", ] [[package]] name = "const-oid" -version = "0.9.5" +version = "0.9.6" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "28c122c3980598d243d63d9a704629a2d748d101f278052ff068be5a4423ab6f" +checksum = "c2459377285ad874054d797f3ccebf984978aa39129f6eafde5cdc8315b612f8" [[package]] name = "cpufeatures" -version = "0.2.11" +version = "0.2.12" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "ce420fe07aecd3e67c5f910618fe65e94158f6dcc0adf44e00d69ce2bdfe0fd0" +checksum = "53fe5e26ff1b7aef8bca9c6080520cfb8d9333c7568e1829cef191a9723e5504" dependencies = [ "libc", ] @@ -136,9 +132,9 @@ dependencies = [ [[package]] name = "crypto-bigint" -version = "0.5.3" +version = "0.5.5" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "740fe28e594155f10cfc383984cbefd529d7396050557148f79cb0f621204124" +checksum = "0dc92fb57ca44df6db8059111ab3af99a63d5d0f8375d9972e319a379c6bab76" dependencies = [ "generic-array", "rand_core", @@ -175,9 +171,9 @@ dependencies = [ [[package]] name = "der" -version = "0.7.8" +version = "0.7.9" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "fffa369a668c8af7dbf8b5e56c9f744fbd399949ed171606040001947de40b1c" +checksum = "f55bf8e7b65898637379c1b74eb1551107c8294ed26d855ceb9fd1a09cfc9bc0" dependencies = [ "const-oid", "pem-rfc7468 0.7.0", @@ -210,16 +206,16 @@ dependencies = [ [[package]] name = "ecdsa" -version = "0.16.8" +version = "0.16.9" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "a4b1e0c257a9e9f25f90ff76d7a68360ed497ee519c8e428d1825ef0000799d4" +checksum = "ee27f32b5c5292967d2d4a9d7f1e0b0aed2c15daded5a60300e4abb9d8020bca" dependencies = [ - "der 0.7.8", + "der 0.7.9", "digest", - "elliptic-curve 0.13.6", + "elliptic-curve 0.13.8", "rfc6979 0.4.0", "signature 2.0.0", - "spki 0.7.2", + "spki 0.7.3", ] [[package]] @@ -233,9 +229,9 @@ dependencies = [ [[package]] name = "ed25519-compact" -version = "2.0.4" +version = "2.1.1" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "6a3d382e8464107391c8706b4c14b087808ecb909f6c15c34114bc42e53a9e4c" +checksum = "e9b3460f44bea8cd47f45a0c70892f1eff856d97cd55358b2f73f663789f6190" dependencies = [ "ct-codecs", "getrandom", @@ -265,12 +261,12 @@ dependencies = [ [[package]] name = "elliptic-curve" -version = "0.13.6" +version = "0.13.8" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "d97ca172ae9dc9f9b779a6e3a65d308f2af74e5b8c921299075bdb4a0370e914" +checksum = "b5e6043086bf7973472e0c7dff2142ea0b680d30e18d9cc40f267efbf222bd47" dependencies = [ "base16ct 0.2.0", - "crypto-bigint 0.5.3", + "crypto-bigint 0.5.5", "digest", "ff 0.13.0", "generic-array", @@ -317,13 +313,15 @@ dependencies = [ [[package]] name = "getrandom" -version = "0.2.10" +version = "0.2.15" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "be4136b2a15dd319360be1c07d9933517ccf0be8f16bf62a3bee4f0d618df427" +checksum = "c4567c8db10ae91089c99af84c68c38da3ec2f087c3f82960bcdbf3656b6f4d7" dependencies = [ "cfg-if", + "js-sys", "libc", "wasi", + "wasm-bindgen", ] [[package]] @@ -350,9 +348,9 @@ dependencies = [ [[package]] name = "hkdf" -version = "0.12.3" +version = "0.12.4" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "791a029f6b9fc27657f6f188ec6e5e43f6911f6f878e0dc5501396e09809d437" +checksum = "7b5f8eb2ad728638ea2c7d47a21db23b7b58a72ed6a38256b8a1849f15fbbdf7" dependencies = [ "hmac", ] @@ -392,9 +390,18 @@ dependencies = [ [[package]] name = "itoa" -version = "1.0.9" +version = "1.0.11" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "af150ab688ff2122fcef229be89cb50dd66af9e01a4ff320cc137eecc9bacc38" +checksum = "49f1f14873335454500d59611f1cf4a4b0f786f9ac11f4312a78e4cf2566695b" + +[[package]] +name = "js-sys" +version = "0.3.69" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "29c15563dc2726973df627357ce0c9ddddbea194836909d655df6a75d2cf296d" +dependencies = [ + "wasm-bindgen", +] [[package]] name = "jwt-simple" @@ -434,7 +441,7 @@ dependencies = [ "hmac-sha1-compact", "hmac-sha256", "hmac-sha512", - "k256 0.13.1", + "k256 0.13.3", "p256 0.13.2", "p384 0.13.0", "rand", @@ -462,13 +469,13 @@ dependencies = [ [[package]] name = "k256" -version = "0.13.1" +version = "0.13.3" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "cadb76004ed8e97623117f3df85b17aaa6626ab0b0831e6573f104df16cd1bcc" +checksum = "956ff9b67e26e1a6a866cb758f12c6f8746208489e3e4a4b5580802f2f0a587b" dependencies = [ "cfg-if", - "ecdsa 0.16.8", - "elliptic-curve 0.13.6", + "ecdsa 0.16.9", + "elliptic-curve 0.13.8", "once_cell", "sha2", "signature 2.0.0", @@ -485,9 +492,9 @@ dependencies = [ [[package]] name = "libc" -version = "0.2.149" +version = "0.2.155" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "a08173bc88b7955d1b3145aa561539096c421ac8debde8cbc3612ec635fee29b" +checksum = "97b3888a4aecf77e811145cadf6eef5901f4782c53886191b2f693f24761847c" [[package]] name = "libm" @@ -509,15 +516,15 @@ dependencies = [ [[package]] name = "log" -version = "0.4.20" +version = "0.4.21" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "b5e6163cb8c49088c2c36f57875e58ccd8c87c7427f7fbd50ea6710b2f3f2e8f" +checksum = "90ed8c1e510134f979dbc4f070f87d4313098b704861a105fe34231c70a3901c" [[package]] name = "memchr" -version = "2.6.4" +version = "2.7.2" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "f665ee40bc4a3c5590afb1e9677db74a508659dfd71e126420da8274909a0167" +checksum = "6c8640c5d730cb13ebd907d8d04b52f55ac9a2eec55b440c8892f40d56c76c1d" [[package]] name = "num-bigint-dig" @@ -538,19 +545,18 @@ dependencies = [ [[package]] name = "num-integer" -version = "0.1.45" +version = "0.1.46" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "225d3389fb3509a24c93f5c29eb6bde2586b98d9f016636dff58d7c6f7569cd9" +checksum = "7969661fd2958a5cb096e56c8e1ad0444ac2bbcd0061bd28660485a44879858f" dependencies = [ - "autocfg", "num-traits", ] [[package]] name = "num-iter" -version = "0.1.43" +version = "0.1.45" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "7d03e6c028c5dc5cac6e2dec0efda81fc887605bb3d884578bb6d6bf7514e252" +checksum = "1429034a0490724d0075ebb2bc9e875d6503c3cf69e235a8941aa757d83ef5bf" dependencies = [ "autocfg", "num-integer", @@ -559,9 +565,9 @@ dependencies = [ [[package]] name = "num-traits" -version = "0.2.17" +version = "0.2.19" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "39e3200413f237f41ab11ad6d161bc7239c84dcb631773ccd7de3dfe4b5c267c" +checksum = "071dfc062690e90b734c0b2273ce72ad0ffa95f0c74596bc250dcfd960262841" dependencies = [ "autocfg", "libm", @@ -569,9 +575,9 @@ dependencies = [ [[package]] name = "once_cell" -version = "1.18.0" +version = "1.19.0" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "dd8b5dd2ae5ed71462c540258bedcb51965123ad7e7ccf4b9a8cafaa4a63576d" +checksum = "3fdb12b2476b595f9358c5161aa467c2438859caa136dec86c26fdd2efe17b92" [[package]] name = "p256" @@ -591,9 +597,9 @@ version = "0.13.2" source = "registry+https://github.com/rust-lang/crates.io-index" checksum = "c9863ad85fa8f4460f9c48cb909d38a0d689dba1f6f6988a5e3e0d31071bcd4b" dependencies = [ - "ecdsa 0.16.8", - "elliptic-curve 0.13.6", - "primeorder 0.13.2", + "ecdsa 0.16.9", + "elliptic-curve 0.13.8", + "primeorder 0.13.6", "sha2", ] @@ -615,9 +621,9 @@ version = "0.13.0" source = "registry+https://github.com/rust-lang/crates.io-index" checksum = "70786f51bcc69f6a4c0360e063a4cac5419ef7c5cd5b3c99ad70f3be5ba79209" dependencies = [ - "ecdsa 0.16.8", - "elliptic-curve 0.13.6", - "primeorder 0.13.2", + "ecdsa 0.16.9", + "elliptic-curve 0.13.8", + "primeorder 0.13.6", "sha2", ] @@ -667,15 +673,15 @@ version = "0.10.2" source = "registry+https://github.com/rust-lang/crates.io-index" checksum = "f950b2377845cebe5cf8b5165cb3cc1a5e0fa5cfa3e1f7f55707d8fd82e0a7b7" dependencies = [ - "der 0.7.8", - "spki 0.7.2", + "der 0.7.9", + "spki 0.7.3", ] [[package]] name = "pkg-config" -version = "0.3.27" +version = "0.3.30" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "26072860ba924cbfa98ea39c8c19b4dd6a4a25423dbdf219c1eca91aa0cf6964" +checksum = "d231b230927b5e4ad203db57bbcbee2802f6bce620b1e4a9024a07d94e2907ec" [[package]] name = "ppv-lite86" @@ -694,27 +700,27 @@ dependencies = [ [[package]] name = "primeorder" -version = "0.13.2" +version = "0.13.6" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "3c2fcef82c0ec6eefcc179b978446c399b3cdf73c392c35604e399eee6df1ee3" +checksum = "353e1ca18966c16d9deb1c69278edbc5f194139612772bd9537af60ac231e1e6" dependencies = [ - "elliptic-curve 0.13.6", + "elliptic-curve 0.13.8", ] [[package]] name = "proc-macro2" -version = "1.0.69" +version = "1.0.84" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "134c189feb4956b20f6f547d2cf727d4c0fe06722b20a0eec87ed445a97f92da" +checksum = "ec96c6a92621310b51366f1e28d05ef11489516e93be030060e5fc12024a49d6" dependencies = [ "unicode-ident", ] [[package]] name = "quote" -version = "1.0.33" +version = "1.0.36" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "5267fca4496028628a95160fc423a33e8b2e6af8a5302579e322e4b520293cae" +checksum = "0fa76aaf39101c457836aec0ce2316dbdc3ab723cdda1c6bd4e6ad4208acaca7" dependencies = [ "proc-macro2", ] @@ -751,9 +757,9 @@ dependencies = [ [[package]] name = "regex" -version = "1.10.2" +version = "1.10.4" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "380b951a9c5e80ddfd6136919eef32310721aa4aacd4889a8d39124b026ab343" +checksum = "c117dbdfde9c8308975b6a18d71f3f385c89461f7b3fb054288ecf2a2058ba4c" dependencies = [ "aho-corasick", "memchr", @@ -763,9 +769,9 @@ dependencies = [ [[package]] name = "regex-automata" -version = "0.4.3" +version = "0.4.6" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "5f804c7828047e88b2d32e2d7fe5a105da8ee3264f01902f796c8e067dc2483f" +checksum = "86b83b8b9847f9bf95ef68afb0b8e6cdb80f498442f5179a29fad448fcc1eaea" dependencies = [ "aho-corasick", "memchr", @@ -774,9 +780,9 @@ dependencies = [ [[package]] name = "regex-syntax" -version = "0.8.2" +version = "0.8.3" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "c08c74e62047bb2de4ff487b251e4a92e24f48745648451635cec7d591162d9f" +checksum = "adad44e29e4c806119491a7f06f03de4d1af22c3a680dd47f1e6e179439d1f56" [[package]] name = "rfc6979" @@ -822,15 +828,15 @@ dependencies = [ [[package]] name = "rustc-serialize" -version = "0.3.24" +version = "0.3.25" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "dcf128d1287d2ea9d80910b5f1120d0b8eede3fbf1abe91c40d39ea7d51e6fda" +checksum = "fe834bc780604f4674073badbad26d7219cadfb4a2275802db12cbae17498401" [[package]] name = "ryu" -version = "1.0.15" +version = "1.0.18" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "1ad4cc8da4ef723ed60bced201181d83791ad433213d8c24efffda1eec85d741" +checksum = "f3cb5ba0dc43242ce17de99c180e96db90b235b8a9fdc9543c96d2209116bd9f" [[package]] name = "same-file" @@ -862,7 +868,7 @@ source = "registry+https://github.com/rust-lang/crates.io-index" checksum = "d3e97a565f76233a6003f9f5c54be1d9c5bdfa3eccfb189469f11ec4901c47dc" dependencies = [ "base16ct 0.2.0", - "der 0.7.8", + "der 0.7.9", "generic-array", "pkcs8 0.10.2", "subtle", @@ -871,18 +877,18 @@ dependencies = [ [[package]] name = "serde" -version = "1.0.190" +version = "1.0.203" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "91d3c334ca1ee894a2c6f6ad698fe8c435b76d504b13d436f0685d648d6d96f7" +checksum = "7253ab4de971e72fb7be983802300c30b5a7f0c2e56fab8abfc6a214307c0094" dependencies = [ "serde_derive", ] [[package]] name = "serde_derive" -version = "1.0.190" +version = "1.0.203" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "67c5609f394e5c2bd7fc51efda478004ea80ef42fee983d5c67a65e34f32c0e3" +checksum = "500cbc0ebeb6f46627f50f3f5811ccf6bf00643be300b4c3eabc0ef55dc5b5ba" dependencies = [ "proc-macro2", "quote", @@ -891,9 +897,9 @@ dependencies = [ [[package]] name = "serde_json" -version = "1.0.108" +version = "1.0.117" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "3d1c7e3eac408d115102c4c24ad393e0821bb3a5df4d506a80f85f7a742a526b" +checksum = "455182ea6142b14f93f4bc5320a2b31c1f266b66a4a5c858b013302a5d8cbfc3" dependencies = [ "itoa", "ryu", @@ -933,9 +939,9 @@ dependencies = [ [[package]] name = "smallvec" -version = "1.11.1" +version = "1.13.2" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "942b4a808e05215192e39f4ab80813e599068285906cc91aa64f923db842bd5a" +checksum = "3c5e1a9a646d36c3599cd173a41282daf47c44583ad367b8e6837255952e5c67" [[package]] name = "sodiumoxide" @@ -967,12 +973,12 @@ dependencies = [ [[package]] name = "spki" -version = "0.7.2" +version = "0.7.3" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "9d1e996ef02c474957d681f1b05213dfb0abab947b446a62d37770b23500184a" +checksum = "d91ed6c858b01f942cd56b37a94b3e0a1798290327d1236e4d9cf4eaca44d29d" dependencies = [ "base64ct", - "der 0.7.8", + "der 0.7.9", ] [[package]] @@ -983,9 +989,9 @@ checksum = "81cdd64d312baedb58e21336b31bc043b77e01cc99033ce76ef539f78e965ebc" [[package]] name = "syn" -version = "2.0.38" +version = "2.0.66" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "e96b79aaa137db8f61e26363a0c9b47d8b4ec75da28b7d1d614c2303e232408b" +checksum = "c42f3f41a2de00b01c0aaad383c5a45241efc8b2d1eda5661812fda5f3cdcff5" dependencies = [ "proc-macro2", "quote", @@ -994,18 +1000,18 @@ dependencies = [ [[package]] name = "thiserror" -version = "1.0.50" +version = "1.0.61" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "f9a7210f5c9a7156bb50aa36aed4c95afb51df0df00713949448cf9e97d382d2" +checksum = "c546c80d6be4bc6a00c0f01730c08df82eaa7a7a61f11d656526506112cc1709" dependencies = [ "thiserror-impl", ] [[package]] name = "thiserror-impl" -version = "1.0.50" +version = "1.0.61" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "266b2e40bc00e5a6c09c3584011e08b06f123c00362c92b975ba9843aaaa14b8" +checksum = "46c3384250002a6d5af4d114f2845d37b57521033f30d5c3f46c4d70e1197533" dependencies = [ "proc-macro2", "quote", @@ -1032,9 +1038,9 @@ checksum = "49874b5167b65d7193b8aba1567f5c7d93d001cafc34600cee003eda787e483f" [[package]] name = "walkdir" -version = "2.4.0" +version = "2.5.0" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "d71d857dc86794ca4c280d616f7da00d2dbfd8cd788846559a6813e6aa4b54ee" +checksum = "29790946404f91d9c5d06f9874efddea1dc06c5efe94541a7d6863108e3a5e4b" dependencies = [ "same-file", "winapi-util", @@ -1046,11 +1052,20 @@ version = "0.11.0+wasi-snapshot-preview1" source = "registry+https://github.com/rust-lang/crates.io-index" checksum = "9c8d87e72b64a3b4db28d11ce29237c246188f4f51057d65a7eab63b7987e423" +[[package]] +name = "wasix" +version = "0.12.21" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "c1fbb4ef9bbca0c1170e0b00dd28abc9e3b68669821600cad1caaed606583c6d" +dependencies = [ + "wasi", +] + [[package]] name = "wasm-bindgen" -version = "0.2.87" +version = "0.2.92" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "7706a72ab36d8cb1f80ffbf0e071533974a60d0a308d01a5d0375bf60499a342" +checksum = "4be2531df63900aeb2bca0daaaddec08491ee64ceecbee5076636a3b026795a8" dependencies = [ "cfg-if", "wasm-bindgen-macro", @@ -1058,9 +1073,9 @@ dependencies = [ [[package]] name = "wasm-bindgen-backend" -version = "0.2.87" +version = "0.2.92" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "5ef2b6d3c510e9625e5fe6f509ab07d66a760f0885d858736483c32ed7809abd" +checksum = "614d787b966d3989fa7bb98a654e369c762374fd3213d212cfc0251257e747da" dependencies = [ "bumpalo", "log", @@ -1073,9 +1088,9 @@ dependencies = [ [[package]] name = "wasm-bindgen-macro" -version = "0.2.87" +version = "0.2.92" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "dee495e55982a3bd48105a7b947fd2a9b4a8ae3010041b9e0faab3f9cd028f1d" +checksum = "a1f8823de937b71b9460c0c34e25f3da88250760bec0ebac694b49997550d726" dependencies = [ "quote", "wasm-bindgen-macro-support", @@ -1083,9 +1098,9 @@ dependencies = [ [[package]] name = "wasm-bindgen-macro-support" -version = "0.2.87" +version = "0.2.92" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "54681b18a46765f095758388f2d0cf16eb8d4169b639ab575a8f5693af210c7b" +checksum = "e94f17b526d0a461a191c78ea52bbce64071ed5c04c9ffe424dcb38f74171bb7" dependencies = [ "proc-macro2", "quote", @@ -1096,40 +1111,91 @@ dependencies = [ [[package]] name = "wasm-bindgen-shared" -version = "0.2.87" +version = "0.2.92" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "ca6ad05a4870b2bf5fe995117d3728437bd27d7cd5f06f13c17443ef369775a1" +checksum = "af190c94f2773fdb3729c55b007a722abb5384da03bc0986df4c289bf5567e96" [[package]] -name = "winapi" -version = "0.3.9" +name = "winapi-util" +version = "0.1.8" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "5c839a674fcd7a98952e593242ea400abe93992746761e38641405d28b00f419" +checksum = "4d4cc384e1e73b93bafa6fb4f1df8c41695c8a91cf9c4c64358067d15a7b6c6b" dependencies = [ - "winapi-i686-pc-windows-gnu", - "winapi-x86_64-pc-windows-gnu", + "windows-sys", ] [[package]] -name = "winapi-i686-pc-windows-gnu" -version = "0.4.0" +name = "windows-sys" +version = "0.52.0" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "ac3b87c63620426dd9b991e5ce0329eff545bccbbb34f3be09ff6fb6ab51b7b6" +checksum = "282be5f36a8ce781fad8c8ae18fa3f9beff57ec1b52cb3de0789201425d9a33d" +dependencies = [ + "windows-targets", +] [[package]] -name = "winapi-util" -version = "0.1.6" +name = "windows-targets" +version = "0.52.5" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "f29e6f9198ba0d26b4c9f07dbe6f9ed633e1f3d5b8b414090084349e46a52596" +checksum = "6f0713a46559409d202e70e28227288446bf7841d3211583a4b53e3f6d96e7eb" dependencies = [ - "winapi", + "windows_aarch64_gnullvm", + "windows_aarch64_msvc", + "windows_i686_gnu", + "windows_i686_gnullvm", + "windows_i686_msvc", + "windows_x86_64_gnu", + "windows_x86_64_gnullvm", + "windows_x86_64_msvc", ] [[package]] -name = "winapi-x86_64-pc-windows-gnu" -version = "0.4.0" +name = "windows_aarch64_gnullvm" +version = "0.52.5" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "712e227841d057c1ee1cd2fb22fa7e5a5461ae8e48fa2ca79ec42cfc1931183f" +checksum = "7088eed71e8b8dda258ecc8bac5fb1153c5cffaf2578fc8ff5d61e23578d3263" + +[[package]] +name = "windows_aarch64_msvc" +version = "0.52.5" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "9985fd1504e250c615ca5f281c3f7a6da76213ebd5ccc9561496568a2752afb6" + +[[package]] +name = "windows_i686_gnu" +version = "0.52.5" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "88ba073cf16d5372720ec942a8ccbf61626074c6d4dd2e745299726ce8b89670" + +[[package]] +name = "windows_i686_gnullvm" +version = "0.52.5" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "87f4261229030a858f36b459e748ae97545d6f1ec60e5e0d6a3d32e0dc232ee9" + +[[package]] +name = "windows_i686_msvc" +version = "0.52.5" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "db3c2bf3d13d5b658be73463284eaf12830ac9a26a90c717b7f771dfe97487bf" + +[[package]] +name = "windows_x86_64_gnu" +version = "0.52.5" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "4e4246f76bdeff09eb48875a0fd3e2af6aada79d409d33011886d3e1581517d9" + +[[package]] +name = "windows_x86_64_gnullvm" +version = "0.52.5" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "852298e482cd67c356ddd9570386e2862b5673c85bd5f88df9ab6802b334c596" + +[[package]] +name = "windows_x86_64_msvc" +version = "0.52.5" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "bec47e5bfd1bff0eeaf6d8b485cc1074891a197ab4225d504cb7a1ab88b02bf0" [[package]] name = "zauth" @@ -1158,6 +1224,6 @@ dependencies = [ [[package]] name = "zeroize" -version = "1.6.0" +version = "1.8.1" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "2a0956f1ba7c7909bfb66c2e9e4124ab6f6482560f6628b5aaeba39207c9aad9" +checksum = "ced3678a2879b30306d323f4542626697a464a97c0a07c9aebf7ebca65cd4dde" diff --git a/libs/libzauth/libzauth-c/Cargo.nix b/libs/libzauth/libzauth-c/Cargo.nix index ac5c917bd28..1c3b94dad3b 100644 --- a/libs/libzauth/libzauth-c/Cargo.nix +++ b/libs/libzauth/libzauth-c/Cargo.nix @@ -83,9 +83,9 @@ rec { crates = { "aho-corasick" = rec { crateName = "aho-corasick"; - version = "1.1.2"; + version = "1.1.3"; edition = "2021"; - sha256 = "1w510wnixvlgimkx1zjbvlxh6xps2vjgfqgwf5a6adlbjp5rv5mj"; + sha256 = "05mrpkvdgp5d20y2p989f187ry9diliijgwrs254fs9s1m1x6q4f"; libName = "aho_corasick"; authors = [ "Andrew Gallant " @@ -104,13 +104,13 @@ rec { "perf-literal" = [ "dep:memchr" ]; "std" = [ "memchr?/std" ]; }; - resolvedDefaultFeatures = [ "default" "perf-literal" "std" ]; + resolvedDefaultFeatures = [ "perf-literal" "std" ]; }; "anyhow" = rec { crateName = "anyhow"; - version = "1.0.75"; + version = "1.0.86"; edition = "2018"; - sha256 = "1rmcjkim91c5mw7h9wn8nv0k6x118yz0xg0z1q18svgn42mqqrm4"; + sha256 = "1nk301x8qhpdaks6a9zvcp7yakjqnczjmqndbg7vk4494d3d1ldk"; authors = [ "David Tolnay " ]; @@ -132,9 +132,9 @@ rec { }; "autocfg" = rec { crateName = "autocfg"; - version = "1.1.0"; + version = "1.3.0"; edition = "2015"; - sha256 = "1ylp3cb47ylzabimazvbz9ms6ap784zhb6syaz6c1jqpmcmq0s6l"; + sha256 = "1c3njkfzpil03k92q0mij5y1pkhhfr4j3bf0h53bgl2vs85lsjqc"; authors = [ "Josh Stone " ]; @@ -168,9 +168,9 @@ rec { }; "base64" = rec { crateName = "base64"; - version = "0.21.5"; + version = "0.21.7"; edition = "2018"; - sha256 = "1y8x2xs9nszj5ix7gg4ycn5a6wy7ca74zxwqri3bdqzdjha6lqrm"; + sha256 = "0rw52yvsk75kar9wgqfwgb414kvil1gn7mqkrhn9zf1537mpsacx"; authors = [ "Alice Maz " "Marshall Pierce " @@ -222,14 +222,15 @@ rec { }; "bumpalo" = rec { crateName = "bumpalo"; - version = "3.14.0"; + version = "3.16.0"; edition = "2021"; - sha256 = "1v4arnv9kwk54v5d0qqpv4vyw2sgr660nk0w3apzixi1cm3yfc3z"; + sha256 = "0b015qb4knwanbdlp1x48pkb4pm57b8gidbhhhxr900q2wb6fabr"; authors = [ "Nick Fitzgerald " ]; features = { "allocator-api2" = [ "dep:allocator-api2" ]; + "serde" = [ "dep:serde" ]; }; resolvedDefaultFeatures = [ "default" ]; }; @@ -247,24 +248,17 @@ rec { }; "cc" = rec { crateName = "cc"; - version = "1.0.83"; + version = "1.0.98"; edition = "2018"; - crateBin = [ ]; - sha256 = "1l643zidlb5iy1dskc5ggqs4wqa29a02f44piczqc8zcnsq4y5zi"; + sha256 = "0gzhij74hblfkzwwyysdc8crfd6fr0m226vzmijmwwhdakkp1hj1"; authors = [ "Alex Crichton " ]; - dependencies = [ - { - name = "libc"; - packageId = "libc"; - usesDefaultFeatures = false; - target = { target, features }: (target."unix" or false); - } - ]; features = { "jobserver" = [ "dep:jobserver" ]; - "parallel" = [ "jobserver" ]; + "libc" = [ "dep:libc" ]; + "once_cell" = [ "dep:once_cell" ]; + "parallel" = [ "libc" "jobserver" "once_cell" ]; }; }; "cfg-if" = rec { @@ -283,9 +277,9 @@ rec { }; "coarsetime" = rec { crateName = "coarsetime"; - version = "0.1.29"; + version = "0.1.34"; edition = "2018"; - sha256 = "1d3xsbrfgwaqhhsmqj1p12qfck9l6bmga4qgbprisc0l1p8g0gm7"; + sha256 = "0pby1xsrzcxj0yq911hzr38bchgm80iwyg5y2h0rddqvy2f87cqk"; authors = [ "Frank Denis " ]; @@ -293,16 +287,12 @@ rec { { name = "libc"; packageId = "libc"; - target = { target, features }: (!("wasi" == target."os")); + target = { target, features }: (!(("wasix" == target."os") || ("wasi" == target."os"))); } { - name = "once_cell"; - packageId = "once_cell"; - } - { - name = "wasi"; - packageId = "wasi"; - target = { target, features }: ("wasi" == target."os"); + name = "wasix"; + packageId = "wasix"; + target = { target, features }: (("wasix" == target."os") || ("wasi" == target."os")); } { name = "wasm-bindgen"; @@ -310,13 +300,15 @@ rec { target = { target, features }: ((("wasm32" == target."arch") || ("wasm64" == target."arch")) && ("unknown" == target."os")); } ]; - features = { }; + features = { + "wasi-abi2" = [ "dep:wasi-abi2" ]; + }; }; "const-oid" = rec { crateName = "const-oid"; - version = "0.9.5"; + version = "0.9.6"; edition = "2021"; - sha256 = "0vxb4d25mgk8y0phay7j078limx2553716ixsr1x5605k31j5h98"; + sha256 = "1y0jnqaq7p2wvspnx7qj76m7hjcqpz73qzvr9l2p9n2s51vr6if2"; authors = [ "RustCrypto Developers" ]; @@ -326,9 +318,9 @@ rec { }; "cpufeatures" = rec { crateName = "cpufeatures"; - version = "0.2.11"; + version = "0.2.12"; edition = "2018"; - sha256 = "1l0gzsyy576n017g9bf0vkv5hhg9cpz1h1libxyfdlzcgbh0yhnf"; + sha256 = "012m7rrak4girqlii3jnqwrr73gv1i980q4wra5yyyhvzwk5xzjk"; authors = [ "RustCrypto Developers" ]; @@ -407,11 +399,11 @@ rec { }; resolvedDefaultFeatures = [ "generic-array" "rand_core" "zeroize" ]; }; - "crypto-bigint 0.5.3" = rec { + "crypto-bigint 0.5.5" = rec { crateName = "crypto-bigint"; - version = "0.5.3"; + version = "0.5.5"; edition = "2021"; - sha256 = "092140hzdc4wyx472mahc0wxfafmxz5q8f9qzh6g2ma1b67f43vl"; + sha256 = "0xmbdff3g6ii5sbxjxc31xfkv9lrmyril4arh3dzckd4gjsjzj8d"; authors = [ "RustCrypto Developers" ]; @@ -537,11 +529,11 @@ rec { }; resolvedDefaultFeatures = [ "alloc" "const-oid" "oid" "pem" "pem-rfc7468" "std" "zeroize" ]; }; - "der 0.7.8" = rec { + "der 0.7.9" = rec { crateName = "der"; - version = "0.7.8"; + version = "0.7.9"; edition = "2021"; - sha256 = "070bwiyr80800h31c5zd96ckkgagfjgnrrdmz3dzg2lccsd3dypz"; + sha256 = "1h4vzjfa1lczxdf8avfj9qlwh1qianqlxdy1g5rn762qnvkzhnzm"; authors = [ "RustCrypto Developers" ]; @@ -681,18 +673,18 @@ rec { }; resolvedDefaultFeatures = [ "alloc" "arithmetic" "der" "digest" "hazmat" "pem" "pkcs8" "rfc6979" "signing" "std" "verifying" ]; }; - "ecdsa 0.16.8" = rec { + "ecdsa 0.16.9" = rec { crateName = "ecdsa"; - version = "0.16.8"; + version = "0.16.9"; edition = "2021"; - sha256 = "1m4r0w0g0pl2s4lf9j0rwmz4kvb0hfkdfxpzj1gz5sd9az1f1cd4"; + sha256 = "1jhb0bcbkaz4001sdmfyv8ajrv8a1cg7z7aa5myrd4jjbhmz69zf"; authors = [ "RustCrypto Developers" ]; dependencies = [ { name = "der"; - packageId = "der 0.7.8"; + packageId = "der 0.7.9"; optional = true; } { @@ -704,7 +696,7 @@ rec { } { name = "elliptic-curve"; - packageId = "elliptic-curve 0.13.6"; + packageId = "elliptic-curve 0.13.8"; usesDefaultFeatures = false; features = [ "digest" "sec1" ]; } @@ -721,7 +713,7 @@ rec { } { name = "spki"; - packageId = "spki 0.7.2"; + packageId = "spki 0.7.3"; optional = true; usesDefaultFeatures = false; } @@ -729,7 +721,7 @@ rec { devDependencies = [ { name = "elliptic-curve"; - packageId = "elliptic-curve 0.13.6"; + packageId = "elliptic-curve 0.13.8"; usesDefaultFeatures = false; features = [ "dev" ]; } @@ -783,9 +775,9 @@ rec { }; "ed25519-compact" = rec { crateName = "ed25519-compact"; - version = "2.0.4"; + version = "2.1.1"; edition = "2018"; - sha256 = "0k4y7bjl5g0l871iav4zj35qx047n0a4qsvhr28p6434hhp3hgba"; + sha256 = "1431kxw67xkk5y5kamfdjxnqbzqy5y4p032syi3wva5y8h7ldcz9"; authors = [ "Frank Denis " ]; @@ -799,6 +791,14 @@ rec { name = "getrandom"; packageId = "getrandom"; optional = true; + target = { target, features }: ((("wasm32" == target."arch") || ("wasm64" == target."arch")) && ("unknown" == target."os")); + features = [ "js" ]; + } + { + name = "getrandom"; + packageId = "getrandom"; + optional = true; + target = { target, features }: (!((("wasm32" == target."arch") || ("wasm64" == target."arch")) && ("unknown" == target."os"))); } ]; devDependencies = [ @@ -809,6 +809,13 @@ rec { { name = "getrandom"; packageId = "getrandom"; + target = { target, features }: ((("wasm32" == target."arch") || ("wasm64" == target."arch")) && ("unknown" == target."os")); + features = [ "js" ]; + } + { + name = "getrandom"; + packageId = "getrandom"; + target = { target, features }: (!((("wasm32" == target."arch") || ("wasm64" == target."arch")) && ("unknown" == target."os"))); } ]; features = { @@ -935,11 +942,11 @@ rec { }; resolvedDefaultFeatures = [ "alloc" "arithmetic" "digest" "ecdh" "ff" "group" "hazmat" "hkdf" "pem" "pem-rfc7468" "pkcs8" "sec1" "std" ]; }; - "elliptic-curve 0.13.6" = rec { + "elliptic-curve 0.13.8" = rec { crateName = "elliptic-curve"; - version = "0.13.6"; + version = "0.13.8"; edition = "2021"; - sha256 = "0579f01lmnsv0yci54lcbd7gfalg61fsdqx6g6vzkjcxmrra2z6r"; + sha256 = "0ixx4brgnzi61z29r3g1606nh2za88hzyz8c5r3p6ydzhqq09rmm"; authors = [ "RustCrypto Developers" ]; @@ -950,7 +957,7 @@ rec { } { name = "crypto-bigint"; - packageId = "crypto-bigint 0.5.3"; + packageId = "crypto-bigint 0.5.5"; usesDefaultFeatures = false; features = [ "rand_core" "generic-array" "zeroize" ]; } @@ -1141,9 +1148,9 @@ rec { }; "getrandom" = rec { crateName = "getrandom"; - version = "0.2.10"; + version = "0.2.15"; edition = "2018"; - sha256 = "09zlimhhskzf7cmgcszix05wyz2i6fcpvh711cv1klsxl6r3chdy"; + sha256 = "1mzlnrb3dgyd1fb84gvw10pyr8wdqdl4ry4sr64i1s8an66pqmn4"; authors = [ "The Rand Project Developers" ]; @@ -1152,6 +1159,12 @@ rec { name = "cfg-if"; packageId = "cfg-if"; } + { + name = "js-sys"; + packageId = "js-sys"; + optional = true; + target = { target, features }: ((("wasm32" == target."arch") || ("wasm64" == target."arch")) && ("unknown" == target."os")); + } { name = "libc"; packageId = "libc"; @@ -1164,6 +1177,13 @@ rec { usesDefaultFeatures = false; target = { target, features }: ("wasi" == target."os"); } + { + name = "wasm-bindgen"; + packageId = "wasm-bindgen"; + optional = true; + usesDefaultFeatures = false; + target = { target, features }: ((("wasm32" == target."arch") || ("wasm64" == target."arch")) && ("unknown" == target."os")); + } ]; features = { "compiler_builtins" = [ "dep:compiler_builtins" ]; @@ -1173,7 +1193,7 @@ rec { "rustc-dep-of-std" = [ "compiler_builtins" "core" "libc/rustc-dep-of-std" "wasi/rustc-dep-of-std" ]; "wasm-bindgen" = [ "dep:wasm-bindgen" ]; }; - resolvedDefaultFeatures = [ "std" ]; + resolvedDefaultFeatures = [ "js" "js-sys" "std" "wasm-bindgen" ]; }; "group 0.12.1" = rec { crateName = "group"; @@ -1248,9 +1268,9 @@ rec { }; "hkdf" = rec { crateName = "hkdf"; - version = "0.12.3"; + version = "0.12.4"; edition = "2018"; - sha256 = "0dyl16cf15hka32hv3l7dwgr3xj3brpfr27iyrbpdhlzdfgh46kr"; + sha256 = "1xxxzcarz151p1b858yn5skmhyrvn8fs4ivx5km3i1kjmnr8wpvv"; authors = [ "RustCrypto Developers" ]; @@ -1363,9 +1383,9 @@ rec { }; "itoa" = rec { crateName = "itoa"; - version = "1.0.9"; + version = "1.0.11"; edition = "2018"; - sha256 = "0f6cpb4yqzhkrhhg6kqsw3wnmmhdnnffi6r2xzy248gzi2v0l5dg"; + sha256 = "0nv9cqjwzr3q58qz84dcz63ggc54yhf1yqar1m858m1kfd4g3wa9"; authors = [ "David Tolnay " ]; @@ -1373,6 +1393,22 @@ rec { "no-panic" = [ "dep:no-panic" ]; }; }; + "js-sys" = rec { + crateName = "js-sys"; + version = "0.3.69"; + edition = "2018"; + sha256 = "0v99rz97asnzapb0jsc3jjhvxpfxr7h7qd97yqyrf9i7viimbh99"; + authors = [ + "The wasm-bindgen Developers" + ]; + dependencies = [ + { + name = "wasm-bindgen"; + packageId = "wasm-bindgen"; + } + ]; + + }; "jwt-simple 0.11.3" = rec { crateName = "jwt-simple"; version = "0.11.3"; @@ -1523,7 +1559,7 @@ rec { } { name = "k256"; - packageId = "k256 0.13.1"; + packageId = "k256 0.13.3"; features = [ "ecdsa" "std" "pkcs8" "pem" ]; } { @@ -1654,11 +1690,11 @@ rec { }; resolvedDefaultFeatures = [ "alloc" "arithmetic" "default" "digest" "ecdsa" "ecdsa-core" "once_cell" "pem" "pkcs8" "precomputed-tables" "schnorr" "sha2" "sha256" "signature" "std" ]; }; - "k256 0.13.1" = rec { + "k256 0.13.3" = rec { crateName = "k256"; - version = "0.13.1"; + version = "0.13.3"; edition = "2021"; - sha256 = "1k0vrlbdy17ifdjix0xhn1m659ma2xdzhgbz24ipdsfq9q07dnya"; + sha256 = "0ysq18pjz040am5llgly90464x7qqq98yxfbcsladq96gsvgjvwm"; authors = [ "RustCrypto Developers" ]; @@ -1669,7 +1705,7 @@ rec { } { name = "ecdsa"; - packageId = "ecdsa 0.16.8"; + packageId = "ecdsa 0.16.9"; rename = "ecdsa-core"; optional = true; usesDefaultFeatures = false; @@ -1677,7 +1713,7 @@ rec { } { name = "elliptic-curve"; - packageId = "elliptic-curve 0.13.6"; + packageId = "elliptic-curve 0.13.8"; usesDefaultFeatures = false; features = [ "hazmat" "sec1" ]; } @@ -1702,7 +1738,7 @@ rec { devDependencies = [ { name = "ecdsa"; - packageId = "ecdsa 0.16.8"; + packageId = "ecdsa 0.16.9"; rename = "ecdsa-core"; usesDefaultFeatures = false; features = [ "dev" ]; @@ -1760,9 +1796,9 @@ rec { }; "libc" = rec { crateName = "libc"; - version = "0.2.149"; + version = "0.2.155"; edition = "2015"; - sha256 = "16z2zqswcbk1qg5yigfyr0d44v0974amdaj564dmv5dpi2y770d0"; + sha256 = "0z44c53z54znna8n322k5iwg80arxxpdzjj5260pxxzc9a58icwp"; authors = [ "The Rust Project Developers" ]; @@ -1829,17 +1865,20 @@ rec { }; "log" = rec { crateName = "log"; - version = "0.4.20"; - edition = "2015"; - sha256 = "13rf7wphnwd61vazpxr7fiycin6cb1g8fmvgqg18i464p0y1drmm"; + version = "0.4.21"; + edition = "2021"; + sha256 = "074hldq1q8rlzq2s2qa8f25hj4s3gpw71w64vdwzjd01a4g8rvch"; authors = [ "The Rust Project Developers" ]; features = { - "kv_unstable" = [ "value-bag" ]; - "kv_unstable_serde" = [ "kv_unstable_std" "value-bag/serde" "serde" ]; - "kv_unstable_std" = [ "std" "kv_unstable" "value-bag/error" ]; - "kv_unstable_sval" = [ "kv_unstable" "value-bag/sval" "sval" "sval_ref" ]; + "kv_serde" = [ "kv_std" "value-bag/serde" "serde" ]; + "kv_std" = [ "std" "kv" "value-bag/error" ]; + "kv_sval" = [ "kv" "value-bag/sval" "sval" "sval_ref" ]; + "kv_unstable" = [ "kv" "value-bag" ]; + "kv_unstable_serde" = [ "kv_serde" "kv_unstable_std" ]; + "kv_unstable_std" = [ "kv_std" "kv_unstable" ]; + "kv_unstable_sval" = [ "kv_sval" "kv_unstable" ]; "serde" = [ "dep:serde" ]; "sval" = [ "dep:sval" ]; "sval_ref" = [ "dep:sval_ref" ]; @@ -1848,9 +1887,9 @@ rec { }; "memchr" = rec { crateName = "memchr"; - version = "2.6.4"; + version = "2.7.2"; edition = "2021"; - sha256 = "0rq1ka8790ns41j147npvxcqcl2anxyngsdimy85ag2api0fwrgn"; + sha256 = "07bcqxb0vx4ji0648ny5xsicjnpma95x1n07v7mi7jrhsz2l11kc"; authors = [ "Andrew Gallant " "bluss" @@ -1864,7 +1903,7 @@ rec { "std" = [ "alloc" ]; "use_std" = [ "std" ]; }; - resolvedDefaultFeatures = [ "alloc" "default" "std" ]; + resolvedDefaultFeatures = [ "alloc" "std" ]; }; "num-bigint-dig" = rec { crateName = "num-bigint-dig"; @@ -1947,9 +1986,9 @@ rec { }; "num-integer" = rec { crateName = "num-integer"; - version = "0.1.45"; - edition = "2015"; - sha256 = "1ncwavvwdmsqzxnn65phv6c6nn72pnv9xhpmjd6a429mzf4k6p92"; + version = "0.1.46"; + edition = "2018"; + sha256 = "13w5g54a9184cqlbsq80rnxw4jj4s0d8wv75jsq5r2lms8gncsbr"; authors = [ "The Rust Project Developers" ]; @@ -1958,26 +1997,20 @@ rec { name = "num-traits"; packageId = "num-traits"; usesDefaultFeatures = false; - } - ]; - buildDependencies = [ - { - name = "autocfg"; - packageId = "autocfg"; + features = [ "i128" ]; } ]; features = { "default" = [ "std" ]; - "i128" = [ "num-traits/i128" ]; "std" = [ "num-traits/std" ]; }; resolvedDefaultFeatures = [ "i128" ]; }; "num-iter" = rec { crateName = "num-iter"; - version = "0.1.43"; - edition = "2015"; - sha256 = "0lp22isvzmmnidbq9n5kbdh8gj0zm3yhxv1ddsn5rp65530fc0vx"; + version = "0.1.45"; + edition = "2018"; + sha256 = "1gzm7vc5g9qsjjl3bqk9rz1h6raxhygbrcpbfl04swlh0i506a8l"; authors = [ "The Rust Project Developers" ]; @@ -1986,11 +2019,13 @@ rec { name = "num-integer"; packageId = "num-integer"; usesDefaultFeatures = false; + features = [ "i128" ]; } { name = "num-traits"; packageId = "num-traits"; usesDefaultFeatures = false; + features = [ "i128" ]; } ]; buildDependencies = [ @@ -2001,15 +2036,14 @@ rec { ]; features = { "default" = [ "std" ]; - "i128" = [ "num-integer/i128" "num-traits/i128" ]; "std" = [ "num-integer/std" "num-traits/std" ]; }; }; "num-traits" = rec { crateName = "num-traits"; - version = "0.2.17"; - edition = "2018"; - sha256 = "0z16bi5zwgfysz6765v3rd6whfbjpihx3mhsn4dg8dzj2c221qrr"; + version = "0.2.19"; + edition = "2021"; + sha256 = "0h984rhdkkqd4ny9cif7y2azl3xdfb7768hb9irhpsch4q3gq787"; authors = [ "The Rust Project Developers" ]; @@ -2034,18 +2068,19 @@ rec { }; "once_cell" = rec { crateName = "once_cell"; - version = "1.18.0"; + version = "1.19.0"; edition = "2021"; - sha256 = "0vapcd5ambwck95wyz3ymlim35jirgnqn9a0qmi19msymv95v2yx"; + sha256 = "14kvw7px5z96dk4dwdm1r9cqhhy2cyj1l5n5b29mynbb8yr15nrz"; authors = [ "Aleksey Kladov " ]; features = { "alloc" = [ "race" ]; "atomic-polyfill" = [ "critical-section" ]; - "critical-section" = [ "dep:critical-section" "dep:atomic-polyfill" ]; + "critical-section" = [ "dep:critical-section" "portable-atomic" ]; "default" = [ "std" ]; "parking_lot" = [ "dep:parking_lot_core" ]; + "portable-atomic" = [ "dep:portable-atomic" ]; "std" = [ "alloc" ]; }; resolvedDefaultFeatures = [ "alloc" "default" "race" "std" ]; @@ -2129,7 +2164,7 @@ rec { dependencies = [ { name = "ecdsa"; - packageId = "ecdsa 0.16.8"; + packageId = "ecdsa 0.16.9"; rename = "ecdsa-core"; optional = true; usesDefaultFeatures = false; @@ -2137,13 +2172,13 @@ rec { } { name = "elliptic-curve"; - packageId = "elliptic-curve 0.13.6"; + packageId = "elliptic-curve 0.13.8"; usesDefaultFeatures = false; features = [ "hazmat" "sec1" ]; } { name = "primeorder"; - packageId = "primeorder 0.13.2"; + packageId = "primeorder 0.13.6"; optional = true; } { @@ -2156,14 +2191,14 @@ rec { devDependencies = [ { name = "ecdsa"; - packageId = "ecdsa 0.16.8"; + packageId = "ecdsa 0.16.9"; rename = "ecdsa-core"; usesDefaultFeatures = false; features = [ "dev" ]; } { name = "primeorder"; - packageId = "primeorder 0.13.2"; + packageId = "primeorder 0.13.6"; features = [ "dev" ]; } ]; @@ -2272,7 +2307,7 @@ rec { dependencies = [ { name = "ecdsa"; - packageId = "ecdsa 0.16.8"; + packageId = "ecdsa 0.16.9"; rename = "ecdsa-core"; optional = true; usesDefaultFeatures = false; @@ -2280,13 +2315,13 @@ rec { } { name = "elliptic-curve"; - packageId = "elliptic-curve 0.13.6"; + packageId = "elliptic-curve 0.13.8"; usesDefaultFeatures = false; features = [ "hazmat" "sec1" ]; } { name = "primeorder"; - packageId = "primeorder 0.13.2"; + packageId = "primeorder 0.13.6"; } { name = "sha2"; @@ -2298,7 +2333,7 @@ rec { devDependencies = [ { name = "ecdsa"; - packageId = "ecdsa 0.16.8"; + packageId = "ecdsa 0.16.9"; rename = "ecdsa-core"; usesDefaultFeatures = false; features = [ "dev" ]; @@ -2420,12 +2455,12 @@ rec { dependencies = [ { name = "der"; - packageId = "der 0.7.8"; + packageId = "der 0.7.9"; features = [ "oid" ]; } { name = "spki"; - packageId = "spki 0.7.2"; + packageId = "spki 0.7.3"; } ]; features = { @@ -2479,9 +2514,9 @@ rec { }; "pkg-config" = rec { crateName = "pkg-config"; - version = "0.3.27"; + version = "0.3.30"; edition = "2015"; - sha256 = "0r39ryh1magcq4cz5g9x88jllsnxnhcqr753islvyk4jp9h2h1r6"; + sha256 = "1v07557dj1sa0aly9c90wsygc0i8xv5vnmyv0g94lpkvj8qb4cfj"; authors = [ "Alex Crichton " ]; @@ -2522,33 +2557,35 @@ rec { "std" = [ "elliptic-curve/std" ]; }; }; - "primeorder 0.13.2" = rec { + "primeorder 0.13.6" = rec { crateName = "primeorder"; - version = "0.13.2"; + version = "0.13.6"; edition = "2021"; - sha256 = "1qqyvzkfx6g30ibc74n3fggkr6rrdi27ifbrq7yfxihf5kwcwbrw"; + sha256 = "1rp16710mxksagcjnxqjjq9r9wf5vf72fs8wxffnvhb6i6hiqgim"; authors = [ "RustCrypto Developers" ]; dependencies = [ { name = "elliptic-curve"; - packageId = "elliptic-curve 0.13.6"; + packageId = "elliptic-curve 0.13.8"; usesDefaultFeatures = false; features = [ "arithmetic" "sec1" ]; } ]; features = { + "alloc" = [ "elliptic-curve/alloc" ]; "serde" = [ "elliptic-curve/serde" "serdect" ]; "serdect" = [ "dep:serdect" ]; - "std" = [ "elliptic-curve/std" ]; + "std" = [ "alloc" "elliptic-curve/std" ]; }; }; "proc-macro2" = rec { crateName = "proc-macro2"; - version = "1.0.69"; + version = "1.0.84"; edition = "2021"; - sha256 = "1nljgyllbm3yr3pa081bf83gxh6l4zvjqzaldw7v4mj9xfgihk0k"; + sha256 = "1mj998115z75c0007glkdr8qj57ibv82h7kg6r8hnc914slwd5pc"; + libName = "proc_macro2"; authors = [ "David Tolnay " "Alex Crichton " @@ -2566,9 +2603,9 @@ rec { }; "quote" = rec { crateName = "quote"; - version = "1.0.33"; + version = "1.0.36"; edition = "2018"; - sha256 = "1biw54hbbr12wdwjac55z1m2x2rylciw83qnjn564a3096jgqrsj"; + sha256 = "19xcmh445bg6simirnnd4fvkmp6v2qiwxh5f6rw4a70h76pnm9qg"; authors = [ "David Tolnay " ]; @@ -2685,9 +2722,9 @@ rec { }; "regex" = rec { crateName = "regex"; - version = "1.10.2"; + version = "1.10.4"; edition = "2021"; - sha256 = "0hxkd814n4irind8im5c9am221ri6bprx49nc7yxv02ykhd9a2rq"; + sha256 = "0k5sb0h2mkwf51ab0gvv3x38jp1q7wgxf63abfbhi0wwvvgxn5y1"; authors = [ "The Rust Project Developers" "Andrew Gallant " @@ -2697,11 +2734,13 @@ rec { name = "aho-corasick"; packageId = "aho-corasick"; optional = true; + usesDefaultFeatures = false; } { name = "memchr"; packageId = "memchr"; optional = true; + usesDefaultFeatures = false; } { name = "regex-automata"; @@ -2741,9 +2780,9 @@ rec { }; "regex-automata" = rec { crateName = "regex-automata"; - version = "0.4.3"; + version = "0.4.6"; edition = "2021"; - sha256 = "0gs8q9yhd3kcg4pr00ag4viqxnh5l7jpyb9fsfr8hzh451w4r02z"; + sha256 = "1spaq7y4im7s56d1gxa2hi4hzf6dwswb1bv8xyavzya7k25kpf46"; authors = [ "The Rust Project Developers" "Andrew Gallant " @@ -2801,9 +2840,9 @@ rec { }; "regex-syntax" = rec { crateName = "regex-syntax"; - version = "0.8.2"; + version = "0.8.3"; edition = "2021"; - sha256 = "17rd2s8xbiyf6lb4aj2nfi44zqlj98g2ays8zzj2vfs743k79360"; + sha256 = "0mhzkm1pkqg6y53xv056qciazlg47pq0czqs94cn302ckvi49bdd"; authors = [ "The Rust Project Developers" "Andrew Gallant " @@ -2972,9 +3011,9 @@ rec { }; "rustc-serialize" = rec { crateName = "rustc-serialize"; - version = "0.3.24"; + version = "0.3.25"; edition = "2015"; - sha256 = "1nkg3vasg7nk80ffkazizgiyv3hb1l9g3d8h17cajbkx538jiwfw"; + sha256 = "00c494bsxjqjvc15h9x2nkgwl6bjdp9bmb9v0xs4ckv0h33lp0zy"; authors = [ "The Rust Project Developers" ]; @@ -2982,9 +3021,9 @@ rec { }; "ryu" = rec { crateName = "ryu"; - version = "1.0.15"; + version = "1.0.18"; edition = "2018"; - sha256 = "0hfphpn1xnpzxwj8qg916ga1lyc33lc03lnf1gb3wwpglj6wrm0s"; + sha256 = "17xx2s8j1lln7iackzd9p0sv546vjq71i779gphjq923vjh5pjzk"; authors = [ "David Tolnay " ]; @@ -3089,7 +3128,7 @@ rec { } { name = "der"; - packageId = "der 0.7.8"; + packageId = "der 0.7.9"; optional = true; features = [ "oid" ]; } @@ -3134,9 +3173,9 @@ rec { }; "serde" = rec { crateName = "serde"; - version = "1.0.190"; + version = "1.0.203"; edition = "2018"; - sha256 = "1xwndn6n8pb8y0vd84sba1nvfdf4x27nkbgnqsi99s0yr8sc7lwi"; + sha256 = "1500ghq198n6py5anvz5qbqagd9h1hq04f4qpsvjzrvix56snlvj"; authors = [ "Erick Tryzelaar " "David Tolnay " @@ -3168,9 +3207,9 @@ rec { }; "serde_derive" = rec { crateName = "serde_derive"; - version = "1.0.190"; + version = "1.0.203"; edition = "2015"; - sha256 = "1qy0697y6rbsqvaq7sgy8bpq1sh4h13xmvsizkbjnp2f76gn1ib7"; + sha256 = "1fmmqmfza3mwxb1v80737dj01gznrh8mhgqgylkndx5npq7bq32h"; procMacro = true; authors = [ "Erick Tryzelaar " @@ -3180,14 +3219,20 @@ rec { { name = "proc-macro2"; packageId = "proc-macro2"; + usesDefaultFeatures = false; + features = [ "proc-macro" ]; } { name = "quote"; packageId = "quote"; + usesDefaultFeatures = false; + features = [ "proc-macro" ]; } { name = "syn"; packageId = "syn"; + usesDefaultFeatures = false; + features = [ "clone-impls" "derive" "parsing" "printing" "proc-macro" ]; } ]; features = { }; @@ -3195,9 +3240,9 @@ rec { }; "serde_json" = rec { crateName = "serde_json"; - version = "1.0.108"; + version = "1.0.117"; edition = "2021"; - sha256 = "0ssj59s7lpzqh1m50kfzlnrip0p0jg9lmhn4098i33a0mhz7w71x"; + sha256 = "1hxziifjlc0kn1cci9d4crmjc7qwnfi20lxwyj9lzca2c7m84la5"; authors = [ "Erick Tryzelaar " "David Tolnay " @@ -3337,9 +3382,9 @@ rec { }; "smallvec" = rec { crateName = "smallvec"; - version = "1.11.1"; + version = "1.13.2"; edition = "2018"; - sha256 = "0nmx8aw3v4jglqdcjv4hhn10d6g52c4bhjlzwf952885is04lawl"; + sha256 = "0rsw5samawl3wsw6glrsb127rx6sh89a8wyikicw6dkdcjd1lpiw"; authors = [ "The Servo Project Developers" ]; @@ -3435,11 +3480,11 @@ rec { }; resolvedDefaultFeatures = [ "alloc" "base64ct" "pem" "std" ]; }; - "spki 0.7.2" = rec { + "spki 0.7.3" = rec { crateName = "spki"; - version = "0.7.2"; + version = "0.7.3"; edition = "2021"; - sha256 = "0jhq00sv4w3psdi6li3vjjmspc6z2d9b1wc1srbljircy1p9j7lx"; + sha256 = "17fj8k5fmx4w9mp27l970clrh5qa7r5sjdvbsln987xhb34dc7nr"; authors = [ "RustCrypto Developers" ]; @@ -3452,7 +3497,7 @@ rec { } { name = "der"; - packageId = "der 0.7.8"; + packageId = "der 0.7.9"; features = [ "oid" ]; } ]; @@ -3483,9 +3528,9 @@ rec { }; "syn" = rec { crateName = "syn"; - version = "2.0.38"; + version = "2.0.66"; edition = "2021"; - sha256 = "12s06bi068scc4fpv2x2bp3lx2vxnk4s0qv3w9hqznrpl6m7jsz9"; + sha256 = "1xfgrprsbz8j31kabvfinb4fyhajlk2q7lxa18fb006yl90kyby4"; authors = [ "David Tolnay " ]; @@ -3508,18 +3553,17 @@ rec { ]; features = { "default" = [ "derive" "parsing" "printing" "clone-impls" "proc-macro" ]; - "printing" = [ "quote" ]; - "proc-macro" = [ "proc-macro2/proc-macro" "quote/proc-macro" ]; - "quote" = [ "dep:quote" ]; + "printing" = [ "dep:quote" ]; + "proc-macro" = [ "proc-macro2/proc-macro" "quote?/proc-macro" ]; "test" = [ "syn-test-suite/all-features" ]; }; - resolvedDefaultFeatures = [ "clone-impls" "default" "derive" "full" "parsing" "printing" "proc-macro" "quote" "visit" ]; + resolvedDefaultFeatures = [ "clone-impls" "default" "derive" "full" "parsing" "printing" "proc-macro" "visit" ]; }; "thiserror" = rec { crateName = "thiserror"; - version = "1.0.50"; + version = "1.0.61"; edition = "2021"; - sha256 = "1ll2sfbrxks8jja161zh1pgm3yssr7aawdmaa2xmcwcsbh7j39zr"; + sha256 = "028prh962l16cmjivwb1g9xalbpqip0305zhq006mg74dc6whin5"; authors = [ "David Tolnay " ]; @@ -3533,10 +3577,11 @@ rec { }; "thiserror-impl" = rec { crateName = "thiserror-impl"; - version = "1.0.50"; + version = "1.0.61"; edition = "2021"; - sha256 = "1f0lmam4765sfnwr4b1n00y14vxh10g0311mkk0adr80pi02wsr6"; + sha256 = "0cvm37hp0kbcyk1xac1z0chpbd9pbn2g456iyid6sah0a113ihs6"; procMacro = true; + libName = "thiserror_impl"; authors = [ "David Tolnay " ]; @@ -3593,9 +3638,9 @@ rec { }; "walkdir" = rec { crateName = "walkdir"; - version = "2.4.0"; + version = "2.5.0"; edition = "2018"; - sha256 = "1vjl9fmfc4v8k9ald23qrpcbyb8dl1ynyq8d516cm537r1yqa7fp"; + sha256 = "0jsy7a710qv8gld5957ybrnc07gavppp963gs32xk4ag8130jy99"; authors = [ "Andrew Gallant " ]; @@ -3627,13 +3672,39 @@ rec { "rustc-dep-of-std" = [ "compiler_builtins" "core" "rustc-std-workspace-alloc" ]; "rustc-std-workspace-alloc" = [ "dep:rustc-std-workspace-alloc" ]; }; + resolvedDefaultFeatures = [ "std" ]; + }; + "wasix" = rec { + crateName = "wasix"; + version = "0.12.21"; + edition = "2018"; + sha256 = "0v9wb03ddbnas75005l2d63bdqy9mclds00b1qbw385wkgpv9yy1"; + authors = [ + "The Cranelift Project Developers" + "john-sharratt" + ]; + dependencies = [ + { + name = "wasi"; + packageId = "wasi"; + usesDefaultFeatures = false; + } + ]; + features = { + "compiler_builtins" = [ "dep:compiler_builtins" ]; + "core" = [ "dep:core" ]; + "default" = [ "std" ]; + "rustc-dep-of-std" = [ "compiler_builtins" "core" "rustc-std-workspace-alloc" "wasi/rustc-dep-of-std" ]; + "rustc-std-workspace-alloc" = [ "dep:rustc-std-workspace-alloc" ]; + "std" = [ "wasi/std" ]; + }; resolvedDefaultFeatures = [ "default" "std" ]; }; "wasm-bindgen" = rec { crateName = "wasm-bindgen"; - version = "0.2.87"; + version = "0.2.92"; edition = "2018"; - sha256 = "0hm3k42gcnrps2jh339h186scx1radqy1w7v1zwb333dncmaf1kp"; + sha256 = "1a4mcw13nsk3fr8fxjzf9kk1wj88xkfsmnm0pjraw01ryqfm7qjb"; authors = [ "The wasm-bindgen Developers" ]; @@ -3662,9 +3733,9 @@ rec { }; "wasm-bindgen-backend" = rec { crateName = "wasm-bindgen-backend"; - version = "0.2.87"; + version = "0.2.92"; edition = "2018"; - sha256 = "1gcsh3bjxhw3cirmin45107pcsnn0ymhkxg6bxg65s8hqp9vdwjy"; + sha256 = "1nj7wxbi49f0rw9d44rjzms26xlw6r76b2mrggx8jfbdjrxphkb1"; authors = [ "The wasm-bindgen Developers" ]; @@ -3706,9 +3777,9 @@ rec { }; "wasm-bindgen-macro" = rec { crateName = "wasm-bindgen-macro"; - version = "0.2.87"; + version = "0.2.92"; edition = "2018"; - sha256 = "07cg0b6zkcxa1yg1n10h62paid59s9zr8yss214bv8w2b7jrbr6y"; + sha256 = "09npa1srjjabd6nfph5yc03jb26sycjlxhy0c2a1pdrpx4yq5y51"; procMacro = true; authors = [ "The wasm-bindgen Developers" @@ -3731,9 +3802,9 @@ rec { }; "wasm-bindgen-macro-support" = rec { crateName = "wasm-bindgen-macro-support"; - version = "0.2.87"; + version = "0.2.92"; edition = "2018"; - sha256 = "0yqc46pr6mlgb9bsnfdnd50qvsqnrz8g5243fnaz0rb7lhc1ns2l"; + sha256 = "1dqv2xs8zcyw4kjgzj84bknp2h76phmsb3n7j6hn396h4ssifkz9"; authors = [ "The wasm-bindgen Developers" ]; @@ -3768,74 +3839,408 @@ rec { }; "wasm-bindgen-shared" = rec { crateName = "wasm-bindgen-shared"; - version = "0.2.87"; + version = "0.2.92"; edition = "2018"; - sha256 = "18bmjwvfyhvlq49nzw6mgiyx4ys350vps4cmx5gvzckh91dd0sna"; + sha256 = "15kyavsrna2cvy30kg03va257fraf9x00ny554vxngvpyaa0q6dg"; authors = [ "The wasm-bindgen Developers" ]; }; - "winapi" = rec { - crateName = "winapi"; - version = "0.3.9"; - edition = "2015"; - sha256 = "06gl025x418lchw1wxj64ycr7gha83m44cjr5sarhynd9xkrm0sw"; + "winapi-util" = rec { + crateName = "winapi-util"; + version = "0.1.8"; + edition = "2021"; + sha256 = "0svcgddd2rw06mj4r76gj655qsa1ikgz3d3gzax96fz7w62c6k2d"; authors = [ - "Peter Atashian " + "Andrew Gallant " ]; dependencies = [ { - name = "winapi-i686-pc-windows-gnu"; - packageId = "winapi-i686-pc-windows-gnu"; - target = { target, features }: (pkgs.rust.lib.toRustTarget stdenv.hostPlatform == "i686-pc-windows-gnu"); + name = "windows-sys"; + packageId = "windows-sys"; + target = { target, features }: (target."windows" or false); + features = [ "Win32_Foundation" "Win32_Storage_FileSystem" "Win32_System_Console" "Win32_System_SystemInformation" ]; } + ]; + + }; + "windows-sys" = rec { + crateName = "windows-sys"; + version = "0.52.0"; + edition = "2021"; + sha256 = "0gd3v4ji88490zgb6b5mq5zgbvwv7zx1ibn8v3x83rwcdbryaar8"; + authors = [ + "Microsoft" + ]; + dependencies = [ { - name = "winapi-x86_64-pc-windows-gnu"; - packageId = "winapi-x86_64-pc-windows-gnu"; - target = { target, features }: (pkgs.rust.lib.toRustTarget stdenv.hostPlatform == "x86_64-pc-windows-gnu"); + name = "windows-targets"; + packageId = "windows-targets"; } ]; features = { - "debug" = [ "impl-debug" ]; + "Wdk_Foundation" = [ "Wdk" ]; + "Wdk_Graphics" = [ "Wdk" ]; + "Wdk_Graphics_Direct3D" = [ "Wdk_Graphics" ]; + "Wdk_Storage" = [ "Wdk" ]; + "Wdk_Storage_FileSystem" = [ "Wdk_Storage" ]; + "Wdk_Storage_FileSystem_Minifilters" = [ "Wdk_Storage_FileSystem" ]; + "Wdk_System" = [ "Wdk" ]; + "Wdk_System_IO" = [ "Wdk_System" ]; + "Wdk_System_OfflineRegistry" = [ "Wdk_System" ]; + "Wdk_System_Registry" = [ "Wdk_System" ]; + "Wdk_System_SystemInformation" = [ "Wdk_System" ]; + "Wdk_System_SystemServices" = [ "Wdk_System" ]; + "Wdk_System_Threading" = [ "Wdk_System" ]; + "Win32_Data" = [ "Win32" ]; + "Win32_Data_HtmlHelp" = [ "Win32_Data" ]; + "Win32_Data_RightsManagement" = [ "Win32_Data" ]; + "Win32_Devices" = [ "Win32" ]; + "Win32_Devices_AllJoyn" = [ "Win32_Devices" ]; + "Win32_Devices_BiometricFramework" = [ "Win32_Devices" ]; + "Win32_Devices_Bluetooth" = [ "Win32_Devices" ]; + "Win32_Devices_Communication" = [ "Win32_Devices" ]; + "Win32_Devices_DeviceAndDriverInstallation" = [ "Win32_Devices" ]; + "Win32_Devices_DeviceQuery" = [ "Win32_Devices" ]; + "Win32_Devices_Display" = [ "Win32_Devices" ]; + "Win32_Devices_Enumeration" = [ "Win32_Devices" ]; + "Win32_Devices_Enumeration_Pnp" = [ "Win32_Devices_Enumeration" ]; + "Win32_Devices_Fax" = [ "Win32_Devices" ]; + "Win32_Devices_HumanInterfaceDevice" = [ "Win32_Devices" ]; + "Win32_Devices_PortableDevices" = [ "Win32_Devices" ]; + "Win32_Devices_Properties" = [ "Win32_Devices" ]; + "Win32_Devices_Pwm" = [ "Win32_Devices" ]; + "Win32_Devices_Sensors" = [ "Win32_Devices" ]; + "Win32_Devices_SerialCommunication" = [ "Win32_Devices" ]; + "Win32_Devices_Tapi" = [ "Win32_Devices" ]; + "Win32_Devices_Usb" = [ "Win32_Devices" ]; + "Win32_Devices_WebServicesOnDevices" = [ "Win32_Devices" ]; + "Win32_Foundation" = [ "Win32" ]; + "Win32_Gaming" = [ "Win32" ]; + "Win32_Globalization" = [ "Win32" ]; + "Win32_Graphics" = [ "Win32" ]; + "Win32_Graphics_Dwm" = [ "Win32_Graphics" ]; + "Win32_Graphics_Gdi" = [ "Win32_Graphics" ]; + "Win32_Graphics_GdiPlus" = [ "Win32_Graphics" ]; + "Win32_Graphics_Hlsl" = [ "Win32_Graphics" ]; + "Win32_Graphics_OpenGL" = [ "Win32_Graphics" ]; + "Win32_Graphics_Printing" = [ "Win32_Graphics" ]; + "Win32_Graphics_Printing_PrintTicket" = [ "Win32_Graphics_Printing" ]; + "Win32_Management" = [ "Win32" ]; + "Win32_Management_MobileDeviceManagementRegistration" = [ "Win32_Management" ]; + "Win32_Media" = [ "Win32" ]; + "Win32_Media_Audio" = [ "Win32_Media" ]; + "Win32_Media_DxMediaObjects" = [ "Win32_Media" ]; + "Win32_Media_KernelStreaming" = [ "Win32_Media" ]; + "Win32_Media_Multimedia" = [ "Win32_Media" ]; + "Win32_Media_Streaming" = [ "Win32_Media" ]; + "Win32_Media_WindowsMediaFormat" = [ "Win32_Media" ]; + "Win32_NetworkManagement" = [ "Win32" ]; + "Win32_NetworkManagement_Dhcp" = [ "Win32_NetworkManagement" ]; + "Win32_NetworkManagement_Dns" = [ "Win32_NetworkManagement" ]; + "Win32_NetworkManagement_InternetConnectionWizard" = [ "Win32_NetworkManagement" ]; + "Win32_NetworkManagement_IpHelper" = [ "Win32_NetworkManagement" ]; + "Win32_NetworkManagement_Multicast" = [ "Win32_NetworkManagement" ]; + "Win32_NetworkManagement_Ndis" = [ "Win32_NetworkManagement" ]; + "Win32_NetworkManagement_NetBios" = [ "Win32_NetworkManagement" ]; + "Win32_NetworkManagement_NetManagement" = [ "Win32_NetworkManagement" ]; + "Win32_NetworkManagement_NetShell" = [ "Win32_NetworkManagement" ]; + "Win32_NetworkManagement_NetworkDiagnosticsFramework" = [ "Win32_NetworkManagement" ]; + "Win32_NetworkManagement_P2P" = [ "Win32_NetworkManagement" ]; + "Win32_NetworkManagement_QoS" = [ "Win32_NetworkManagement" ]; + "Win32_NetworkManagement_Rras" = [ "Win32_NetworkManagement" ]; + "Win32_NetworkManagement_Snmp" = [ "Win32_NetworkManagement" ]; + "Win32_NetworkManagement_WNet" = [ "Win32_NetworkManagement" ]; + "Win32_NetworkManagement_WebDav" = [ "Win32_NetworkManagement" ]; + "Win32_NetworkManagement_WiFi" = [ "Win32_NetworkManagement" ]; + "Win32_NetworkManagement_WindowsConnectionManager" = [ "Win32_NetworkManagement" ]; + "Win32_NetworkManagement_WindowsFilteringPlatform" = [ "Win32_NetworkManagement" ]; + "Win32_NetworkManagement_WindowsFirewall" = [ "Win32_NetworkManagement" ]; + "Win32_NetworkManagement_WindowsNetworkVirtualization" = [ "Win32_NetworkManagement" ]; + "Win32_Networking" = [ "Win32" ]; + "Win32_Networking_ActiveDirectory" = [ "Win32_Networking" ]; + "Win32_Networking_Clustering" = [ "Win32_Networking" ]; + "Win32_Networking_HttpServer" = [ "Win32_Networking" ]; + "Win32_Networking_Ldap" = [ "Win32_Networking" ]; + "Win32_Networking_WebSocket" = [ "Win32_Networking" ]; + "Win32_Networking_WinHttp" = [ "Win32_Networking" ]; + "Win32_Networking_WinInet" = [ "Win32_Networking" ]; + "Win32_Networking_WinSock" = [ "Win32_Networking" ]; + "Win32_Networking_WindowsWebServices" = [ "Win32_Networking" ]; + "Win32_Security" = [ "Win32" ]; + "Win32_Security_AppLocker" = [ "Win32_Security" ]; + "Win32_Security_Authentication" = [ "Win32_Security" ]; + "Win32_Security_Authentication_Identity" = [ "Win32_Security_Authentication" ]; + "Win32_Security_Authorization" = [ "Win32_Security" ]; + "Win32_Security_Credentials" = [ "Win32_Security" ]; + "Win32_Security_Cryptography" = [ "Win32_Security" ]; + "Win32_Security_Cryptography_Catalog" = [ "Win32_Security_Cryptography" ]; + "Win32_Security_Cryptography_Certificates" = [ "Win32_Security_Cryptography" ]; + "Win32_Security_Cryptography_Sip" = [ "Win32_Security_Cryptography" ]; + "Win32_Security_Cryptography_UI" = [ "Win32_Security_Cryptography" ]; + "Win32_Security_DiagnosticDataQuery" = [ "Win32_Security" ]; + "Win32_Security_DirectoryServices" = [ "Win32_Security" ]; + "Win32_Security_EnterpriseData" = [ "Win32_Security" ]; + "Win32_Security_ExtensibleAuthenticationProtocol" = [ "Win32_Security" ]; + "Win32_Security_Isolation" = [ "Win32_Security" ]; + "Win32_Security_LicenseProtection" = [ "Win32_Security" ]; + "Win32_Security_NetworkAccessProtection" = [ "Win32_Security" ]; + "Win32_Security_WinTrust" = [ "Win32_Security" ]; + "Win32_Security_WinWlx" = [ "Win32_Security" ]; + "Win32_Storage" = [ "Win32" ]; + "Win32_Storage_Cabinets" = [ "Win32_Storage" ]; + "Win32_Storage_CloudFilters" = [ "Win32_Storage" ]; + "Win32_Storage_Compression" = [ "Win32_Storage" ]; + "Win32_Storage_DistributedFileSystem" = [ "Win32_Storage" ]; + "Win32_Storage_FileHistory" = [ "Win32_Storage" ]; + "Win32_Storage_FileSystem" = [ "Win32_Storage" ]; + "Win32_Storage_Imapi" = [ "Win32_Storage" ]; + "Win32_Storage_IndexServer" = [ "Win32_Storage" ]; + "Win32_Storage_InstallableFileSystems" = [ "Win32_Storage" ]; + "Win32_Storage_IscsiDisc" = [ "Win32_Storage" ]; + "Win32_Storage_Jet" = [ "Win32_Storage" ]; + "Win32_Storage_Nvme" = [ "Win32_Storage" ]; + "Win32_Storage_OfflineFiles" = [ "Win32_Storage" ]; + "Win32_Storage_OperationRecorder" = [ "Win32_Storage" ]; + "Win32_Storage_Packaging" = [ "Win32_Storage" ]; + "Win32_Storage_Packaging_Appx" = [ "Win32_Storage_Packaging" ]; + "Win32_Storage_ProjectedFileSystem" = [ "Win32_Storage" ]; + "Win32_Storage_StructuredStorage" = [ "Win32_Storage" ]; + "Win32_Storage_Vhd" = [ "Win32_Storage" ]; + "Win32_Storage_Xps" = [ "Win32_Storage" ]; + "Win32_System" = [ "Win32" ]; + "Win32_System_AddressBook" = [ "Win32_System" ]; + "Win32_System_Antimalware" = [ "Win32_System" ]; + "Win32_System_ApplicationInstallationAndServicing" = [ "Win32_System" ]; + "Win32_System_ApplicationVerifier" = [ "Win32_System" ]; + "Win32_System_ClrHosting" = [ "Win32_System" ]; + "Win32_System_Com" = [ "Win32_System" ]; + "Win32_System_Com_Marshal" = [ "Win32_System_Com" ]; + "Win32_System_Com_StructuredStorage" = [ "Win32_System_Com" ]; + "Win32_System_Com_Urlmon" = [ "Win32_System_Com" ]; + "Win32_System_ComponentServices" = [ "Win32_System" ]; + "Win32_System_Console" = [ "Win32_System" ]; + "Win32_System_CorrelationVector" = [ "Win32_System" ]; + "Win32_System_DataExchange" = [ "Win32_System" ]; + "Win32_System_DeploymentServices" = [ "Win32_System" ]; + "Win32_System_DeveloperLicensing" = [ "Win32_System" ]; + "Win32_System_Diagnostics" = [ "Win32_System" ]; + "Win32_System_Diagnostics_Ceip" = [ "Win32_System_Diagnostics" ]; + "Win32_System_Diagnostics_Debug" = [ "Win32_System_Diagnostics" ]; + "Win32_System_Diagnostics_Debug_Extensions" = [ "Win32_System_Diagnostics_Debug" ]; + "Win32_System_Diagnostics_Etw" = [ "Win32_System_Diagnostics" ]; + "Win32_System_Diagnostics_ProcessSnapshotting" = [ "Win32_System_Diagnostics" ]; + "Win32_System_Diagnostics_ToolHelp" = [ "Win32_System_Diagnostics" ]; + "Win32_System_DistributedTransactionCoordinator" = [ "Win32_System" ]; + "Win32_System_Environment" = [ "Win32_System" ]; + "Win32_System_ErrorReporting" = [ "Win32_System" ]; + "Win32_System_EventCollector" = [ "Win32_System" ]; + "Win32_System_EventLog" = [ "Win32_System" ]; + "Win32_System_EventNotificationService" = [ "Win32_System" ]; + "Win32_System_GroupPolicy" = [ "Win32_System" ]; + "Win32_System_HostCompute" = [ "Win32_System" ]; + "Win32_System_HostComputeNetwork" = [ "Win32_System" ]; + "Win32_System_HostComputeSystem" = [ "Win32_System" ]; + "Win32_System_Hypervisor" = [ "Win32_System" ]; + "Win32_System_IO" = [ "Win32_System" ]; + "Win32_System_Iis" = [ "Win32_System" ]; + "Win32_System_Ioctl" = [ "Win32_System" ]; + "Win32_System_JobObjects" = [ "Win32_System" ]; + "Win32_System_Js" = [ "Win32_System" ]; + "Win32_System_Kernel" = [ "Win32_System" ]; + "Win32_System_LibraryLoader" = [ "Win32_System" ]; + "Win32_System_Mailslots" = [ "Win32_System" ]; + "Win32_System_Mapi" = [ "Win32_System" ]; + "Win32_System_Memory" = [ "Win32_System" ]; + "Win32_System_Memory_NonVolatile" = [ "Win32_System_Memory" ]; + "Win32_System_MessageQueuing" = [ "Win32_System" ]; + "Win32_System_MixedReality" = [ "Win32_System" ]; + "Win32_System_Ole" = [ "Win32_System" ]; + "Win32_System_PasswordManagement" = [ "Win32_System" ]; + "Win32_System_Performance" = [ "Win32_System" ]; + "Win32_System_Performance_HardwareCounterProfiling" = [ "Win32_System_Performance" ]; + "Win32_System_Pipes" = [ "Win32_System" ]; + "Win32_System_Power" = [ "Win32_System" ]; + "Win32_System_ProcessStatus" = [ "Win32_System" ]; + "Win32_System_Recovery" = [ "Win32_System" ]; + "Win32_System_Registry" = [ "Win32_System" ]; + "Win32_System_RemoteDesktop" = [ "Win32_System" ]; + "Win32_System_RemoteManagement" = [ "Win32_System" ]; + "Win32_System_RestartManager" = [ "Win32_System" ]; + "Win32_System_Restore" = [ "Win32_System" ]; + "Win32_System_Rpc" = [ "Win32_System" ]; + "Win32_System_Search" = [ "Win32_System" ]; + "Win32_System_Search_Common" = [ "Win32_System_Search" ]; + "Win32_System_SecurityCenter" = [ "Win32_System" ]; + "Win32_System_Services" = [ "Win32_System" ]; + "Win32_System_SetupAndMigration" = [ "Win32_System" ]; + "Win32_System_Shutdown" = [ "Win32_System" ]; + "Win32_System_StationsAndDesktops" = [ "Win32_System" ]; + "Win32_System_SubsystemForLinux" = [ "Win32_System" ]; + "Win32_System_SystemInformation" = [ "Win32_System" ]; + "Win32_System_SystemServices" = [ "Win32_System" ]; + "Win32_System_Threading" = [ "Win32_System" ]; + "Win32_System_Time" = [ "Win32_System" ]; + "Win32_System_TpmBaseServices" = [ "Win32_System" ]; + "Win32_System_UserAccessLogging" = [ "Win32_System" ]; + "Win32_System_Variant" = [ "Win32_System" ]; + "Win32_System_VirtualDosMachines" = [ "Win32_System" ]; + "Win32_System_WindowsProgramming" = [ "Win32_System" ]; + "Win32_System_Wmi" = [ "Win32_System" ]; + "Win32_UI" = [ "Win32" ]; + "Win32_UI_Accessibility" = [ "Win32_UI" ]; + "Win32_UI_ColorSystem" = [ "Win32_UI" ]; + "Win32_UI_Controls" = [ "Win32_UI" ]; + "Win32_UI_Controls_Dialogs" = [ "Win32_UI_Controls" ]; + "Win32_UI_HiDpi" = [ "Win32_UI" ]; + "Win32_UI_Input" = [ "Win32_UI" ]; + "Win32_UI_Input_Ime" = [ "Win32_UI_Input" ]; + "Win32_UI_Input_KeyboardAndMouse" = [ "Win32_UI_Input" ]; + "Win32_UI_Input_Pointer" = [ "Win32_UI_Input" ]; + "Win32_UI_Input_Touch" = [ "Win32_UI_Input" ]; + "Win32_UI_Input_XboxController" = [ "Win32_UI_Input" ]; + "Win32_UI_InteractionContext" = [ "Win32_UI" ]; + "Win32_UI_Magnification" = [ "Win32_UI" ]; + "Win32_UI_Shell" = [ "Win32_UI" ]; + "Win32_UI_Shell_PropertiesSystem" = [ "Win32_UI_Shell" ]; + "Win32_UI_TabletPC" = [ "Win32_UI" ]; + "Win32_UI_TextServices" = [ "Win32_UI" ]; + "Win32_UI_WindowsAndMessaging" = [ "Win32_UI" ]; + "Win32_Web" = [ "Win32" ]; + "Win32_Web_InternetExplorer" = [ "Win32_Web" ]; }; - resolvedDefaultFeatures = [ "consoleapi" "errhandlingapi" "fileapi" "minwindef" "processenv" "std" "sysinfoapi" "winbase" "wincon" "winerror" "winnt" ]; + resolvedDefaultFeatures = [ "Win32" "Win32_Foundation" "Win32_Storage" "Win32_Storage_FileSystem" "Win32_System" "Win32_System_Console" "Win32_System_SystemInformation" "default" ]; }; - "winapi-i686-pc-windows-gnu" = rec { - crateName = "winapi-i686-pc-windows-gnu"; - version = "0.4.0"; - edition = "2015"; - sha256 = "1dmpa6mvcvzz16zg6d5vrfy4bxgg541wxrcip7cnshi06v38ffxc"; + "windows-targets" = rec { + crateName = "windows-targets"; + version = "0.52.5"; + edition = "2021"; + sha256 = "1sz7jrnkygmmlj1ia8fk85wbyil450kq5qkh5qh9sh2rcnj161vg"; + authors = [ + "Microsoft" + ]; + dependencies = [ + { + name = "windows_aarch64_gnullvm"; + packageId = "windows_aarch64_gnullvm"; + target = { target, features }: (pkgs.rust.lib.toRustTarget stdenv.hostPlatform == "aarch64-pc-windows-gnullvm"); + } + { + name = "windows_aarch64_msvc"; + packageId = "windows_aarch64_msvc"; + target = { target, features }: (("aarch64" == target."arch") && ("msvc" == target."env") && (!(target."windows_raw_dylib" or false))); + } + { + name = "windows_i686_gnu"; + packageId = "windows_i686_gnu"; + target = { target, features }: (("x86" == target."arch") && ("gnu" == target."env") && (!("llvm" == target."abi")) && (!(target."windows_raw_dylib" or false))); + } + { + name = "windows_i686_gnullvm"; + packageId = "windows_i686_gnullvm"; + target = { target, features }: (pkgs.rust.lib.toRustTarget stdenv.hostPlatform == "i686-pc-windows-gnullvm"); + } + { + name = "windows_i686_msvc"; + packageId = "windows_i686_msvc"; + target = { target, features }: (("x86" == target."arch") && ("msvc" == target."env") && (!(target."windows_raw_dylib" or false))); + } + { + name = "windows_x86_64_gnu"; + packageId = "windows_x86_64_gnu"; + target = { target, features }: (("x86_64" == target."arch") && ("gnu" == target."env") && (!("llvm" == target."abi")) && (!(target."windows_raw_dylib" or false))); + } + { + name = "windows_x86_64_gnullvm"; + packageId = "windows_x86_64_gnullvm"; + target = { target, features }: (pkgs.rust.lib.toRustTarget stdenv.hostPlatform == "x86_64-pc-windows-gnullvm"); + } + { + name = "windows_x86_64_msvc"; + packageId = "windows_x86_64_msvc"; + target = { target, features }: ((("x86_64" == target."arch") || ("arm64ec" == target."arch")) && ("msvc" == target."env") && (!(target."windows_raw_dylib" or false))); + } + ]; + + }; + "windows_aarch64_gnullvm" = rec { + crateName = "windows_aarch64_gnullvm"; + version = "0.52.5"; + edition = "2021"; + sha256 = "0qrjimbj67nnyn7zqy15mzzmqg0mn5gsr2yciqjxm3cb3vbyx23h"; authors = [ - "Peter Atashian " + "Microsoft" ]; }; - "winapi-util" = rec { - crateName = "winapi-util"; - version = "0.1.6"; + "windows_aarch64_msvc" = rec { + crateName = "windows_aarch64_msvc"; + version = "0.52.5"; edition = "2021"; - sha256 = "15i5lm39wd44004i9d5qspry2cynkrpvwzghr6s2c3dsk28nz7pj"; + sha256 = "1dmga8kqlmln2ibckk6mxc9n59vdg8ziqa2zr8awcl720hazv1cr"; authors = [ - "Andrew Gallant " + "Microsoft" ]; - dependencies = [ - { - name = "winapi"; - packageId = "winapi"; - target = { target, features }: (target."windows" or false); - features = [ "std" "consoleapi" "errhandlingapi" "fileapi" "minwindef" "processenv" "sysinfoapi" "winbase" "wincon" "winerror" "winnt" ]; - } + + }; + "windows_i686_gnu" = rec { + crateName = "windows_i686_gnu"; + version = "0.52.5"; + edition = "2021"; + sha256 = "0w4np3l6qwlra9s2xpflqrs60qk1pz6ahhn91rr74lvdy4y0gfl8"; + authors = [ + "Microsoft" ]; }; - "winapi-x86_64-pc-windows-gnu" = rec { - crateName = "winapi-x86_64-pc-windows-gnu"; - version = "0.4.0"; - edition = "2015"; - sha256 = "0gqq64czqb64kskjryj8isp62m2sgvx25yyj3kpc2myh85w24bki"; + "windows_i686_gnullvm" = rec { + crateName = "windows_i686_gnullvm"; + version = "0.52.5"; + edition = "2021"; + sha256 = "1s9f4gff0cixd86mw3n63rpmsm4pmr4ffndl6s7qa2h35492dx47"; + authors = [ + "Microsoft" + ]; + + }; + "windows_i686_msvc" = rec { + crateName = "windows_i686_msvc"; + version = "0.52.5"; + edition = "2021"; + sha256 = "1gw7fklxywgpnwbwg43alb4hm0qjmx72hqrlwy5nanrxs7rjng6v"; + authors = [ + "Microsoft" + ]; + + }; + "windows_x86_64_gnu" = rec { + crateName = "windows_x86_64_gnu"; + version = "0.52.5"; + edition = "2021"; + sha256 = "1n8p2mcf3lw6300k77a0knksssmgwb9hynl793mhkzyydgvlchjf"; authors = [ - "Peter Atashian " + "Microsoft" + ]; + + }; + "windows_x86_64_gnullvm" = rec { + crateName = "windows_x86_64_gnullvm"; + version = "0.52.5"; + edition = "2021"; + sha256 = "15n56jrh4s5bz66zimavr1rmcaw6wa306myrvmbc6rydhbj9h8l5"; + authors = [ + "Microsoft" + ]; + + }; + "windows_x86_64_msvc" = rec { + crateName = "windows_x86_64_msvc"; + version = "0.52.5"; + edition = "2021"; + sha256 = "1w1bn24ap8dp9i85s8mlg8cim2bl2368bd6qyvm0xzqvzmdpxi5y"; + authors = [ + "Microsoft" ]; }; @@ -3929,9 +4334,9 @@ rec { }; "zeroize" = rec { crateName = "zeroize"; - version = "1.6.0"; + version = "1.8.1"; edition = "2021"; - sha256 = "1ndar43r58zbmasjhrhgas168vxb4i0rwbkcnszhjybwpbqmc29a"; + sha256 = "1pjdrmjwmszpxfd7r860jx54cyk94qk59x13sc307cvr5256glyf"; authors = [ "The RustCrypto Project Developers" ]; @@ -4043,7 +4448,6 @@ rec { ( _: { buildTests = true; - release = false; } ); # If the user hasn't set any pre/post commands, we don't want to @@ -4068,7 +4472,7 @@ rec { # recreate a file hierarchy as when running tests with cargo # the source for test data - ${pkgs.buildPackages.xorg.lndir}/bin/lndir ${crate.src} + ${pkgs.xorg.lndir}/bin/lndir ${crate.src} # build outputs testRoot=target/debug @@ -4098,12 +4502,10 @@ rec { passthru = (crate.passthru or { }) // { inherit test; }; - } - (lib.optionalString (stdenv.buildPlatform.canExecute stdenv.hostPlatform) '' - echo tested by ${test} - '' + '' - ${lib.concatMapStringsSep "\n" (output: "ln -s ${crate.${output}} ${"$"}${output}") crate.outputs} - ''); + } '' + echo tested by ${test} + ${lib.concatMapStringsSep "\n" (output: "ln -s ${crate.${output}} ${"$"}${output}") crate.outputs} + ''; /* A restricted overridable version of builtRustCratesWithFeatures. */ buildRustCrateWithFeatures = diff --git a/libs/libzauth/libzauth-c/crate-hashes.json b/libs/libzauth/libzauth-c/crate-hashes.json index 35f3b6ec1e4..e6d8e90ef5a 100644 --- a/libs/libzauth/libzauth-c/crate-hashes.json +++ b/libs/libzauth/libzauth-c/crate-hashes.json @@ -1,4 +1,127 @@ { - "jwt-simple 0.11.3 (git+https://github.com/wireapp/rust-jwt-simple?rev=15a69f82288d68b74a75c1364e5d4bf681f1c07b#15a69f82288d68b74a75c1364e5d4bf681f1c07b)": "1ms7bym5j3gvn10gdbacai7v5dsdw8cf747py7igg5almk105n0z", - "jwt-simple 0.11.4 (git+https://github.com/wireapp/rust-jwt-simple?rev=5a35177ae37c06d65225df4ba2c2b065917748c5#5a35177ae37c06d65225df4ba2c2b065917748c5)": "1fkv1w82dy681qbw9wwja2dapgg1m8d01j5i2zxn1vccpsy89cnc" + "git+https://github.com/wireapp/rust-jwt-simple?rev=15a69f82288d68b74a75c1364e5d4bf681f1c07b#jwt-simple@0.11.3": "1ms7bym5j3gvn10gdbacai7v5dsdw8cf747py7igg5almk105n0z", + "git+https://github.com/wireapp/rust-jwt-simple?rev=5a35177ae37c06d65225df4ba2c2b065917748c5#jwt-simple@0.11.4": "1fkv1w82dy681qbw9wwja2dapgg1m8d01j5i2zxn1vccpsy89cnc", + "registry+https://github.com/rust-lang/crates.io-index#aho-corasick@1.1.3": "05mrpkvdgp5d20y2p989f187ry9diliijgwrs254fs9s1m1x6q4f", + "registry+https://github.com/rust-lang/crates.io-index#anyhow@1.0.86": "1nk301x8qhpdaks6a9zvcp7yakjqnczjmqndbg7vk4494d3d1ldk", + "registry+https://github.com/rust-lang/crates.io-index#asexp@0.3.2": "0li6h191ppfyrsv6iwppbaxsmcbpc3sb2b8wgwq4g2bmrrhqfdjy", + "registry+https://github.com/rust-lang/crates.io-index#autocfg@1.3.0": "1c3njkfzpil03k92q0mij5y1pkhhfr4j3bf0h53bgl2vs85lsjqc", + "registry+https://github.com/rust-lang/crates.io-index#base16ct@0.1.1": "1klccxr7igf73wpi0x3asjd8n0xjg0v6a7vxgvfk5ybvgh1hd6il", + "registry+https://github.com/rust-lang/crates.io-index#base16ct@0.2.0": "1kylrjhdzk7qpknrvlphw8ywdnvvg39dizw9622w3wk5xba04zsc", + "registry+https://github.com/rust-lang/crates.io-index#base64@0.21.7": "0rw52yvsk75kar9wgqfwgb414kvil1gn7mqkrhn9zf1537mpsacx", + "registry+https://github.com/rust-lang/crates.io-index#base64ct@1.6.0": "0nvdba4jb8aikv60az40x2w1y96sjdq8z3yp09rwzmkhiwv1lg4c", + "registry+https://github.com/rust-lang/crates.io-index#binstring@0.1.1": "11bsghizyz2xwxmqvsj7hlxs6qp180kl2vr0n4n7484k7nbn03by", + "registry+https://github.com/rust-lang/crates.io-index#block-buffer@0.10.4": "0w9sa2ypmrsqqvc20nhwr75wbb5cjr4kkyhpjm1z1lv2kdicfy1h", + "registry+https://github.com/rust-lang/crates.io-index#bumpalo@3.16.0": "0b015qb4knwanbdlp1x48pkb4pm57b8gidbhhhxr900q2wb6fabr", + "registry+https://github.com/rust-lang/crates.io-index#byteorder@1.5.0": "0jzncxyf404mwqdbspihyzpkndfgda450l0893pz5xj685cg5l0z", + "registry+https://github.com/rust-lang/crates.io-index#cc@1.0.98": "0gzhij74hblfkzwwyysdc8crfd6fr0m226vzmijmwwhdakkp1hj1", + "registry+https://github.com/rust-lang/crates.io-index#cfg-if@1.0.0": "1za0vb97n4brpzpv8lsbnzmq5r8f2b0cpqqr0sy8h5bn751xxwds", + "registry+https://github.com/rust-lang/crates.io-index#coarsetime@0.1.34": "0pby1xsrzcxj0yq911hzr38bchgm80iwyg5y2h0rddqvy2f87cqk", + "registry+https://github.com/rust-lang/crates.io-index#const-oid@0.9.6": "1y0jnqaq7p2wvspnx7qj76m7hjcqpz73qzvr9l2p9n2s51vr6if2", + "registry+https://github.com/rust-lang/crates.io-index#cpufeatures@0.2.12": "012m7rrak4girqlii3jnqwrr73gv1i980q4wra5yyyhvzwk5xzjk", + "registry+https://github.com/rust-lang/crates.io-index#crypto-bigint@0.4.9": "1vqprgj0aj1340w186zyspi58397ih78jsc0iydvhs6zrlilnazg", + "registry+https://github.com/rust-lang/crates.io-index#crypto-bigint@0.5.5": "0xmbdff3g6ii5sbxjxc31xfkv9lrmyril4arh3dzckd4gjsjzj8d", + "registry+https://github.com/rust-lang/crates.io-index#crypto-common@0.1.6": "1cvby95a6xg7kxdz5ln3rl9xh66nz66w46mm3g56ri1z5x815yqv", + "registry+https://github.com/rust-lang/crates.io-index#ct-codecs@1.1.1": "1pvmrkk95jadmhhd5mn88mq2dfnq0yng8mk3pfd5l6dq0i2fpdzk", + "registry+https://github.com/rust-lang/crates.io-index#der@0.6.1": "1pnl3y52m1s6srxpfrfbazf6qilzq8fgksk5dv79nxaybjk6g97i", + "registry+https://github.com/rust-lang/crates.io-index#der@0.7.9": "1h4vzjfa1lczxdf8avfj9qlwh1qianqlxdy1g5rn762qnvkzhnzm", + "registry+https://github.com/rust-lang/crates.io-index#digest@0.10.7": "14p2n6ih29x81akj097lvz7wi9b6b9hvls0lwrv7b6xwyy0s5ncy", + "registry+https://github.com/rust-lang/crates.io-index#ecdsa@0.15.1": "0zk3nz2qlczayd8w7zp3nh1skxh5nvrk1l16m62l3msab50l310j", + "registry+https://github.com/rust-lang/crates.io-index#ecdsa@0.16.9": "1jhb0bcbkaz4001sdmfyv8ajrv8a1cg7z7aa5myrd4jjbhmz69zf", + "registry+https://github.com/rust-lang/crates.io-index#ed25519-compact@2.1.1": "1431kxw67xkk5y5kamfdjxnqbzqy5y4p032syi3wva5y8h7ldcz9", + "registry+https://github.com/rust-lang/crates.io-index#ed25519@1.5.3": "1rzydm5wd8szkddx3g55w4vm86y1ika8qp8qwckada5vf1fg7kwi", + "registry+https://github.com/rust-lang/crates.io-index#elliptic-curve@0.12.3": "1lwi108mh6drw5nzqzlz7ighdba5qxdg5vmwwnw1j2ihnn58ifz7", + "registry+https://github.com/rust-lang/crates.io-index#elliptic-curve@0.13.8": "0ixx4brgnzi61z29r3g1606nh2za88hzyz8c5r3p6ydzhqq09rmm", + "registry+https://github.com/rust-lang/crates.io-index#ff@0.12.1": "0q3imz4m3dj2cy182i20wa8kbclgj13ddfngqb2miicc6cjzq4yh", + "registry+https://github.com/rust-lang/crates.io-index#ff@0.13.0": "0jcl8yhcs5kbfxfpnrhpkkvnk7s666vly6sgawg3nri9nx215m6y", + "registry+https://github.com/rust-lang/crates.io-index#generic-array@0.14.7": "16lyyrzrljfq424c3n8kfwkqihlimmsg5nhshbbp48np3yjrqr45", + "registry+https://github.com/rust-lang/crates.io-index#getrandom@0.2.15": "1mzlnrb3dgyd1fb84gvw10pyr8wdqdl4ry4sr64i1s8an66pqmn4", + "registry+https://github.com/rust-lang/crates.io-index#group@0.12.1": "1ixspxqdpq0hxg0hd9s6rngrp6rll21v4jjnr7ar1lzvdhxgpysx", + "registry+https://github.com/rust-lang/crates.io-index#group@0.13.0": "0qqs2p5vqnv3zvq9mfjkmw3qlvgqb0c3cm6p33srkh7pc9sfzygh", + "registry+https://github.com/rust-lang/crates.io-index#hkdf@0.12.4": "1xxxzcarz151p1b858yn5skmhyrvn8fs4ivx5km3i1kjmnr8wpvv", + "registry+https://github.com/rust-lang/crates.io-index#hmac-sha1-compact@1.1.4": "19w4iiwrprcnvq3k2gkv6xm9b11alda4w9l7vvya6bvkxh2x9yfz", + "registry+https://github.com/rust-lang/crates.io-index#hmac-sha256@1.1.7": "0dapmabsj2mvblwjy64h518frj1cvk468kr5awayr3q172dyd21n", + "registry+https://github.com/rust-lang/crates.io-index#hmac-sha512@1.1.5": "12pp9qdf0f62lgwcb8h1xnvlb1pmkgqgjf5rzaiqkrdsar31zkp4", + "registry+https://github.com/rust-lang/crates.io-index#hmac@0.12.1": "0pmbr069sfg76z7wsssfk5ddcqd9ncp79fyz6zcm6yn115yc6jbc", + "registry+https://github.com/rust-lang/crates.io-index#itoa@1.0.11": "0nv9cqjwzr3q58qz84dcz63ggc54yhf1yqar1m858m1kfd4g3wa9", + "registry+https://github.com/rust-lang/crates.io-index#js-sys@0.3.69": "0v99rz97asnzapb0jsc3jjhvxpfxr7h7qd97yqyrf9i7viimbh99", + "registry+https://github.com/rust-lang/crates.io-index#k256@0.12.0": "15rk834ksg9jw96kh6hwiyv94i5qy6brw784rwmjcb5pyc7mx9cj", + "registry+https://github.com/rust-lang/crates.io-index#k256@0.13.3": "0ysq18pjz040am5llgly90464x7qqq98yxfbcsladq96gsvgjvwm", + "registry+https://github.com/rust-lang/crates.io-index#lazy_static@1.4.0": "0in6ikhw8mgl33wjv6q6xfrb5b9jr16q8ygjy803fay4zcisvaz2", + "registry+https://github.com/rust-lang/crates.io-index#libc@0.2.155": "0z44c53z54znna8n322k5iwg80arxxpdzjj5260pxxzc9a58icwp", + "registry+https://github.com/rust-lang/crates.io-index#libm@0.2.8": "0n4hk1rs8pzw8hdfmwn96c4568s93kfxqgcqswr7sajd2diaihjf", + "registry+https://github.com/rust-lang/crates.io-index#libsodium-sys@0.2.7": "1zcjka23grayr8kjrgbada6vwagp0kkni9m45v0gpbanrn3r6xvb", + "registry+https://github.com/rust-lang/crates.io-index#log@0.4.21": "074hldq1q8rlzq2s2qa8f25hj4s3gpw71w64vdwzjd01a4g8rvch", + "registry+https://github.com/rust-lang/crates.io-index#memchr@2.7.2": "07bcqxb0vx4ji0648ny5xsicjnpma95x1n07v7mi7jrhsz2l11kc", + "registry+https://github.com/rust-lang/crates.io-index#num-bigint-dig@0.8.4": "0lb12df24wgxxbspz4gw1sf1kdqwvpdcpwq4fdlwg4gj41c1k16w", + "registry+https://github.com/rust-lang/crates.io-index#num-integer@0.1.46": "13w5g54a9184cqlbsq80rnxw4jj4s0d8wv75jsq5r2lms8gncsbr", + "registry+https://github.com/rust-lang/crates.io-index#num-iter@0.1.45": "1gzm7vc5g9qsjjl3bqk9rz1h6raxhygbrcpbfl04swlh0i506a8l", + "registry+https://github.com/rust-lang/crates.io-index#num-traits@0.2.19": "0h984rhdkkqd4ny9cif7y2azl3xdfb7768hb9irhpsch4q3gq787", + "registry+https://github.com/rust-lang/crates.io-index#once_cell@1.19.0": "14kvw7px5z96dk4dwdm1r9cqhhy2cyj1l5n5b29mynbb8yr15nrz", + "registry+https://github.com/rust-lang/crates.io-index#p256@0.12.0": "0m8f1d0n69bvm4xpranhwv3nrvcq3lcfqn4cqsxbqhyfrfrj9ha9", + "registry+https://github.com/rust-lang/crates.io-index#p256@0.13.2": "0jyd3c3k239ybs59ixpnl7dqkmm072fr1js8kh7ldx58bzc3m1n9", + "registry+https://github.com/rust-lang/crates.io-index#p384@0.12.0": "1m6jw4zm5v9czk6ncbdzcdq82jsnby8a8qdfrz78wd0q4sdll2k3", + "registry+https://github.com/rust-lang/crates.io-index#p384@0.13.0": "02cjlxdvxwvhmnckqnydqpvrwhf5raj67q300d66m7y6pi8nyy3h", + "registry+https://github.com/rust-lang/crates.io-index#pem-rfc7468@0.6.0": "1b5d8rvc4lgwxhs72m99fnrg0wq7bqh4x4wq0c7501ci7a1mkl94", + "registry+https://github.com/rust-lang/crates.io-index#pem-rfc7468@0.7.0": "04l4852scl4zdva31c1z6jafbak0ni5pi0j38ml108zwzjdrrcw8", + "registry+https://github.com/rust-lang/crates.io-index#pkcs1@0.4.1": "06gpasl1v2d2r74xa8vm72vqy6ryxjynwxna5s5cjk65vzdkpwzg", + "registry+https://github.com/rust-lang/crates.io-index#pkcs8@0.10.2": "1dx7w21gvn07azszgqd3ryjhyphsrjrmq5mmz1fbxkj5g0vv4l7r", + "registry+https://github.com/rust-lang/crates.io-index#pkcs8@0.9.0": "1fm4sigvcd0zpzg9jcp862a8p272kk08b9lgcs1dm1az19cjrjly", + "registry+https://github.com/rust-lang/crates.io-index#pkg-config@0.3.30": "1v07557dj1sa0aly9c90wsygc0i8xv5vnmyv0g94lpkvj8qb4cfj", + "registry+https://github.com/rust-lang/crates.io-index#ppv-lite86@0.2.17": "1pp6g52aw970adv3x2310n7glqnji96z0a9wiamzw89ibf0ayh2v", + "registry+https://github.com/rust-lang/crates.io-index#primeorder@0.12.1": "1cn5lh5pb1g7x9l0cq888qp6im36bg95pkqlyji6bfix3c9zfm0b", + "registry+https://github.com/rust-lang/crates.io-index#primeorder@0.13.6": "1rp16710mxksagcjnxqjjq9r9wf5vf72fs8wxffnvhb6i6hiqgim", + "registry+https://github.com/rust-lang/crates.io-index#proc-macro2@1.0.84": "1mj998115z75c0007glkdr8qj57ibv82h7kg6r8hnc914slwd5pc", + "registry+https://github.com/rust-lang/crates.io-index#quote@1.0.36": "19xcmh445bg6simirnnd4fvkmp6v2qiwxh5f6rw4a70h76pnm9qg", + "registry+https://github.com/rust-lang/crates.io-index#rand@0.8.5": "013l6931nn7gkc23jz5mm3qdhf93jjf0fg64nz2lp4i51qd8vbrl", + "registry+https://github.com/rust-lang/crates.io-index#rand_chacha@0.3.1": "123x2adin558xbhvqb8w4f6syjsdkmqff8cxwhmjacpsl1ihmhg6", + "registry+https://github.com/rust-lang/crates.io-index#rand_core@0.6.4": "0b4j2v4cb5krak1pv6kakv4sz6xcwbrmy2zckc32hsigbrwy82zc", + "registry+https://github.com/rust-lang/crates.io-index#regex-automata@0.4.6": "1spaq7y4im7s56d1gxa2hi4hzf6dwswb1bv8xyavzya7k25kpf46", + "registry+https://github.com/rust-lang/crates.io-index#regex-syntax@0.8.3": "0mhzkm1pkqg6y53xv056qciazlg47pq0czqs94cn302ckvi49bdd", + "registry+https://github.com/rust-lang/crates.io-index#regex@1.10.4": "0k5sb0h2mkwf51ab0gvv3x38jp1q7wgxf63abfbhi0wwvvgxn5y1", + "registry+https://github.com/rust-lang/crates.io-index#rfc6979@0.3.1": "1fzsp705b5lhwd2r9il9grc3lj6rm3b2r89vh0xv181gy5xg2hvp", + "registry+https://github.com/rust-lang/crates.io-index#rfc6979@0.4.0": "1chw95jgcfrysyzsq6a10b1j5qb7bagkx8h0wda4lv25in02mpgq", + "registry+https://github.com/rust-lang/crates.io-index#rsa@0.7.2": "1709a7gcb2h4r95qyrkdz8nz3jb8k4hafj5q3ibfzg0c8zam4h09", + "registry+https://github.com/rust-lang/crates.io-index#rustc-serialize@0.3.25": "00c494bsxjqjvc15h9x2nkgwl6bjdp9bmb9v0xs4ckv0h33lp0zy", + "registry+https://github.com/rust-lang/crates.io-index#ryu@1.0.18": "17xx2s8j1lln7iackzd9p0sv546vjq71i779gphjq923vjh5pjzk", + "registry+https://github.com/rust-lang/crates.io-index#same-file@1.0.6": "00h5j1w87dmhnvbv9l8bic3y7xxsnjmssvifw2ayvgx9mb1ivz4k", + "registry+https://github.com/rust-lang/crates.io-index#sec1@0.3.0": "0a09lk5w3nyggpyz54m10nnlg9v8qbh6kw3v1bgla31988c4rqiv", + "registry+https://github.com/rust-lang/crates.io-index#sec1@0.7.3": "1p273j8c87pid6a1iyyc7vxbvifrw55wbxgr0dh3l8vnbxb7msfk", + "registry+https://github.com/rust-lang/crates.io-index#serde@1.0.203": "1500ghq198n6py5anvz5qbqagd9h1hq04f4qpsvjzrvix56snlvj", + "registry+https://github.com/rust-lang/crates.io-index#serde_derive@1.0.203": "1fmmqmfza3mwxb1v80737dj01gznrh8mhgqgylkndx5npq7bq32h", + "registry+https://github.com/rust-lang/crates.io-index#serde_json@1.0.117": "1hxziifjlc0kn1cci9d4crmjc7qwnfi20lxwyj9lzca2c7m84la5", + "registry+https://github.com/rust-lang/crates.io-index#sha2@0.10.8": "1j1x78zk9il95w9iv46dh9wm73r6xrgj32y6lzzw7bxws9dbfgbr", + "registry+https://github.com/rust-lang/crates.io-index#signature@1.6.4": "0z3xg405pg827g6hfdprnszsdqkkbrsfx7f1dl04nv9g7cxks8vl", + "registry+https://github.com/rust-lang/crates.io-index#signature@2.0.0": "0zg534qaa8cl5spq8d0rs0jq6km4w9vil69148awiy9khg4mir4g", + "registry+https://github.com/rust-lang/crates.io-index#smallvec@1.13.2": "0rsw5samawl3wsw6glrsb127rx6sh89a8wyikicw6dkdcjd1lpiw", + "registry+https://github.com/rust-lang/crates.io-index#sodiumoxide@0.2.7": "0a00rcp2vphrs8qh0477rzs6lhsng1m5i0l4qamagnf2nsnf6sz2", + "registry+https://github.com/rust-lang/crates.io-index#spin@0.5.2": "0b84m6dbzrwf2kxylnw82d3dr8w06av7rfkr8s85fb5f43rwyqvf", + "registry+https://github.com/rust-lang/crates.io-index#spki@0.6.0": "0ar1ldkl7svp8l3gfw2hyiiph7n2nqynjnjgdv1pscvsmjxh5kv7", + "registry+https://github.com/rust-lang/crates.io-index#spki@0.7.3": "17fj8k5fmx4w9mp27l970clrh5qa7r5sjdvbsln987xhb34dc7nr", + "registry+https://github.com/rust-lang/crates.io-index#subtle@2.5.0": "1g2yjs7gffgmdvkkq0wrrh0pxds3q0dv6dhkw9cdpbib656xdkc1", + "registry+https://github.com/rust-lang/crates.io-index#syn@2.0.66": "1xfgrprsbz8j31kabvfinb4fyhajlk2q7lxa18fb006yl90kyby4", + "registry+https://github.com/rust-lang/crates.io-index#thiserror-impl@1.0.61": "0cvm37hp0kbcyk1xac1z0chpbd9pbn2g456iyid6sah0a113ihs6", + "registry+https://github.com/rust-lang/crates.io-index#thiserror@1.0.61": "028prh962l16cmjivwb1g9xalbpqip0305zhq006mg74dc6whin5", + "registry+https://github.com/rust-lang/crates.io-index#typenum@1.17.0": "09dqxv69m9lj9zvv6xw5vxaqx15ps0vxyy5myg33i0kbqvq0pzs2", + "registry+https://github.com/rust-lang/crates.io-index#unicode-ident@1.0.12": "0jzf1znfpb2gx8nr8mvmyqs1crnv79l57nxnbiszc7xf7ynbjm1k", + "registry+https://github.com/rust-lang/crates.io-index#version_check@0.9.4": "0gs8grwdlgh0xq660d7wr80x14vxbizmd8dbp29p2pdncx8lp1s9", + "registry+https://github.com/rust-lang/crates.io-index#walkdir@2.5.0": "0jsy7a710qv8gld5957ybrnc07gavppp963gs32xk4ag8130jy99", + "registry+https://github.com/rust-lang/crates.io-index#wasi@0.11.0+wasi-snapshot-preview1": "08z4hxwkpdpalxjps1ai9y7ihin26y9f476i53dv98v45gkqg3cw", + "registry+https://github.com/rust-lang/crates.io-index#wasix@0.12.21": "0v9wb03ddbnas75005l2d63bdqy9mclds00b1qbw385wkgpv9yy1", + "registry+https://github.com/rust-lang/crates.io-index#wasm-bindgen-backend@0.2.92": "1nj7wxbi49f0rw9d44rjzms26xlw6r76b2mrggx8jfbdjrxphkb1", + "registry+https://github.com/rust-lang/crates.io-index#wasm-bindgen-macro-support@0.2.92": "1dqv2xs8zcyw4kjgzj84bknp2h76phmsb3n7j6hn396h4ssifkz9", + "registry+https://github.com/rust-lang/crates.io-index#wasm-bindgen-macro@0.2.92": "09npa1srjjabd6nfph5yc03jb26sycjlxhy0c2a1pdrpx4yq5y51", + "registry+https://github.com/rust-lang/crates.io-index#wasm-bindgen-shared@0.2.92": "15kyavsrna2cvy30kg03va257fraf9x00ny554vxngvpyaa0q6dg", + "registry+https://github.com/rust-lang/crates.io-index#wasm-bindgen@0.2.92": "1a4mcw13nsk3fr8fxjzf9kk1wj88xkfsmnm0pjraw01ryqfm7qjb", + "registry+https://github.com/rust-lang/crates.io-index#winapi-util@0.1.8": "0svcgddd2rw06mj4r76gj655qsa1ikgz3d3gzax96fz7w62c6k2d", + "registry+https://github.com/rust-lang/crates.io-index#windows-sys@0.52.0": "0gd3v4ji88490zgb6b5mq5zgbvwv7zx1ibn8v3x83rwcdbryaar8", + "registry+https://github.com/rust-lang/crates.io-index#windows-targets@0.52.5": "1sz7jrnkygmmlj1ia8fk85wbyil450kq5qkh5qh9sh2rcnj161vg", + "registry+https://github.com/rust-lang/crates.io-index#windows_aarch64_gnullvm@0.52.5": "0qrjimbj67nnyn7zqy15mzzmqg0mn5gsr2yciqjxm3cb3vbyx23h", + "registry+https://github.com/rust-lang/crates.io-index#windows_aarch64_msvc@0.52.5": "1dmga8kqlmln2ibckk6mxc9n59vdg8ziqa2zr8awcl720hazv1cr", + "registry+https://github.com/rust-lang/crates.io-index#windows_i686_gnu@0.52.5": "0w4np3l6qwlra9s2xpflqrs60qk1pz6ahhn91rr74lvdy4y0gfl8", + "registry+https://github.com/rust-lang/crates.io-index#windows_i686_gnullvm@0.52.5": "1s9f4gff0cixd86mw3n63rpmsm4pmr4ffndl6s7qa2h35492dx47", + "registry+https://github.com/rust-lang/crates.io-index#windows_i686_msvc@0.52.5": "1gw7fklxywgpnwbwg43alb4hm0qjmx72hqrlwy5nanrxs7rjng6v", + "registry+https://github.com/rust-lang/crates.io-index#windows_x86_64_gnu@0.52.5": "1n8p2mcf3lw6300k77a0knksssmgwb9hynl793mhkzyydgvlchjf", + "registry+https://github.com/rust-lang/crates.io-index#windows_x86_64_gnullvm@0.52.5": "15n56jrh4s5bz66zimavr1rmcaw6wa306myrvmbc6rydhbj9h8l5", + "registry+https://github.com/rust-lang/crates.io-index#windows_x86_64_msvc@0.52.5": "1w1bn24ap8dp9i85s8mlg8cim2bl2368bd6qyvm0xzqvzmdpxi5y", + "registry+https://github.com/rust-lang/crates.io-index#zeroize@1.8.1": "1pjdrmjwmszpxfd7r860jx54cyk94qk59x13sc307cvr5256glyf" } \ No newline at end of file diff --git a/libs/metrics-core/default.nix b/libs/metrics-core/default.nix index f3eab69051a..b7e369144f6 100644 --- a/libs/metrics-core/default.nix +++ b/libs/metrics-core/default.nix @@ -4,16 +4,12 @@ # dependencies are added or removed. { mkDerivation , base -, containers , gitignoreSource -, hashable , immortal , imports , lib , prometheus-client -, text , time -, unordered-containers }: mkDerivation { pname = "metrics-core"; @@ -21,14 +17,10 @@ mkDerivation { src = gitignoreSource ./.; libraryHaskellDepends = [ base - containers - hashable immortal imports prometheus-client - text time - unordered-containers ]; description = "Metrics core"; license = lib.licenses.agpl3Only; diff --git a/libs/metrics-core/metrics-core.cabal b/libs/metrics-core/metrics-core.cabal index 278c23d2a84..67ef9011baa 100644 --- a/libs/metrics-core/metrics-core.cabal +++ b/libs/metrics-core/metrics-core.cabal @@ -12,7 +12,6 @@ build-type: Simple library exposed-modules: - Data.Metrics Data.Metrics.AWS Data.Metrics.GC @@ -66,14 +65,10 @@ library -Wredundant-constraints -Wunused-packages build-depends: - base >=4.9 - , containers - , hashable >=1.2 + base >=4.9 , immortal , imports , prometheus-client - , text >=0.11 , time - , unordered-containers >=0.2 default-language: GHC2021 diff --git a/libs/metrics-core/src/Data/Metrics.hs b/libs/metrics-core/src/Data/Metrics.hs deleted file mode 100644 index 1a7c1726183..00000000000 --- a/libs/metrics-core/src/Data/Metrics.hs +++ /dev/null @@ -1,295 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} - --- 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.Metrics - ( -- * Types - Path, - Metrics, - Histogram, - Counter, - Gauge, - - -- * Counters - counterGet, - counterAdd, - counterIncr, - counterValue, - - -- * Gauges - gaugeGet, - gaugeAdd, - gaugeSub, - gaugeIncr, - gaugeDecr, - gaugeSet, - gaugeValue, - - -- * Histograms - - -- ** Types - HistogramInfo, - Buckets, - Bucket, - - -- ** Describing Histograms - linearHistogram, - customHistogram, - - -- ** Manipulating Histograms - histoGet, - histoSubmit, - histoValue, - histoTimeAction, - - -- * Helper functions - path, - metrics, - ) -where - -import Data.HashMap.Strict qualified as HM -import Data.Hashable -import Data.Map.Strict qualified as M -import Data.Text qualified as T -import Imports hiding (lookup, union) -import Prometheus qualified as P - --- | Internal Counter type -newtype Counter = Counter P.Counter - --- | Internal Gauge type -newtype Gauge = Gauge P.Gauge - --- | Internal Histogram type -newtype Histogram = Histogram P.Histogram - --- | Represents a descriptive metric path or name. --- --- NOTE: Until all metrics are fully migrated to Prometheus this should be a valid --- name according to collectd; e.g. @net.resources./teams/invitations/info@ --- All names are converted into valid prometheus names when needed via 'toInfo' -newtype Path = Path - { _path :: Text - } - deriving (Eq, Show, Hashable, Semigroup, Monoid) - --- | Create a path -path :: Text -> Path -path = Path - --- | Opaque storage of metrics -data Metrics = Metrics - { counters :: IORef (HashMap Path Counter), - gauges :: IORef (HashMap Path Gauge), - histograms :: IORef (HashMap Path Histogram) - } - deriving (Generic) - --- Initialize an empty set of metrics -metrics :: MonadIO m => m Metrics -metrics = - liftIO $ - Metrics - <$> newIORef HM.empty - <*> newIORef HM.empty - <*> newIORef HM.empty - --- | Converts a CollectD style 'path' to a Metric name usable by prometheus --- This is to provide back compatibility with the previous collect-d metric names --- which often had paths and dot-separated names. --- --- See the spec for valid prometheus names: --- https://prometheus.io/docs/concepts/data_model/ --- --- E.g. we sanitize a metric name like "net.resources._conversations_:cnv-members_:usr.DELETE.time.960" --- into: "net_resources_conversations_:cnv_members_:usr_delete_time_960" -toInfo :: Path -> P.Info -toInfo (Path p) = - P.Info - ( p - & T.map sanitize - & ensureValidStartingChar - & collapseMultipleUnderscores - & T.toLower - ) - "description not provided" - where - ensureValidStartingChar :: Text -> Text - ensureValidStartingChar = T.dropWhile (not . validStartingChar) - validStartingChar :: Char -> Bool - validStartingChar c = isAlpha c || c `elem` ['_', ':'] - collapseMultipleUnderscores :: Text -> Text - collapseMultipleUnderscores = T.intercalate "_" . filter (not . T.null) . T.splitOn "_" - sanitize :: Char -> Char - sanitize ':' = ':' - sanitize c - | isAlphaNum c = c - | otherwise = '_' - --- | Checks whether a given key exists in a mutable hashmap (i.e. one inside an IORef) --- If it exists it is returned, if it does not then one is initialized using the provided --- initializer, then stored, then returned. -getOrCreate :: (MonadIO m, Hashable k) => IORef (HashMap k v) -> k -> IO v -> m v -getOrCreate mapRef key initializer = liftIO $ do - hMap <- readIORef mapRef - maybe initialize pure (HM.lookup key hMap) - where - initialize = do - val <- initializer - atomicModifyIORef' mapRef $ \m -> (HM.insert key val m, val) - ------------------------------------------------------------------------------ --- Counter specifics - --- | Create a counter for a 'Path' -newCounter :: Path -> IO Counter -newCounter p = Counter <$> P.register (P.counter $ toInfo p) - --- | Access the counter for a given 'Path' -counterGet :: MonadIO m => Path -> Metrics -> m Counter -counterGet p m = getOrCreate (counters m) p (newCounter p) - --- | Add the given amount to the counter at 'Path' -counterAdd :: MonadIO m => Double -> Path -> Metrics -> m () -counterAdd x p m = liftIO $ do - Counter c <- counterGet p m - void $ P.addCounter c x - --- | Add 1 to the counter at 'Path' -counterIncr :: MonadIO m => Path -> Metrics -> m () -counterIncr = counterAdd 1 - --- | Get the current value of the Counter -counterValue :: MonadIO m => Counter -> m Double -counterValue (Counter c) = P.getCounter c - ------------------------------------------------------------------------------ --- Gauge specifics - --- | Create a gauge for a 'Path' -newGauge :: Path -> IO Gauge -newGauge p = Gauge <$> P.register (P.gauge $ toInfo p) - --- | Access the gauge for a given 'Path' -gaugeGet :: MonadIO m => Path -> Metrics -> m Gauge -gaugeGet p m = getOrCreate (gauges m) p (newGauge p) - --- | Set the 'Gauge' at 'Path' to the given value -gaugeSet :: MonadIO m => Double -> Path -> Metrics -> m () -gaugeSet x p m = liftIO $ do - Gauge g <- gaugeGet p m - P.setGauge g x - --- | Add the given amount to the gauge at 'Path' -gaugeAdd :: MonadIO m => Double -> Path -> Metrics -> m () -gaugeAdd x p m = liftIO $ do - Gauge g <- gaugeGet p m - P.addGauge g x - --- | Add 1 to the gauge at 'Path' -gaugeIncr :: MonadIO m => Path -> Metrics -> m () -gaugeIncr = gaugeAdd 1 - --- | Subtract 1 from the gauge at 'Path' -gaugeDecr :: MonadIO m => Path -> Metrics -> m () -gaugeDecr = gaugeAdd (-1) - --- | Subtract the given amount from the gauge at 'Path' -gaugeSub :: MonadIO m => Double -> Path -> Metrics -> m () -gaugeSub x = gaugeAdd (-x) - --- | Get the current value of the Gauge -gaugeValue :: MonadIO m => Gauge -> m Double -gaugeValue (Gauge g) = liftIO $ P.getGauge g - ------------------------------------------------------------------------------ --- Histogram specifics - --- | A marker of a bucketing point -type Bucket = Double - --- | Description of discrete buckets which histogram samples will be allocated into -type Buckets = [Bucket] - --- | Describes a histogram metric -data HistogramInfo = HistogramInfo - { hiPath :: Path, - hiBuckets :: Buckets - } - deriving (Eq, Show) - -type RangeStart = Double - -type RangeEnd = Double - -type BucketWidth = Double - --- | Creates a 'HistogramInfo' which has evenly sized buckets of the given 'BucketWidth' --- between 'RangeStart' and 'RangeEnd' -linearHistogram :: Path -> RangeStart -> RangeEnd -> BucketWidth -> HistogramInfo -linearHistogram pth start end width = - HistogramInfo - { hiPath = pth, - hiBuckets = buckets - } - where - count :: Int - count = ceiling $ (end - start) / width - buckets :: Buckets - buckets = P.linearBuckets start width count - --- | Construct a histogram using a given list of buckets. --- It's recommended that you use 'linearHistogram' instead when possible. -customHistogram :: Path -> Buckets -> HistogramInfo -customHistogram pth buckets = HistogramInfo {hiPath = pth, hiBuckets = buckets} - --- | Create a histo for a 'HistogramInfo' -newHisto :: HistogramInfo -> IO Histogram -newHisto HistogramInfo {hiPath, hiBuckets} = - Histogram <$> P.register (P.histogram (toInfo hiPath) hiBuckets) - --- | Access the histogram for a given 'HistogramInfo' -histoGet :: - MonadIO m => - HistogramInfo -> - Metrics -> - m Histogram -histoGet hi@HistogramInfo {hiPath} m = getOrCreate (histograms m) hiPath (newHisto hi) - --- | Get the current distribution of a Histogram -histoValue :: MonadIO m => Histogram -> m (M.Map Bucket Int) -histoValue (Histogram histo) = liftIO $ P.getHistogram histo - --- | Report an individual value to be bucketed in the histogram -histoSubmit :: MonadIO m => Double -> HistogramInfo -> Metrics -> m () -histoSubmit val hi m = liftIO $ do - Histogram h <- histoGet hi m - P.observe h val - --- | Execute and time the provided monadic action and submit it as an entry --- to the provided Histogram metric. --- --- NOTE: If the action throws an exception it will NOT be reported. --- This is particularly relevant for web handlers which signal their response --- with an exception. -histoTimeAction :: (P.MonadMonitor m, MonadIO m) => HistogramInfo -> Metrics -> m a -> m a -histoTimeAction hi m act = do - Histogram h <- histoGet hi m - P.observeDuration h act diff --git a/libs/metrics-core/src/Data/Metrics/AWS.hs b/libs/metrics-core/src/Data/Metrics/AWS.hs index 7ff710f229c..437ad2f0628 100644 --- a/libs/metrics-core/src/Data/Metrics/AWS.hs +++ b/libs/metrics-core/src/Data/Metrics/AWS.hs @@ -16,14 +16,24 @@ module Data.Metrics.AWS (gaugeTokenRemaing) where -import Data.Metrics (Metrics, gaugeSet, path) import Data.Time import Imports +import Prometheus qualified as Prom -gaugeTokenRemaing :: Metrics -> Maybe NominalDiffTime -> IO () -gaugeTokenRemaing m mbRemaining = do +gaugeTokenRemaing :: Maybe NominalDiffTime -> IO () +gaugeTokenRemaing mbRemaining = do let t = toSeconds (fromMaybe 0 mbRemaining) - gaugeSet t (path "aws_auth.token_secs_remaining") m + Prom.setGauge awsAuthTokenSecsRemaining t where toSeconds :: NominalDiffTime -> Double toSeconds = fromRational . toRational + +{-# NOINLINE awsAuthTokenSecsRemaining #-} +awsAuthTokenSecsRemaining :: Prom.Gauge +awsAuthTokenSecsRemaining = + Prom.unsafeRegister $ + Prom.gauge + Prom.Info + { Prom.metricName = "aws_auth.token_secs_remaining", + Prom.metricHelp = "Number of seconds left before AWS Auth expires" + } diff --git a/libs/metrics-wai/default.nix b/libs/metrics-wai/default.nix index eb65cf447ae..eb3a260e929 100644 --- a/libs/metrics-wai/default.nix +++ b/libs/metrics-wai/default.nix @@ -9,10 +9,8 @@ , gitignoreSource , hspec , hspec-discover -, http-types , imports , lib -, metrics-core , servant , servant-multipart , text @@ -30,9 +28,7 @@ mkDerivation { base bytestring containers - http-types imports - metrics-core servant servant-multipart text diff --git a/libs/metrics-wai/metrics-wai.cabal b/libs/metrics-wai/metrics-wai.cabal index 3d9725348fe..ed848c893cb 100644 --- a/libs/metrics-wai/metrics-wai.cabal +++ b/libs/metrics-wai/metrics-wai.cabal @@ -12,7 +12,6 @@ build-type: Simple library exposed-modules: - Data.Metrics.Middleware Data.Metrics.Middleware.Prometheus Data.Metrics.Servant Data.Metrics.Test @@ -73,9 +72,7 @@ library base >=4 && <5 , bytestring >=0.10 , containers - , http-types >=0.8 , imports - , metrics-core >=0.3 , servant , servant-multipart , text >=0.11 diff --git a/libs/metrics-wai/src/Data/Metrics/Middleware.hs b/libs/metrics-wai/src/Data/Metrics/Middleware.hs deleted file mode 100644 index a65c902d6ff..00000000000 --- a/libs/metrics-wai/src/Data/Metrics/Middleware.hs +++ /dev/null @@ -1,80 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- 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 . - --- | FUTUREWORK: use package wai-middleware-prometheus instead and deprecate collectd? -module Data.Metrics.Middleware - ( PathTemplate, - Paths, - withPathTemplate, - requestCounter, - module Data.Metrics, - ) -where - -import Data.Metrics -import Data.Metrics.Types -import Data.Text qualified as T -import Data.Text.Encoding qualified as T -import Imports -import Network.HTTP.Types -import Network.Wai -import Network.Wai.Internal (Response (ResponseRaw)) -import Network.Wai.Route.Tree qualified as Tree - -withPathTemplate :: Paths -> (PathTemplate -> Middleware) -> Middleware -withPathTemplate t f app r k = f (fromMaybe def tmp) app r k - where - def = PathTemplate "N/A" - tmp = - PathTemplate - . T.decodeUtf8 - <$> treeLookup t (Tree.segments $ rawPathInfo r) - --- Count Requests and their status code. --- --- [Note [Raw Response]]: --- --- We ignore the status code of raw responses which are returned after --- websocket communication ends because there is no meaningful status code --- to ask for. WAI uses the fallback response status code (i.e. 500) which --- is only used in servers which do not support raw responses (i.e. not --- Warp). -requestCounter :: Metrics -> PathTemplate -> Middleware -requestCounter m (PathTemplate t) f rq k = f rq onResponse - where - onResponse rs@(ResponseRaw _ _) = do - -- See Note [Raw Response] - counterIncr (path "net.requests") m - k rs - onResponse rs = do - counterIncr (path "net.requests") m - counterIncr (mkPath [t, methodName rq, "status", code rs]) m - k rs - -mkPath :: [Text] -> Path -mkPath = path . mconcat . intersperse "." . ("net.resources" :) -{-# INLINE mkPath #-} - -code :: Response -> Text -code = T.pack . show . statusCode . responseStatus -{-# INLINE code #-} - -methodName :: Request -> Text -methodName = T.decodeUtf8 . requestMethod -{-# INLINE methodName #-} diff --git a/libs/metrics-wai/src/Data/Metrics/Middleware/Prometheus.hs b/libs/metrics-wai/src/Data/Metrics/Middleware/Prometheus.hs index c9806e60788..f1f7c1ca562 100644 --- a/libs/metrics-wai/src/Data/Metrics/Middleware/Prometheus.hs +++ b/libs/metrics-wai/src/Data/Metrics/Middleware/Prometheus.hs @@ -32,7 +32,7 @@ import Network.Wai.Routing.Route (Routes, prepare) -- | Adds a prometheus metrics endpoint at @/i/metrics@ -- This middleware requires your servers 'Routes' because it does some normalization -- (e.g. removing params from calls) -waiPrometheusMiddleware :: Monad m => Routes a m b -> Wai.Middleware +waiPrometheusMiddleware :: (Monad m) => Routes a m b -> Wai.Middleware waiPrometheusMiddleware routes = Promth.prometheus conf . instrument (normalizeWaiRequestRoute paths) where diff --git a/libs/metrics-wai/src/Data/Metrics/Servant.hs b/libs/metrics-wai/src/Data/Metrics/Servant.hs index b8ec0984997..6d1df7d26ff 100644 --- a/libs/metrics-wai/src/Data/Metrics/Servant.hs +++ b/libs/metrics-wai/src/Data/Metrics/Servant.hs @@ -77,7 +77,7 @@ conf = Promth.prometheusInstrumentApp = False } -routesToPaths :: forall routes. RoutesToPaths routes => Paths +routesToPaths :: forall routes. (RoutesToPaths routes) => Paths routesToPaths = Paths (meltTree (getRoutes @routes)) class RoutesToPaths routes where @@ -122,19 +122,19 @@ instance getRoutes = getRoutes @rest instance - RoutesToPaths rest => + (RoutesToPaths rest) => RoutesToPaths (QueryParam' mods name a :> rest) where getRoutes = getRoutes @rest -instance RoutesToPaths rest => RoutesToPaths (MultipartForm tag a :> rest) where +instance (RoutesToPaths rest) => RoutesToPaths (MultipartForm tag a :> rest) where getRoutes = getRoutes @rest -instance RoutesToPaths api => RoutesToPaths (QueryFlag a :> api) where +instance (RoutesToPaths api) => RoutesToPaths (QueryFlag a :> api) where getRoutes = getRoutes @api instance - RoutesToPaths rest => + (RoutesToPaths rest) => RoutesToPaths (Description desc :> rest) where getRoutes = getRoutes @rest diff --git a/libs/metrics-wai/src/Data/Metrics/WaiRoute.hs b/libs/metrics-wai/src/Data/Metrics/WaiRoute.hs index cd8a993c2cb..b4ca4c01ded 100644 --- a/libs/metrics-wai/src/Data/Metrics/WaiRoute.hs +++ b/libs/metrics-wai/src/Data/Metrics/WaiRoute.hs @@ -25,5 +25,5 @@ import Data.Metrics.Types import Imports import Network.Wai.Route.Tree as Tree -treeToPaths :: HasCallStack => Tree a -> Paths +treeToPaths :: (HasCallStack) => Tree a -> Paths treeToPaths = either error id . mkTree . fmap (Tree.segments . path) . Tree.toList diff --git a/libs/polysemy-wire-zoo/src/Wire/Sem/Concurrency.hs b/libs/polysemy-wire-zoo/src/Wire/Sem/Concurrency.hs index 29ac503809d..8cdf9f6600a 100644 --- a/libs/polysemy-wire-zoo/src/Wire/Sem/Concurrency.hs +++ b/libs/polysemy-wire-zoo/src/Wire/Sem/Concurrency.hs @@ -40,13 +40,13 @@ data ConcurrencySafety = Safe | Unsafe type Concurrency :: ConcurrencySafety -> (Type -> Type) -> Type -> Type data Concurrency (safe :: ConcurrencySafety) m a where UnsafePooledMapConcurrentlyN :: - Foldable t => + (Foldable t) => Int -> (a -> m b) -> t a -> Concurrency safe m [b] UnsafePooledMapConcurrentlyN_ :: - Foldable t => + (Foldable t) => Int -> (a -> m b) -> t a -> @@ -108,7 +108,7 @@ unsafePooledForConcurrentlyN_ n as f = pooledMapConcurrentlyN :: forall r' r t a b. - r' ~ '[Final IO] => + (r' ~ '[Final IO]) => (Member (Concurrency 'Safe) r, Subsume r' r, Foldable t) => -- | Max. number of threads. Should not be less than 1. Int -> @@ -124,7 +124,7 @@ pooledMapConcurrentlyN n f as = pooledMapConcurrentlyN_ :: forall r' r t a b. - r' ~ '[Final IO] => + (r' ~ '[Final IO]) => (Member (Concurrency 'Safe) r, Subsume r' r, Foldable t) => -- | Max. number of threads. Should not be less than 1. Int -> @@ -140,7 +140,7 @@ pooledMapConcurrentlyN_ n f as = pooledForConcurrentlyN :: forall r' r t a b. - r' ~ '[Final IO] => + (r' ~ '[Final IO]) => (Member (Concurrency 'Safe) r, Subsume r' r, Foldable t) => -- | Max. number of threads. Should not be less than 1. Int -> @@ -156,7 +156,7 @@ pooledForConcurrentlyN n as f = pooledForConcurrentlyN_ :: forall r' r t a b. - r' ~ '[Final IO] => + (r' ~ '[Final IO]) => (Member (Concurrency 'Safe) r, Subsume r' r, Foldable t) => -- | Max. number of threads. Should not be less than 1. Int -> diff --git a/libs/polysemy-wire-zoo/src/Wire/Sem/Concurrency/IO.hs b/libs/polysemy-wire-zoo/src/Wire/Sem/Concurrency/IO.hs index d5887bce411..471a0c75512 100644 --- a/libs/polysemy-wire-zoo/src/Wire/Sem/Concurrency/IO.hs +++ b/libs/polysemy-wire-zoo/src/Wire/Sem/Concurrency/IO.hs @@ -10,7 +10,7 @@ import Wire.Sem.Concurrency (Concurrency (..), ConcurrencySafety (Safe)) -- | Safely perform concurrency that wraps only IO effects. performConcurrency :: - Member (Final IO) r => + (Member (Final IO) r) => Sem (Concurrency 'Safe ': r) a -> Sem r a performConcurrency = unsafelyPerformConcurrency @@ -21,7 +21,7 @@ performConcurrency = unsafelyPerformConcurrency -- obscure bugs. See the notes on 'Concurrency' to get a better understanding -- of what can go wrong here. unsafelyPerformConcurrency :: - Member (Final IO) r => + (Member (Final IO) r) => Sem (Concurrency safe ': r) a -> Sem r a unsafelyPerformConcurrency = interpretFinal @IO $ \case diff --git a/libs/polysemy-wire-zoo/src/Wire/Sem/Delay.hs b/libs/polysemy-wire-zoo/src/Wire/Sem/Delay.hs index 7b1395b8ed0..00e6457d08c 100644 --- a/libs/polysemy-wire-zoo/src/Wire/Sem/Delay.hs +++ b/libs/polysemy-wire-zoo/src/Wire/Sem/Delay.hs @@ -10,7 +10,7 @@ data Delay m a where makeSem ''Delay -runDelay :: Member (Embed IO) r => Sem (Delay ': r) a -> Sem r a +runDelay :: (Member (Embed IO) r) => Sem (Delay ': r) a -> Sem r a runDelay = interpret $ \case Delay i -> threadDelay i diff --git a/libs/polysemy-wire-zoo/src/Wire/Sem/Jwk.hs b/libs/polysemy-wire-zoo/src/Wire/Sem/Jwk.hs index 913e5cbf7b7..6ce9454879f 100644 --- a/libs/polysemy-wire-zoo/src/Wire/Sem/Jwk.hs +++ b/libs/polysemy-wire-zoo/src/Wire/Sem/Jwk.hs @@ -15,7 +15,7 @@ data Jwk m a where makeSem ''Jwk -interpretJwk :: Members '[Embed IO] r => Sem (Jwk ': r) a -> Sem r a +interpretJwk :: (Members '[Embed IO] r) => Sem (Jwk ': r) a -> Sem r a interpretJwk = interpret $ \(Get fp) -> liftIO $ readJwk fp readJwk :: FilePath -> IO (Maybe JWK) diff --git a/libs/polysemy-wire-zoo/src/Wire/Sem/Logger.hs b/libs/polysemy-wire-zoo/src/Wire/Sem/Logger.hs index 8a3f96560c6..ff619d5a1cb 100644 --- a/libs/polysemy-wire-zoo/src/Wire/Sem/Logger.hs +++ b/libs/polysemy-wire-zoo/src/Wire/Sem/Logger.hs @@ -33,22 +33,22 @@ data Logger msg m a where -- TODO(sandy): Inline this definition --- no TH makeSem ''Logger -trace :: Member (Logger msg) r => msg -> Sem r () +trace :: (Member (Logger msg) r) => msg -> Sem r () trace = log Trace -debug :: Member (Logger msg) r => msg -> Sem r () +debug :: (Member (Logger msg) r) => msg -> Sem r () debug = log Debug -info :: Member (Logger msg) r => msg -> Sem r () +info :: (Member (Logger msg) r) => msg -> Sem r () info = log Info -warn :: Member (Logger msg) r => msg -> Sem r () +warn :: (Member (Logger msg) r) => msg -> Sem r () warn = log Warn -err :: Member (Logger msg) r => msg -> Sem r () +err :: (Member (Logger msg) r) => msg -> Sem r () err = log Error -fatal :: Member (Logger msg) r => msg -> Sem r () +fatal :: (Member (Logger msg) r) => msg -> Sem r () fatal = log Fatal -------------------------------------------------------------------------------- @@ -56,7 +56,7 @@ fatal = log Fatal mapLogger :: forall msg msg' r a. - Member (Logger msg') r => + (Member (Logger msg') r) => (msg -> msg') -> Sem (Logger msg ': r) a -> Sem r a diff --git a/libs/polysemy-wire-zoo/src/Wire/Sem/Logger/TinyLog.hs b/libs/polysemy-wire-zoo/src/Wire/Sem/Logger/TinyLog.hs index a7b63f7fe7d..231485fe45c 100644 --- a/libs/polysemy-wire-zoo/src/Wire/Sem/Logger/TinyLog.hs +++ b/libs/polysemy-wire-zoo/src/Wire/Sem/Logger/TinyLog.hs @@ -38,7 +38,7 @@ import Wire.Sem.Logger import Wire.Sem.Logger.Level loggerToTinyLog :: - Member (Embed IO) r => + (Member (Embed IO) r) => Log.Logger -> Sem (Logger (Log.Msg -> Log.Msg) ': r) a -> Sem r a @@ -48,18 +48,17 @@ loggerToTinyLog tinylog = interpret $ \case -- | Log the request ID along with the message loggerToTinyLogReqId :: - Member (Embed IO) r => + (Member (Embed IO) r) => RequestId -> Log.Logger -> - Sem (Logger (Log.Msg -> Log.Msg) ': r) a -> + Sem (TinyLog ': r) a -> Sem r a loggerToTinyLogReqId r tinylog = loggerToTinyLog tinylog - . mapLogger - (Log.field "request" (unRequestId r) Log.~~) - . raise @(Logger (Log.Msg -> Log.Msg)) + . mapLogger (Log.field "request" (unRequestId r) .) + . raiseUnder @TinyLog -stringLoggerToTinyLog :: Member (Logger (Log.Msg -> Log.Msg)) r => Sem (Logger String ': r) a -> Sem r a +stringLoggerToTinyLog :: (Member (Logger (Log.Msg -> Log.Msg)) r) => Sem (Logger String ': r) a -> Sem r a stringLoggerToTinyLog = mapLogger @String Log.msg discardTinyLogs :: Sem (Logger (Log.Msg -> Log.Msg) ': r) a -> Sem r a @@ -70,6 +69,6 @@ newtype LogRecorder = LogRecorder {recordedLogs :: IORef [(Level, LByteString)]} newLogRecorder :: IO LogRecorder newLogRecorder = LogRecorder <$> newIORef [] -recordLogs :: Member (Embed IO) r => LogRecorder -> Sem (TinyLog ': r) a -> Sem r a +recordLogs :: (Member (Embed IO) r) => LogRecorder -> Sem (TinyLog ': r) a -> Sem r a recordLogs LogRecorder {..} = interpret $ \(Log lvl msg) -> modifyIORef' recordedLogs (++ [(lvl, Log.render (Log.renderDefault ", ") msg)]) diff --git a/libs/polysemy-wire-zoo/src/Wire/Sem/Now/Input.hs b/libs/polysemy-wire-zoo/src/Wire/Sem/Now/Input.hs index b8c43249f9d..6e3c2dcb688 100644 --- a/libs/polysemy-wire-zoo/src/Wire/Sem/Now/Input.hs +++ b/libs/polysemy-wire-zoo/src/Wire/Sem/Now/Input.hs @@ -27,7 +27,7 @@ import Polysemy.Input import Wire.Sem.Now nowToInput :: - Member (Input UTCTime) r => + (Member (Input UTCTime) r) => Sem (Now ': r) a -> Sem r a nowToInput = interpret $ \case diff --git a/libs/polysemy-wire-zoo/src/Wire/Sem/Now/Spec.hs b/libs/polysemy-wire-zoo/src/Wire/Sem/Now/Spec.hs index 0ded935d5f1..84b789646ba 100644 --- a/libs/polysemy-wire-zoo/src/Wire/Sem/Now/Spec.hs +++ b/libs/polysemy-wire-zoo/src/Wire/Sem/Now/Spec.hs @@ -30,7 +30,7 @@ import Test.QuickCheck import qualified Wire.Sem.Now as E propsForInterpreter :: - PropConstraints r f => + (PropConstraints r f) => String -> (forall a. Sem r a -> IO (f a)) -> Spec @@ -42,15 +42,15 @@ propsForInterpreter interpreter lower = do -- A regular type synonym doesn't work due to dreaded impredicative -- polymorphism. class - (Functor f, Member E.Now r, Member (Input ()) r, forall z. Show z => Show (f z), forall z. Eq z => Eq (f z)) => + (Functor f, Member E.Now r, Member (Input ()) r, forall z. (Show z) => Show (f z), forall z. (Eq z) => Eq (f z)) => PropConstraints r f instance - (Functor f, Member E.Now r, Member (Input ()) r, forall z. Show z => Show (f z), forall z. Eq z => Eq (f z)) => + (Functor f, Member E.Now r, Member (Input ()) r, forall z. (Show z) => Show (f z), forall z. (Eq z) => Eq (f z)) => PropConstraints r f prop_nowNow :: - PropConstraints r f => + (PropConstraints r f) => Maybe (f Bool -> String) -> (forall a. Sem r a -> IO (f a)) -> Property diff --git a/libs/polysemy-wire-zoo/src/Wire/Sem/Random.hs b/libs/polysemy-wire-zoo/src/Wire/Sem/Random.hs index da054b545ed..8cc1ef33868 100644 --- a/libs/polysemy-wire-zoo/src/Wire/Sem/Random.hs +++ b/libs/polysemy-wire-zoo/src/Wire/Sem/Random.hs @@ -23,6 +23,7 @@ module Wire.Sem.Random uuid, scimTokenId, liftRandom, + nDigitNumber, ) where @@ -36,6 +37,7 @@ data Random m a where Bytes :: Int -> Random m ByteString Uuid :: Random m UUID ScimTokenId :: Random m ScimTokenId - LiftRandom :: (forall mr. MonadRandom mr => mr a) -> Random m a + LiftRandom :: (forall mr. (MonadRandom mr) => mr a) -> Random m a + NDigitNumber :: Int -> Random m Integer makeSem ''Random diff --git a/libs/polysemy-wire-zoo/src/Wire/Sem/Random/IO.hs b/libs/polysemy-wire-zoo/src/Wire/Sem/Random/IO.hs index e64815799f4..d073d267e8b 100644 --- a/libs/polysemy-wire-zoo/src/Wire/Sem/Random/IO.hs +++ b/libs/polysemy-wire-zoo/src/Wire/Sem/Random/IO.hs @@ -23,12 +23,13 @@ where import Data.Id (randomId) import qualified Data.UUID.V4 as UUID import Imports +import OpenSSL.BN import OpenSSL.Random (randBytes) import Polysemy import Wire.Sem.Random (Random (..)) randomToIO :: - Member (Embed IO) r => + (Member (Embed IO) r) => Sem (Random ': r) a -> Sem r a randomToIO = interpret $ \case @@ -36,3 +37,4 @@ randomToIO = interpret $ \case Uuid -> embed $ UUID.nextRandom ScimTokenId -> embed $ randomId @IO LiftRandom m -> embed @IO $ m + NDigitNumber n -> embed $ randIntegerZeroToNMinusOne (10 ^ n) diff --git a/libs/ropes/.ormolu b/libs/ropes/.ormolu deleted file mode 120000 index 157b212d7cd..00000000000 --- a/libs/ropes/.ormolu +++ /dev/null @@ -1 +0,0 @@ -../../.ormolu \ No newline at end of file diff --git a/libs/ropes/LICENSE b/libs/ropes/LICENSE deleted file mode 100644 index dba13ed2ddf..00000000000 --- a/libs/ropes/LICENSE +++ /dev/null @@ -1,661 +0,0 @@ - GNU AFFERO GENERAL PUBLIC LICENSE - Version 3, 19 November 2007 - - Copyright (C) 2007 Free Software Foundation, Inc. - Everyone is permitted to copy and distribute verbatim copies - of this license document, but changing it is not allowed. - - Preamble - - The GNU Affero General Public License is a free, copyleft license for -software and other kinds of works, specifically designed to ensure -cooperation with the community in the case of network server software. - - The licenses for most software and other practical works are designed -to take away your freedom to share and change the works. By contrast, -our General Public Licenses are intended to guarantee your freedom to -share and change all versions of a program--to make sure it remains free -software for all its users. - - When we speak of free software, we are referring to freedom, not -price. Our General Public Licenses are designed to make sure that you -have the freedom to distribute copies of free software (and charge for -them if you wish), that you receive source code or can get it if you -want it, that you can change the software or use pieces of it in new -free programs, and that you know you can do these things. - - Developers that use our General Public Licenses protect your rights -with two steps: (1) assert copyright on the software, and (2) offer -you this License which gives you legal permission to copy, distribute -and/or modify the software. - - A secondary benefit of defending all users' freedom is that -improvements made in alternate versions of the program, if they -receive widespread use, become available for other developers to -incorporate. Many developers of free software are heartened and -encouraged by the resulting cooperation. However, in the case of -software used on network servers, this result may fail to come about. -The GNU General Public License permits making a modified version and -letting the public access it on a server without ever releasing its -source code to the public. - - The GNU Affero General Public License is designed specifically to -ensure that, in such cases, the modified source code becomes available -to the community. It requires the operator of a network server to -provide the source code of the modified version running there to the -users of that server. Therefore, public use of a modified version, on -a publicly accessible server, gives the public access to the source -code of the modified version. - - An older license, called the Affero General Public License and -published by Affero, was designed to accomplish similar goals. This is -a different license, not a version of the Affero GPL, but Affero has -released a new version of the Affero GPL which permits relicensing under -this license. - - The precise terms and conditions for copying, distribution and -modification follow. - - TERMS AND CONDITIONS - - 0. Definitions. - - "This License" refers to version 3 of the GNU Affero General Public License. - - "Copyright" also means copyright-like laws that apply to other kinds of -works, such as semiconductor masks. - - "The Program" refers to any copyrightable work licensed under this -License. Each licensee is addressed as "you". "Licensees" and -"recipients" may be individuals or organizations. - - To "modify" a work means to copy from or adapt all or part of the work -in a fashion requiring copyright permission, other than the making of an -exact copy. The resulting work is called a "modified version" of the -earlier work or a work "based on" the earlier work. - - A "covered work" means either the unmodified Program or a work based -on the Program. - - To "propagate" a work means to do anything with it that, without -permission, would make you directly or secondarily liable for -infringement under applicable copyright law, except executing it on a -computer or modifying a private copy. Propagation includes copying, -distribution (with or without modification), making available to the -public, and in some countries other activities as well. - - To "convey" a work means any kind of propagation that enables other -parties to make or receive copies. Mere interaction with a user through -a computer network, with no transfer of a copy, is not conveying. - - An interactive user interface displays "Appropriate Legal Notices" -to the extent that it includes a convenient and prominently visible -feature that (1) displays an appropriate copyright notice, and (2) -tells the user that there is no warranty for the work (except to the -extent that warranties are provided), that licensees may convey the -work under this License, and how to view a copy of this License. If -the interface presents a list of user commands or options, such as a -menu, a prominent item in the list meets this criterion. - - 1. Source Code. - - The "source code" for a work means the preferred form of the work -for making modifications to it. "Object code" means any non-source -form of a work. - - A "Standard Interface" means an interface that either is an official -standard defined by a recognized standards body, or, in the case of -interfaces specified for a particular programming language, one that -is widely used among developers working in that language. - - The "System Libraries" of an executable work include anything, other -than the work as a whole, that (a) is included in the normal form of -packaging a Major Component, but which is not part of that Major -Component, and (b) serves only to enable use of the work with that -Major Component, or to implement a Standard Interface for which an -implementation is available to the public in source code form. A -"Major Component", in this context, means a major essential component -(kernel, window system, and so on) of the specific operating system -(if any) on which the executable work runs, or a compiler used to -produce the work, or an object code interpreter used to run it. - - The "Corresponding Source" for a work in object code form means all -the source code needed to generate, install, and (for an executable -work) run the object code and to modify the work, including scripts to -control those activities. However, it does not include the work's -System Libraries, or general-purpose tools or generally available free -programs which are used unmodified in performing those activities but -which are not part of the work. For example, Corresponding Source -includes interface definition files associated with source files for -the work, and the source code for shared libraries and dynamically -linked subprograms that the work is specifically designed to require, -such as by intimate data communication or control flow between those -subprograms and other parts of the work. - - The Corresponding Source need not include anything that users -can regenerate automatically from other parts of the Corresponding -Source. - - The Corresponding Source for a work in source code form is that -same work. - - 2. Basic Permissions. - - All rights granted under this License are granted for the term of -copyright on the Program, and are irrevocable provided the stated -conditions are met. This License explicitly affirms your unlimited -permission to run the unmodified Program. The output from running a -covered work is covered by this License only if the output, given its -content, constitutes a covered work. This License acknowledges your -rights of fair use or other equivalent, as provided by copyright law. - - You may make, run and propagate covered works that you do not -convey, without conditions so long as your license otherwise remains -in force. You may convey covered works to others for the sole purpose -of having them make modifications exclusively for you, or provide you -with facilities for running those works, provided that you comply with -the terms of this License in conveying all material for which you do -not control copyright. Those thus making or running the covered works -for you must do so exclusively on your behalf, under your direction -and control, on terms that prohibit them from making any copies of -your copyrighted material outside their relationship with you. - - Conveying under any other circumstances is permitted solely under -the conditions stated below. Sublicensing is not allowed; section 10 -makes it unnecessary. - - 3. Protecting Users' Legal Rights From Anti-Circumvention Law. - - No covered work shall be deemed part of an effective technological -measure under any applicable law fulfilling obligations under article -11 of the WIPO copyright treaty adopted on 20 December 1996, or -similar laws prohibiting or restricting circumvention of such -measures. - - When you convey a covered work, you waive any legal power to forbid -circumvention of technological measures to the extent such circumvention -is effected by exercising rights under this License with respect to -the covered work, and you disclaim any intention to limit operation or -modification of the work as a means of enforcing, against the work's -users, your or third parties' legal rights to forbid circumvention of -technological measures. - - 4. Conveying Verbatim Copies. - - You may convey verbatim copies of the Program's source code as you -receive it, in any medium, provided that you conspicuously and -appropriately publish on each copy an appropriate copyright notice; -keep intact all notices stating that this License and any -non-permissive terms added in accord with section 7 apply to the code; -keep intact all notices of the absence of any warranty; and give all -recipients a copy of this License along with the Program. - - You may charge any price or no price for each copy that you convey, -and you may offer support or warranty protection for a fee. - - 5. Conveying Modified Source Versions. - - You may convey a work based on the Program, or the modifications to -produce it from the Program, in the form of source code under the -terms of section 4, provided that you also meet all of these conditions: - - a) The work must carry prominent notices stating that you modified - it, and giving a relevant date. - - b) The work must carry prominent notices stating that it is - released under this License and any conditions added under section - 7. This requirement modifies the requirement in section 4 to - "keep intact all notices". - - c) You must license the entire work, as a whole, under this - License to anyone who comes into possession of a copy. This - License will therefore apply, along with any applicable section 7 - additional terms, to the whole of the work, and all its parts, - regardless of how they are packaged. This License gives no - permission to license the work in any other way, but it does not - invalidate such permission if you have separately received it. - - d) If the work has interactive user interfaces, each must display - Appropriate Legal Notices; however, if the Program has interactive - interfaces that do not display Appropriate Legal Notices, your - work need not make them do so. - - A compilation of a covered work with other separate and independent -works, which are not by their nature extensions of the covered work, -and which are not combined with it such as to form a larger program, -in or on a volume of a storage or distribution medium, is called an -"aggregate" if the compilation and its resulting copyright are not -used to limit the access or legal rights of the compilation's users -beyond what the individual works permit. Inclusion of a covered work -in an aggregate does not cause this License to apply to the other -parts of the aggregate. - - 6. Conveying Non-Source Forms. - - You may convey a covered work in object code form under the terms -of sections 4 and 5, provided that you also convey the -machine-readable Corresponding Source under the terms of this License, -in one of these ways: - - a) Convey the object code in, or embodied in, a physical product - (including a physical distribution medium), accompanied by the - Corresponding Source fixed on a durable physical medium - customarily used for software interchange. - - b) Convey the object code in, or embodied in, a physical product - (including a physical distribution medium), accompanied by a - written offer, valid for at least three years and valid for as - long as you offer spare parts or customer support for that product - model, to give anyone who possesses the object code either (1) a - copy of the Corresponding Source for all the software in the - product that is covered by this License, on a durable physical - medium customarily used for software interchange, for a price no - more than your reasonable cost of physically performing this - conveying of source, or (2) access to copy the - Corresponding Source from a network server at no charge. - - c) Convey individual copies of the object code with a copy of the - written offer to provide the Corresponding Source. This - alternative is allowed only occasionally and noncommercially, and - only if you received the object code with such an offer, in accord - with subsection 6b. - - d) Convey the object code by offering access from a designated - place (gratis or for a charge), and offer equivalent access to the - Corresponding Source in the same way through the same place at no - further charge. You need not require recipients to copy the - Corresponding Source along with the object code. If the place to - copy the object code is a network server, the Corresponding Source - may be on a different server (operated by you or a third party) - that supports equivalent copying facilities, provided you maintain - clear directions next to the object code saying where to find the - Corresponding Source. Regardless of what server hosts the - Corresponding Source, you remain obligated to ensure that it is - available for as long as needed to satisfy these requirements. - - e) Convey the object code using peer-to-peer transmission, provided - you inform other peers where the object code and Corresponding - Source of the work are being offered to the general public at no - charge under subsection 6d. - - A separable portion of the object code, whose source code is excluded -from the Corresponding Source as a System Library, need not be -included in conveying the object code work. - - A "User Product" is either (1) a "consumer product", which means any -tangible personal property which is normally used for personal, family, -or household purposes, or (2) anything designed or sold for incorporation -into a dwelling. In determining whether a product is a consumer product, -doubtful cases shall be resolved in favor of coverage. For a particular -product received by a particular user, "normally used" refers to a -typical or common use of that class of product, regardless of the status -of the particular user or of the way in which the particular user -actually uses, or expects or is expected to use, the product. A product -is a consumer product regardless of whether the product has substantial -commercial, industrial or non-consumer uses, unless such uses represent -the only significant mode of use of the product. - - "Installation Information" for a User Product means any methods, -procedures, authorization keys, or other information required to install -and execute modified versions of a covered work in that User Product from -a modified version of its Corresponding Source. The information must -suffice to ensure that the continued functioning of the modified object -code is in no case prevented or interfered with solely because -modification has been made. - - If you convey an object code work under this section in, or with, or -specifically for use in, a User Product, and the conveying occurs as -part of a transaction in which the right of possession and use of the -User Product is transferred to the recipient in perpetuity or for a -fixed term (regardless of how the transaction is characterized), the -Corresponding Source conveyed under this section must be accompanied -by the Installation Information. But this requirement does not apply -if neither you nor any third party retains the ability to install -modified object code on the User Product (for example, the work has -been installed in ROM). - - The requirement to provide Installation Information does not include a -requirement to continue to provide support service, warranty, or updates -for a work that has been modified or installed by the recipient, or for -the User Product in which it has been modified or installed. Access to a -network may be denied when the modification itself materially and -adversely affects the operation of the network or violates the rules and -protocols for communication across the network. - - Corresponding Source conveyed, and Installation Information provided, -in accord with this section must be in a format that is publicly -documented (and with an implementation available to the public in -source code form), and must require no special password or key for -unpacking, reading or copying. - - 7. Additional Terms. - - "Additional permissions" are terms that supplement the terms of this -License by making exceptions from one or more of its conditions. -Additional permissions that are applicable to the entire Program shall -be treated as though they were included in this License, to the extent -that they are valid under applicable law. If additional permissions -apply only to part of the Program, that part may be used separately -under those permissions, but the entire Program remains governed by -this License without regard to the additional permissions. - - When you convey a copy of a covered work, you may at your option -remove any additional permissions from that copy, or from any part of -it. (Additional permissions may be written to require their own -removal in certain cases when you modify the work.) You may place -additional permissions on material, added by you to a covered work, -for which you have or can give appropriate copyright permission. - - Notwithstanding any other provision of this License, for material you -add to a covered work, you may (if authorized by the copyright holders of -that material) supplement the terms of this License with terms: - - a) Disclaiming warranty or limiting liability differently from the - terms of sections 15 and 16 of this License; or - - b) Requiring preservation of specified reasonable legal notices or - author attributions in that material or in the Appropriate Legal - Notices displayed by works containing it; or - - c) Prohibiting misrepresentation of the origin of that material, or - requiring that modified versions of such material be marked in - reasonable ways as different from the original version; or - - d) Limiting the use for publicity purposes of names of licensors or - authors of the material; or - - e) Declining to grant rights under trademark law for use of some - trade names, trademarks, or service marks; or - - f) Requiring indemnification of licensors and authors of that - material by anyone who conveys the material (or modified versions of - it) with contractual assumptions of liability to the recipient, for - any liability that these contractual assumptions directly impose on - those licensors and authors. - - All other non-permissive additional terms are considered "further -restrictions" within the meaning of section 10. If the Program as you -received it, or any part of it, contains a notice stating that it is -governed by this License along with a term that is a further -restriction, you may remove that term. If a license document contains -a further restriction but permits relicensing or conveying under this -License, you may add to a covered work material governed by the terms -of that license document, provided that the further restriction does -not survive such relicensing or conveying. - - If you add terms to a covered work in accord with this section, you -must place, in the relevant source files, a statement of the -additional terms that apply to those files, or a notice indicating -where to find the applicable terms. - - Additional terms, permissive or non-permissive, may be stated in the -form of a separately written license, or stated as exceptions; -the above requirements apply either way. - - 8. Termination. - - You may not propagate or modify a covered work except as expressly -provided under this License. Any attempt otherwise to propagate or -modify it is void, and will automatically terminate your rights under -this License (including any patent licenses granted under the third -paragraph of section 11). - - However, if you cease all violation of this License, then your -license from a particular copyright holder is reinstated (a) -provisionally, unless and until the copyright holder explicitly and -finally terminates your license, and (b) permanently, if the copyright -holder fails to notify you of the violation by some reasonable means -prior to 60 days after the cessation. - - Moreover, your license from a particular copyright holder is -reinstated permanently if the copyright holder notifies you of the -violation by some reasonable means, this is the first time you have -received notice of violation of this License (for any work) from that -copyright holder, and you cure the violation prior to 30 days after -your receipt of the notice. - - Termination of your rights under this section does not terminate the -licenses of parties who have received copies or rights from you under -this License. If your rights have been terminated and not permanently -reinstated, you do not qualify to receive new licenses for the same -material under section 10. - - 9. Acceptance Not Required for Having Copies. - - You are not required to accept this License in order to receive or -run a copy of the Program. Ancillary propagation of a covered work -occurring solely as a consequence of using peer-to-peer transmission -to receive a copy likewise does not require acceptance. However, -nothing other than this License grants you permission to propagate or -modify any covered work. These actions infringe copyright if you do -not accept this License. Therefore, by modifying or propagating a -covered work, you indicate your acceptance of this License to do so. - - 10. Automatic Licensing of Downstream Recipients. - - Each time you convey a covered work, the recipient automatically -receives a license from the original licensors, to run, modify and -propagate that work, subject to this License. You are not responsible -for enforcing compliance by third parties with this License. - - An "entity transaction" is a transaction transferring control of an -organization, or substantially all assets of one, or subdividing an -organization, or merging organizations. If propagation of a covered -work results from an entity transaction, each party to that -transaction who receives a copy of the work also receives whatever -licenses to the work the party's predecessor in interest had or could -give under the previous paragraph, plus a right to possession of the -Corresponding Source of the work from the predecessor in interest, if -the predecessor has it or can get it with reasonable efforts. - - You may not impose any further restrictions on the exercise of the -rights granted or affirmed under this License. For example, you may -not impose a license fee, royalty, or other charge for exercise of -rights granted under this License, and you may not initiate litigation -(including a cross-claim or counterclaim in a lawsuit) alleging that -any patent claim is infringed by making, using, selling, offering for -sale, or importing the Program or any portion of it. - - 11. Patents. - - A "contributor" is a copyright holder who authorizes use under this -License of the Program or a work on which the Program is based. The -work thus licensed is called the contributor's "contributor version". - - A contributor's "essential patent claims" are all patent claims -owned or controlled by the contributor, whether already acquired or -hereafter acquired, that would be infringed by some manner, permitted -by this License, of making, using, or selling its contributor version, -but do not include claims that would be infringed only as a -consequence of further modification of the contributor version. For -purposes of this definition, "control" includes the right to grant -patent sublicenses in a manner consistent with the requirements of -this License. - - Each contributor grants you a non-exclusive, worldwide, royalty-free -patent license under the contributor's essential patent claims, to -make, use, sell, offer for sale, import and otherwise run, modify and -propagate the contents of its contributor version. - - In the following three paragraphs, a "patent license" is any express -agreement or commitment, however denominated, not to enforce a patent -(such as an express permission to practice a patent or covenant not to -sue for patent infringement). To "grant" such a patent license to a -party means to make such an agreement or commitment not to enforce a -patent against the party. - - If you convey a covered work, knowingly relying on a patent license, -and the Corresponding Source of the work is not available for anyone -to copy, free of charge and under the terms of this License, through a -publicly available network server or other readily accessible means, -then you must either (1) cause the Corresponding Source to be so -available, or (2) arrange to deprive yourself of the benefit of the -patent license for this particular work, or (3) arrange, in a manner -consistent with the requirements of this License, to extend the patent -license to downstream recipients. "Knowingly relying" means you have -actual knowledge that, but for the patent license, your conveying the -covered work in a country, or your recipient's use of the covered work -in a country, would infringe one or more identifiable patents in that -country that you have reason to believe are valid. - - If, pursuant to or in connection with a single transaction or -arrangement, you convey, or propagate by procuring conveyance of, a -covered work, and grant a patent license to some of the parties -receiving the covered work authorizing them to use, propagate, modify -or convey a specific copy of the covered work, then the patent license -you grant is automatically extended to all recipients of the covered -work and works based on it. - - A patent license is "discriminatory" if it does not include within -the scope of its coverage, prohibits the exercise of, or is -conditioned on the non-exercise of one or more of the rights that are -specifically granted under this License. You may not convey a covered -work if you are a party to an arrangement with a third party that is -in the business of distributing software, under which you make payment -to the third party based on the extent of your activity of conveying -the work, and under which the third party grants, to any of the -parties who would receive the covered work from you, a discriminatory -patent license (a) in connection with copies of the covered work -conveyed by you (or copies made from those copies), or (b) primarily -for and in connection with specific products or compilations that -contain the covered work, unless you entered into that arrangement, -or that patent license was granted, prior to 28 March 2007. - - Nothing in this License shall be construed as excluding or limiting -any implied license or other defenses to infringement that may -otherwise be available to you under applicable patent law. - - 12. No Surrender of Others' Freedom. - - If conditions are imposed on you (whether by court order, agreement or -otherwise) that contradict the conditions of this License, they do not -excuse you from the conditions of this License. If you cannot convey a -covered work so as to satisfy simultaneously your obligations under this -License and any other pertinent obligations, then as a consequence you may -not convey it at all. For example, if you agree to terms that obligate you -to collect a royalty for further conveying from those to whom you convey -the Program, the only way you could satisfy both those terms and this -License would be to refrain entirely from conveying the Program. - - 13. Remote Network Interaction; Use with the GNU General Public License. - - Notwithstanding any other provision of this License, if you modify the -Program, your modified version must prominently offer all users -interacting with it remotely through a computer network (if your version -supports such interaction) an opportunity to receive the Corresponding -Source of your version by providing access to the Corresponding Source -from a network server at no charge, through some standard or customary -means of facilitating copying of software. This Corresponding Source -shall include the Corresponding Source for any work covered by version 3 -of the GNU General Public License that is incorporated pursuant to the -following paragraph. - - Notwithstanding any other provision of this License, you have -permission to link or combine any covered work with a work licensed -under version 3 of the GNU General Public License into a single -combined work, and to convey the resulting work. The terms of this -License will continue to apply to the part which is the covered work, -but the work with which it is combined will remain governed by version -3 of the GNU General Public License. - - 14. Revised Versions of this License. - - The Free Software Foundation may publish revised and/or new versions of -the GNU Affero General Public License from time to time. Such new versions -will be similar in spirit to the present version, but may differ in detail to -address new problems or concerns. - - Each version is given a distinguishing version number. If the -Program specifies that a certain numbered version of the GNU Affero General -Public License "or any later version" applies to it, you have the -option of following the terms and conditions either of that numbered -version or of any later version published by the Free Software -Foundation. If the Program does not specify a version number of the -GNU Affero General Public License, you may choose any version ever published -by the Free Software Foundation. - - If the Program specifies that a proxy can decide which future -versions of the GNU Affero General Public License can be used, that proxy's -public statement of acceptance of a version permanently authorizes you -to choose that version for the Program. - - Later license versions may give you additional or different -permissions. However, no additional obligations are imposed on any -author or copyright holder as a result of your choosing to follow a -later version. - - 15. Disclaimer of Warranty. - - THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY -APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT -HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY -OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, -THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM -IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF -ALL NECESSARY SERVICING, REPAIR OR CORRECTION. - - 16. Limitation of Liability. - - IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING -WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS -THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY -GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE -USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF -DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD -PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), -EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF -SUCH DAMAGES. - - 17. Interpretation of Sections 15 and 16. - - If the disclaimer of warranty and limitation of liability provided -above cannot be given local legal effect according to their terms, -reviewing courts shall apply local law that most closely approximates -an absolute waiver of all civil liability in connection with the -Program, unless a warranty or assumption of liability accompanies a -copy of the Program in return for a fee. - - END OF TERMS AND CONDITIONS - - How to Apply These Terms to Your New Programs - - If you develop a new program, and you want it to be of the greatest -possible use to the public, the best way to achieve this is to make it -free software which everyone can redistribute and change under these terms. - - To do so, attach the following notices to the program. It is safest -to attach them to the start of each source file to most effectively -state the exclusion of warranty; and each file should have at least -the "copyright" line and a pointer to where the full notice is found. - - - Copyright (C) - - This program is free software: you can redistribute it and/or modify - it under the terms of the GNU Affero General Public License as published by - the Free Software Foundation, either version 3 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU Affero General Public License for more details. - - You should have received a copy of the GNU Affero General Public License - along with this program. If not, see . - -Also add information on how to contact you by electronic and paper mail. - - If your software can interact with users remotely through a computer -network, you should also make sure that it provides a way for users to -get its source. For example, if your program is a web application, its -interface could display a "Source" link that leads users to an archive -of the code. There are many ways you could offer source, and different -solutions will be better for different programs; see section 13 for the -specific requirements. - - You should also get your employer (if you work as a programmer) or school, -if any, to sign a "copyright disclaimer" for the program, if necessary. -For more information on this, and how to apply and follow the GNU AGPL, see -. diff --git a/libs/ropes/default.nix b/libs/ropes/default.nix deleted file mode 100644 index 6dd3c1ed69f..00000000000 --- a/libs/ropes/default.nix +++ /dev/null @@ -1,37 +0,0 @@ -# WARNING: GENERATED FILE, DO NOT EDIT. -# This file is generated by running hack/bin/generate-local-nix-packages.sh and -# must be regenerated whenever local packages are added or removed, or -# dependencies are added or removed. -{ mkDerivation -, aeson -, base -, bytestring -, errors -, gitignoreSource -, http-client -, http-types -, imports -, iso3166-country-codes -, lib -, text -, time -}: -mkDerivation { - pname = "ropes"; - version = "0.4.20"; - src = gitignoreSource ./.; - libraryHaskellDepends = [ - aeson - base - bytestring - errors - http-client - http-types - imports - iso3166-country-codes - text - time - ]; - description = "Various ropes to tie together with external web services"; - license = lib.licenses.agpl3Only; -} diff --git a/libs/ropes/ropes.cabal b/libs/ropes/ropes.cabal deleted file mode 100644 index 0a5e9457039..00000000000 --- a/libs/ropes/ropes.cabal +++ /dev/null @@ -1,79 +0,0 @@ -cabal-version: 1.12 -name: ropes -version: 0.4.20 -synopsis: Various ropes to tie together with external web services. -category: Network -author: Wire Swiss GmbH -maintainer: Wire Swiss GmbH -copyright: (c) 2017 Wire Swiss GmbH -license: AGPL-3 -license-file: LICENSE -build-type: Simple - -library - exposed-modules: - Ropes.Nexmo - Ropes.Twilio - - other-modules: Paths_ropes - hs-source-dirs: src - default-extensions: - AllowAmbiguousTypes - BangPatterns - ConstraintKinds - DataKinds - DefaultSignatures - DeriveFunctor - DeriveGeneric - DeriveLift - DeriveTraversable - DerivingStrategies - DerivingVia - DuplicateRecordFields - EmptyCase - FlexibleContexts - FlexibleInstances - FunctionalDependencies - GADTs - InstanceSigs - KindSignatures - LambdaCase - MultiParamTypeClasses - MultiWayIf - NamedFieldPuns - NoImplicitPrelude - OverloadedRecordDot - OverloadedStrings - PackageImports - PatternSynonyms - PolyKinds - QuasiQuotes - RankNTypes - ScopedTypeVariables - StandaloneDeriving - TupleSections - TypeApplications - TypeFamilies - TypeFamilyDependencies - TypeOperators - UndecidableInstances - ViewPatterns - - ghc-options: - -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates - -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path - -Wredundant-constraints -Wunused-packages - - build-depends: - aeson >=2.0.1.0 - , base >=4 && <5 - , bytestring >=0.9 - , errors >=2.0 - , http-client >=0.7 - , http-types >=0.7 - , imports - , iso3166-country-codes >=0.20140203.7 - , text >=0.11 - , time >=1.1 - - default-language: GHC2021 diff --git a/libs/ropes/src/Ropes/Nexmo.hs b/libs/ropes/src/Ropes/Nexmo.hs deleted file mode 100644 index 9f1900a86f4..00000000000 --- a/libs/ropes/src/Ropes/Nexmo.hs +++ /dev/null @@ -1,356 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- 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 Ropes.Nexmo - ( -- * Types - ApiKey (..), - ApiSecret (..), - Credentials, - ParseError (..), - Charset (..), - - -- * SMS - MessageErrorResponse (..), - MessageErrorStatus (..), - Message (..), - MessageId, - MessageResponse, - - -- * Call - Call (..), - CallId, - CallErrorResponse (..), - CallErrorStatus (..), - - -- * Functions - sendCall, - sendMessage, - sendMessages, - sendFeedback, - msgIds, - ) -where - -import Control.Exception -import Data.Aeson -import Data.Aeson.Types -import Data.ByteString.Lazy (toStrict) -import Data.List.NonEmpty (NonEmpty (..)) -import Data.List.NonEmpty qualified as N -import Data.Text.Encoding (decodeUtf8) -import Data.Time (UTCTime) -import Data.Time.Format (defaultTimeLocale, formatTime) -import Imports hiding (head, length) -import Network.HTTP.Client hiding (Response) -import Network.HTTP.Types - --- * Types - -newtype ApiKey = ApiKey Text deriving (FromJSON) - -newtype ApiSecret = ApiSecret Text deriving (FromJSON) - -data Charset = GSM7 | GSM8 | UCS2 deriving (Eq, Show) - -data Credentials = Credentials - { key :: ApiKey, - secret :: ApiSecret - } - -instance FromJSON Credentials where - parseJSON = withObject "credentials" $ \o -> - Credentials - <$> o .: "key" - <*> o .: "secret" - --- * SMS related - -newtype MessageId = MessageId {messageIdText :: Text} deriving (Eq, Show) - -data Message = Message - { msgFrom :: !Text, - msgTo :: !Text, - msgText :: !Text, - msgType :: !Charset - } - deriving (Eq, Show) - -newtype MessageResponse = MessageResponse {msgIds :: NonEmpty MessageId} - deriving (Eq, Show) - -data MessageErrorStatus - = MessageThrottled - | MessageInternal - | MessageUnroutable - | MessageNumBarred - | MessagePartnerAccountBarred - | MessagePartnerQuotaExceeded - | MessageTooLong - | MessageCommunicationFailed - | MessageInvalidSenderAddress - | MessageFacilityNotAllowed - | MessageInvalidMessageClass - | MessageOther - deriving (Eq, Show) - -instance FromJSON MessageErrorStatus where - parseJSON "1" = pure MessageThrottled - parseJSON "5" = pure MessageInternal - parseJSON "6" = pure MessageUnroutable - parseJSON "7" = pure MessageNumBarred - parseJSON "8" = pure MessagePartnerAccountBarred - parseJSON "9" = pure MessagePartnerQuotaExceeded - parseJSON "12" = pure MessageTooLong - parseJSON "13" = pure MessageCommunicationFailed - parseJSON "15" = pure MessageInvalidSenderAddress - parseJSON "19" = pure MessageFacilityNotAllowed - parseJSON "20" = pure MessageInvalidMessageClass - parseJSON _ = pure MessageOther - -data MessageErrorResponse = MessageErrorResponse - { erStatus :: !MessageErrorStatus, - erErrorText :: !(Maybe Text) - } - deriving (Eq, Show, Typeable) - -instance Exception MessageErrorResponse - -instance FromJSON MessageErrorResponse where - parseJSON = withObject "message-error-response" $ \o -> - MessageErrorResponse - <$> o .: "status" - <*> o .:? "error-text" - -newtype ParseError = ParseError String - deriving (Eq, Show, Typeable) - -instance Exception ParseError - -instance FromJSON MessageId where - parseJSON = withText "MessageId" $ pure . MessageId - -instance ToJSON MessageId where - toJSON = String . messageIdText - -instance FromJSON Charset where - parseJSON "text" = pure GSM7 - parseJSON "binary" = pure GSM8 - parseJSON "unicode" = pure UCS2 - parseJSON x = fail $ "Unsupported charset " <> show x - -instance ToJSON Charset where - toJSON GSM7 = "text" - toJSON GSM8 = "binary" - toJSON UCS2 = "unicode" - --- * Internal message parsers - -parseMessageFeedback :: Value -> Parser (Either MessageErrorResponse MessageId) -parseMessageFeedback j@(Object o) = do - st <- o .: "status" - case (st :: Text) of - "0" -> Right <$> parseMessageId j - _ -> Left <$> parseJSON j -parseMessageFeedback _ = fail "Ropes.Nexmo: message should be an object" - -parseMessageId :: Value -> Parser MessageId -parseMessageId = withObject "message-response" (.: "message-id") - -parseMessageResponse :: Value -> Parser (Either MessageErrorResponse MessageResponse) -parseMessageResponse = withObject "nexmo-response" $ \o -> do - xs <- o .: "messages" - ys <- sequence <$> mapM parseMessageFeedback xs - case ys of - Left e -> pure $ Left e - Right (f : fs) -> pure $ Right $ MessageResponse (f :| fs) - Right _ -> fail "Must have at least one message-id" - --- * Call related - -newtype CallId = CallId {callIdText :: Text} deriving (Eq, Show) - -data Call = Call - { callFrom :: !(Maybe Text), - callTo :: !Text, - callText :: !Text, - callLang :: !(Maybe Text), - callRepeat :: !(Maybe Int) - } - -data CallErrorStatus - = CallThrottled - | CallInternal - | CallDestinationNotPermitted - | CallDestinationBarred - | CallPartnerQuotaExceeded - | CallInvalidDestinationAddress - | CallUnroutable - | CallOther - deriving (Eq, Show) - -instance FromJSON CallErrorStatus where - parseJSON "1" = pure CallThrottled - parseJSON "5" = pure CallInternal - parseJSON "6" = pure CallDestinationNotPermitted - parseJSON "7" = pure CallDestinationBarred - parseJSON "9" = pure CallPartnerQuotaExceeded - parseJSON "15" = pure CallInvalidDestinationAddress - parseJSON "17" = pure CallUnroutable - parseJSON _ = pure CallOther - -data CallErrorResponse = CallErrorResponse - { caStatus :: !CallErrorStatus, - caErrorText :: !(Maybe Text) - } - deriving (Eq, Show, Typeable) - -instance Exception CallErrorResponse - -instance FromJSON CallErrorResponse where - parseJSON = withObject "call-error-response" $ \o -> - CallErrorResponse - <$> o .: "status" - <*> o .:? "error-text" - --- * Internal call parsers - -parseCallId :: Value -> Parser CallId -parseCallId = withObject "call-response" $ \o -> - CallId <$> o .: "call_id" - -parseCallResponse :: Value -> Parser (Either CallErrorResponse CallId) -parseCallResponse j@(Object o) = do - st <- o .: "status" - case (st :: Text) of - "0" -> Right <$> parseCallId j - _ -> Left <$> parseJSON j -parseCallResponse _ = fail "Ropes.Nexmo: response should be an object" - --- * Feedback related - -data Feedback = Feedback - { feedbackId :: !(Either CallId MessageId), - feedbackTime :: !UTCTime, - feedbackDelivered :: !Bool - } - deriving (Eq, Show) - -data FeedbackErrorResponse = FeedbackErrorResponse Text - deriving (Eq, Show) - -instance Exception FeedbackErrorResponse - --- * Functions - -sendCall :: Credentials -> Manager -> Call -> IO CallId -sendCall cr mgr call = httpLbs req mgr >>= parseResult - where - parseResult res = case parseEither parseCallResponse =<< eitherDecode (responseBody res) of - Left e -> throwIO $ ParseError e - Right r -> either throwIO pure r - req = - defaultRequest - { method = "POST", - host = "api.nexmo.com", - secure = True, - port = 443, - path = "/tts/json", - requestBody = RequestBodyLBS $ encode body, - requestHeaders = [(hContentType, "application/json")] - } - (ApiKey apiKey, ApiSecret apiSecret) = (key cr, secret cr) - body = - object - [ "api_key" .= apiKey, - "api_secret" .= apiSecret, - "from" .= callFrom call, - "to" .= callTo call, - "text" .= callText call, - "repeat" .= callRepeat call, - "lg" .= callLang call - ] - -sendFeedback :: Credentials -> Manager -> Feedback -> IO () -sendFeedback cr mgr fb = httpLbs req mgr >>= parseResponse - where - req = - defaultRequest - { method = "POST", - host = "api.nexmo.com", - secure = True, - port = 443, - path = - either - (const "/conversions/voice") - (const "/conversions/sms") - (feedbackId fb), - requestBody = RequestBodyLBS $ encode body, - requestHeaders = [(hContentType, "application/json")] - } - (ApiKey apiKey, ApiSecret apiSecret) = (key cr, secret cr) - body = - object - [ "api_key" .= apiKey, - "api_secret" .= apiSecret, - "message-id" .= either callIdText messageIdText (feedbackId fb), - "delivered" .= feedbackDelivered fb, - "timestamp" .= nexmoTimeFormat (feedbackTime fb) - ] - -- Format as specified https://docs.nexmo.com/api-ref/conversion-api/request - -- Note that the claim that "If you do not set this parameter, the Cloud - -- Communications Platform uses the time it recieves this request." is false - -- You must _always_ specify a timestamp - nexmoTimeFormat = formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" - parseResponse res = - unless (responseStatus res == status200) $ - throwIO $ - FeedbackErrorResponse (decodeUtf8 . toStrict . responseBody $ res) - -sendMessage :: Credentials -> Manager -> Message -> IO MessageResponse -sendMessage cr mgr msg = N.head <$> sendMessages cr mgr (msg :| []) - -sendMessages :: Credentials -> Manager -> NonEmpty Message -> IO (NonEmpty MessageResponse) -sendMessages cr mgr msgs = forM msgs $ \m -> httpLbs (req m) mgr >>= parseResult - where - parseResult res = case parseEither parseMessageResponse =<< eitherDecode (responseBody res) of - Left e -> throwIO $ ParseError e - Right r -> either throwIO pure r - req m = - defaultRequest - { method = "POST", - host = "rest.nexmo.com", - secure = True, - port = 443, - path = "/sms/json", - requestBody = RequestBodyLBS $ encode (body m), - requestHeaders = [(hContentType, "application/json")] - } - (ApiKey apiKey, ApiSecret apiSecret) = (key cr, secret cr) - body m = - object - [ "api_key" .= apiKey, - "api_secret" .= apiSecret, - "from" .= msgFrom m, - "to" .= msgTo m, - "text" .= msgText m, - "type" .= msgType m - ] diff --git a/libs/ropes/src/Ropes/Twilio.hs b/libs/ropes/src/Ropes/Twilio.hs deleted file mode 100644 index e9a935b7302..00000000000 --- a/libs/ropes/src/Ropes/Twilio.hs +++ /dev/null @@ -1,224 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} - --- 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 Ropes.Twilio - ( -- * Types - SID (..), - AccessToken (..), - Credentials, - Message (..), - MessageId, - LookupDetail (..), - CarrierInfo (..), - PhoneType (..), - LookupResult (..), - ErrorResponse (..), - ParseError (..), - - -- * Functions - sendMessage, - sendMessages, - lookupPhone, - tryTwilio, - ) -where - -import Control.Error (ExceptT (..)) -import Control.Exception -import Data.Aeson -import Data.ByteString.Char8 qualified as C -import Data.ISO3166_CountryCodes (CountryCode) -import Data.List.NonEmpty (NonEmpty (..)) -import Data.List.NonEmpty qualified as N -import Data.Text.Encoding (encodeUtf8) -import Imports hiding (head, length) -import Network.HTTP.Client -import Network.HTTP.Types.Status -import Network.HTTP.Types.URI - --- * Types - -newtype MessageId = MessageId ByteString - -newtype SID = SID ByteString - -newtype AccessToken = AccessToken ByteString - -data Credentials = Credentials - { sid :: SID, - token :: AccessToken - } - -instance FromJSON Credentials where - parseJSON = withObject "credentials" $ \o -> - Credentials - <$> (SID . encodeUtf8 <$> o .: "sid") - <*> (AccessToken . encodeUtf8 <$> o .: "token") - -data Message = Message - { msgFrom :: !Text, - msgTo :: !Text, - msgText :: !Text - } - deriving (Eq, Show) - -data ErrorResponse = ErrorResponse - { errStatus :: !Int, - errMessage :: !Text, - errCode :: !(Maybe Int), - errMoreInfo :: !(Maybe Text) - } - deriving (Eq, Show, Typeable) - -instance Exception ErrorResponse - -instance FromJSON ErrorResponse where - parseJSON = withObject "error-response" $ \o -> - ErrorResponse - <$> o .: "status" - <*> o .: "message" - <*> o .:? "code" - <*> o .:? "more_info" - -newtype ParseError = ParseError String - deriving (Eq, Show, Typeable) - -instance Exception ParseError - -data MessageResponse = MessageResponse - { msgId :: !MessageId - } - -instance FromJSON MessageResponse where - parseJSON = withObject "MessageResponse" $ \o -> - MessageResponse . MessageId . encodeUtf8 <$> o .: "sid" - -data LookupDetail - = LookupNoDetail - | LookupCarrier - deriving (Eq, Show) - -data LookupResult = LookupResult - { lookupE164 :: !Text, - lookupCarrier :: !(Maybe CarrierInfo) - } - -data CarrierInfo = CarrierInfo - { carrierName :: !(Maybe Text), - carrierType :: !(Maybe PhoneType) - } - -data PhoneType - = Landline - | Mobile - | VoIp - deriving (Eq, Show) - -instance FromJSON LookupResult where - parseJSON = withObject "LookupResult" $ \o -> - LookupResult - <$> o .: "phone_number" - <*> o .:? "carrier" - -instance FromJSON CarrierInfo where - parseJSON = withObject "CarrierInfo" $ \o -> - CarrierInfo - <$> o .:? "name" - <*> o .:? "type" - -instance FromJSON PhoneType where - parseJSON = withText "PhoneType" $ \case - "mobile" -> pure Mobile - "landline" -> pure Landline - "voip" -> pure VoIp - x -> fail $ "Unexpected phone type: " ++ show x - --- * Functions - -tryTwilio :: MonadIO m => IO a -> ExceptT ErrorResponse m a -tryTwilio = ExceptT . liftIO . try - -sendMessage :: Credentials -> Manager -> Message -> IO MessageId -sendMessage cr mgr msg = N.head <$> sendMessages cr mgr (msg :| []) - -sendMessages :: Credentials -> Manager -> NonEmpty Message -> IO (NonEmpty MessageId) -sendMessages cr mgr msgs = forM msgs $ \m -> do - let req = urlEncodedBody (form m) . applyBasicAuth tSid tToken $ apiReq - rsp <- httpLbs req mgr - if responseStatus rsp == status201 - then case eitherDecode (responseBody rsp) of - Right r -> pure $ msgId r - Left e -> throwIO $ ParseError e - else case eitherDecode (responseBody rsp) of - Right e -> throwIO (e :: ErrorResponse) - Left e -> throwIO $ ParseError e - where - apiReq = - defaultRequest - { method = "POST", - host = "api.twilio.com", - secure = True, - port = 443, - path = "/2010-04-01/Accounts/" <> tSid <> "/Messages.json" - } - (SID tSid, AccessToken tToken) = (sid cr, token cr) - form m = - [ ("From", encodeUtf8 . msgFrom $ m), - ("To", encodeUtf8 . msgTo $ m), - ("Body", encodeUtf8 . msgText $ m) - ] - -lookupPhone :: - Credentials -> - Manager -> - Text -> - LookupDetail -> - Maybe CountryCode -> - IO LookupResult -lookupPhone cr mgr phone detail country = do - let req = applyBasicAuth tSid tToken apiReq - rsp <- httpLbs req mgr - if responseStatus rsp == status200 - then case eitherDecode (responseBody rsp) of - Right r -> pure r - Left e -> throwIO $ ParseError e - else case eitherDecode (responseBody rsp) of - Right e -> throwIO (e :: ErrorResponse) - Left e -> throwIO $ ParseError e - where - (SID tSid, AccessToken tToken) = (sid cr, token cr) - apiReq = - defaultRequest - { method = "GET", - host = "lookups.twilio.com", - secure = True, - port = 443, - path = "/v1/PhoneNumbers/" <> encodeUtf8 phone, - queryString = renderSimpleQuery False queryItems - } - queryItems = - catMaybes - [ countryCode <$> country, - lookupType detail - ] - countryCode c = ("CountryCode", C.pack (show c)) - lookupType LookupNoDetail = Nothing - lookupType LookupCarrier = Just ("Type", "carrier") diff --git a/libs/schema-profunctor/src/Data/Schema.hs b/libs/schema-profunctor/src/Data/Schema.hs index e2dd11a7853..9f6104e07a9 100644 --- a/libs/schema-profunctor/src/Data/Schema.hs +++ b/libs/schema-profunctor/src/Data/Schema.hs @@ -138,7 +138,7 @@ newtype SchemaOut v a b = SchemaOut (a -> Maybe v) -- The following instance is correct because `Ap Maybe v` is a -- near-semiring when v is a monoid -instance Monoid v => Alternative (SchemaOut v a) where +instance (Monoid v) => Alternative (SchemaOut v a) where empty = mempty (<|>) = (<>) @@ -153,7 +153,7 @@ instance Monoid (SchemaOut v a b) where -- -- This is used for schema documentation types, to support different behaviours -- for composing schemas sequentially vs alternatively. -class Monoid m => NearSemiRing m where +class (Monoid m) => NearSemiRing m where zero :: m add :: m -> m -> m @@ -162,7 +162,7 @@ newtype SchemaDoc doc a b = SchemaDoc {getDoc :: doc} deriving (Applicative) via (Const doc) deriving (Profunctor, Choice) via Joker (Const doc) -instance NearSemiRing doc => Alternative (SchemaDoc doc a) where +instance (NearSemiRing doc) => Alternative (SchemaDoc doc a) where empty = zero (<|>) = add @@ -240,11 +240,11 @@ instance (NearSemiRing doc, Monoid v') => Alternative (SchemaP doc v v' a) where -- /Note/: this is a more general instance than the 'Alternative' one, -- since it works for arbitrary v' -instance Semigroup doc => Semigroup (SchemaP doc v v' a b) where +instance (Semigroup doc) => Semigroup (SchemaP doc v v' a b) where SchemaP d1 i1 o1 <> SchemaP d2 i2 o2 = SchemaP (d1 <> d2) (i1 <> i2) (o1 <> o2) -instance Monoid doc => Monoid (SchemaP doc v v' a b) where +instance (Monoid doc) => Monoid (SchemaP doc v v' a b) where mempty = SchemaP mempty mempty mempty instance Profunctor (SchemaP doc v v') where @@ -282,7 +282,7 @@ schemaIn (SchemaP _ (SchemaIn i) _) = i schemaOut :: SchemaP ss v m a b -> a -> Maybe m schemaOut (SchemaP _ _ (SchemaOut o)) = o -class Functor f => FieldFunctor doc f where +class (Functor f) => FieldFunctor doc f where parseFieldF :: (A.Value -> A.Parser a) -> A.Object -> Text -> A.Parser (f a) mkDocF :: doc -> doc @@ -290,14 +290,14 @@ instance FieldFunctor doc Identity where parseFieldF f obj key = Identity <$> A.explicitParseField f obj (Key.fromText key) mkDocF = id -instance HasOpt doc => FieldFunctor doc Maybe where +instance (HasOpt doc) => FieldFunctor doc Maybe where parseFieldF f obj key = A.explicitParseFieldMaybe f obj (Key.fromText key) mkDocF = mkOpt -- | A schema for a one-field JSON object. field :: forall doc' doc a b. - HasField doc' doc => + (HasField doc' doc) => Text -> SchemaP doc' A.Value A.Value a b -> SchemaP doc A.Object [A.Pair] a b @@ -366,7 +366,7 @@ fieldOver l name = fmap runIdentity . fieldOverF l name -- documentation of the field. fieldWithDocModifier :: forall doc' doc a b. - HasField doc' doc => + (HasField doc' doc) => Text -> (doc' -> doc') -> SchemaP doc' A.Value A.Value a b -> @@ -396,7 +396,7 @@ fieldWithDocModifierF :: fieldWithDocModifierF name modify sch = fieldF @doc' @doc name (over doc modify sch) -- | Change the input type of a schema. -(.=) :: Profunctor p => (a -> a') -> p a' b -> p a b +(.=) :: (Profunctor p) => (a -> a') -> p a' b -> p a b (.=) = lmap -- | Change the input and output types of a schema via a prism. @@ -408,7 +408,7 @@ tag f = rmap runIdentity . f . rmap Identity -- This can be used to convert a combination of schemas obtained using -- 'field' into a single schema for a JSON object. object :: - HasObject doc doc' => + (HasObject doc doc') => Text -> SchemaP doc A.Object [A.Pair] a b -> SchemaP doc' A.Value A.Value a b @@ -418,7 +418,7 @@ object = objectOver id -- -- Just like 'fieldOver', but for 'object'. objectOver :: - HasObject doc doc' => + (HasObject doc doc') => Lens v v' A.Value A.Object -> Text -> SchemaP doc v' [A.Pair] a b -> @@ -433,7 +433,7 @@ objectOver l name sch = SchemaP (SchemaDoc s) (SchemaIn r) (SchemaOut w) -- | Like 'object', but apply an arbitrary function to the -- documentation of the resulting object. objectWithDocModifier :: - HasObject doc doc' => + (HasObject doc doc') => Text -> (doc' -> doc') -> ObjectSchema doc a -> @@ -446,14 +446,14 @@ objectWithDocModifier name modify sch = over doc modify (object name sch) -- schema. If the inner schema is unnamed, it gets "inlined" in the -- larger scheme definition, and otherwise it gets "referenced". This -- combinator makes it possible to choose one of the two options. -unnamed :: HasObject doc doc' => SchemaP doc' v m a b -> SchemaP doc v m a b +unnamed :: (HasObject doc doc') => SchemaP doc' v m a b -> SchemaP doc v m a b unnamed = over doc unmkObject -- | Attach a name to a schema. -- -- This only affects the documentation portion of a schema, and not -- the parsing or serialisation. -named :: HasObject doc doc' => Text -> SchemaP doc v m a b -> SchemaP doc' v m a b +named :: (HasObject doc doc') => Text -> SchemaP doc v m a b -> SchemaP doc' v m a b named name = over doc (mkObject name) -- | A schema for a JSON array. @@ -524,7 +524,7 @@ setMinItems :: (HasMinItems doc (Maybe Integer)) => Integer -> ValueSchema doc a setMinItems m = doc . minItems ?~ m -- | Ad-hoc class for types corresponding to JSON primitive types. -class A.ToJSON a => With a where +class (A.ToJSON a) => With a where with :: String -> (a -> A.Parser b) -> A.Value -> A.Parser b instance With Text where @@ -574,7 +574,7 @@ enum name sch = SchemaP (SchemaDoc d) (SchemaIn i) (SchemaOut o) -- -- This is most commonly used for optional fields, and it will cause the field -- to be omitted from the output of the serialiser. -maybe_ :: Monoid w => SchemaP d v w a b -> SchemaP d v w (Maybe a) b +maybe_ :: (Monoid w) => SchemaP d v w a b -> SchemaP d v w (Maybe a) b maybe_ = maybeWithDefault mempty -- | A schema for 'Maybe', producing the given default value on serialisation. @@ -649,7 +649,7 @@ jsonValue :: ValueSchema SwaggerDoc A.Value jsonValue = mkSchema mempty pure Just -- | A schema for a null value. -null_ :: Monoid d => ValueSchemaP d () () +null_ :: (Monoid d) => ValueSchemaP d () () null_ = mkSchema mempty i o where i x = guard (x == A.Null) @@ -662,7 +662,7 @@ null_ = mkSchema mempty i o -- -- The serialiser behaves similarly, but in the other direction. nullable :: - Monoid d => + (Monoid d) => ValueSchema d a -> ValueSchema d (Maybe a) nullable s = @@ -687,14 +687,14 @@ instance Applicative WithDeclare where WithDeclare d1 s1 <*> WithDeclare d2 s2 = WithDeclare (d1 >> d2) (s1 s2) -instance Semigroup s => Semigroup (WithDeclare s) where +instance (Semigroup s) => Semigroup (WithDeclare s) where WithDeclare d1 s1 <> WithDeclare d2 s2 = WithDeclare (d1 >> d2) (s1 <> s2) -instance Monoid s => Monoid (WithDeclare s) where +instance (Monoid s) => Monoid (WithDeclare s) where mempty = WithDeclare (pure ()) mempty -instance NearSemiRing s => NearSemiRing (WithDeclare s) where +instance (NearSemiRing s) => NearSemiRing (WithDeclare s) where zero = WithDeclare (pure ()) zero add (WithDeclare d1 s1) (WithDeclare d2 s2) = WithDeclare (d1 >> d2) (add s1 s2) @@ -745,17 +745,17 @@ instance HasName SwaggerDoc where instance HasName NamedSwaggerDoc where getName = S._namedSchemaName . extract -class Monoid doc => HasField ndoc doc | ndoc -> doc where +class (Monoid doc) => HasField ndoc doc | ndoc -> doc where mkField :: Text -> ndoc -> doc -class Monoid doc => HasObject doc ndoc | doc -> ndoc, ndoc -> doc where +class (Monoid doc) => HasObject doc ndoc | doc -> ndoc, ndoc -> doc where mkObject :: Text -> doc -> ndoc unmkObject :: ndoc -> doc -class Monoid doc => HasArray ndoc doc | ndoc -> doc where +class (Monoid doc) => HasArray ndoc doc | ndoc -> doc where mkArray :: ndoc -> doc -class Monoid doc => HasMap ndoc doc | ndoc -> doc where +class (Monoid doc) => HasMap ndoc doc | ndoc -> doc where mkMap :: ndoc -> doc class HasOpt doc where @@ -764,7 +764,7 @@ class HasOpt doc where class HasEnum a doc where mkEnum :: Text -> [A.Value] -> doc -instance HasSchemaRef doc => HasField doc SwaggerDoc where +instance (HasSchemaRef doc) => HasField doc SwaggerDoc where mkField name = fmap f . schemaRef where f ref = @@ -779,7 +779,7 @@ instance HasObject SwaggerDoc NamedSwaggerDoc where unmkObject (WithDeclare d (S.NamedSchema (Just n) s)) = WithDeclare (d *> S.declare [(n, s)]) s -instance HasSchemaRef ndoc => HasArray ndoc SwaggerDoc where +instance (HasSchemaRef ndoc) => HasArray ndoc SwaggerDoc where mkArray = fmap f . schemaRef where f :: S.Referenced S.Schema -> S.Schema @@ -788,7 +788,7 @@ instance HasSchemaRef ndoc => HasArray ndoc SwaggerDoc where & S.type_ ?~ S.OpenApiArray & S.items ?~ S.OpenApiItemsObject ref -instance HasSchemaRef ndoc => HasMap ndoc SwaggerDoc where +instance (HasSchemaRef ndoc) => HasMap ndoc SwaggerDoc where mkMap = fmap f . schemaRef where f :: S.Referenced S.Schema -> S.Schema @@ -846,24 +846,24 @@ class ToSchema a where newtype Schema a = Schema {getSchema :: a} deriving (Generic) -schemaToSwagger :: forall a. ToSchema a => Proxy a -> Declare S.NamedSchema +schemaToSwagger :: forall a. (ToSchema a) => Proxy a -> Declare S.NamedSchema schemaToSwagger _ = runDeclare (schemaDoc (schema @a)) instance (Typeable a, ToSchema a) => S.ToSchema (Schema a) where declareNamedSchema _ = schemaToSwagger (Proxy @a) -- | JSON serialiser for an instance of 'ToSchema'. -schemaToJSON :: forall a. ToSchema a => a -> A.Value +schemaToJSON :: forall a. (ToSchema a) => a -> A.Value schemaToJSON = fromMaybe A.Null . schemaOut (schema @a) -instance ToSchema a => A.ToJSON (Schema a) where +instance (ToSchema a) => A.ToJSON (Schema a) where toJSON = schemaToJSON . getSchema -- | JSON parser for an instance of 'ToSchema'. -schemaParseJSON :: forall a. ToSchema a => A.Value -> A.Parser a +schemaParseJSON :: forall a. (ToSchema a) => A.Value -> A.Parser a schemaParseJSON = schemaIn schema -instance ToSchema a => A.FromJSON (Schema a) where +instance (ToSchema a) => A.FromJSON (Schema a) where parseJSON = fmap Schema . schemaParseJSON instance ToSchema Text where schema = genericToSchema @@ -899,7 +899,7 @@ instance ToSchema Natural where schema = genericToSchema declareSwaggerSchema :: SchemaP (WithDeclare d) v w a b -> Declare d declareSwaggerSchema = runDeclare . schemaDoc -swaggerDoc :: forall a. S.ToSchema a => NamedSwaggerDoc +swaggerDoc :: forall a. (S.ToSchema a) => NamedSwaggerDoc swaggerDoc = unrunDeclare (S.declareNamedSchema (Proxy @a)) genericToSchema :: forall a. (S.ToSchema a, A.ToJSON a, A.FromJSON a) => ValueSchema NamedSwaggerDoc a @@ -920,7 +920,7 @@ instance S.HasSchema SwaggerDoc S.Schema where instance S.HasSchema NamedSwaggerDoc S.Schema where schema = declared . S.schema -instance S.HasSchema d S.Schema => S.HasSchema (SchemaP d v w a b) S.Schema where +instance (S.HasSchema d S.Schema) => S.HasSchema (SchemaP d v w a b) S.Schema where schema = doc . S.schema instance S.HasDescription NamedSwaggerDoc (Maybe Text) where @@ -929,11 +929,11 @@ instance S.HasDescription NamedSwaggerDoc (Maybe Text) where instance S.HasDeprecated NamedSwaggerDoc (Maybe Bool) where deprecated = declared . S.schema . S.deprecated -instance {-# OVERLAPPABLE #-} S.HasDescription s a => S.HasDescription (WithDeclare s) a where +instance {-# OVERLAPPABLE #-} (S.HasDescription s a) => S.HasDescription (WithDeclare s) a where description = declared . S.description -instance {-# OVERLAPPABLE #-} S.HasDeprecated s a => S.HasDeprecated (WithDeclare s) a where +instance {-# OVERLAPPABLE #-} (S.HasDeprecated s a) => S.HasDeprecated (WithDeclare s) a where deprecated = declared . S.deprecated -instance {-# OVERLAPPABLE #-} S.HasExample s a => S.HasExample (WithDeclare s) a where +instance {-# OVERLAPPABLE #-} (S.HasExample s a) => S.HasExample (WithDeclare s) a where example = declared . S.example diff --git a/libs/ssl-util/src/Ssl/Util.hs b/libs/ssl-util/src/Ssl/Util.hs index 9f9d8ece4e4..f0f7ae19902 100644 --- a/libs/ssl-util/src/Ssl/Util.hs +++ b/libs/ssl-util/src/Ssl/Util.hs @@ -156,7 +156,7 @@ verifyFingerprint hash fprs ssl = do -- | Compute a simple (non-standard) fingerprint of an RSA -- public key for use with 'verifyRsaFingerprint' with the given -- 'Digest'. -rsaFingerprint :: RSAKey k => Digest -> k -> IO ByteString +rsaFingerprint :: (RSAKey k) => Digest -> k -> IO ByteString rsaFingerprint d k = fmap (digestLBS d . toLazyByteString) $ do let s = rsaSize k n <- integerToMPI (rsaN k) diff --git a/libs/tasty-cannon/src/Test/Tasty/Cannon.hs b/libs/tasty-cannon/src/Test/Tasty/Cannon.hs index 9775bb718f7..7fb72b5ca33 100644 --- a/libs/tasty-cannon/src/Test/Tasty/Cannon.hs +++ b/libs/tasty-cannon/src/Test/Tasty/Cannon.hs @@ -103,20 +103,20 @@ data WebSocket = WebSocket wsAppThread :: Async () } -connect :: MonadIO m => Cannon -> UserId -> ConnId -> m WebSocket +connect :: (MonadIO m) => Cannon -> UserId -> ConnId -> m WebSocket connect can uid = connectAsMaybeClient can uid Nothing -connectAsClient :: MonadIO m => Cannon -> UserId -> ClientId -> ConnId -> m WebSocket +connectAsClient :: (MonadIO m) => Cannon -> UserId -> ClientId -> ConnId -> m WebSocket connectAsClient can uid client = connectAsMaybeClient can uid (Just client) -connectAsMaybeClient :: MonadIO m => Cannon -> UserId -> Maybe ClientId -> ConnId -> m WebSocket +connectAsMaybeClient :: (MonadIO m) => Cannon -> UserId -> Maybe ClientId -> ConnId -> m WebSocket connectAsMaybeClient can uid client conn = liftIO $ do nchan <- newTChanIO latch <- newEmptyMVar wsapp <- run can uid client conn (clientApp nchan latch) pure $ WebSocket nchan latch wsapp -close :: MonadIO m => WebSocket -> m () +close :: (MonadIO m) => WebSocket -> m () close ws = liftIO $ do putMVar (wsCloseLatch ws) () void $ waitCatch (wsAppThread ws) @@ -166,10 +166,10 @@ bracketAsClientN c us f = go [] us -- Random Connection IDs -connectR :: MonadIO m => Cannon -> UserId -> m WebSocket +connectR :: (MonadIO m) => Cannon -> UserId -> m WebSocket connectR can uid = randomConnId >>= connect can uid -connectAsClientR :: MonadIO m => Cannon -> UserId -> ClientId -> m WebSocket +connectAsClientR :: (MonadIO m) => Cannon -> UserId -> ClientId -> m WebSocket connectAsClientR can uid clientId = randomConnId >>= connectAsClient can uid clientId bracketR :: (MonadIO m, MonadMask m) => Cannon -> UserId -> (WebSocket -> m a) -> m a @@ -271,7 +271,7 @@ instance Show RegistrationTimeout where show (RegistrationTimeout s) = "Failed to find a registration after " ++ show s ++ " retries.\n" -await :: MonadIO m => Timeout -> WebSocket -> m (Maybe Notification) +await :: (MonadIO m) => Timeout -> WebSocket -> m (Maybe Notification) await t = liftIO . timeout t . atomically . readTChan . wsChan -- | 'await' a 'Notification' on the 'WebSocket'. If it satisfies the 'Assertion', return it. @@ -372,7 +372,7 @@ assertNoEvent t ww = do ----------------------------------------------------------------------------- -- Unpacking Notifications -unpackPayload :: FromJSON a => Notification -> List1 a +unpackPayload :: (FromJSON a) => Notification -> List1 a unpackPayload = fmap decodeEvent . ntfPayload where decodeEvent o = case fromJSON (Object o) of @@ -382,7 +382,7 @@ unpackPayload = fmap decodeEvent . ntfPayload ----------------------------------------------------------------------------- -- Randomness -randomConnId :: MonadIO m => m ConnId +randomConnId :: (MonadIO m) => m ConnId randomConnId = liftIO $ do r <- randomIO :: IO Word32 pure . ConnId $ C.pack $ show r @@ -392,7 +392,7 @@ randomConnId = liftIO $ do -- | Start a client thread in 'Async' that opens a web socket to a Cannon, wait -- for the connection to register with Gundeck, and return the 'Async' thread. -run :: MonadIO m => Cannon -> UserId -> Maybe ClientId -> ConnId -> WS.ClientApp () -> m (Async ()) +run :: (MonadIO m) => Cannon -> UserId -> Maybe ClientId -> ConnId -> WS.ClientApp () -> m (Async ()) run cannon@(($ Http.defaultRequest) -> ca) uid client connId app = liftIO $ do latch <- newEmptyMVar wsapp <- diff --git a/libs/types-common-journal/src/Data/Proto.hs b/libs/types-common-journal/src/Data/Proto.hs index b0a7de0c4b8..64fed865650 100644 --- a/libs/types-common-journal/src/Data/Proto.hs +++ b/libs/types-common-journal/src/Data/Proto.hs @@ -20,5 +20,5 @@ module Data.Proto where import Data.Time.Clock.POSIX import Imports -now :: MonadIO m => m Int64 +now :: (MonadIO m) => m Int64 now = liftIO $ round . utcTimeToPOSIXSeconds <$> getCurrentTime diff --git a/libs/types-common/src/Data/Code.hs b/libs/types-common/src/Data/Code.hs index ef70a0aeb52..6bba1c5f087 100644 --- a/libs/types-common/src/Data/Code.hs +++ b/libs/types-common/src/Data/Code.hs @@ -44,7 +44,7 @@ import Test.QuickCheck (Arbitrary (arbitrary)) -- | A scoped identifier for a 'Value' with an associated 'Timeout'. newtype Key = Key {asciiKey :: Range 20 20 AsciiBase64Url} - deriving (Eq, Show) + deriving (Eq, Show, Ord) deriving newtype ( A.FromJSON, A.ToJSON, diff --git a/libs/types-common/src/Data/CommaSeparatedList.hs b/libs/types-common/src/Data/CommaSeparatedList.hs index 36f072914be..fa4f07396f2 100644 --- a/libs/types-common/src/Data/CommaSeparatedList.hs +++ b/libs/types-common/src/Data/CommaSeparatedList.hs @@ -37,11 +37,11 @@ newtype CommaSeparatedList a = CommaSeparatedList {fromCommaSeparatedList :: [a] deriving (Functor, Foldable, Traversable) deriving newtype (Bounds, Semigroup, Monoid) -instance FromByteString (List a) => FromHttpApiData (CommaSeparatedList a) where +instance (FromByteString (List a)) => FromHttpApiData (CommaSeparatedList a) where parseUrlPiece t = CommaSeparatedList . fromList <$> Bifunctor.first Text.pack (runParser parser $ encodeUtf8 t) -instance ToByteString (List a) => ToHttpApiData (CommaSeparatedList a) where +instance (ToByteString (List a)) => ToHttpApiData (CommaSeparatedList a) where toQueryParam (CommaSeparatedList l) = decodeUtf8With lenientDecode $ toStrict $ toByteString $ builder $ List l instance ToParamSchema (CommaSeparatedList a) where diff --git a/libs/types-common/src/Data/ETag.hs b/libs/types-common/src/Data/ETag.hs index c042a042f43..948435e7c62 100644 --- a/libs/types-common/src/Data/ETag.hs +++ b/libs/types-common/src/Data/ETag.hs @@ -67,7 +67,7 @@ data Digest = MD5 | SHA1 -- of arbitrary types to a 'Builder', concatenating them, and applying the hash -- function on the result. data Opaque (d :: Digest) where - Opaque :: ToByteString a => a -> Opaque d + Opaque :: (ToByteString a) => a -> Opaque d instance ToByteString (Opaque 'MD5) where builder (Opaque x) = @@ -80,11 +80,11 @@ instance ToByteString (Opaque 'SHA1) where instance Semigroup (Opaque d) where Opaque a <> Opaque b = Opaque (builder a <> builder b) -opaqueMD5 :: ToByteString a => a -> Opaque 'MD5 +opaqueMD5 :: (ToByteString a) => a -> Opaque 'MD5 opaqueMD5 = Opaque {-# INLINE opaqueMD5 #-} -opaqueSHA1 :: ToByteString a => a -> Opaque 'SHA1 +opaqueSHA1 :: (ToByteString a) => a -> Opaque 'SHA1 opaqueSHA1 = Opaque {-# INLINE opaqueSHA1 #-} @@ -103,11 +103,11 @@ data ETag a | WeakETag !a deriving (Eq, Show) -instance ToByteString a => ToByteString (ETag a) where +instance (ToByteString a) => ToByteString (ETag a) where builder (StrictETag v) = byteString "\"" <> builder v <> byteString "\"" builder (WeakETag v) = byteString "W/\"" <> builder v <> byteString "\"" -instance FromByteString a => FromByteString (ETag a) where +instance (FromByteString a) => FromByteString (ETag a) where parser = do w <- optional (string "W/") v <- char '"' *> takeWhile (/= '"') <* char '"' @@ -115,7 +115,7 @@ instance FromByteString a => FromByteString (ETag a) where Left e -> fail e Right a -> pure $ maybe (StrictETag a) (const $ WeakETag a) w -instance Semigroup a => Semigroup (ETag a) where +instance (Semigroup a) => Semigroup (ETag a) where StrictETag a <> StrictETag b = StrictETag (a <> b) StrictETag a <> WeakETag b = WeakETag (a <> b) WeakETag a <> StrictETag b = WeakETag (a <> b) diff --git a/libs/types-common/src/Data/Handle.hs b/libs/types-common/src/Data/Handle.hs index 59854e89ec8..64842b51e70 100644 --- a/libs/types-common/src/Data/Handle.hs +++ b/libs/types-common/src/Data/Handle.hs @@ -18,14 +18,16 @@ -- with this program. If not, see . module Data.Handle - ( Handle (..), + ( Handle (fromHandle), parseHandle, parseHandleEither, isValidHandle, + BadHandle (..), ) where import Cassandra qualified as C +import Control.Lens (ix, (.~)) import Data.Aeson (FromJSON (..), ToJSON (..)) import Data.Attoparsec.ByteString.Char8 qualified as Atto import Data.Bifunctor (Bifunctor (first)) @@ -101,3 +103,24 @@ instance Arbitrary Handle where Handle . Text.pack <$> do len <- oneof [choose (2, 10), choose (2, 256)] -- prefer short handles replicateM len (elements $ ['a' .. 'z'] <> ['0' .. '9'] <> "_-.") + +-- | for testing +newtype BadHandle = BadHandle {fromBadHandle :: Text} + deriving newtype (Eq, Show) + +instance Arbitrary BadHandle where + arbitrary = oneof [tooShort, tooLong, badBytes] + where + tooShort = (BadHandle . Text.pack . (: [])) <$> elements validChar + tooLong = (BadHandle . Text.pack) <$> replicateM 258 (elements validChar) + badBytes = + BadHandle <$> do + totalLen :: Int <- choose (2, 256) + invalidCharPos :: Int <- choose (0, totalLen - 1) + invalidCharContent <- elements invalidChar + good :: Text <- Text.pack <$> replicateM totalLen (elements validChar) + let bad :: Text = good & ix invalidCharPos .~ invalidCharContent + pure bad + + validChar :: [Char] = ['a' .. 'z'] <> ['0' .. '9'] <> "_-." + invalidChar :: [Char] = [minBound ..] \\ validChar diff --git a/libs/types-common/src/Data/Id.hs b/libs/types-common/src/Data/Id.hs index 2f57ba3d920..3ef7152c913 100644 --- a/libs/types-common/src/Data/Id.hs +++ b/libs/types-common/src/Data/Id.hs @@ -235,7 +235,7 @@ instance A.ToJSONKey (Id a) where instance A.FromJSONKey (Id a) where fromJSONKey = A.FromJSONKeyTextParser idFromText -randomId :: MonadIO m => m (Id a) +randomId :: (MonadIO m) => m (Id a) randomId = Id <$> liftIO nextRandom idFromText :: Text -> A.Parser (Id a) @@ -444,7 +444,7 @@ newtype IdObject a = IdObject {fromIdObject :: a} deriving (Eq, Show, Generic) deriving (ToJSON, FromJSON, S.ToSchema) via Schema (IdObject a) -instance ToSchema a => ToSchema (IdObject a) where +instance (ToSchema a) => ToSchema (IdObject a) where schema = idObjectSchema (IdObject <$> fromIdObject .= schema) idObjectSchema :: ValueSchemaP NamedSwaggerDoc a b -> ValueSchemaP NamedSwaggerDoc a b diff --git a/libs/types-common/src/Data/List1.hs b/libs/types-common/src/Data/List1.hs index 8a1d31555d2..c98f0099453 100644 --- a/libs/types-common/src/Data/List1.hs +++ b/libs/types-common/src/Data/List1.hs @@ -64,7 +64,7 @@ head :: List1 a -> a head = N.head . toNonEmpty {-# INLINE head #-} -instance ToSchema a => ToSchema (List1 a) where +instance (ToSchema a) => ToSchema (List1 a) where schema = named "List1" $ toNonEmpty S..= fmap List1 (nonEmptyArray S.schema) diff --git a/libs/types-common/src/Data/Misc.hs b/libs/types-common/src/Data/Misc.hs index 837c24d18c2..fc896fb1e59 100644 --- a/libs/types-common/src/Data/Misc.hs +++ b/libs/types-common/src/Data/Misc.hs @@ -341,9 +341,9 @@ newtype PlainTextPassword' (minLen :: Nat) = PlainTextPassword' {fromPlainTextPassword' :: Range minLen (1024 :: Nat) Text} deriving stock (Eq, Generic) -deriving via (Schema (PlainTextPassword' tag)) instance ToSchema (PlainTextPassword' tag) => FromJSON (PlainTextPassword' tag) +deriving via (Schema (PlainTextPassword' tag)) instance (ToSchema (PlainTextPassword' tag)) => FromJSON (PlainTextPassword' tag) -deriving via (Schema (PlainTextPassword' tag)) instance ToSchema (PlainTextPassword' tag) => ToJSON (PlainTextPassword' tag) +deriving via (Schema (PlainTextPassword' tag)) instance (ToSchema (PlainTextPassword' tag)) => ToJSON (PlainTextPassword' tag) deriving via (Schema (PlainTextPassword' tag)) instance (KnownNat tag, ToSchema (PlainTextPassword' tag)) => S.ToSchema (PlainTextPassword' tag) @@ -368,12 +368,12 @@ newtype FutureWork label payload = FutureWork payload ------------------------------------------------------------------------------- -- | Same as 'read' but works on 'Text' -readT :: Read a => Text -> Maybe a +readT :: (Read a) => Text -> Maybe a readT = readMaybe . Text.unpack {-# INLINE readT #-} -- | Same as 'show' but works on 'Text' -showT :: Show a => a -> Text +showT :: (Show a) => a -> Text showT = Text.pack . show {-# INLINE showT #-} diff --git a/libs/types-common/src/Data/Nonce.hs b/libs/types-common/src/Data/Nonce.hs index 50d84f7c655..ca5c502f1ed 100644 --- a/libs/types-common/src/Data/Nonce.hs +++ b/libs/types-common/src/Data/Nonce.hs @@ -84,7 +84,7 @@ instance FromHttpApiData Nonce where . fromStrict . encodeUtf8 -randomNonce :: MonadIO m => m Nonce +randomNonce :: (MonadIO m) => m Nonce randomNonce = Nonce <$> liftIO nextRandom isValidBase64UrlEncodedUUID :: ByteString -> Bool diff --git a/libs/types-common/src/Data/Qualified.hs b/libs/types-common/src/Data/Qualified.hs index 1c1ba088e10..0d1632ad4b1 100644 --- a/libs/types-common/src/Data/Qualified.hs +++ b/libs/types-common/src/Data/Qualified.hs @@ -131,25 +131,25 @@ foldQualified loc f g q -- Note that the local values are returned as unqualified values, as a (probably -- insignificant) optimisation. Use 'partitionQualifiedAndTag' to get them as -- 'Local' values. -partitionQualified :: Foldable f => Local x -> f (Qualified a) -> ([a], [Remote a]) +partitionQualified :: (Foldable f) => Local x -> f (Qualified a) -> ([a], [Remote a]) partitionQualified loc = foldMap $ foldQualified loc (\l -> ([tUnqualified l], mempty)) (\r -> (mempty, [r])) -partitionQualifiedAndTag :: Foldable f => Local x -> f (Qualified a) -> ([Local a], [Remote a]) +partitionQualifiedAndTag :: (Foldable f) => Local x -> f (Qualified a) -> ([Local a], [Remote a]) partitionQualifiedAndTag loc = first (map (qualifyAs loc)) . partitionQualified loc -- | Index a list of qualified values by domain. -indexQualified :: Foldable f => f (Qualified a) -> Map Domain [a] +indexQualified :: (Foldable f) => f (Qualified a) -> Map Domain [a] indexQualified = foldr add mempty where add :: Qualified a -> Map Domain [a] -> Map Domain [a] add (Qualified x domain) = Map.insertWith (<>) domain [x] -- | Bucket a list of qualified values by domain. -bucketQualified :: Foldable f => f (Qualified a) -> [Qualified [a]] +bucketQualified :: (Foldable f) => f (Qualified a) -> [Qualified [a]] bucketQualified = map (\(d, a) -> Qualified a d) . Map.assocs . indexQualified bucketRemote :: (Functor f, Foldable f) => f (Remote a) -> [Remote [a]] @@ -171,7 +171,7 @@ deprecatedSchema new = . (deprecated ?~ True) qualifiedSchema :: - HasSchemaRef doc => + (HasSchemaRef doc) => Text -> Text -> ValueSchema doc a -> @@ -181,7 +181,7 @@ qualifiedSchema name fieldName sch = qualifiedObjectSchema fieldName sch qualifiedObjectSchema :: - HasSchemaRef d => + (HasSchemaRef d) => Text -> ValueSchema d a -> ObjectSchema SwaggerDoc (Qualified a) @@ -190,16 +190,16 @@ qualifiedObjectSchema fieldName sch = <$> qDomain .= field "domain" schema <*> qUnqualified .= field fieldName sch -instance KnownIdTag t => ToSchema (Qualified (Id t)) where +instance (KnownIdTag t) => ToSchema (Qualified (Id t)) where schema = qualifiedSchema (idTagName (idTagValue @t) <> "Id") "id" schema instance ToSchema (Qualified Handle) where schema = qualifiedSchema "Handle" "handle" schema -instance KnownIdTag t => ToJSON (Qualified (Id t)) where +instance (KnownIdTag t) => ToJSON (Qualified (Id t)) where toJSON = schemaToJSON -instance KnownIdTag t => FromJSON (Qualified (Id t)) where +instance (KnownIdTag t) => FromJSON (Qualified (Id t)) where parseJSON = schemaParseJSON instance (Typeable t, KnownIdTag t) => S.ToSchema (Qualified (Id t)) where @@ -217,5 +217,5 @@ instance S.ToSchema (Qualified Handle) where ---------------------------------------------------------------------- -- ARBITRARY -instance Arbitrary a => Arbitrary (Qualified a) where +instance (Arbitrary a) => Arbitrary (Qualified a) where arbitrary = Qualified <$> arbitrary <*> arbitrary diff --git a/libs/types-common/src/Data/Range.hs b/libs/types-common/src/Data/Range.hs index d7a92f08d11..73cdda9fea7 100644 --- a/libs/types-common/src/Data/Range.hs +++ b/libs/types-common/src/Data/Range.hs @@ -109,7 +109,7 @@ instance (Show a, Num a, Within a n m, KnownNat n, KnownNat m) => Bounded (Range instance NFData (Range n m a) where rnf (Range a) = seq a () -instance ToJSON a => ToJSON (Range n m a) where +instance (ToJSON a) => ToJSON (Range n m a) where toJSON = toJSON . fromRange instance forall a n m. (KnownNat n, KnownNat m, Within a n m, FromJSON a) => FromJSON (Range n m a) where @@ -135,47 +135,48 @@ untypedRangedSchema :: untypedRangedSchema n m sch = (sch `withParser` check) & doc %~ rangedSchemaDocModifier (Proxy @b) n m where check x = - x <$ guard (within x n m) - <|> fail (errorMsg n m "") + x + <$ guard (within x n m) + <|> fail (errorMsg n m "") -class Bounds a => HasRangedSchemaDocModifier d a where +class (Bounds a) => HasRangedSchemaDocModifier d a where rangedSchemaDocModifier :: Proxy a -> Integer -> Integer -> d -> d -listRangedSchemaDocModifier :: S.HasSchema d S.Schema => Integer -> Integer -> d -> d +listRangedSchemaDocModifier :: (S.HasSchema d S.Schema) => Integer -> Integer -> d -> d listRangedSchemaDocModifier n m = S.schema %~ ((S.minItems ?~ n) . (S.maxItems ?~ m)) -stringRangedSchemaDocModifier :: S.HasSchema d S.Schema => Integer -> Integer -> d -> d +stringRangedSchemaDocModifier :: (S.HasSchema d S.Schema) => Integer -> Integer -> d -> d stringRangedSchemaDocModifier n m = S.schema %~ ((S.minLength ?~ n) . (S.maxLength ?~ m)) -numRangedSchemaDocModifier :: S.HasSchema d S.Schema => Integer -> Integer -> d -> d +numRangedSchemaDocModifier :: (S.HasSchema d S.Schema) => Integer -> Integer -> d -> d numRangedSchemaDocModifier n m = S.schema %~ ((S.minimum_ ?~ fromIntegral n) . (S.maximum_ ?~ fromIntegral m)) -instance S.HasSchema d S.Schema => HasRangedSchemaDocModifier d [a] where rangedSchemaDocModifier _ = listRangedSchemaDocModifier +instance (S.HasSchema d S.Schema) => HasRangedSchemaDocModifier d [a] where rangedSchemaDocModifier _ = listRangedSchemaDocModifier -- Sets are similar to lists, so use that as our defininition -instance S.HasSchema d S.Schema => HasRangedSchemaDocModifier d (Set a) where rangedSchemaDocModifier _ = listRangedSchemaDocModifier +instance (S.HasSchema d S.Schema) => HasRangedSchemaDocModifier d (Set a) where rangedSchemaDocModifier _ = listRangedSchemaDocModifier -instance S.HasSchema d S.Schema => HasRangedSchemaDocModifier d Text where rangedSchemaDocModifier _ = stringRangedSchemaDocModifier +instance (S.HasSchema d S.Schema) => HasRangedSchemaDocModifier d Text where rangedSchemaDocModifier _ = stringRangedSchemaDocModifier -instance S.HasSchema d S.Schema => HasRangedSchemaDocModifier d String where rangedSchemaDocModifier _ = stringRangedSchemaDocModifier +instance (S.HasSchema d S.Schema) => HasRangedSchemaDocModifier d String where rangedSchemaDocModifier _ = stringRangedSchemaDocModifier -instance S.HasSchema d S.Schema => HasRangedSchemaDocModifier d (AsciiText c) where rangedSchemaDocModifier _ = stringRangedSchemaDocModifier +instance (S.HasSchema d S.Schema) => HasRangedSchemaDocModifier d (AsciiText c) where rangedSchemaDocModifier _ = stringRangedSchemaDocModifier -instance S.HasSchema d S.Schema => HasRangedSchemaDocModifier d Int where rangedSchemaDocModifier _ = numRangedSchemaDocModifier +instance (S.HasSchema d S.Schema) => HasRangedSchemaDocModifier d Int where rangedSchemaDocModifier _ = numRangedSchemaDocModifier -instance S.HasSchema d S.Schema => HasRangedSchemaDocModifier d Int32 where rangedSchemaDocModifier _ = numRangedSchemaDocModifier +instance (S.HasSchema d S.Schema) => HasRangedSchemaDocModifier d Int32 where rangedSchemaDocModifier _ = numRangedSchemaDocModifier -instance S.HasSchema d S.Schema => HasRangedSchemaDocModifier d Integer where rangedSchemaDocModifier _ = numRangedSchemaDocModifier +instance (S.HasSchema d S.Schema) => HasRangedSchemaDocModifier d Integer where rangedSchemaDocModifier _ = numRangedSchemaDocModifier -instance S.HasSchema d S.Schema => HasRangedSchemaDocModifier d Word where rangedSchemaDocModifier _ = numRangedSchemaDocModifier +instance (S.HasSchema d S.Schema) => HasRangedSchemaDocModifier d Word where rangedSchemaDocModifier _ = numRangedSchemaDocModifier -instance S.HasSchema d S.Schema => HasRangedSchemaDocModifier d Word8 where rangedSchemaDocModifier _ = numRangedSchemaDocModifier +instance (S.HasSchema d S.Schema) => HasRangedSchemaDocModifier d Word8 where rangedSchemaDocModifier _ = numRangedSchemaDocModifier -instance S.HasSchema d S.Schema => HasRangedSchemaDocModifier d Word16 where rangedSchemaDocModifier _ = numRangedSchemaDocModifier +instance (S.HasSchema d S.Schema) => HasRangedSchemaDocModifier d Word16 where rangedSchemaDocModifier _ = numRangedSchemaDocModifier -instance S.HasSchema d S.Schema => HasRangedSchemaDocModifier d Word32 where rangedSchemaDocModifier _ = numRangedSchemaDocModifier +instance (S.HasSchema d S.Schema) => HasRangedSchemaDocModifier d Word32 where rangedSchemaDocModifier _ = numRangedSchemaDocModifier -instance S.HasSchema d S.Schema => HasRangedSchemaDocModifier d Word64 where rangedSchemaDocModifier _ = numRangedSchemaDocModifier +instance (S.HasSchema d S.Schema) => HasRangedSchemaDocModifier d Word64 where rangedSchemaDocModifier _ = numRangedSchemaDocModifier instance (KnownNat n, KnownNat m, Within a n m, ToSchema a, HasRangedSchemaDocModifier NamedSwaggerDoc a) => ToSchema (Range n m a) where schema = fromRange .= rangedSchema schema @@ -246,7 +247,7 @@ instance (KnownNat n, KnownNat m, Within a n m, FromHttpApiData a) => FromHttpAp type Within a (n :: Nat) (m :: Nat) = (Bounds a, n <= m) -mk :: Bounds a => a -> Nat -> Nat -> Maybe (Range n m a) +mk :: (Bounds a) => a -> Nat -> Nat -> Maybe (Range n m a) mk a n m = if within a (toInteger n) (toInteger m) then Just (Range a) @@ -263,7 +264,7 @@ errorMsg n m = . shows m . showString "]" -checkedEitherMsg :: forall a n m. (KnownNat n, KnownNat m) => Within a n m => String -> a -> Either String (Range n m a) +checkedEitherMsg :: forall a n m. (KnownNat n, KnownNat m) => (Within a n m) => String -> a -> Either String (Range n m a) checkedEitherMsg msg x = do let sn = natVal (Proxy @n) sm = natVal (Proxy @m) @@ -271,7 +272,7 @@ checkedEitherMsg msg x = do Nothing -> Left $ showString msg . showString ": " . errorMsg sn sm $ "" Just r -> Right r -checkedEither :: forall a n m. (KnownNat n, KnownNat m) => Within a n m => a -> Either String (Range n m a) +checkedEither :: forall a n m. (KnownNat n, KnownNat m) => (Within a n m) => a -> Either String (Range n m a) checkedEither x = do let sn = natVal (Proxy @n) sm = natVal (Proxy @m) @@ -300,10 +301,10 @@ unsafeRange x = fromMaybe msg (checked x) rcast :: (n <= m, m <= m', n >= n') => Range n m a -> Range n' m' a rcast (Range a) = Range a -rnil :: Monoid a => Range 0 0 a +rnil :: (Monoid a) => Range 0 0 a rnil = Range mempty -rcons, (<|) :: n <= m => a -> Range n m [a] -> Range n (m + 1) [a] +rcons, (<|) :: (n <= m) => a -> Range n m [a] -> Range n (m + 1) [a] rcons a (Range aa) = Range (a : aa) infixr 5 <| @@ -397,7 +398,7 @@ instance Bounds (HashMap k a) where instance Bounds (HashSet a) where within x y z = rangeCheck (length (take (fromIntegral z + 1) (HashSet.toList x))) y z -instance Bounds a => Bounds (Maybe a) where +instance (Bounds a) => Bounds (Maybe a) where within Nothing _ _ = True within (Just x) y z = within x y z @@ -420,7 +421,7 @@ instance (KnownNat n, KnownNat m, Within a n m, FromByteString a) => FromByteStr where msg = fail (errorMsg (natVal (Proxy @n)) (natVal (Proxy @m)) "") -instance ToByteString a => ToByteString (Range n m a) where +instance (ToByteString a) => ToByteString (Range n m a) where builder = builder . fromRange ---------------------------------------------------------------------------- @@ -430,7 +431,7 @@ instance ToByteString a => ToByteString (Range n m a) where newtype Ranged m n a = Ranged {fromRanged :: a} deriving stock (Show) -instance Arbitrary (Range m n a) => Arbitrary (Ranged m n a) where +instance (Arbitrary (Range m n a)) => Arbitrary (Ranged m n a) where arbitrary = Ranged . fromRange <$> arbitrary @(Range m n a) instance diff --git a/libs/types-common/src/Data/RetryAfter.hs b/libs/types-common/src/Data/RetryAfter.hs index e06c6b8bd06..ced0efd84e0 100644 --- a/libs/types-common/src/Data/RetryAfter.hs +++ b/libs/types-common/src/Data/RetryAfter.hs @@ -21,4 +21,4 @@ import Imports newtype RetryAfter = RetryAfter {retryAfterSeconds :: Int64} - deriving (Eq, Show) + deriving (Eq, Show, Num, Ord, Enum, Real, Integral) diff --git a/libs/types-common/src/Data/SizedHashMap.hs b/libs/types-common/src/Data/SizedHashMap.hs index 81494390103..b7070a6b2fc 100644 --- a/libs/types-common/src/Data/SizedHashMap.hs +++ b/libs/types-common/src/Data/SizedHashMap.hs @@ -44,7 +44,7 @@ size (SizedHashMap s _) = s empty :: forall k v. SizedHashMap k v empty = SizedHashMap 0 M.empty -insert :: forall k v. Hashable k => k -> v -> SizedHashMap k v -> SizedHashMap k v +insert :: forall k v. (Hashable k) => k -> v -> SizedHashMap k v -> SizedHashMap k v insert k v (SizedHashMap n hm) = SizedHashMap n' hm' where n' = if M.member k hm then n else n + 1 @@ -59,10 +59,10 @@ elems (SizedHashMap _ hm) = M.elems hm toList :: forall k v. SizedHashMap k v -> [(k, v)] toList (SizedHashMap _ hm) = M.toList hm -lookup :: forall k v. Hashable k => k -> SizedHashMap k v -> Maybe v +lookup :: forall k v. (Hashable k) => k -> SizedHashMap k v -> Maybe v lookup k (SizedHashMap _ hm) = M.lookup k hm -delete :: forall k v. Hashable k => k -> SizedHashMap k v -> SizedHashMap k v +delete :: forall k v. (Hashable k) => k -> SizedHashMap k v -> SizedHashMap k v delete k (SizedHashMap n hm) = SizedHashMap n' hm' where n' = if M.member k hm then n - 1 else n diff --git a/libs/types-common/src/Data/Text/Ascii.hs b/libs/types-common/src/Data/Text/Ascii.hs index 0fac4b07e2f..aed072030c0 100644 --- a/libs/types-common/src/Data/Text/Ascii.hs +++ b/libs/types-common/src/Data/Text/Ascii.hs @@ -138,36 +138,36 @@ class AsciiChars c where -- | Note: Assumes UTF8 encoding. If the bytestring is known to -- be in a different encoding, 'validate' the text after decoding it with -- the correct encoding instead of using this instance. -instance AsciiChars c => FromByteString (AsciiText c) where +instance (AsciiChars c) => FromByteString (AsciiText c) where parser = parseBytes validate -- | Note: 'fromString' is a partial function that will 'error' when given -- a string containing characters not in the set @c@. It is only intended to be used -- via the @OverloadedStrings@ extension, i.e. for known ASCII string literals. -instance AsciiChars c => IsString (AsciiText c) where +instance (AsciiChars c) => IsString (AsciiText c) where fromString = unsafeString validate -instance AsciiChars c => ToSchema (AsciiText c) where +instance (AsciiChars c) => ToSchema (AsciiText c) where schema = toText .= parsedText "ASCII" validate -instance AsciiChars c => ToJSON (AsciiText c) where +instance (AsciiChars c) => ToJSON (AsciiText c) where toJSON = schemaToJSON -instance AsciiChars c => FromJSON (AsciiText c) where +instance (AsciiChars c) => FromJSON (AsciiText c) where parseJSON = schemaParseJSON instance (Typeable c, AsciiChars c) => S.ToSchema (AsciiText c) where declareNamedSchema = schemaToSwagger -instance AsciiChars c => Cql (AsciiText c) where +instance (AsciiChars c) => Cql (AsciiText c) where ctype = Tagged AsciiColumn toCql = CqlAscii . toText fromCql = fmap (unsafeFromText . fromAscii) . fromCql -fromAsciiChars :: AsciiChars c => [AsciiChar c] -> AsciiText c +fromAsciiChars :: (AsciiChars c) => [AsciiChar c] -> AsciiText c fromAsciiChars = fromString . map toChar -fromChar :: AsciiChars c => c -> Char -> Maybe (AsciiChar c) +fromChar :: (AsciiChars c) => c -> Char -> Maybe (AsciiChar c) fromChar c char | contains c char = Just (AsciiChar char) | otherwise = Nothing @@ -379,13 +379,13 @@ widenChar (AsciiChar t) = AsciiChar t -- | Construct 'AsciiText' from a known ASCII 'Text'. -- This is a total function but unsafe because the text is not checked -- for non-ASCII characters. -unsafeFromText :: AsciiChars c => Text -> AsciiText c +unsafeFromText :: (AsciiChars c) => Text -> AsciiText c unsafeFromText = AsciiText -- | Construct 'AsciiText' from a known ASCII 'ByteString'. -- This is a total function but unsafe because the bytestring is not checked -- for non-ASCII characters. -unsafeFromByteString :: AsciiChars c => ByteString -> AsciiText c +unsafeFromByteString :: (AsciiChars c) => ByteString -> AsciiText c unsafeFromByteString = AsciiText . decodeLatin1 -------------------------------------------------------------------------------- diff --git a/libs/types-common/src/Data/UUID/Tagged.hs b/libs/types-common/src/Data/UUID/Tagged.hs index 5f573d38dfb..fa6eb11ce5f 100644 --- a/libs/types-common/src/Data/UUID/Tagged.hs +++ b/libs/types-common/src/Data/UUID/Tagged.hs @@ -58,7 +58,7 @@ data V5 instance Version V5 where versionValue = 5 -mk :: forall v. Version v => D.UUID -> UUID v +mk :: forall v. (Version v) => D.UUID -> UUID v mk u = UUID $ case D.toWords u of (x0, x1, x2, x3) -> diff --git a/libs/types-common/src/Util/Options.hs b/libs/types-common/src/Util/Options.hs index f9beac14583..2d46e74097a 100644 --- a/libs/types-common/src/Util/Options.hs +++ b/libs/types-common/src/Util/Options.hs @@ -102,7 +102,7 @@ loadSecret (FilePathSecrets p) = do -- instead of the command line. getOptions :: forall a. - FromJSON a => + (FromJSON a) => -- | Program description String -> -- | CLI parser for the options (if there is no config) diff --git a/libs/types-common/src/Wire/Arbitrary.hs b/libs/types-common/src/Wire/Arbitrary.hs index 59c4504eedf..516ea477dd2 100644 --- a/libs/types-common/src/Wire/Arbitrary.hs +++ b/libs/types-common/src/Wire/Arbitrary.hs @@ -88,10 +88,10 @@ customSizedOpts = nonEmptyListOf' :: Gen a -> Gen (NonEmpty a) nonEmptyListOf' g = (:|) <$> g <*> listOf' g -setOf' :: Ord a => Gen a -> Gen (Set a) +setOf' :: (Ord a) => Gen a -> Gen (Set a) setOf' g = Set.fromList <$> Generic.listOf' g -mapOf' :: Ord k => Gen k -> Gen v -> Gen (Map k v) +mapOf' :: (Ord k) => Gen k -> Gen v -> Gen (Map k v) mapOf' genK genV = Map.fromList <$> Generic.listOf' (liftA2 (,) genK genV) -------------------------------------------------------------------------------- @@ -116,7 +116,7 @@ deriving via (GenericUniform CountryCode) instance Arbitrary CountryCode -- we cannot rely on swagger-ui to generate nice examples. So far, this is only -- required for maps as swagger2 doesn't have a good way to specify the type of -- keys. -generateExample :: Arbitrary a => a +generateExample :: (Arbitrary a) => a generateExample = let (MkGen f) = arbitrary in f (mkQCGen 42) 42 diff --git a/libs/types-common/test/Test/Handle.hs b/libs/types-common/test/Test/Handle.hs index d194cbe13b7..0f6bc8b3352 100644 --- a/libs/types-common/test/Test/Handle.hs +++ b/libs/types-common/test/Test/Handle.hs @@ -20,7 +20,7 @@ module Test.Handle ) where -import Data.Handle (Handle (fromHandle), parseHandleEither) +import Data.Handle (BadHandle (fromBadHandle), Handle (fromHandle), parseHandleEither) import Data.Text qualified as Text import Imports import Test.Tasty @@ -67,5 +67,8 @@ testHandleSerialization = Right parsed -> assertFailure $ "invalid handle parsed successfully: " <> show (h, parsed), testProperty "roundtrip for Handle" $ \(x :: Handle) -> - parseHandleEither (fromHandle x) === Right x + parseHandleEither (fromHandle x) === Right x, + testProperty "roundtrip for BadHandle" $ + \(x :: BadHandle) -> + property . isLeft . parseHandleEither $ fromBadHandle x ] diff --git a/libs/types-common/test/Test/Properties.hs b/libs/types-common/test/Test/Properties.hs index fbd1de60122..e8ce0320de7 100644 --- a/libs/types-common/test/Test/Properties.hs +++ b/libs/types-common/test/Test/Properties.hs @@ -137,7 +137,7 @@ tests = (BS.fromByteString' . cs . BS.toByteString') t === Just t, -- - let toUTCTimeMillisSlow :: HasCallStack => UTCTime -> Maybe UTCTime + let toUTCTimeMillisSlow :: (HasCallStack) => UTCTime -> Maybe UTCTime toUTCTimeMillisSlow t = parseExact formatRounded where parseExact = parseTimeM True defaultTimeLocale "%FT%T%QZ" diff --git a/libs/wai-utilities/default.nix b/libs/wai-utilities/default.nix index bc345ab3586..db4b25e4fb6 100644 --- a/libs/wai-utilities/default.nix +++ b/libs/wai-utilities/default.nix @@ -11,23 +11,26 @@ , errors , exceptions , gitignoreSource +, hspec +, hspec-discover , http-types , http2 , imports , kan-extensions , lib , metrics-core -, metrics-wai , openapi3 , pipes , prometheus-client , schema-profunctor , servant-server , streaming-commons +, temporary , text , tinylog , types-common , unix +, uuid , wai , wai-predicates , wai-routing @@ -51,7 +54,6 @@ mkDerivation { imports kan-extensions metrics-core - metrics-wai openapi3 pipes prometheus-client @@ -62,12 +64,23 @@ mkDerivation { tinylog types-common unix + uuid wai wai-predicates wai-routing warp warp-tls ]; + testHaskellDepends = [ + bytestring + hspec + http-types + imports + temporary + tinylog + wai + ]; + testToolDepends = [ hspec-discover ]; description = "Various helpers for WAI"; license = lib.licenses.agpl3Only; } diff --git a/libs/wai-utilities/src/Network/Wai/Utilities/Error.hs b/libs/wai-utilities/src/Network/Wai/Utilities/Error.hs index ba7bdcf90fd..aea3d8b41f3 100644 --- a/libs/wai-utilities/src/Network/Wai/Utilities/Error.hs +++ b/libs/wai-utilities/src/Network/Wai/Utilities/Error.hs @@ -98,5 +98,5 @@ instance FromJSON Error where -- FIXME: This should not live here. infixl 5 !>> -(!>>) :: Monad m => ExceptT a m r -> (a -> b) -> ExceptT b m r +(!>>) :: (Monad m) => ExceptT a m r -> (a -> b) -> ExceptT b m r (!>>) = flip fmapLT diff --git a/libs/wai-utilities/src/Network/Wai/Utilities/Request.hs b/libs/wai-utilities/src/Network/Wai/Utilities/Request.hs index a0d11b59658..7da25d4449b 100644 --- a/libs/wai-utilities/src/Network/Wai/Utilities/Request.hs +++ b/libs/wai-utilities/src/Network/Wai/Utilities/Request.hs @@ -27,9 +27,10 @@ import Control.Monad.Catch (MonadThrow, throwM) import Data.Aeson import Data.ByteString qualified as B import Data.ByteString.Lazy qualified as Lazy +import Data.Id import Data.Text.Lazy qualified as Text import Imports -import Network.HTTP.Types.Status (status400) +import Network.HTTP.Types import Network.Wai import Network.Wai.Predicate import Network.Wai.Predicate.Request @@ -68,8 +69,13 @@ parseOptionalBody r = nonEmptyBody "" = Nothing nonEmptyBody ne = Just ne -lookupRequestId :: HasRequest r => r -> Maybe ByteString -lookupRequestId = lookup "Request-Id" . requestHeaders . getRequest +lookupRequestId :: HeaderName -> Request -> Maybe ByteString +lookupRequestId reqIdHeaderName = + lookup reqIdHeaderName . requestHeaders + +getRequestId :: HeaderName -> Request -> RequestId +getRequestId reqIdHeaderName req = + RequestId $ fromMaybe "N/A" $ lookupRequestId reqIdHeaderName req ---------------------------------------------------------------------------- -- Typed JSON 'Request' diff --git a/libs/wai-utilities/src/Network/Wai/Utilities/Response.hs b/libs/wai-utilities/src/Network/Wai/Utilities/Response.hs index 3b82467372c..ce838ff5463 100644 --- a/libs/wai-utilities/src/Network/Wai/Utilities/Response.hs +++ b/libs/wai-utilities/src/Network/Wai/Utilities/Response.hs @@ -39,7 +39,7 @@ plain = responseLBS status200 [plainContent] plainContent :: Header plainContent = (hContentType, "text/plain; charset=UTF-8") -json :: ToJSON a => a -> Response +json :: (ToJSON a) => a -> Response json = responseLBS status200 [jsonContent] . encode jsonContent :: Header diff --git a/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs b/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs index 14fa566c12a..04a1f17c873 100644 --- a/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs +++ b/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs @@ -30,9 +30,9 @@ module Network.Wai.Utilities.Server route, -- * Middlewares + requestIdMiddleware, catchErrors, catchErrorsWithRequestId, - OnErrorMetrics, heavyDebugLogging, rethrow5xx, lazyResponseBody, @@ -42,15 +42,17 @@ module Network.Wai.Utilities.Server logError, logError', logErrorMsg, - logIO, - runHandlers, restrict, flushRequestBody, + + -- * Constants + defaultRequestIdHeaderName, + federationRequestIdHeaderName, ) where import Control.Error.Util ((?:)) -import Control.Exception (throw) +import Control.Exception (AsyncException (..), throwIO) import Control.Monad.Catch hiding (onError, onException) import Data.Aeson (decode, encode) import Data.ByteString (toStrict) @@ -60,20 +62,21 @@ import Data.ByteString.Char8 qualified as C import Data.ByteString.Lazy qualified as LBS import Data.Domain (domainText) import Data.Metrics.GC (spawnGCMetricsCollector) -import Data.Metrics.Middleware import Data.Streaming.Zlib (ZlibException (..)) +import Data.Text.Encoding qualified as Text import Data.Text.Encoding.Error (lenientDecode) import Data.Text.Lazy qualified as LT import Data.Text.Lazy.Encoding qualified as LT +import Data.UUID qualified as UUID +import Data.UUID.V4 qualified as UUID import Imports -import Network.HTTP.Types.Status +import Network.HTTP.Types import Network.Wai import Network.Wai.Handler.Warp import Network.Wai.Handler.Warp.Internal (TimeoutThread) import Network.Wai.Internal qualified as WaiInt import Network.Wai.Predicate hiding (Error, err, status) import Network.Wai.Predicate qualified as P -import Network.Wai.Predicate.Request (HasRequest) import Network.Wai.Routing.Route (App, Continue, Routes, Tree) import Network.Wai.Routing.Route qualified as Route import Network.Wai.Utilities.Error qualified as Error @@ -81,7 +84,7 @@ import Network.Wai.Utilities.Error qualified as Wai import Network.Wai.Utilities.JSONResponse import Network.Wai.Utilities.Request (lookupRequestId) import Network.Wai.Utilities.Response -import Prometheus qualified as Prm +import Prometheus qualified as Prom import System.Logger qualified as Log import System.Logger.Class hiding (Error, Settings, format) import System.Posix.Signals (installHandler, sigINT, sigTERM) @@ -94,18 +97,14 @@ data Server = Server { serverHost :: String, serverPort :: Word16, serverLogger :: Logger, - serverMetrics :: Metrics, serverTimeout :: Maybe Int } -defaultServer :: String -> Word16 -> Logger -> Metrics -> Server -defaultServer h p l m = Server h p l m Nothing +defaultServer :: String -> Word16 -> Logger -> Server +defaultServer h p l = Server h p l Nothing -newSettings :: MonadIO m => Server -> m Settings -newSettings (Server h p l m t) = do - -- (Atomically) initialise the standard metrics, to avoid races. - void $ gaugeGet (path "net.connections") m - void $ counterGet (path "net.errors") m +newSettings :: (MonadIO m) => Server -> m Settings +newSettings (Server h p l t) = do pure $ setHost (fromString h) . setPort (fromIntegral p) @@ -115,12 +114,22 @@ newSettings (Server h p l m t) = do . setTimeout (fromMaybe 300 t) $ defaultSettings where - connStart = gaugeIncr (path "net.connections") m - connEnd = gaugeDecr (path "net.connections") m + connStart = Prom.incGauge netConnections + connEnd = Prom.decGauge netConnections logStart = Log.info l . msg $ val "Listening on " +++ h +++ ':' +++ p +{-# NOINLINE netConnections #-} +netConnections :: Prom.Gauge +netConnections = + Prom.unsafeRegister $ + Prom.gauge + Prom.Info + { Prom.metricName = "net.connections", + Prom.metricHelp = "Number of active connections" + } + -- Run a WAI 'Application', initiating Warp's graceful shutdown -- on receiving either the INT or TERM signals. After closing -- the listen socket, Warp will be allowed to drain existing @@ -150,7 +159,7 @@ runSettingsWithCleanup cleanup s app (fromMaybe defaultShutdownTime -> secs) = d defaultShutdownTime :: Int defaultShutdownTime = 30 -compile :: Monad m => Routes a m b -> Tree (App m) +compile :: (Monad m) => Routes a m b -> Tree (App m) compile routes = Route.prepare (Route.renderer predicateError >> routes) where predicateError e = pure (encode $ Wai.mkError (P.status e) "client-error" (format e), [jsonContent]) @@ -176,7 +185,7 @@ compile routes = Route.prepare (Route.renderer predicateError >> routes) messageStr (Just t) = char7 ':' <> char7 ' ' <> byteString t messageStr Nothing = mempty -route :: MonadIO m => Tree (App m) -> Request -> Continue IO -> m ResponseReceived +route :: (MonadIO m) => Tree (App m) -> Request -> Continue IO -> m ResponseReceived route rt rq k = Route.routeWith (Route.Config $ errorRs' noEndpoint) rt rq (liftIO . k) where noEndpoint = Wai.mkError status404 "no-endpoint" "The requested endpoint does not exist" @@ -185,8 +194,23 @@ route rt rq k = Route.routeWith (Route.Config $ errorRs' noEndpoint) rt rq (lift -------------------------------------------------------------------------------- -- Middlewares -catchErrors :: Logger -> OnErrorMetrics -> Middleware -catchErrors l m = catchErrorsWithRequestId lookupRequestId l m +requestIdMiddleware :: Logger -> HeaderName -> Middleware +requestIdMiddleware logger reqIdHeaderName origApp req responder = + case lookup reqIdHeaderName req.requestHeaders of + Just _ -> origApp req responder + Nothing -> do + reqId <- Text.encodeUtf8 . UUID.toText <$> UUID.nextRandom + unless (req.rawPathInfo `elem` ["/i/status", "/i/metrics", "/api-version"]) $ + Log.info logger $ + msg ("generated a new request id for local request" :: ByteString) + . field "request" reqId + . field "method" (requestMethod req) + . field "path" (rawPathInfo req) + let reqWithId = req {requestHeaders = (reqIdHeaderName, reqId) : req.requestHeaders} + origApp reqWithId responder + +catchErrors :: Logger -> HeaderName -> Middleware +catchErrors l reqIdHeaderName = catchErrorsWithRequestId (lookupRequestId reqIdHeaderName) l -- | Create a middleware that catches exceptions and turns -- them into appropriate 'Error' responses, thereby logging @@ -198,9 +222,8 @@ catchErrors l m = catchErrorsWithRequestId lookupRequestId l m catchErrorsWithRequestId :: (Request -> Maybe ByteString) -> Logger -> - OnErrorMetrics -> Middleware -catchErrorsWithRequestId getRequestId l m app req k = +catchErrorsWithRequestId getRequestId l app req k = rethrow5xx getRequestId l app req k `catch` errorResponse where mReqId = getRequestId req @@ -208,18 +231,29 @@ catchErrorsWithRequestId getRequestId l m app req k = errorResponse :: SomeException -> IO ResponseReceived errorResponse ex = do er <- runHandlers ex errorHandlers - onError l mReqId m req k er + onError l mReqId req k er {-# INLINEABLE catchErrors #-} -- | Standard handlers for turning exceptions into appropriate -- 'Error' responses. -errorHandlers :: Applicative m => [Handler m (Either Wai.Error JSONResponse)] +errorHandlers :: [Handler IO (Either Wai.Error JSONResponse)] errorHandlers = -- a Wai.Error can be converted to a JSONResponse, but doing so here would -- prevent us from logging the error cleanly later [ Handler $ \(x :: JSONResponse) -> pure (Right x), Handler $ \(x :: Wai.Error) -> pure (Left x), + -- warp throws 'ThreadKilled' when the client is gone or when it thinks it's + -- time to reap the worker thread. Here, there is no point trying to respond + -- nicely and there is no point logging this as it happens regularly when a + -- client just closes a long running connection without consuming the whole + -- body. + Handler $ \(x :: AsyncException) -> + case x of + ThreadKilled -> throwIO x + _ -> + pure . Left $ + Wai.mkError status500 "server-error" ("Server Error. " <> LT.pack (displayException x)), Handler $ \(_ :: InvalidRequest) -> pure . Left $ Wai.mkError status400 "client-error" "Invalid Request", @@ -258,8 +292,9 @@ heavyDebugLogging :: ((Request, LByteString) -> Maybe (Request, LByteString)) -> Level -> Logger -> + HeaderName -> Middleware -heavyDebugLogging sanitizeReq lvl lgr app = \req cont -> do +heavyDebugLogging sanitizeReq lvl lgr reqIdHeaderName app = \req cont -> do (bdy, req') <- if lvl `elem` [Trace, Debug] then cloneBody req @@ -278,7 +313,7 @@ heavyDebugLogging sanitizeReq lvl lgr app = \req cont -> do logMostlyEverything req bdy resp = Log.debug lgr logMsg where logMsg = - field "request" (fromMaybe "N/A" $ lookupRequestId req) + field "request" (fromMaybe "N/A" $ lookupRequestId reqIdHeaderName req) . field "request_details" (show req) . field "request_body" bdy . field "response_status" (show $ responseStatus resp) @@ -352,37 +387,47 @@ lazyResponseBody rs = case responseToStream rs of -------------------------------------------------------------------------------- -- Utilities --- | 'onError' and 'catchErrors' support both the metrics-core ('Right') and the prometheus --- package introduced for spar ('Left'). -type OnErrorMetrics = [Either Prm.Counter Metrics] - -- | Send an 'Error' response. onError :: - MonadIO m => + (MonadIO m) => Logger -> Maybe ByteString -> - OnErrorMetrics -> Request -> Continue IO -> Either Wai.Error JSONResponse -> m ResponseReceived -onError g mReqId m r k e = liftIO $ do +onError g mReqId r k e = liftIO $ do case e of Left we -> logError' g mReqId we Right jr -> logJSONResponse g mReqId jr let resp = either waiErrorToJSONResponse id e let code = statusCode (resp.status) - when (code >= 500) $ - either Prm.incCounter (counterIncr (path "net.errors")) `mapM_` m + when (code >= 500) $ Prom.incCounter netErrors flushRequestBody r k (jsonResponseToWai resp) +{-# NOINLINE netErrors #-} +netErrors :: Prom.Counter +netErrors = + Prom.unsafeRegister $ + Prom.counter + Prom.Info + { Prom.metricName = "net.errors", + Prom.metricHelp = "Number of exceptions caught by catchErrors middleware" + } + +defaultRequestIdHeaderName :: HeaderName +defaultRequestIdHeaderName = "Request-Id" + +federationRequestIdHeaderName :: HeaderName +federationRequestIdHeaderName = "Wire-Origin-Request-Id" + -- | Log an 'Error' response for debugging purposes. -- -- It would be nice to have access to the request body here, but that's already streamed away -- by the handler in all likelyhood. See 'heavyDebugLogging'. -logError :: (MonadIO m, HasRequest r) => Logger -> Maybe r -> Wai.Error -> m () -logError g mr = logError' g (lookupRequestId =<< mr) +logError :: (MonadIO m) => Logger -> Maybe Request -> Wai.Error -> m () +logError g mr = logError' g (lookupRequestId defaultRequestIdHeaderName =<< mr) logError' :: (MonadIO m) => Logger -> Maybe ByteString -> Wai.Error -> m () logError' g mr e = liftIO $ doLog g (logErrorMsgWithRequest mr e) @@ -391,7 +436,7 @@ logError' g mr e = liftIO $ doLog g (logErrorMsgWithRequest mr e) | statusCode (Error.code e) >= 500 = Log.err | otherwise = Log.debug -logJSONResponse :: MonadIO m => Logger -> Maybe ByteString -> JSONResponse -> m () +logJSONResponse :: (MonadIO m) => Logger -> Maybe ByteString -> JSONResponse -> m () logJSONResponse g mReqId e = do let r = fromMaybe "N/A" mReqId liftIO $ @@ -421,14 +466,8 @@ logErrorMsgWithRequest :: Maybe ByteString -> Wai.Error -> Msg -> Msg logErrorMsgWithRequest mr e = field "request" (fromMaybe "N/A" mr) . logErrorMsg e -logIO :: (ToBytes msg, HasRequest r) => Logger -> Level -> Maybe r -> msg -> IO () -logIO lg lv r a = - let reqId = field "request" . fromMaybe "N/A" . lookupRequestId <$> r - mesg = fromMaybe id reqId . msg a - in Log.log lg lv mesg - -runHandlers :: SomeException -> [Handler m a] -> m a -runHandlers e [] = throw e +runHandlers :: SomeException -> [Handler IO a] -> IO a +runHandlers e [] = throwIO e runHandlers e (Handler h : hs) = maybe (runHandlers e hs) h (fromException e) restrict :: Int -> Int -> Predicate r P.Error Int -> Predicate r P.Error Int diff --git a/libs/wai-utilities/src/Network/Wai/Utilities/ZAuth.hs b/libs/wai-utilities/src/Network/Wai/Utilities/ZAuth.hs index c70d65f7a67..5733203a0bd 100644 --- a/libs/wai-utilities/src/Network/Wai/Utilities/ZAuth.hs +++ b/libs/wai-utilities/src/Network/Wai/Utilities/ZAuth.hs @@ -66,11 +66,11 @@ instance FromByteString ZAuthType where _ -> fail $ "Invalid ZAuth type: " ++ show t -- | A token type is present if the request was authenticated. -zauthType :: HasHeaders r => Predicate r Error ZAuthType +zauthType :: (HasHeaders r) => Predicate r Error ZAuthType zauthType = zheader "Z-Type" -- | Require a specific token type to be used. -zauth :: HasHeaders r => ZAuthType -> Predicate r Error () +zauth :: (HasHeaders r) => ZAuthType -> Predicate r Error () zauth t = do r <- zauthType pure $ case r of @@ -79,24 +79,24 @@ zauth t = do -- | A zauth user ID is present if 'zauthType' is either 'ZAuthAccess' -- or 'ZAuthUser'. -zauthUserId :: HasHeaders r => Predicate r Error UserId +zauthUserId :: (HasHeaders r) => Predicate r Error UserId zauthUserId = zheader "Z-User" -- | A zauth connection ID is present if 'zauthType' is 'ZAuthAccess'. -zauthConnId :: HasHeaders r => Predicate r Error ConnId +zauthConnId :: (HasHeaders r) => Predicate r Error ConnId zauthConnId = zheader "Z-Connection" -- | A zauth bot ID is present if 'zauthType' is 'ZAuthBot'. -zauthBotId :: HasHeaders r => Predicate r Error BotId +zauthBotId :: (HasHeaders r) => Predicate r Error BotId zauthBotId = zheader "Z-Bot" -- | A zauth conversation ID is present if 'zauthType' is 'ZAuthBot'. -zauthConvId :: HasHeaders r => Predicate r Error ConvId +zauthConvId :: (HasHeaders r) => Predicate r Error ConvId zauthConvId = zheader "Z-Conversation" -- | A provider ID is present if 'zauthType' is either 'ZAuthBot' -- or 'ZAuthProvider'. -zauthProviderId :: HasHeaders r => Predicate r Error ProviderId +zauthProviderId :: (HasHeaders r) => Predicate r Error ProviderId zauthProviderId = zheader "Z-Provider" -- Extra Predicate Combinators ------------------------------------------------ diff --git a/libs/wai-utilities/test/Main.hs b/libs/wai-utilities/test/Main.hs new file mode 100644 index 00000000000..a824f8c30c8 --- /dev/null +++ b/libs/wai-utilities/test/Main.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/libs/wai-utilities/test/Network/Wai/Utilities/ServerSpec.hs b/libs/wai-utilities/test/Network/Wai/Utilities/ServerSpec.hs new file mode 100644 index 00000000000..db27b579266 --- /dev/null +++ b/libs/wai-utilities/test/Network/Wai/Utilities/ServerSpec.hs @@ -0,0 +1,67 @@ +module Network.Wai.Utilities.ServerSpec where + +import Data.ByteString.Char8 qualified as BC8 +import Imports +import Network.HTTP.Types +import Network.Wai +import Network.Wai.Internal +import Network.Wai.Utilities.Server +import System.IO.Temp +import System.Logger qualified as Log +import Test.Hspec + +spec :: Spec +spec = do + describe "requestIdMiddleware" $ do + it "should add request id header if it is missing in the orig request" $ do + requestProcessed <- newIORef False + reqIdRef <- newIORef Nothing + withSystemTempFile "requestIdMiddlewareTest-" $ \logFile logFileHandle -> do + hClose logFileHandle + logger <- Log.new $ Log.setOutput (Log.Path logFile) Log.defSettings + let headerName = "Request-ID-Test" + app req responder = do + writeIORef requestProcessed True + case find (\(n, _) -> n == headerName) (requestHeaders req) of + Nothing -> expectationFailure "The request has no header with a request ID" + Just (_, reqId) -> writeIORef reqIdRef (Just reqId) + responder $ responseLBS status200 [] "" + req0 = defaultRequest {requestMethod = "POST", rawPathInfo = "/req-id-test"} + responder0 _resp = pure ResponseReceived + void $ requestIdMiddleware logger headerName app req0 responder0 + + Log.close logger + logEntries <- readFile logFile + + Just reqId <- readIORef reqIdRef + length (lines logEntries) `shouldBe` 1 + logEntries `shouldContain` "generated a new request id for local request" + logEntries `shouldContain` ("request=" <> BC8.unpack reqId) + logEntries `shouldContain` "method=POST" + logEntries `shouldContain` "path=/req-id-test" + + readIORef requestProcessed `shouldReturn` True + + it "should not add request id header if is present in the orig request" $ do + requestProcessed <- newIORef False + withSystemTempFile "requestIdMiddlewareTest-" $ \logFile logFileHandle -> do + hClose logFileHandle + logger <- Log.new $ Log.setOutput (Log.Path logFile) Log.defSettings + let origRequestId = "test-req-id" + headerName = "Request-ID-Test" + app req responder = do + writeIORef requestProcessed True + case find (\(n, _) -> n == headerName) (requestHeaders req) of + Nothing -> expectationFailure "The request has no header with a request ID" + Just (_, foundReqId) -> foundReqId `shouldBe` origRequestId + responder $ responseLBS status200 [] "" + req0 = defaultRequest {requestHeaders = [(headerName, origRequestId)]} + responder0 _resp = pure ResponseReceived + void $ requestIdMiddleware logger headerName app req0 responder0 + Log.close logger + + -- Nothing should be logged + logEntries <- readFile logFile + length logEntries `shouldBe` 0 + + readIORef requestProcessed `shouldReturn` True diff --git a/libs/wai-utilities/wai-utilities.cabal b/libs/wai-utilities/wai-utilities.cabal index 6105387dddb..f40d486e0f2 100644 --- a/libs/wai-utilities/wai-utilities.cabal +++ b/libs/wai-utilities/wai-utilities.cabal @@ -1,4 +1,4 @@ -cabal-version: 1.12 +cabal-version: 3.0 name: wai-utilities version: 0.16.1 synopsis: Various helpers for WAI @@ -7,24 +7,17 @@ category: Web author: Wire Swiss GmbH maintainer: Wire Swiss GmbH copyright: (c) 2017 Wire Swiss GmbH -license: AGPL-3 +license: AGPL-3.0-only license-file: LICENSE build-type: Simple -library - exposed-modules: - Network.Wai.Utilities - Network.Wai.Utilities.Error - Network.Wai.Utilities.Headers - Network.Wai.Utilities.JSONResponse - Network.Wai.Utilities.MockServer - Network.Wai.Utilities.Request - Network.Wai.Utilities.Response - Network.Wai.Utilities.Server - Network.Wai.Utilities.ZAuth +common common-all + default-language: GHC2021 + ghc-options: + -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates + -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path + -Wredundant-constraints -Wunused-packages - other-modules: Paths_wai_utilities - hs-source-dirs: src default-extensions: AllowAmbiguousTypes BangPatterns @@ -67,13 +60,23 @@ library UndecidableInstances ViewPatterns - ghc-options: - -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates - -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path - -Wredundant-constraints -Wunused-packages +library + import: common-all + exposed-modules: + Network.Wai.Utilities + Network.Wai.Utilities.Error + Network.Wai.Utilities.Headers + Network.Wai.Utilities.JSONResponse + Network.Wai.Utilities.MockServer + Network.Wai.Utilities.Request + Network.Wai.Utilities.Response + Network.Wai.Utilities.Server + Network.Wai.Utilities.ZAuth + other-modules: Paths_wai_utilities + hs-source-dirs: src build-depends: - aeson >=2.0.1.0 + , aeson >=2.0.1.0 , async >=2.0 , base >=4.6 && <5.0 , bytestring >=0.10 @@ -85,7 +88,6 @@ library , imports , kan-extensions , metrics-core >=0.1 - , metrics-wai >=0.5.7 , openapi3 , pipes >=4.1 , prometheus-client @@ -96,10 +98,29 @@ library , tinylog >=0.8 , types-common >=0.12 , unix >=2.7 + , uuid , wai >=3.0 , wai-predicates >=0.8 , wai-routing >=0.12 , warp >=3.0 , warp-tls - default-language: GHC2021 +test-suite wai-utilities-tests + import: common-all + type: exitcode-stdio-1.0 + main-is: Main.hs + ghc-options: -threaded -with-rtsopts=-N + hs-source-dirs: test + build-tool-depends: hspec-discover:hspec-discover + + -- cabal-fmt: expand test -Main + other-modules: Network.Wai.Utilities.ServerSpec + build-depends: + , bytestring + , hspec + , http-types + , imports + , temporary + , tinylog + , wai + , wai-utilities diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API.hs b/libs/wire-api-federation/src/Wire/API/Federation/API.hs index 89ba99b4e6a..bf33723b172 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/API.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/API.hs @@ -79,13 +79,13 @@ type HasFedEndpoint comp api name = (HasUnsafeFedEndpoint comp api name) -- you to forget about some federated calls. type HasUnsafeFedEndpoint comp api name = 'Just api ~ LookupEndpoint (FedApi comp) name -nameVal :: forall {k} (name :: k). IsNamed name => Text +nameVal :: forall {k} (name :: k). (IsNamed name) => Text nameVal = nameVal' @k @name class IsNamed (name :: k) where nameVal' :: Text -instance KnownSymbol name => IsNamed (name :: Symbol) where +instance (KnownSymbol name) => IsNamed (name :: Symbol) where nameVal' = Text.pack (symbolVal (Proxy @name)) instance (IsNamed name, SingI v) => IsNamed (Versioned (v :: Version) name) where @@ -136,7 +136,7 @@ fedClientIn :: fedClientIn = clientIn (Proxy @api) (Proxy @m) sendBundle :: - KnownComponent c => + (KnownComponent c) => PayloadBundle c -> FedQueueClient c () sendBundle bundle = do diff --git a/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs b/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs index 43849c716da..2e3f4b8d488 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs @@ -140,7 +140,7 @@ sendNotification env component path body = case someComponent component of withoutFirstSlash (Text.stripPrefix "/" -> Just t) = t withoutFirstSlash t = t - go :: forall c. KnownComponent c => Proxy c -> IO (Either FederatorClientError ()) + go :: forall c. (KnownComponent c) => Proxy c -> IO (Either FederatorClientError ()) go _ = lowerCodensity . runExceptT diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Client.hs b/libs/wire-api-federation/src/Wire/API/Federation/Client.hs index 37444a6a49e..98f653e6083 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/Client.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/Client.hs @@ -120,7 +120,7 @@ instance VersionedMonad Version (FederatorClient c) where liftCodensity :: Codensity IO a -> FederatorClient c a liftCodensity = FederatorClient . lift . lift . lift -headersFromTable :: HTTP2.HeaderTable -> [HTTP.Header] +headersFromTable :: HTTP2.TokenHeaderTable -> [HTTP.Header] headersFromTable (headerList, _) = flip map headerList $ first HTTP2.tokenKey -- This opens a new http2 connection. Using a http2-manager leads to this problem https://wearezeta.atlassian.net/browse/WPB-4787 @@ -167,7 +167,7 @@ consumeStreamingResponseWith k resp = do responseBody = result } -instance KnownComponent c => RunClient (FederatorClient c) where +instance (KnownComponent c) => RunClient (FederatorClient c) where runRequestAcceptStatus expectedStatuses req = do let successfulStatus status = maybe @@ -198,7 +198,7 @@ instance KnownComponent c => RunClient (FederatorClient c) where throwClientError = throwError . FederatorClientServantError -instance KnownComponent c => RunStreamingClient (FederatorClient c) where +instance (KnownComponent c) => RunStreamingClient (FederatorClient c) where withStreamingRequest = withHTTP2StreamingRequest HTTP.statusIsSuccessful streamingResponseStrictBody :: StreamingResponse -> IO Builder @@ -211,7 +211,7 @@ streamingResponseStrictBody = -- Perform a streaming request to the local federator. withHTTP2StreamingRequest :: forall c a. - KnownComponent c => + (KnownComponent c) => (HTTP.Status -> Bool) -> Request -> (StreamingResponse -> IO a) -> @@ -245,8 +245,10 @@ withHTTP2StreamingRequest successfulStatus req handleResponse = do (lazyByteString body) let Endpoint (Text.encodeUtf8 -> hostname) (fromIntegral -> port) = ceFederator env resp <- - either throwError pure <=< liftCodensity $ - Codensity $ \k -> + either throwError pure + <=< liftCodensity + $ Codensity + $ \k -> E.catches (withNewHttpRequest (False, hostname, port) req' (consumeStreamingResponseWith (k . Right))) [ E.Handler $ k . Left . FederatorClientHTTP2Error, @@ -365,7 +367,8 @@ versionNegotiation localVersions = case Set.lookupMax (Set.intersection remoteVersions localVersions) of Just v -> pure v Nothing -> - E.throw . FederatorClientVersionNegotiationError $ - if Set.lookupMax localVersions > Set.lookupMax remoteVersions + E.throw + . FederatorClientVersionNegotiationError + $ if Set.lookupMax localVersions > Set.lookupMax remoteVersions then RemoteTooOld else RemoteTooNew diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Component.hs b/libs/wire-api-federation/src/Wire/API/Federation/Component.hs index 1a5b91e6bd3..aef5cc95980 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/Component.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/Component.hs @@ -49,7 +49,7 @@ instance KnownComponent 'Cargohold where componentVal = Cargohold data SomeComponent where - SomeComponent :: KnownComponent c => Proxy c -> SomeComponent + SomeComponent :: (KnownComponent c) => Proxy c -> SomeComponent someComponent :: Component -> SomeComponent someComponent Brig = SomeComponent (Proxy @'Brig) diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Domain.hs b/libs/wire-api-federation/src/Wire/API/Federation/Domain.hs index 5a8e8a5bb16..e9d128fe670 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/Domain.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/Domain.hs @@ -37,19 +37,19 @@ type OriginDomainHeaderName = "Wire-Origin-Domain" :: Symbol data OriginDomainHeader -instance RoutesToPaths api => RoutesToPaths (OriginDomainHeader :> api) where +instance (RoutesToPaths api) => RoutesToPaths (OriginDomainHeader :> api) where getRoutes = getRoutes @api type instance SpecialiseToVersion v (OriginDomainHeader :> api) = OriginDomainHeader :> SpecialiseToVersion v api -instance HasClient m api => HasClient m (OriginDomainHeader :> api) where +instance (HasClient m api) => HasClient m (OriginDomainHeader :> api) where type Client m (OriginDomainHeader :> api) = Client m api clientWithRoute pm _ req = clientWithRoute pm (Proxy @api) req hoistClientMonad pm _ = hoistClientMonad pm (Proxy @api) -instance HasClientAlgebra m api => HasClientAlgebra m (OriginDomainHeader :> api) where +instance (HasClientAlgebra m api) => HasClientAlgebra m (OriginDomainHeader :> api) where joinClient = joinClient @m @api bindClient = bindClient @m @api @@ -65,7 +65,7 @@ instance route _pa = route (Proxy @(OriginDomainHeaderHasServer :> api)) hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s -originDomainHeaderName :: IsString a => a +originDomainHeaderName :: (IsString a) => a originDomainHeaderName = fromString $ symbolVal (Proxy @OriginDomainHeaderName) instance (HasOpenApi api) => HasOpenApi (OriginDomainHeader :> api) where diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Endpoint.hs b/libs/wire-api-federation/src/Wire/API/Federation/Endpoint.hs index f24085139cb..910a6c2d4b1 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/Endpoint.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/Endpoint.hs @@ -33,7 +33,7 @@ import Wire.API.Routes.Named data Versioned v name -instance {-# OVERLAPPING #-} RenderableSymbol a => RenderableSymbol (Versioned v a) where +instance {-# OVERLAPPING #-} (RenderableSymbol a) => RenderableSymbol (Versioned v a) where renderSymbol = renderSymbol @a type family FedPath (name :: k) :: Symbol diff --git a/libs/wire-api-federation/src/Wire/API/Federation/HasNotificationEndpoint.hs b/libs/wire-api-federation/src/Wire/API/Federation/HasNotificationEndpoint.hs index 7fba640ee90..cbc16a0d769 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/HasNotificationEndpoint.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/HasNotificationEndpoint.hs @@ -59,7 +59,7 @@ type HasFedPath t = KnownSymbol (NotificationPath t) type HasVersionRange t = MkVersionRange (NotificationMods t) -fedPath :: forall t. HasFedPath t => String +fedPath :: forall t. (HasFedPath t) => String fedPath = symbolVal (Proxy @(NotificationPath t)) -- | Build a version range using any 'Until' and 'From' combinators present in @@ -84,9 +84,9 @@ instance where mkVersionRange = mkVersionRange @mods <> rangeUntilVersion (demote @v) -instance {-# OVERLAPPABLE #-} MkVersionRange mods => MkVersionRange (m ': mods) where +instance {-# OVERLAPPABLE #-} (MkVersionRange mods) => MkVersionRange (m ': mods) where mkVersionRange = mkVersionRange @mods -- | The federation API version range this endpoint is supported in. -versionRange :: forall t. HasVersionRange t => VersionRange +versionRange :: forall t. (HasVersionRange t) => VersionRange versionRange = mkVersionRange @(NotificationMods t) diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Version.hs b/libs/wire-api-federation/src/Wire/API/Federation/Version.hs index 06089028de5..c6f14413058 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/Version.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/Version.hs @@ -176,14 +176,14 @@ enumVersionRange = -- remote versions are given as integers as the range of versions supported by -- the remote backend can include a version unknown to the local backend. If -- there is no version in common, the return value is 'Nothing'. -latestCommonVersion :: Foldable f => VersionRange -> f Int -> Maybe Version +latestCommonVersion :: (Foldable f) => VersionRange -> f Int -> Maybe Version latestCommonVersion localVersions = safeMaximum . filter (inVersionRange localVersions) . mapMaybe intToVersion . toList -safeMaximum :: Ord a => [a] -> Maybe a +safeMaximum :: (Ord a) => [a] -> Maybe a safeMaximum [] = Nothing safeMaximum as = Just (maximum as) diff --git a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/Runner.hs b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/Runner.hs index 5d7d956cb02..ba2c5e02e54 100644 --- a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/Runner.hs +++ b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/Runner.hs @@ -79,7 +79,7 @@ testFromJSONFailure path = do Right x -> assertFailure $ show (typeRep @a) <> ": FromJSON of " <> path <> ": expected failure, got " <> show x Left _ -> pure () -assertRight :: Show a => Either a b -> IO b +assertRight :: (Show a) => Either a b -> IO b assertRight = \case Left a -> assertFailure $ "Expected Right, got Left: " <> show a diff --git a/libs/wire-api/default.nix b/libs/wire-api/default.nix index c55239a351b..ce55894b212 100644 --- a/libs/wire-api/default.nix +++ b/libs/wire-api/default.nix @@ -29,6 +29,7 @@ , crypton , crypton-x509 , currency-codes +, data-default , deriving-aeson , deriving-swagger2 , either @@ -76,6 +77,7 @@ , saml2-web-sso , schema-profunctor , scientific +, semigroupoids , servant , servant-client , servant-client-core @@ -119,7 +121,6 @@ mkDerivation { libraryHaskellDepends = [ aeson asn1-encoding - async attoparsec base base64-bytestring @@ -139,6 +140,7 @@ mkDerivation { crypton crypton-x509 currency-codes + data-default deriving-aeson deriving-swagger2 either @@ -180,6 +182,7 @@ mkDerivation { saml2-web-sso schema-profunctor scientific + semigroupoids servant servant-client servant-client-core @@ -243,7 +246,6 @@ mkDerivation { proto-lens QuickCheck random - saml2-web-sso schema-profunctor servant servant-server diff --git a/services/brig/src/Brig/Allowlists.hs b/libs/wire-api/src/Wire/API/Allowlists.hs similarity index 67% rename from services/brig/src/Brig/Allowlists.hs rename to libs/wire-api/src/Wire/API/Allowlists.hs index af2e0c7be10..244a5e8cb85 100644 --- a/services/brig/src/Brig/Allowlists.hs +++ b/libs/wire-api/src/Wire/API/Allowlists.hs @@ -18,15 +18,13 @@ -- | > docs/reference/user/activation.md {#RefActivationAllowlist} -- -- Email/phone whitelist. -module Brig.Allowlists +module Wire.API.Allowlists ( AllowlistEmailDomains (..), - AllowlistPhonePrefixes (..), verify, ) where import Data.Aeson -import Data.Text qualified as Text import Imports import Wire.API.User.Identity @@ -36,15 +34,8 @@ data AllowlistEmailDomains = AllowlistEmailDomains [Text] instance FromJSON AllowlistEmailDomains -data AllowlistPhonePrefixes = AllowlistPhonePrefixes [Text] - deriving (Show, Generic) - -instance FromJSON AllowlistPhonePrefixes - -- | Consult the whitelist settings in brig's config file and verify that the provided --- email/phone address is whitelisted. -verify :: Maybe AllowlistEmailDomains -> Maybe AllowlistPhonePrefixes -> Either Email Phone -> Bool -verify (Just (AllowlistEmailDomains allowed)) _ (Left email) = emailDomain email `elem` allowed -verify _ (Just (AllowlistPhonePrefixes allowed)) (Right phone) = any (`Text.isPrefixOf` fromPhone phone) allowed -verify Nothing _ (Left _) = True -verify _ Nothing (Right _) = True +-- email address is whitelisted. +verify :: Maybe AllowlistEmailDomains -> Email -> Bool +verify (Just (AllowlistEmailDomains allowed)) email = emailDomain email `elem` allowed +verify Nothing (_) = True diff --git a/libs/wire-api/src/Wire/API/Asset.hs b/libs/wire-api/src/Wire/API/Asset.hs index 4148a1d4832..d2a53bad442 100644 --- a/libs/wire-api/src/Wire/API/Asset.hs +++ b/libs/wire-api/src/Wire/API/Asset.hs @@ -105,14 +105,14 @@ data Asset' key = Asset } deriving stock (Eq, Show, Generic, Functor) -deriving via Schema (Asset' key) instance ToSchema (Asset' key) => (ToJSON (Asset' key)) +deriving via Schema (Asset' key) instance (ToSchema (Asset' key)) => (ToJSON (Asset' key)) -deriving via Schema (Asset' key) instance ToSchema (Asset' key) => (FromJSON (Asset' key)) +deriving via Schema (Asset' key) instance (ToSchema (Asset' key)) => (FromJSON (Asset' key)) deriving via Schema (Asset' key) instance (Typeable key, ToSchema (Asset' key)) => (S.ToSchema (Asset' key)) -- Generate expiry time with millisecond precision -instance Arbitrary key => Arbitrary (Asset' key) where +instance (Arbitrary key) => Arbitrary (Asset' key) where arbitrary = Asset <$> arbitrary <*> (fmap milli <$> arbitrary) <*> arbitrary where milli = fromUTCTimeMillis . toUTCTimeMillis diff --git a/libs/wire-api/src/Wire/API/Call/Config.hs b/libs/wire-api/src/Wire/API/Call/Config.hs index a4eb530ae5c..b48d771e20d 100644 --- a/libs/wire-api/src/Wire/API/Call/Config.hs +++ b/libs/wire-api/src/Wire/API/Call/Config.hs @@ -49,7 +49,7 @@ module Wire.API.Call.Config isHostName, -- * SFTUsername - SFTUsername (SFTUsername), + SFTUsername, mkSFTUsername, suExpiresAt, suVersion, @@ -465,13 +465,13 @@ data SFTUsername = SFTUsername deriving (A.ToJSON, A.FromJSON, S.ToSchema) via (Schema SFTUsername) -- note that the random value is not checked for well-formedness -mkSFTUsername :: POSIXTime -> Text -> SFTUsername -mkSFTUsername expires rnd = +mkSFTUsername :: Bool -> POSIXTime -> Text -> SFTUsername +mkSFTUsername shared expires rnd = SFTUsername { _suExpiresAt = expires, _suVersion = 1, _suKeyindex = 0, - _suShared = True, + _suShared = shared, _suRandom = rnd } @@ -497,7 +497,7 @@ instance BC.ToByteString SFTUsername where <> shortByteString ".r=" <> byteString (view (re utf8) (_suRandom su)) where - boolToWord :: Num a => Bool -> a + boolToWord :: (Num a) => Bool -> a boolToWord False = 0 boolToWord True = 1 diff --git a/libs/wire-api/src/Wire/API/Conversation.hs b/libs/wire-api/src/Wire/API/Conversation.hs index 1165445df2f..0aa78bd25c6 100644 --- a/libs/wire-api/src/Wire/API/Conversation.hs +++ b/libs/wire-api/src/Wire/API/Conversation.hs @@ -268,7 +268,7 @@ cnvReceiptMode = cnvmReceiptMode . cnvMetadata instance ToSchema Conversation where schema = conversationSchema Nothing -instance SingI v => ToSchema (Versioned v Conversation) where +instance (SingI v) => ToSchema (Versioned v Conversation) where schema = Versioned <$> unVersioned .= conversationSchema (Just (demote @v)) conversationObjectSchema :: Maybe Version -> ObjectSchema SwaggerDoc Conversation @@ -305,7 +305,7 @@ data CreateGroupConversation = CreateGroupConversation instance ToSchema CreateGroupConversation where schema = createGroupConversationSchema Nothing -instance SingI v => ToSchema (Versioned v CreateGroupConversation) where +instance (SingI v) => ToSchema (Versioned v CreateGroupConversation) where schema = Versioned <$> unVersioned .= createGroupConversationSchema (Just (demote @v)) createGroupConversationSchema :: Maybe Version -> ValueSchema NamedSwaggerDoc CreateGroupConversation @@ -321,7 +321,7 @@ createGroupConversationSchema v = toFlatList :: Map Domain (Set a) -> [Qualified a] toFlatList m = (\(d, s) -> flip Qualified d <$> Set.toList s) =<< Map.assocs m - fromFlatList :: Ord a => [Qualified a] -> Map Domain (Set a) + fromFlatList :: (Ord a) => [Qualified a] -> Map Domain (Set a) fromFlatList = fmap Set.fromList . indexQualified -- | Limited view of a 'Conversation'. Is used to inform users with an invite @@ -375,7 +375,7 @@ instance ToSchema (Versioned 'V2 (ConversationList Conversation)) where conversationListSchema :: forall a. - ConversationListItem a => + (ConversationListItem a) => ValueSchema NamedSwaggerDoc a -> ValueSchema NamedSwaggerDoc (ConversationList a) conversationListSchema sch = @@ -449,7 +449,7 @@ conversationsResponseSchema v = instance ToSchema ConversationsResponse where schema = conversationsResponseSchema Nothing -instance SingI v => ToSchema (Versioned v ConversationsResponse) where +instance (SingI v) => ToSchema (Versioned v ConversationsResponse) where schema = Versioned <$> unVersioned .= conversationsResponseSchema (Just (demote @v)) -------------------------------------------------------------------------------- @@ -553,7 +553,7 @@ toAccessRoleLegacy :: Set AccessRole -> AccessRoleLegacy toAccessRoleLegacy accessRoles = do fromMaybe NonActivatedAccessRole $ find (allMember accessRoles . fromAccessRoleLegacy) [minBound ..] where - allMember :: Ord a => Set a -> Set a -> Bool + allMember :: (Ord a) => Set a -> Set a -> Bool allMember rhs lhs = all (`Set.member` lhs) rhs instance ToSchema AccessRole where @@ -764,7 +764,7 @@ instance ToSchema ConvTeamInfo where (description ?~ managedDesc) (c (False :: Bool)) where - c :: ToJSON a => a -> ValueSchema SwaggerDoc () + c :: (ToJSON a) => a -> ValueSchema SwaggerDoc () c val = mkSchema mempty (const (pure ())) (const (pure (toJSON val))) -------------------------------------------------------------------------------- diff --git a/libs/wire-api/src/Wire/API/Conversation/Bot.hs b/libs/wire-api/src/Wire/API/Conversation/Bot.hs index f46a83869d4..aea518cfc92 100644 --- a/libs/wire-api/src/Wire/API/Conversation/Bot.hs +++ b/libs/wire-api/src/Wire/API/Conversation/Bot.hs @@ -32,8 +32,9 @@ import Data.OpenApi qualified as S import Data.Schema import Imports import Wire.API.Event.Conversation (Event) +import Wire.API.Locale (Locale) import Wire.API.User.Client.Prekey (Prekey) -import Wire.API.User.Profile (Asset, ColourId, Locale, Name) +import Wire.API.User.Profile (Asset, ColourId, Name) import Wire.Arbitrary (Arbitrary, GenericUniform (..)) -------------------------------------------------------------------------------- diff --git a/libs/wire-api/src/Wire/API/Conversation/Member.hs b/libs/wire-api/src/Wire/API/Conversation/Member.hs index f07f619b3e5..1443e158af8 100644 --- a/libs/wire-api/src/Wire/API/Conversation/Member.hs +++ b/libs/wire-api/src/Wire/API/Conversation/Member.hs @@ -131,7 +131,7 @@ instance ToSchema Member where <*> memHiddenRef .= optField "hidden_ref" (maybeWithDefault A.Null schema) <*> memConvRoleName .= (fromMaybe roleNameWireAdmin <$> optField "conversation_role" schema) where - c :: ToJSON a => a -> ValueSchema SwaggerDoc () + c :: (ToJSON a) => a -> ValueSchema SwaggerDoc () c val = mkSchema mempty (const (pure ())) (const (pure (toJSON val))) -- | The semantics of the possible different values is entirely up to clients, diff --git a/libs/wire-api/src/Wire/API/Deprecated.hs b/libs/wire-api/src/Wire/API/Deprecated.hs index c68120be996..6a584f5582a 100644 --- a/libs/wire-api/src/Wire/API/Deprecated.hs +++ b/libs/wire-api/src/Wire/API/Deprecated.hs @@ -35,23 +35,23 @@ data Deprecated deriving (Typeable) -- All of these instances are very similar to the instances -- for Summary. These don't impact the API directly, but are -- for marking the deprecated flag in the openapi output. -instance HasLink sub => HasLink (Deprecated :> sub :: Type) where +instance (HasLink sub) => HasLink (Deprecated :> sub :: Type) where type MkLink (Deprecated :> sub) a = MkLink sub a toLink = let simpleToLink toA _ = toLink toA (Proxy :: Proxy sub) in simpleToLink -instance HasOpenApi api => HasOpenApi (Deprecated :> api :: Type) where +instance (HasOpenApi api) => HasOpenApi (Deprecated :> api :: Type) where toOpenApi _ = toOpenApi (Proxy @api) & allOperations . deprecated ?~ True -instance HasServer api ctx => HasServer (Deprecated :> api) ctx where +instance (HasServer api ctx) => HasServer (Deprecated :> api) ctx where type ServerT (Deprecated :> api) m = ServerT api m route _ = route $ Proxy @api hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy @api) pc nt s -instance HasClient m api => HasClient m (Deprecated :> api) where +instance (HasClient m api) => HasClient m (Deprecated :> api) where type Client m (Deprecated :> api) = Client m api clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api) hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl diff --git a/libs/wire-api/src/Wire/API/Error.hs b/libs/wire-api/src/Wire/API/Error.hs index 7f6dab367dd..275d554a139 100644 --- a/libs/wire-api/src/Wire/API/Error.hs +++ b/libs/wire-api/src/Wire/API/Error.hs @@ -137,7 +137,7 @@ mkDynError c l msg = (Text.pack (symbolVal l)) (Text.pack (symbolVal msg)) -dynError :: forall e. KnownError e => DynError +dynError :: forall e. (KnownError e) => DynError dynError = dynError' $ seSing @e staticErrorSchema :: SStaticError e -> ValueSchema NamedSwaggerDoc (SStaticError e) @@ -159,17 +159,17 @@ staticErrorSchema e@(SStaticError c l m) = codeSchema :: ValueSchema SwaggerDoc Natural codeSchema = unnamed $ enum @Natural "Status" (element code code) -instance KnownError e => ToSchema (SStaticError e) where +instance (KnownError e) => ToSchema (SStaticError e) where schema = staticErrorSchema seSing data CanThrow e data CanThrowMany e -instance RoutesToPaths api => RoutesToPaths (CanThrow err :> api) where +instance (RoutesToPaths api) => RoutesToPaths (CanThrow err :> api) where getRoutes = getRoutes @api -instance RoutesToPaths api => RoutesToPaths (CanThrowMany errs :> api) where +instance (RoutesToPaths api) => RoutesToPaths (CanThrowMany errs :> api) where getRoutes = getRoutes @api type instance @@ -194,7 +194,7 @@ instance where toOpenApi _ = addToOpenApi @e (toOpenApi (Proxy @api)) -instance HasClient m api => HasClient m (CanThrow e :> api) where +instance (HasClient m api) => HasClient m (CanThrow e :> api) where type Client m (CanThrow e :> api) = Client m api clientWithRoute pm _ = clientWithRoute pm $ Proxy @api hoistClientMonad pm _ = hoistClientMonad pm (Proxy @api) @@ -203,7 +203,7 @@ type instance SpecialiseToVersion v (CanThrowMany es :> api) = CanThrowMany es :> SpecialiseToVersion v api -instance HasOpenApi api => HasOpenApi (CanThrowMany '() :> api) where +instance (HasOpenApi api) => HasOpenApi (CanThrowMany '() :> api) where toOpenApi _ = toOpenApi (Proxy @api) instance @@ -243,7 +243,7 @@ addErrorResponseToSwagger code resp = . S.responses . at code %~ Just - . addRef + . addRef where addRef :: Maybe (S.Referenced S.Response) -> S.Referenced S.Response addRef Nothing = S.Inline resp @@ -280,7 +280,7 @@ mapErrorS :: mapErrorS = mapError (Tagged @e' . unTagged) mapToRuntimeError :: - forall e e' r a. Member (Error e') r => e' -> Sem (ErrorS e ': r) a -> Sem r a + forall e e' r a. (Member (Error e') r) => e' -> Sem (ErrorS e ': r) a -> Sem r a mapToRuntimeError e' = mapError (const e') mapToDynamicError :: @@ -290,10 +290,10 @@ mapToDynamicError :: Sem r a mapToDynamicError = mapToRuntimeError (dynError @(MapError e)) -errorToWai :: forall e. KnownError (MapError e) => Wai.Error +errorToWai :: forall e. (KnownError (MapError e)) => Wai.Error errorToWai = dynErrorToWai (dynError @(MapError e)) -errorToResponse :: forall e. KnownError (MapError e) => JSONResponse +errorToResponse :: forall e. (KnownError (MapError e)) => JSONResponse errorToResponse = toResponse (dynError @(MapError e)) class APIError e where @@ -336,7 +336,7 @@ instance responseRender = responseRender @cs @(RespondWithStaticError (MapError e)) responseUnrender = responseUnrender @cs @(RespondWithStaticError (MapError e)) -instance KnownError (MapError e) => AsConstructor '[] (ErrorResponse e) where +instance (KnownError (MapError e)) => AsConstructor '[] (ErrorResponse e) where toConstructor _ = Nil fromConstructor _ = dynError @(MapError e) diff --git a/libs/wire-api/src/Wire/API/Error/Brig.hs b/libs/wire-api/src/Wire/API/Error/Brig.hs index ba1a227794b..e84846c1620 100644 --- a/libs/wire-api/src/Wire/API/Error/Brig.hs +++ b/libs/wire-api/src/Wire/API/Error/Brig.hs @@ -44,7 +44,6 @@ data BrigError | InvalidHandle | HandleNotFound | UserCreationRestricted - | BlacklistedPhone | AllowlistError | InvalidInvitationCode | MissingIdentity @@ -65,6 +64,7 @@ data BrigError | UserKeyExists | NameManagedByScim | HandleManagedByScim + | LocaleManagedByScim | LastIdentity | NoPassword | ChangePasswordMustDiffer @@ -112,10 +112,6 @@ type instance MapError 'ServiceDisabled = 'StaticError 403 "service-disabled" "T type instance MapError 'InvalidBot = 'StaticError 403 "invalid-bot" "The targeted user is not a bot." -type instance MapError 'ServiceDisabled = 'StaticError 403 "service-disabled" "The desired service is currently disabled." - -type instance MapError 'InvalidBot = 'StaticError 403 "invalid-bot" "The targeted user is not a bot." - type instance MapError 'UserNotFound = 'StaticError 404 "not-found" "User not found" type instance MapError 'InvalidConversation = 'StaticError 403 "invalid-conversation" "The operation is not allowed in this conversation." @@ -168,23 +164,21 @@ type instance MapError 'NotConnected = 'StaticError 403 "not-connected" "Users a type instance MapError 'InvalidTransition = 'StaticError 403 "bad-conn-update" "Invalid status transition" -type instance MapError 'NoIdentity = 'StaticError 403 "no-identity" "The user has no verified identity (email or phone number)" +type instance MapError 'NoIdentity = 'StaticError 403 "no-identity" "The user has no verified email" type instance MapError 'HandleExists = 'StaticError 409 "handle-exists" "The given handle is already taken" -type instance MapError 'InvalidHandle = 'StaticError 400 "invalid-handle" "The given handle is invalid" +type instance MapError 'InvalidHandle = 'StaticError 400 "invalid-handle" "The given handle is invalid (less than 2 or more than 256 characters; chars not in \"a-z0-9_.-\"; or on the blocklist)" type instance MapError 'HandleNotFound = 'StaticError 404 "not-found" "Handle not found" type instance MapError 'MLSDuplicatePublicKey = 'StaticError 400 "mls-duplicate-public-key" "MLS public key for the given signature scheme already exists" -type instance MapError 'BlacklistedPhone = 'StaticError 403 "blacklisted-phone" "The given phone number has been blacklisted due to suspected abuse or a complaint" - -type instance MapError 'AllowlistError = 'StaticError 403 "unauthorized" "Unauthorized e-mail address or phone number." +type instance MapError 'AllowlistError = 'StaticError 403 "unauthorized" "Unauthorized e-mail address" type instance MapError 'InvalidInvitationCode = 'StaticError 400 "invalid-invitation-code" "Invalid invitation code." -type instance MapError 'MissingIdentity = 'StaticError 403 "missing-identity" "Using an invitation code requires registering the given email and/or phone." +type instance MapError 'MissingIdentity = 'StaticError 403 "missing-identity" "Using an invitation code requires registering the given email." type instance MapError 'BlacklistedEmail = @@ -236,13 +230,15 @@ type instance MapError 'AccountEphemeral = 'StaticError 403 "ephemeral" "Account type instance MapError 'AccountPending = 'StaticError 403 "pending-activation" "Account pending activation" -type instance MapError 'UserKeyExists = 'StaticError 409 "key-exists" "The given e-mail address or phone number is in use." +type instance MapError 'UserKeyExists = 'StaticError 409 "key-exists" "The given e-mail address is in use." + +type instance MapError 'NameManagedByScim = 'StaticError 403 "managed-by-scim" "Updating name is not allowed, because it is managed by SCIM, or E2EId is enabled" -type instance MapError 'NameManagedByScim = 'StaticError 403 "managed-by-scim" "Updating name is not allowed, because it is managed by SCIM" +type instance MapError 'HandleManagedByScim = 'StaticError 403 "managed-by-scim" "Updating handle is not allowed, because it is managed by SCIM, or E2EId is enabled" -type instance MapError 'HandleManagedByScim = 'StaticError 403 "managed-by-scim" "Updating handle is not allowed, because it is managed by SCIM" +type instance MapError 'LocaleManagedByScim = 'StaticError 403 "managed-by-scim" "Updating locale is not allowed, because it is managed by SCIM, or E2EId is enabled" -type instance MapError 'LastIdentity = 'StaticError 403 "last-identity" "The last user identity (email or phone number) cannot be removed." +type instance MapError 'LastIdentity = 'StaticError 403 "last-identity" "The last user identity cannot be removed." type instance MapError 'NoPassword = 'StaticError 403 "no-password" "The user has no password." diff --git a/libs/wire-api/src/Wire/API/Error/Empty.hs b/libs/wire-api/src/Wire/API/Error/Empty.hs index 290c75c978d..8e25c71e210 100644 --- a/libs/wire-api/src/Wire/API/Error/Empty.hs +++ b/libs/wire-api/src/Wire/API/Error/Empty.hs @@ -33,7 +33,7 @@ data EmptyErrorForLegacyReasons s desc type instance ResponseType (EmptyErrorForLegacyReasons s desc) = () instance - KnownStatus s => + (KnownStatus s) => IsResponse cs (EmptyErrorForLegacyReasons s desc) where type ResponseStatus (EmptyErrorForLegacyReasons s desc) = s @@ -52,7 +52,7 @@ instance responseUnrender _ output = guard (responseStatusCode output == statusVal (Proxy @s)) instance - KnownSymbol desc => + (KnownSymbol desc) => IsSwaggerResponse (EmptyErrorForLegacyReasons s desc) where responseSwagger = diff --git a/libs/wire-api/src/Wire/API/Error/Galley.hs b/libs/wire-api/src/Wire/API/Error/Galley.hs index cf48534dff7..ed4d3a0e226 100644 --- a/libs/wire-api/src/Wire/API/Error/Galley.hs +++ b/libs/wire-api/src/Wire/API/Error/Galley.hs @@ -151,7 +151,7 @@ $(genSingletons [''GalleyError]) instance (Typeable (MapError e), KnownError (MapError e)) => IsSwaggerError (e :: GalleyError) where addToOpenApi = addStaticErrorToSwagger @(MapError e) -instance KnownError (MapError e) => APIError (Tagged (e :: GalleyError) ()) where +instance (KnownError (MapError e)) => APIError (Tagged (e :: GalleyError) ()) where toResponse _ = toResponse $ dynError @(MapError e) -- | Convenience synonym for an operation denied error with an unspecified permission. @@ -353,7 +353,7 @@ authenticationErrorToDyn ReAuthFailed = dynError @(MapError 'ReAuthFailed) authenticationErrorToDyn VerificationCodeAuthFailed = dynError @(MapError 'VerificationCodeAuthFailed) authenticationErrorToDyn VerificationCodeRequired = dynError @(MapError 'VerificationCodeRequired) -instance Member (Error DynError) r => ServerEffect (Error AuthenticationError) r where +instance (Member (Error DynError) r) => ServerEffect (Error AuthenticationError) r where interpretServerEffect = mapError authenticationErrorToDyn -------------------------------------------------------------------------------- @@ -366,6 +366,7 @@ data TeamFeatureError | DisableSsoNotImplemented | FeatureLocked | MLSProtocolMismatch + | MLSE2EIDMissingCrlProxy instance IsSwaggerError TeamFeatureError where -- Do not display in Swagger @@ -397,9 +398,11 @@ type instance MapError 'FeatureLocked = 'StaticError 409 "feature-locked" "Featu type instance MapError 'MLSProtocolMismatch = 'StaticError 400 "mls-protocol-mismatch" "The default protocol needs to be part of the supported protocols" +type instance MapError 'MLSE2EIDMissingCrlProxy = 'StaticError 400 "mls-e2eid-missing-crl-proxy" "The field 'crlProxy' is missing in the request payload" + type instance ErrorEffect TeamFeatureError = Error TeamFeatureError -instance Member (Error DynError) r => ServerEffect (Error TeamFeatureError) r where +instance (Member (Error DynError) r) => ServerEffect (Error TeamFeatureError) r where interpretServerEffect = mapError $ \case AppLockInactivityTimeoutTooLow -> dynError @(MapError 'AppLockInactivityTimeoutTooLow) LegalHoldFeatureFlagNotEnabled -> dynError @(MapError 'LegalHoldFeatureFlagNotEnabled) @@ -407,6 +410,7 @@ instance Member (Error DynError) r => ServerEffect (Error TeamFeatureError) r wh DisableSsoNotImplemented -> dynError @(MapError 'DisableSsoNotImplemented) FeatureLocked -> dynError @(MapError 'FeatureLocked) MLSProtocolMismatch -> dynError @(MapError 'MLSProtocolMismatch) + MLSE2EIDMissingCrlProxy -> dynError @(MapError 'MLSE2EIDMissingCrlProxy) -------------------------------------------------------------------------------- -- Proposal failure @@ -431,7 +435,7 @@ instance IsSwaggerError MLSProposalFailure where \for more details on the possible error responses of each type of \ \proposal." -instance Member (Error JSONResponse) r => ServerEffect (Error MLSProposalFailure) r where +instance (Member (Error JSONResponse) r) => ServerEffect (Error MLSProposalFailure) r where interpretServerEffect = mapError pfInner -------------------------------------------------------------------------------- @@ -456,7 +460,7 @@ nonFederatingBackendsStatus = HTTP.status409 nonFederatingBackendsToList :: NonFederatingBackends -> [Domain] nonFederatingBackendsToList (NonFederatingBackends a b) = [a, b] -nonFederatingBackendsFromList :: MonadFail m => [Domain] -> m NonFederatingBackends +nonFederatingBackendsFromList :: (MonadFail m) => [Domain] -> m NonFederatingBackends nonFederatingBackendsFromList [a, b] = pure (NonFederatingBackends a b) nonFederatingBackendsFromList domains = fail $ @@ -483,7 +487,7 @@ instance IsSwaggerError NonFederatingBackends where type instance ErrorEffect NonFederatingBackends = Error NonFederatingBackends -instance Member (Error JSONResponse) r => ServerEffect (Error NonFederatingBackends) r where +instance (Member (Error JSONResponse) r) => ServerEffect (Error NonFederatingBackends) r where interpretServerEffect = mapError toResponse -------------------------------------------------------------------------------- @@ -527,7 +531,7 @@ instance IsSwaggerError UnreachableBackends where type instance ErrorEffect UnreachableBackends = Error UnreachableBackends -instance Member (Error JSONResponse) r => ServerEffect (Error UnreachableBackends) r where +instance (Member (Error JSONResponse) r) => ServerEffect (Error UnreachableBackends) r where interpretServerEffect = mapError toResponse unreachableUsersToUnreachableBackends :: UnreachableUsers -> UnreachableBackends @@ -553,5 +557,5 @@ instance APIError UnreachableBackendsLegacy where type instance ErrorEffect UnreachableBackendsLegacy = Error UnreachableBackendsLegacy -instance Member (Error JSONResponse) r => ServerEffect (Error UnreachableBackendsLegacy) r where +instance (Member (Error JSONResponse) r) => ServerEffect (Error UnreachableBackendsLegacy) r where interpretServerEffect = mapError toResponse diff --git a/libs/wire-api/src/Wire/API/Event/Team.hs b/libs/wire-api/src/Wire/API/Event/Team.hs index d5dac32eb39..bbeb15ebe10 100644 --- a/libs/wire-api/src/Wire/API/Event/Team.hs +++ b/libs/wire-api/src/Wire/API/Event/Team.hs @@ -167,8 +167,10 @@ instance ToJSON EventData where toJSON (EdMemberJoin usr) = A.object ["user" A..= usr] toJSON (EdMemberUpdate usr mPerm) = A.object $ - "user" A..= usr - # "permissions" A..= mPerm + "user" + A..= usr + # "permissions" + A..= mPerm # [] toJSON (EdMemberLeave usr) = A.object ["user" A..= usr] toJSON (EdConvCreate cnv) = A.object ["conv" A..= cnv] diff --git a/libs/wire-api/src/Wire/API/Locale.hs b/libs/wire-api/src/Wire/API/Locale.hs new file mode 100644 index 00000000000..576c7eeeb10 --- /dev/null +++ b/libs/wire-api/src/Wire/API/Locale.hs @@ -0,0 +1,231 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Wire.API.Locale + ( Locale (..), + Language (..), + Country (..), + timeLocale, + formatDateTime, + deDe, + frFr, + locToText, + parseLocale, + lan2Text, + parseLanguage, + con2Text, + parseCountry, + ) +where + +import Cassandra as C +import Control.Applicative (optional) +import Control.Error.Util (hush, note) +import Data.Aeson (FromJSON, ToJSON) +import Data.Attoparsec.Text +import Data.ISO3166_CountryCodes (CountryCode) +import Data.LanguageCodes (ISO639_1 (DE, FR)) +import Data.OpenApi qualified as S +import Data.Schema +import Data.Text qualified as Text +import Data.Time.Clock (UTCTime) +import Data.Time.Format +import Data.Time.LocalTime (TimeZone (..), utc) +import Imports +import Test.QuickCheck +import Wire.API.User.Orphans () +import Wire.Arbitrary + +timeLocale :: Locale -> TimeLocale +timeLocale (Locale (Language DE) _) = deDe +timeLocale (Locale (Language FR) _) = frFr +timeLocale _ = defaultTimeLocale + +formatDateTime :: String -> TimeLocale -> UTCTime -> Text +formatDateTime s l = fromString . formatTime l s + +deDe :: TimeLocale +deDe = + TimeLocale + { wDays = + [ ("Sonntag", "Son"), + ("Montag", "Mon"), + ("Dienstag", "Die"), + ("Mittwoch", "Mit"), + ("Donnerstag", "Don"), + ("Freitag", "Fre"), + ("Samstag", "Sam") + ], + months = + [ ("Januar", "Jan"), + ("Februar", "Feb"), + ("März", "Mär"), + ("April", "Apr"), + ("Mai", "Mai"), + ("Juni", "Jun"), + ("Juli", "Jul"), + ("August", "Aug"), + ("September", "Sep"), + ("Oktober", "Okt"), + ("November", "Nov"), + ("Dezember", "Dez") + ], + amPm = ("", ""), + dateTimeFmt = "%d. %B %Y %H:%M:%S %Z", + dateFmt = "%d.%m.%Y", + timeFmt = "%H:%M:%S", + time12Fmt = "%H:%M:%S", + knownTimeZones = + [ utc, + TimeZone 60 False "MEZ", + TimeZone 120 True "MESZ" + ] + } + +frFr :: TimeLocale +frFr = + TimeLocale + { wDays = + [ ("dimanche", "dim"), + ("lundi", "lun"), + ("mardi", "mar"), + ("mercredi", "mer"), + ("jeudi", "jeu"), + ("vendredi", "ven"), + ("samedi", "sam") + ], + months = + [ ("janvier", "jan"), + ("février", "fév"), + ("mars", "mar"), + ("avril", "avr"), + ("mai", "mai"), + ("juin", "jun"), + ("juillet", "jul"), + ("août", "aoû"), + ("septembre", "sep"), + ("octobre", "oct"), + ("novembre", "nov"), + ("décembre", "déc") + ], + amPm = ("", ""), + dateTimeFmt = "%d %B %Y %H h %M %Z", + dateFmt = "%d/%m/%Y", + timeFmt = "%H h %M", + time12Fmt = "%H h %M", + knownTimeZones = + [ utc, + TimeZone 60 False "HNEC", + TimeZone 120 True "HAEC" + ] + } + +-------------------------------------------------------------------------------- +-- Locale + +data Locale = Locale + { lLanguage :: Language, + lCountry :: Maybe Country + } + deriving stock (Eq, Ord, Generic) + deriving (Arbitrary) via (GenericUniform Locale) + deriving (FromJSON, ToJSON, S.ToSchema) via Schema Locale + +instance ToSchema Locale where + schema = locToText .= parsedText "Locale" (note err . parseLocale) + where + err = "Invalid locale. Expected (-)? format" + +instance Show Locale where + show = Text.unpack . locToText + +locToText :: Locale -> Text +locToText (Locale l c) = lan2Text l <> foldMap (("-" <>) . con2Text) c + +parseLocale :: Text -> Maybe Locale +parseLocale = hush . parseOnly localeParser + where + localeParser :: Parser Locale + localeParser = + Locale + <$> (languageParser "Language code") + <*> (optional (char '-' *> countryParser) "Country code") + +-------------------------------------------------------------------------------- +-- Language + +newtype Language = Language {fromLanguage :: ISO639_1} + deriving stock (Eq, Ord, Show, Generic) + deriving newtype (Arbitrary, S.ToSchema) + +instance C.Cql Language where + ctype = C.Tagged C.AsciiColumn + toCql = C.toCql . lan2Text + + fromCql (C.CqlAscii l) = case parseLanguage l of + Just l' -> pure l' + Nothing -> Left "Language: ISO 639-1 expected." + fromCql _ = Left "Language: ASCII expected" + +languageParser :: Parser Language +languageParser = codeParser "language" $ fmap Language . checkAndConvert isLower + +lan2Text :: Language -> Text +lan2Text = Text.toLower . Text.pack . show . fromLanguage + +parseLanguage :: Text -> Maybe Language +parseLanguage = hush . parseOnly languageParser + +-------------------------------------------------------------------------------- +-- Country + +newtype Country = Country {fromCountry :: CountryCode} + deriving stock (Eq, Ord, Show, Generic) + deriving newtype (Arbitrary, S.ToSchema) + +instance C.Cql Country where + ctype = C.Tagged C.AsciiColumn + toCql = C.toCql . con2Text + + fromCql (C.CqlAscii c) = case parseCountry c of + Just c' -> pure c' + Nothing -> Left "Country: ISO 3166-1-alpha2 expected." + fromCql _ = Left "Country: ASCII expected" + +countryParser :: Parser Country +countryParser = codeParser "country" $ fmap Country . checkAndConvert isUpper + +con2Text :: Country -> Text +con2Text = Text.pack . show . fromCountry + +parseCountry :: Text -> Maybe Country +parseCountry = hush . parseOnly countryParser + +-------------------------------------------------------------------------------- +-- helpers + +-- Common language / country functions +checkAndConvert :: (Read a) => (Char -> Bool) -> String -> Maybe a +checkAndConvert f t = + if all f t + then readMaybe (map toUpper t) + else fail "Format not supported." + +codeParser :: String -> (String -> Maybe a) -> Parser a +codeParser err conv = do + code <- count 2 anyChar + maybe (fail err) pure (conv code) diff --git a/libs/wire-api/src/Wire/API/MLS/CipherSuite.hs b/libs/wire-api/src/Wire/API/MLS/CipherSuite.hs index 0a92ca9886e..a286a02d0a1 100644 --- a/libs/wire-api/src/Wire/API/MLS/CipherSuite.hs +++ b/libs/wire-api/src/Wire/API/MLS/CipherSuite.hs @@ -173,7 +173,7 @@ tagCipherSuite MLS_256_DHKEMP521_AES256GCM_SHA512_P521 = CipherSuite 0x5 tagCipherSuite MLS_128_X25519Kyber768Draft00_AES128GCM_SHA256_Ed25519 = CipherSuite 0xf031 data SomeHashAlgorithm where - SomeHashAlgorithm :: HashAlgorithm a => a -> SomeHashAlgorithm + SomeHashAlgorithm :: (HashAlgorithm a) => a -> SomeHashAlgorithm csHashAlgorithm :: CipherSuiteTag -> SomeHashAlgorithm csHashAlgorithm MLS_128_DHKEMX25519_AES128GCM_SHA256_Ed25519 = SomeHashAlgorithm SHA256 @@ -294,7 +294,7 @@ data SignatureSchemeTag deriving (Arbitrary) via GenericUniform SignatureSchemeTag class IsSignatureScheme (ss :: SignatureSchemeTag) where - sign :: MonadRandom m => KeyPair ss -> ByteString -> m ByteString + sign :: (MonadRandom m) => KeyPair ss -> ByteString -> m ByteString instance IsSignatureScheme 'Ed25519 where sign (priv, pub) = pure . BA.convert . Ed25519.sign priv pub @@ -352,7 +352,7 @@ signatureSchemeFromName name = getAlt $ flip foldMap [minBound .. maxBound] $ \s -> guard (signatureSchemeName s == name) $> s -parseSignatureScheme :: MonadFail f => Text -> f SignatureSchemeTag +parseSignatureScheme :: (MonadFail f) => Text -> f SignatureSchemeTag parseSignatureScheme name = maybe (fail ("Unsupported signature scheme " <> T.unpack name)) diff --git a/libs/wire-api/src/Wire/API/MLS/CommitBundle.hs b/libs/wire-api/src/Wire/API/MLS/CommitBundle.hs index ccfe3006284..2307f8ac38b 100644 --- a/libs/wire-api/src/Wire/API/MLS/CommitBundle.hs +++ b/libs/wire-api/src/Wire/API/MLS/CommitBundle.hs @@ -41,14 +41,14 @@ data CommitBundleF f = CommitBundleF deriving instance Show (CommitBundleF []) -instance Alternative f => Semigroup (CommitBundleF f) where +instance (Alternative f) => Semigroup (CommitBundleF f) where cb1 <> cb2 = CommitBundleF (cb1.commitMsg <|> cb2.commitMsg) (cb1.welcome <|> cb2.welcome) (cb1.groupInfo <|> cb2.groupInfo) -instance Alternative f => Monoid (CommitBundleF f) where +instance (Alternative f) => Monoid (CommitBundleF f) where mempty = CommitBundleF empty empty empty checkCommitBundleF :: CommitBundleF [] -> Either Text CommitBundle @@ -68,7 +68,7 @@ checkCommitBundleF cb = checkOpt _ [x] = pure (Just x) checkOpt name _ = Left ("Redundant occurrence of " <> name) -findMessageInStream :: Alternative f => RawMLS Message -> Either Text (CommitBundleF f) +findMessageInStream :: (Alternative f) => RawMLS Message -> Either Text (CommitBundleF f) findMessageInStream msg = case msg.value.content of MessagePublic mp -> case mp.content.value.content of FramedContentCommit _ -> pure (CommitBundleF (pure msg) empty empty) @@ -77,7 +77,7 @@ findMessageInStream msg = case msg.value.content of MessageGroupInfo gi -> pure (CommitBundleF empty empty (pure gi)) _ -> Left "unexpected message type" -findMessagesInStream :: Alternative f => [RawMLS Message] -> Either Text (CommitBundleF f) +findMessagesInStream :: (Alternative f) => [RawMLS Message] -> Either Text (CommitBundleF f) findMessagesInStream = getAp . foldMap (Ap . findMessageInStream) instance ParseMLS CommitBundle where diff --git a/libs/wire-api/src/Wire/API/MLS/ECDSA.hs b/libs/wire-api/src/Wire/API/MLS/ECDSA.hs index 11d197c0369..addaab7b64c 100644 --- a/libs/wire-api/src/Wire/API/MLS/ECDSA.hs +++ b/libs/wire-api/src/Wire/API/MLS/ECDSA.hs @@ -30,7 +30,7 @@ import Wire.API.MLS.Serialisation -- | Decode an ECDSA signature. decodeSignature :: forall curve. - EllipticCurveECDSA curve => + (EllipticCurveECDSA curve) => Proxy curve -> ByteString -> Maybe (Signature curve) @@ -43,7 +43,7 @@ decodeSignature curve bs = do -- Encode an ECDSA signature. encodeSignature :: forall curve. - EllipticCurveECDSA curve => + (EllipticCurveECDSA curve) => Proxy curve -> Signature curve -> ByteString diff --git a/libs/wire-api/src/Wire/API/MLS/Epoch.hs b/libs/wire-api/src/Wire/API/MLS/Epoch.hs index 117e26abd28..c820310a4ed 100644 --- a/libs/wire-api/src/Wire/API/MLS/Epoch.hs +++ b/libs/wire-api/src/Wire/API/MLS/Epoch.hs @@ -38,5 +38,5 @@ instance ParseMLS Epoch where instance SerialiseMLS Epoch where serialiseMLS (Epoch n) = put n -addToEpoch :: Integral a => a -> Epoch -> Epoch +addToEpoch :: (Integral a) => a -> Epoch -> Epoch addToEpoch n (Epoch e) = Epoch (e + fromIntegral n) diff --git a/libs/wire-api/src/Wire/API/MLS/Keys.hs b/libs/wire-api/src/Wire/API/MLS/Keys.hs index 92afc2df664..545a9c1c5cf 100644 --- a/libs/wire-api/src/Wire/API/MLS/Keys.hs +++ b/libs/wire-api/src/Wire/API/MLS/Keys.hs @@ -35,7 +35,7 @@ data MLSKeysByPurpose a = MLSKeysByPurpose deriving (Eq, Show, Functor, Foldable, Traversable) deriving (FromJSON, ToJSON, S.ToSchema) via Schema (MLSKeysByPurpose a) -instance ToSchema a => ToSchema (MLSKeysByPurpose a) where +instance (ToSchema a) => ToSchema (MLSKeysByPurpose a) where schema = object "MLSKeysByPurpose" $ MLSKeysByPurpose @@ -50,7 +50,7 @@ data MLSKeys a = MLSKeys deriving (Eq, Show) deriving (FromJSON, ToJSON, S.ToSchema) via Schema (MLSKeys a) -instance ToSchema a => ToSchema (MLSKeys a) where +instance (ToSchema a) => ToSchema (MLSKeys a) where schema = object "MLSKeys" $ MLSKeys diff --git a/libs/wire-api/src/Wire/API/MLS/Serialisation.hs b/libs/wire-api/src/Wire/API/MLS/Serialisation.hs index 7ae47e8493a..618d26201bf 100644 --- a/libs/wire-api/src/Wire/API/MLS/Serialisation.hs +++ b/libs/wire-api/src/Wire/API/MLS/Serialisation.hs @@ -233,17 +233,17 @@ instance SerialiseMLS Word32 where serialiseMLS = put instance SerialiseMLS Word64 where serialiseMLS = put -- | Encode an MLS value to a lazy bytestring. -encodeMLS :: SerialiseMLS a => a -> LByteString +encodeMLS :: (SerialiseMLS a) => a -> LByteString encodeMLS = runPut . serialiseMLS -encodeMLS' :: SerialiseMLS a => a -> ByteString +encodeMLS' :: (SerialiseMLS a) => a -> ByteString encodeMLS' = LBS.toStrict . encodeMLS -- | Decode an MLS value from a lazy bytestring. Return an error message in case of failure. -decodeMLS :: ParseMLS a => LByteString -> Either Text a +decodeMLS :: (ParseMLS a) => LByteString -> Either Text a decodeMLS = decodeMLSWith parseMLS -decodeMLS' :: ParseMLS a => ByteString -> Either Text a +decodeMLS' :: (ParseMLS a) => ByteString -> Either Text a decodeMLS' = decodeMLS . LBS.fromStrict -- | Decode an MLS value from a lazy bytestring given a custom parser. @@ -298,10 +298,10 @@ rawMLSFromText p txt = do value <- first Text.unpack (p mlsData) pure $ RawMLS mlsData value -instance S.ToSchema a => S.ToSchema (RawMLS a) where +instance (S.ToSchema a) => S.ToSchema (RawMLS a) where declareNamedSchema _ = S.declareNamedSchema (Proxy @a) -instance ParseMLS a => FromJSON (RawMLS a) where +instance (ParseMLS a) => FromJSON (RawMLS a) where parseJSON = Aeson.withText "Base64 MLS object" $ either fail pure . rawMLSFromText decodeMLS' @@ -318,16 +318,16 @@ parseRawMLS p = do -- construct RawMLS value pure $ RawMLS raw x -instance ParseMLS a => ParseMLS (RawMLS a) where +instance (ParseMLS a) => ParseMLS (RawMLS a) where parseMLS = parseRawMLS parseMLS instance SerialiseMLS (RawMLS a) where serialiseMLS = putByteString . raw -mkRawMLS :: SerialiseMLS a => a -> RawMLS a +mkRawMLS :: (SerialiseMLS a) => a -> RawMLS a mkRawMLS x = RawMLS (LBS.toStrict (runPut (serialiseMLS x))) x -traceMLS :: Show a => String -> Get a -> Get a +traceMLS :: (Show a) => String -> Get a -> Get a traceMLS l g = do begin <- bytesRead r <- g diff --git a/libs/wire-api/src/Wire/API/MLS/Servant.hs b/libs/wire-api/src/Wire/API/MLS/Servant.hs index 4807d82d930..e1061779bc8 100644 --- a/libs/wire-api/src/Wire/API/MLS/Servant.hs +++ b/libs/wire-api/src/Wire/API/MLS/Servant.hs @@ -30,10 +30,10 @@ data MLS instance Accept MLS where contentType _ = "message" // "mls" -instance {-# OVERLAPPABLE #-} ParseMLS a => MimeUnrender MLS a where +instance {-# OVERLAPPABLE #-} (ParseMLS a) => MimeUnrender MLS a where mimeUnrender _ = mimeUnrenderMLSWith parseMLS -instance {-# OVERLAPPABLE #-} SerialiseMLS a => MimeRender MLS a where +instance {-# OVERLAPPABLE #-} (SerialiseMLS a) => MimeRender MLS a where mimeRender _ = encodeMLS mimeUnrenderMLSWith :: Get a -> LByteString -> Either String a diff --git a/libs/wire-api/src/Wire/API/MakesFederatedCall.hs b/libs/wire-api/src/Wire/API/MakesFederatedCall.hs index 5b9875db078..2a59e5648fb 100644 --- a/libs/wire-api/src/Wire/API/MakesFederatedCall.hs +++ b/libs/wire-api/src/Wire/API/MakesFederatedCall.hs @@ -50,7 +50,7 @@ import GHC.TypeLits import Imports import Servant.API import Servant.API.Extended (ReqBodyCustomError') -import Servant.API.Extended.RawM (RawM) +import Servant.API.Extended.RawM qualified as RawM import Servant.Client import Servant.Multipart import Servant.OpenApi @@ -93,7 +93,7 @@ import Wire.Arbitrary (GenericUniform (..)) -- The @x@ parameter here is intentionally ambiguous, existing as a unique -- skolem to prevent GHC from caching the results of solving -- 'ToHasAnnotations'. Callers needn't worry about it. -exposeAnnotations :: ToHasAnnotations x => a -> a +exposeAnnotations :: (ToHasAnnotations x) => a -> a exposeAnnotations = id data Component @@ -161,11 +161,11 @@ instance (HasServer api ctx) => HasServer (MakesFederatedCall comp name :> api : route _ ctx f = route (Proxy @api) ctx $ fmap ($ synthesizeCallsFed @comp @name) f hoistServerWithContext _ ctx f s = hoistServerWithContext (Proxy @api) ctx f . s -instance HasLink api => HasLink (MakesFederatedCall comp name :> api :: Type) where +instance (HasLink api) => HasLink (MakesFederatedCall comp name :> api :: Type) where type MkLink (MakesFederatedCall comp name :> api) x = MkLink api x toLink f _ l = toLink f (Proxy @api) l -instance RoutesToPaths api => RoutesToPaths (MakesFederatedCall comp name :> api :: Type) where +instance (RoutesToPaths api) => RoutesToPaths (MakesFederatedCall comp name :> api :: Type) where getRoutes = getRoutes @api -- | Get a symbol representation of our component. @@ -185,7 +185,9 @@ instance (HasOpenApi api, KnownSymbol name, KnownSymbol (ShowComponent comp)) => toOpenApi (Proxy @api) -- Append federated call line to the description of routes -- that perform calls to federation members. - & S.allOperations . S.description %~ pure . maybe call (\d -> d <> "
" <> call) + & S.allOperations + . S.description + %~ pure . maybe call (\d -> d <> "
" <> call) where call :: Text call = @@ -194,7 +196,7 @@ instance (HasOpenApi api, KnownSymbol name, KnownSymbol (ShowComponent comp)) => <> T.pack " on " <> T.pack (symbolVal $ Proxy @name) -instance HasClient m api => HasClient m (MakesFederatedCall comp name :> api :: Type) where +instance (HasClient m api) => HasClient m (MakesFederatedCall comp name :> api :: Type) where type Client m (MakesFederatedCall comp name :> api) = Client m api clientWithRoute p _ = clientWithRoute p $ Proxy @api hoistClientMonad p _ f c = hoistClientMonad p (Proxy @api) f c @@ -208,7 +210,7 @@ class SolveCallsFed c r a where -- This function should always be called with an argument of -- 'exposeAnnotations'. See the documentation there for more information on -- why. - callsFed :: (c => r) -> a + callsFed :: ((c) => r) -> a instance (c ~ ((k, d) :: Constraint), SolveCallsFed d r a) => SolveCallsFed c r (Dict k -> a) where callsFed f Dict = callsFed @d @r @a f @@ -221,7 +223,7 @@ instance {-# OVERLAPPABLE #-} (c ~ (() :: Constraint), r ~ a) => SolveCallsFed c -- -- This is unsafe in the sense that it will drop the 'CallsFed' constraint, and -- thus might mean a federated call gets forgotten in the documentation. -unsafeCallsFed :: forall (comp :: Component) (name :: Symbol) r. (CallsFed comp name => r) -> r +unsafeCallsFed :: forall (comp :: Component) (name :: Symbol) r. ((CallsFed comp name) => r) -> r unsafeCallsFed f = withDict (synthesizeCallsFed @comp @name) f data FedCallFrom' f = FedCallFrom @@ -298,22 +300,22 @@ instance (HasFeds rest, KnownSymbol (ShowComponent comp), KnownSymbol name) => H modify $ \s -> s {fedCalls = fedCalls s <> Calls call} getFedCalls $ Proxy @rest -instance ReflectMethod method => HasFeds (MultiVerb method cs as r) where +instance (ReflectMethod method) => HasFeds (MultiVerb method cs as r) where getFedCalls _ = do modify $ \s -> s {method = getMethod @method} gets pure -instance ReflectMethod method => HasFeds (Verb method status cts a) where +instance (ReflectMethod method) => HasFeds (Verb method status cts a) where getFedCalls _ = do modify $ \s -> s {method = getMethod @method} gets pure -instance ReflectMethod method => HasFeds (NoContentVerb method) where +instance (ReflectMethod method) => HasFeds (NoContentVerb method) where getFedCalls _ = do modify $ \s -> s {method = getMethod @method} gets pure -instance ReflectMethod method => HasFeds (Stream method status framing ct a) where +instance (ReflectMethod method) => HasFeds (Stream method status framing ct a) where getFedCalls _ = do modify $ \s -> s {method = getMethod @method} gets pure @@ -339,10 +341,10 @@ instance HasFeds EmptyAPI where instance HasFeds Raw where getFedCalls _ = gets pure -instance HasFeds RawM where +instance HasFeds RawM.RawM where getFedCalls _ = gets pure -getMethod :: forall method. ReflectMethod method => Maybe String +getMethod :: forall method. (ReflectMethod method) => Maybe String getMethod = pure . fmap toLower . unpack . reflectMethod $ Proxy @method appendName :: String -> FedCallFrom -> FedCallFrom @@ -352,59 +354,59 @@ appendName toAppend s = s {name = pure $ maybe toAppend (<> toAppend) $ name s} instance (RenderableSymbol name, HasFeds rest) => HasFeds (Named name rest) where getFedCalls _ = getFedCalls $ Proxy @rest -instance HasFeds rest => HasFeds (Header' mods name a :> rest) where +instance (HasFeds rest) => HasFeds (Header' mods name a :> rest) where getFedCalls _ = getFedCalls $ Proxy @rest -instance HasFeds rest => HasFeds (ReqBody' mods cts a :> rest) where +instance (HasFeds rest) => HasFeds (ReqBody' mods cts a :> rest) where getFedCalls _ = getFedCalls $ Proxy @rest -instance HasFeds rest => HasFeds (StreamBody' opts framing ct a :> rest) where +instance (HasFeds rest) => HasFeds (StreamBody' opts framing ct a :> rest) where getFedCalls _ = getFedCalls $ Proxy @rest -instance HasFeds rest => HasFeds (Summary summary :> rest) where +instance (HasFeds rest) => HasFeds (Summary summary :> rest) where getFedCalls _ = getFedCalls $ Proxy @rest -instance HasFeds rest => HasFeds (QueryParam' mods name a :> rest) where +instance (HasFeds rest) => HasFeds (QueryParam' mods name a :> rest) where getFedCalls _ = getFedCalls $ Proxy @rest -instance HasFeds rest => HasFeds (MultipartForm tag a :> rest) where +instance (HasFeds rest) => HasFeds (MultipartForm tag a :> rest) where getFedCalls _ = getFedCalls $ Proxy @rest -instance HasFeds rest => HasFeds (QueryFlag a :> rest) where +instance (HasFeds rest) => HasFeds (QueryFlag a :> rest) where getFedCalls _ = getFedCalls $ Proxy @rest -instance HasFeds rest => HasFeds (Description desc :> rest) where +instance (HasFeds rest) => HasFeds (Description desc :> rest) where getFedCalls _ = getFedCalls $ Proxy @rest -instance HasFeds rest => HasFeds (Deprecated :> rest) where +instance (HasFeds rest) => HasFeds (Deprecated :> rest) where getFedCalls _ = getFedCalls $ Proxy @rest -instance HasFeds rest => HasFeds (CanThrow e :> rest) where +instance (HasFeds rest) => HasFeds (CanThrow e :> rest) where getFedCalls _ = getFedCalls $ Proxy @rest -instance HasFeds rest => HasFeds (CanThrowMany es :> rest) where +instance (HasFeds rest) => HasFeds (CanThrowMany es :> rest) where getFedCalls _ = getFedCalls $ Proxy @rest -instance HasFeds rest => HasFeds (Bearer a :> rest) where +instance (HasFeds rest) => HasFeds (Bearer a :> rest) where getFedCalls _ = getFedCalls $ Proxy @rest -instance HasFeds rest => HasFeds (Cookies cs :> rest) where +instance (HasFeds rest) => HasFeds (Cookies cs :> rest) where getFedCalls _ = getFedCalls $ Proxy @rest -instance HasFeds rest => HasFeds (ZHostOpt :> rest) where +instance (HasFeds rest) => HasFeds (ZHostOpt :> rest) where getFedCalls _ = getFedCalls $ Proxy @rest -instance HasFeds rest => HasFeds (ZAuthServant ztype opts :> rest) where +instance (HasFeds rest) => HasFeds (ZAuthServant ztype opts :> rest) where getFedCalls _ = getFedCalls $ Proxy @rest -instance HasFeds rest => HasFeds (ReqBodyCustomError' mods cts tag a :> rest) where +instance (HasFeds rest) => HasFeds (ReqBodyCustomError' mods cts tag a :> rest) where getFedCalls _ = getFedCalls $ Proxy @rest -instance HasFeds rest => HasFeds (DescriptionOAuthScope scope :> rest) where +instance (HasFeds rest) => HasFeds (DescriptionOAuthScope scope :> rest) where getFedCalls _ = getFedCalls $ Proxy @rest -instance HasFeds rest => HasFeds (OmitDocs :> rest) where +instance (HasFeds rest) => HasFeds (OmitDocs :> rest) where getFedCalls _ = getFedCalls $ Proxy @rest -instance HasFeds rest => HasFeds (VersionedReqBody v cts a :> rest) where +instance (HasFeds rest) => HasFeds (VersionedReqBody v cts a :> rest) where getFedCalls _ = getFedCalls $ Proxy @rest diff --git a/libs/wire-api/src/Wire/API/Message.hs b/libs/wire-api/src/Wire/API/Message.hs index 6b117791bc3..85cdda18909 100644 --- a/libs/wire-api/src/Wire/API/Message.hs +++ b/libs/wire-api/src/Wire/API/Message.hs @@ -451,7 +451,7 @@ clientMismatchStrategyToProtolens = \case & Proto.Otr.userIds .~ map qualifiedUserIdToProtolens (toList users) ) -protolensToSetQualifiedUserIds :: ProtoLens.HasField s "userIds" [Proto.Otr.QualifiedUserId] => s -> Either String (Set (Qualified UserId)) +protolensToSetQualifiedUserIds :: (ProtoLens.HasField s "userIds" [Proto.Otr.QualifiedUserId]) => s -> Either String (Set (Qualified UserId)) protolensToSetQualifiedUserIds = fmap Set.fromList . mapM protolensToQualifiedUserId . view Proto.Otr.userIds protolensToQualifiedUserId :: Proto.Otr.QualifiedUserId -> Either String (Qualified UserId) diff --git a/libs/wire-api/src/Wire/API/Message/Proto.hs b/libs/wire-api/src/Wire/API/Message/Proto.hs index b2b6f1a3832..d20ecd75ab6 100644 --- a/libs/wire-api/src/Wire/API/Message/Proto.hs +++ b/libs/wire-api/src/Wire/API/Message/Proto.hs @@ -68,7 +68,7 @@ instance Decode UserId fromUserId :: Id.UserId -> UserId fromUserId u = UserId {_user = putField u} -userId :: Functor f => (Id.UserId -> f Id.UserId) -> UserId -> f UserId +userId :: (Functor f) => (Id.UserId -> f Id.UserId) -> UserId -> f UserId userId f c = (\x -> c {_user = x}) <$> field f (_user c) -------------------------------------------------------------------------------- @@ -86,7 +86,7 @@ instance Decode ClientId newClientId :: Word64 -> ClientId newClientId c = ClientId {_client = putField c} -clientId :: Functor f => (Word64 -> f Word64) -> ClientId -> f ClientId +clientId :: (Functor f) => (Word64 -> f Word64) -> ClientId -> f ClientId clientId f c = (\x -> c {_client = x}) <$> field f (_client c) toClientId :: ClientId -> Id.ClientId @@ -115,10 +115,10 @@ clientEntry c t = _clientVal = putField t } -clientEntryId :: Functor f => (ClientId -> f ClientId) -> ClientEntry -> f ClientEntry +clientEntryId :: (Functor f) => (ClientId -> f ClientId) -> ClientEntry -> f ClientEntry clientEntryId f c = (\x -> c {_clientId = x}) <$> field f (_clientId c) -clientEntryMessage :: Functor f => (ByteString -> f ByteString) -> ClientEntry -> f ClientEntry +clientEntryMessage :: (Functor f) => (ByteString -> f ByteString) -> ClientEntry -> f ClientEntry clientEntryMessage f c = (\x -> c {_clientVal = x}) <$> field f (_clientVal c) -------------------------------------------------------------------------------- @@ -141,10 +141,10 @@ userEntry u c = _userVal = putField c } -userEntryId :: Functor f => (UserId -> f UserId) -> UserEntry -> f UserEntry +userEntryId :: (Functor f) => (UserId -> f UserId) -> UserEntry -> f UserEntry userEntryId f c = (\x -> c {_userId = x}) <$> field f (_userId c) -userEntryClients :: Functor f => ([ClientEntry] -> f [ClientEntry]) -> UserEntry -> f UserEntry +userEntryClients :: (Functor f) => ([ClientEntry] -> f [ClientEntry]) -> UserEntry -> f UserEntry userEntryClients f c = (\x -> c {_userVal = x}) <$> field f (_userVal c) -------------------------------------------------------------------------------- @@ -199,27 +199,27 @@ newOtrMessage c us = _newOtrReportMissing = putField [] } -newOtrMessageSender :: Functor f => (ClientId -> f ClientId) -> NewOtrMessage -> f NewOtrMessage +newOtrMessageSender :: (Functor f) => (ClientId -> f ClientId) -> NewOtrMessage -> f NewOtrMessage newOtrMessageSender f c = (\x -> c {_newOtrSender = x}) <$> field f (_newOtrSender c) -newOtrMessageRecipients :: Functor f => ([UserEntry] -> f [UserEntry]) -> NewOtrMessage -> f NewOtrMessage +newOtrMessageRecipients :: (Functor f) => ([UserEntry] -> f [UserEntry]) -> NewOtrMessage -> f NewOtrMessage newOtrMessageRecipients f c = (\x -> c {_newOtrRecipients = x}) <$> field f (_newOtrRecipients c) -newOtrMessageNativePush :: Functor f => (Bool -> f Bool) -> NewOtrMessage -> f NewOtrMessage +newOtrMessageNativePush :: (Functor f) => (Bool -> f Bool) -> NewOtrMessage -> f NewOtrMessage newOtrMessageNativePush f c = let g x = Just <$> f (fromMaybe True x) in (\x -> c {_newOtrNativePush = x}) <$> field g (_newOtrNativePush c) -newOtrMessageTransient :: Functor f => (Bool -> f Bool) -> NewOtrMessage -> f NewOtrMessage +newOtrMessageTransient :: (Functor f) => (Bool -> f Bool) -> NewOtrMessage -> f NewOtrMessage newOtrMessageTransient f c = let g x = Just <$> f (fromMaybe False x) in (\x -> c {_newOtrTransient = x}) <$> field g (_newOtrTransient c) -newOtrMessageData :: Functor f => (Maybe ByteString -> f (Maybe ByteString)) -> NewOtrMessage -> f NewOtrMessage +newOtrMessageData :: (Functor f) => (Maybe ByteString -> f (Maybe ByteString)) -> NewOtrMessage -> f NewOtrMessage newOtrMessageData f c = (\x -> c {_newOtrData = x}) <$> field f (_newOtrData c) -newOtrMessageNativePriority :: Functor f => (Maybe Priority -> f (Maybe Priority)) -> NewOtrMessage -> f NewOtrMessage +newOtrMessageNativePriority :: (Functor f) => (Maybe Priority -> f (Maybe Priority)) -> NewOtrMessage -> f NewOtrMessage newOtrMessageNativePriority f c = (\x -> c {_newOtrNativePriority = x}) <$> field f (_newOtrNativePriority c) -newOtrMessageReportMissing :: Functor f => ([UserId] -> f [UserId]) -> NewOtrMessage -> f NewOtrMessage +newOtrMessageReportMissing :: (Functor f) => ([UserId] -> f [UserId]) -> NewOtrMessage -> f NewOtrMessage newOtrMessageReportMissing f c = (\x -> c {_newOtrReportMissing = x}) <$> field f (_newOtrReportMissing c) diff --git a/libs/wire-api/src/Wire/API/OAuth.hs b/libs/wire-api/src/Wire/API/OAuth.hs index dfbd5987201..89c28f98370 100644 --- a/libs/wire-api/src/Wire/API/OAuth.hs +++ b/libs/wire-api/src/Wire/API/OAuth.hs @@ -19,7 +19,6 @@ module Wire.API.OAuth where import Cassandra hiding (Set) import Control.Lens (preview, view, (%~), (?~)) -import Control.Monad.Except import Crypto.Hash as Crypto import Crypto.JWT hiding (Context, params, uri, verify) import Data.Aeson.KeyMap qualified as M @@ -110,8 +109,10 @@ instance ToSchema OAuthClientConfig where schema = object "OAuthClientConfig" $ OAuthClientConfig - <$> applicationName .= fieldWithDocModifier "application_name" applicationNameDescription schema - <*> (.redirectUrl) .= fieldWithDocModifier "redirect_url" redirectUrlDescription schema + <$> applicationName + .= fieldWithDocModifier "application_name" applicationNameDescription schema + <*> (.redirectUrl) + .= fieldWithDocModifier "redirect_url" redirectUrlDescription schema where applicationNameDescription = description ?~ "The name of the application. This will be shown to the user when they are asked to authorize the application. The name must be between " <> minL <> " and " <> maxL <> " characters long." redirectUrlDescription = description ?~ "The URL to redirect to after the user has authorized the application." @@ -147,8 +148,10 @@ instance ToSchema OAuthClientCredentials where schema = object "OAuthClientCredentials" $ OAuthClientCredentials - <$> (.clientId) .= fieldWithDocModifier "client_id" clientIdDescription schema - <*> (.clientSecret) .= fieldWithDocModifier "client_secret" clientSecretDescription schema + <$> (.clientId) + .= fieldWithDocModifier "client_id" clientIdDescription schema + <*> (.clientSecret) + .= fieldWithDocModifier "client_secret" clientSecretDescription schema where clientIdDescription = description ?~ "The ID of the application." clientSecretDescription = description ?~ "The secret of the application." @@ -166,9 +169,12 @@ instance ToSchema OAuthClient where schema = object "OAuthClient" $ OAuthClient - <$> (.clientId) .= field "client_id" schema - <*> (.name) .= field "application_name" schema - <*> (.redirectUrl) .= field "redirect_url" schema + <$> (.clientId) + .= field "client_id" schema + <*> (.name) + .= field "application_name" schema + <*> (.redirectUrl) + .= field "redirect_url" schema data OAuthResponseType = OAuthResponseTypeCode deriving (Eq, Show, Generic) @@ -244,7 +250,8 @@ instance ToSchema OAuthScopes where oauthScopeParser :: Text -> A.Parser (Set OAuthScope) oauthScopeParser scope = pure $ - (not . T.null) `filter` T.splitOn " " scope + (not . T.null) + `filter` T.splitOn " " scope & maybe Set.empty Set.fromList . mapM (fromByteString' . fromStrict . TE.encodeUtf8) @@ -321,13 +328,20 @@ instance ToSchema CreateOAuthAuthorizationCodeRequest where schema = object "CreateOAuthAuthorizationCodeRequest" $ CreateOAuthAuthorizationCodeRequest - <$> (.clientId) .= fieldWithDocModifier "client_id" clientIdDescription schema - <*> (.scope) .= fieldWithDocModifier "scope" scopeDescription schema - <*> (.responseType) .= fieldWithDocModifier "response_type" responseTypeDescription schema - <*> (.redirectUri) .= fieldWithDocModifier "redirect_uri" redirectUriDescription schema - <*> (.state) .= fieldWithDocModifier "state" stateDescription schema - <*> (.codeChallengeMethod) .= fieldWithDocModifier "code_challenge_method" codeChallengeMethodDescription schema - <*> (.codeChallenge) .= fieldWithDocModifier "code_challenge" codeChallengeDescription schema + <$> (.clientId) + .= fieldWithDocModifier "client_id" clientIdDescription schema + <*> (.scope) + .= fieldWithDocModifier "scope" scopeDescription schema + <*> (.responseType) + .= fieldWithDocModifier "response_type" responseTypeDescription schema + <*> (.redirectUri) + .= fieldWithDocModifier "redirect_uri" redirectUriDescription schema + <*> (.state) + .= fieldWithDocModifier "state" stateDescription schema + <*> (.codeChallengeMethod) + .= fieldWithDocModifier "code_challenge_method" codeChallengeMethodDescription schema + <*> (.codeChallenge) + .= fieldWithDocModifier "code_challenge" codeChallengeDescription schema where clientIdDescription = description ?~ "The ID of the OAuth client" scopeDescription = description ?~ "The scopes which are requested to get authorization for, separated by a space" @@ -405,11 +419,16 @@ instance ToSchema OAuthAccessTokenRequest where schema = object "OAuthAccessTokenRequest" $ OAuthAccessTokenRequest - <$> (.grantType) .= fieldWithDocModifier "grant_type" grantTypeDescription schema - <*> (.clientId) .= fieldWithDocModifier "client_id" clientIdDescription schema - <*> (.codeVerifier) .= fieldWithDocModifier "code_verifier" codeVerifierDescription schema - <*> (.code) .= fieldWithDocModifier "code" codeDescription schema - <*> (.redirectUri) .= fieldWithDocModifier "redirect_uri" redirectUrlDescription schema + <$> (.grantType) + .= fieldWithDocModifier "grant_type" grantTypeDescription schema + <*> (.clientId) + .= fieldWithDocModifier "client_id" clientIdDescription schema + <*> (.codeVerifier) + .= fieldWithDocModifier "code_verifier" codeVerifierDescription schema + <*> (.code) + .= fieldWithDocModifier "code" codeDescription schema + <*> (.redirectUri) + .= fieldWithDocModifier "redirect_uri" redirectUrlDescription schema where grantTypeDescription = description ?~ "Indicates which authorization flow to use. Use `authorization_code` for authorization code flow." clientIdDescription = description ?~ "The ID of the OAuth client" @@ -499,10 +518,14 @@ instance ToSchema OAuthAccessTokenResponse where schema = object "OAuthAccessTokenResponse" $ OAuthAccessTokenResponse - <$> accessToken .= fieldWithDocModifier "access_token" accessTokenDescription schema - <*> tokenType .= fieldWithDocModifier "token_type" tokenTypeDescription schema - <*> expiresIn .= fieldWithDocModifier "expires_in" expiresInDescription (fromIntegral <$> roundDiffTime .= schema) - <*> (.refreshToken) .= fieldWithDocModifier "refresh_token" refreshTokenDescription schema + <$> accessToken + .= fieldWithDocModifier "access_token" accessTokenDescription schema + <*> tokenType + .= fieldWithDocModifier "token_type" tokenTypeDescription schema + <*> expiresIn + .= fieldWithDocModifier "expires_in" expiresInDescription (fromIntegral <$> roundDiffTime .= schema) + <*> (.refreshToken) + .= fieldWithDocModifier "refresh_token" refreshTokenDescription schema where roundDiffTime :: NominalDiffTime -> Int32 roundDiffTime = round @@ -521,7 +544,8 @@ instance A.FromJSON OAuthClaimsSet where parseJSON = A.withObject "OAuthClaimsSet" $ \o -> OAuthClaimsSet <$> A.parseJSON (A.Object o) - <*> o A..: "scope" + <*> o + A..: "scope" instance A.ToJSON OAuthClaimsSet where toJSON s = @@ -530,11 +554,12 @@ instance A.ToJSON OAuthClaimsSet where ins k v (A.Object o) = A.Object $ M.insert k (A.toJSON v) o ins _ _ a = a -hcsSub :: HasClaimsSet hcs => hcs -> Maybe (Id a) +hcsSub :: (HasClaimsSet hcs) => hcs -> Maybe (Id a) hcsSub = view claimSub >=> preview string - >=> either (const Nothing) pure . parseIdFromText + >=> either (const Nothing) pure + . parseIdFromText -- | Verify a JWT and return the claims set. Use this function if you have a custom claims set. verify :: JWK -> SignedJWT -> IO (Either JWTError OAuthClaimsSet) @@ -570,9 +595,12 @@ instance ToSchema OAuthRefreshAccessTokenRequest where schema = object "OAuthRefreshAccessTokenRequest" $ OAuthRefreshAccessTokenRequest - <$> (.grantType) .= fieldWithDocModifier "grant_type" grantTypeDescription schema - <*> (.clientId) .= fieldWithDocModifier "client_id" clientIdDescription schema - <*> (.refreshToken) .= fieldWithDocModifier "refresh_token" refreshTokenDescription schema + <$> (.grantType) + .= fieldWithDocModifier "grant_type" grantTypeDescription schema + <*> (.clientId) + .= fieldWithDocModifier "client_id" clientIdDescription schema + <*> (.refreshToken) + .= fieldWithDocModifier "refresh_token" refreshTokenDescription schema where grantTypeDescription = description ?~ "The grant type. Must be `refresh_token`" clientIdDescription = description ?~ "The OAuth client's ID" @@ -614,8 +642,10 @@ instance ToSchema OAuthRevokeRefreshTokenRequest where schema = object "OAuthRevokeRefreshTokenRequest" $ OAuthRevokeRefreshTokenRequest - <$> (.clientId) .= fieldWithDocModifier "client_id" clientIdDescription schema - <*> (.refreshToken) .= fieldWithDocModifier "refresh_token" refreshTokenDescription schema + <$> (.clientId) + .= fieldWithDocModifier "client_id" clientIdDescription schema + <*> (.refreshToken) + .= fieldWithDocModifier "refresh_token" refreshTokenDescription schema where clientIdDescription = description ?~ "The OAuth client's ID" refreshTokenDescription = description ?~ "The refresh token" @@ -632,8 +662,10 @@ instance ToSchema OAuthApplication where schema = object "OAuthApplication" $ OAuthApplication - <$> applicationId .= fieldWithDocModifier "id" idDescription schema - <*> (.name) .= fieldWithDocModifier "name" nameDescription schema + <$> applicationId + .= fieldWithDocModifier "id" idDescription schema + <*> (.name) + .= fieldWithDocModifier "name" nameDescription schema where idDescription = description ?~ "The OAuth client's ID" nameDescription = description ?~ "The OAuth client's name" @@ -701,9 +733,11 @@ instance Cql OAuthScope where ctype = Tagged TextColumn toCql = CqlText . TE.decodeUtf8With lenientDecode . toByteString' fromCql (CqlText t) = - maybe (Left "invalid oauth scope") Right $ - fromByteString' . fromStrict . TE.encodeUtf8 $ - t + maybe (Left "invalid oauth scope") Right + $ fromByteString' + . fromStrict + . TE.encodeUtf8 + $ t fromCql _ = Left "OAuthScope: Text expected" instance Cql OAuthCodeChallenge where diff --git a/libs/wire-api/src/Wire/API/Password.hs b/libs/wire-api/src/Wire/API/Password.hs index f9188b6dcfb..6090f9ae6c7 100644 --- a/libs/wire-api/src/Wire/API/Password.hs +++ b/libs/wire-api/src/Wire/API/Password.hs @@ -22,11 +22,13 @@ module Wire.API.Password ( Password, PasswordStatus (..), genPassword, - mkSafePassword, + mkSafePasswordScrypt, mkSafePasswordArgon2id, verifyPassword, verifyPasswordWithStatus, unsafeMkPassword, + hashPasswordArgon2idWithSalt, + hashPasswordArgon2idWithOptions, ) where @@ -90,8 +92,8 @@ data ScryptParameters = ScryptParameters } deriving (Eq, Show) -defaultParams :: ScryptParameters -defaultParams = +defaultScryptParams :: ScryptParameters +defaultScryptParams = ScryptParameters { saltLength = 32, rounds = 14, @@ -124,16 +126,15 @@ fromScrypt scryptParams = -- | Generate a strong, random plaintext password of length 16 -- containing only alphanumeric characters, '+' and '/'. -genPassword :: MonadIO m => m PlainTextPassword8 +genPassword :: (MonadIO m) => m PlainTextPassword8 genPassword = liftIO . fmap (plainTextPassword8Unsafe . Text.decodeUtf8 . B64.encode) $ randBytes 12 --- | Stretch a plaintext password so that it can be safely stored. -mkSafePassword :: MonadIO m => PlainTextPassword' t -> m Password -mkSafePassword = fmap Password . hashPasswordScrypt . Text.encodeUtf8 . fromPlainTextPassword +mkSafePasswordScrypt :: (MonadIO m) => PlainTextPassword' t -> m Password +mkSafePasswordScrypt = fmap Password . hashPasswordScrypt . Text.encodeUtf8 . fromPlainTextPassword -mkSafePasswordArgon2id :: MonadIO m => PlainTextPassword' t -> m Password +mkSafePasswordArgon2id :: (MonadIO m) => PlainTextPassword' t -> m Password mkSafePasswordArgon2id = fmap Password . hashPasswordArgon2id . Text.encodeUtf8 . fromPlainTextPassword -- | Verify a plaintext password from user input against a stretched @@ -147,44 +148,50 @@ verifyPasswordWithStatus plain opaque = expected = fromPassword opaque in checkPassword actual expected -hashPasswordArgon2id :: MonadIO m => ByteString -> m Text -hashPasswordArgon2id pwd = do - salt <- newSalt $ fromIntegral defaultParams.saltLength - let key = hashPasswordWithOptions defaultOptions pwd salt - opts = - Text.intercalate - "," - [ "m=" <> showT defaultOptions.memory, - "t=" <> showT defaultOptions.iterations, - "p=" <> showT defaultOptions.parallelism - ] - pure $ - "$argon2" - <> Text.intercalate - "$" - [ variantToCode defaultOptions.variant, - "v=" <> versionToNum defaultOptions.version, - opts, - encodeWithoutPadding salt, - encodeWithoutPadding key - ] - where - encodeWithoutPadding = Text.dropWhileEnd (== '=') . Text.decodeUtf8 . B64.encode - -hashPasswordScrypt :: MonadIO m => ByteString -> m Text +hashPasswordScrypt :: (MonadIO m) => ByteString -> m Text hashPasswordScrypt password = do - salt <- newSalt $ fromIntegral defaultParams.saltLength - let key = hashPasswordWithParams defaultParams password salt + salt <- newSalt $ fromIntegral defaultScryptParams.saltLength + let key = hashPasswordWithParams defaultScryptParams password salt pure $ Text.intercalate "|" - [ showT defaultParams.rounds, - showT defaultParams.blockSize, - showT defaultParams.parallelism, + [ showT defaultScryptParams.rounds, + showT defaultScryptParams.blockSize, + showT defaultScryptParams.parallelism, Text.decodeUtf8 . B64.encode $ salt, Text.decodeUtf8 . B64.encode $ key ] +hashPasswordArgon2id :: (MonadIO m) => ByteString -> m Text +hashPasswordArgon2id pwd = do + salt <- newSalt 32 + pure $ hashPasswordArgon2idWithSalt salt pwd + +hashPasswordArgon2idWithSalt :: ByteString -> ByteString -> Text +hashPasswordArgon2idWithSalt = hashPasswordArgon2idWithOptions defaultOptions + +hashPasswordArgon2idWithOptions :: Argon2idOptions -> ByteString -> ByteString -> Text +hashPasswordArgon2idWithOptions opts salt pwd = do + let key = hashPasswordWithOptions opts pwd salt + optsStr = + Text.intercalate + "," + [ "m=" <> showT opts.memory, + "t=" <> showT opts.iterations, + "p=" <> showT opts.parallelism + ] + in "$argon2" + <> Text.intercalate + "$" + [ variantToCode opts.variant, + "v=" <> versionToNum opts.version, + optsStr, + encodeWithoutPadding salt, + encodeWithoutPadding key + ] + where + encodeWithoutPadding = Text.dropWhileEnd (== '=') . Text.decodeUtf8 . B64.encode + checkPassword :: Text -> Text -> (Bool, PasswordStatus) checkPassword actual expected = case parseArgon2idPasswordHashOptions expected of @@ -198,7 +205,7 @@ checkPassword actual expected = in (hashedKeyS `constEq` producedKeyS, PasswordStatusNeedsUpdate) Nothing -> (False, PasswordStatusNeedsUpdate) -newSalt :: MonadIO m => Int -> m ByteString +newSalt :: (MonadIO m) => Int -> m ByteString newSalt i = liftIO $ getRandomBytes i {-# INLINE newSalt #-} diff --git a/libs/wire-api/src/Wire/API/Provider/External.hs b/libs/wire-api/src/Wire/API/Provider/External.hs index 246b6aa5317..aebbd8f38e3 100644 --- a/libs/wire-api/src/Wire/API/Provider/External.hs +++ b/libs/wire-api/src/Wire/API/Provider/External.hs @@ -27,9 +27,10 @@ import Data.Aeson import Data.Id import Data.Json.Util ((#)) import Imports +import Wire.API.Locale (Locale) import Wire.API.Provider.Bot (BotConvView, BotUserView) import Wire.API.User.Client.Prekey (LastPrekey, Prekey) -import Wire.API.User.Profile (Asset, ColourId, Locale, Name) +import Wire.API.User.Profile (Asset, ColourId, Name) import Wire.Arbitrary (Arbitrary, GenericUniform (..)) -------------------------------------------------------------------------------- @@ -67,12 +68,18 @@ instance FromJSON NewBotRequest where instance ToJSON NewBotRequest where toJSON n = object $ - "id" .= newBotId n - # "client" .= newBotClient n - # "origin" .= newBotOrigin n - # "conversation" .= newBotConv n - # "token" .= newBotToken n - # "locale" .= newBotLocale n + "id" + .= newBotId n + # "client" + .= newBotClient n + # "origin" + .= newBotOrigin n + # "conversation" + .= newBotConv n + # "token" + .= newBotToken n + # "locale" + .= newBotLocale n # [] -------------------------------------------------------------------------------- @@ -103,9 +110,14 @@ instance FromJSON NewBotResponse where instance ToJSON NewBotResponse where toJSON r = object $ - "prekeys" .= rsNewBotPrekeys r - # "last_prekey" .= rsNewBotLastPrekey r - # "name" .= rsNewBotName r - # "accent_id" .= rsNewBotColour r - # "assets" .= rsNewBotAssets r + "prekeys" + .= rsNewBotPrekeys r + # "last_prekey" + .= rsNewBotLastPrekey r + # "name" + .= rsNewBotName r + # "accent_id" + .= rsNewBotColour r + # "assets" + .= rsNewBotAssets r # [] diff --git a/libs/wire-api/src/Wire/API/Provider/Service/Tag.hs b/libs/wire-api/src/Wire/API/Provider/Service/Tag.hs index 1df9b6a14bc..ec44311dece 100644 --- a/libs/wire-api/src/Wire/API/Provider/Service/Tag.hs +++ b/libs/wire-api/src/Wire/API/Provider/Service/Tag.hs @@ -238,7 +238,7 @@ instance (KnownNat n, KnownNat m, m <= n) => FromByteString (QueryAnyTags m n) w rs <- either fail pure (Range.checkedEither (Set.fromList ts)) pure $! QueryAnyTags rs -runPartial :: IsString i => Bool -> IResult i b -> Either Text b +runPartial :: (IsString i) => Bool -> IResult i b -> Either Text b runPartial alreadyRun result = case result of Fail _ _ e -> Left $ Text.pack e Partial f -> diff --git a/libs/wire-api/src/Wire/API/Routes/API.hs b/libs/wire-api/src/Wire/API/Routes/API.hs index 23ac38e6fed..ed77df72ba3 100644 --- a/libs/wire-api/src/Wire/API/Routes/API.hs +++ b/libs/wire-api/src/Wire/API/Routes/API.hs @@ -47,7 +47,7 @@ class ServiceAPI service (v :: Version) where type ServiceAPIRoutes service type SpecialisedAPIRoutes v service :: Type type SpecialisedAPIRoutes v service = SpecialiseToVersion v (ServiceAPIRoutes service) - serviceSwagger :: HasOpenApi (SpecialisedAPIRoutes v service) => S.OpenApi + serviceSwagger :: (HasOpenApi (SpecialisedAPIRoutes v service)) => S.OpenApi serviceSwagger = toOpenApi (Proxy @(SpecialisedAPIRoutes v service)) instance ServiceAPI VersionAPITag v where @@ -86,7 +86,7 @@ infixr 3 <@> -- type argument. hoistServerWithDomain :: forall api m n. - HasServer api '[Domain] => + (HasServer api '[Domain]) => (forall x. m x -> n x) -> ServerT api m -> ServerT api n @@ -94,7 +94,7 @@ hoistServerWithDomain = hoistServerWithContext (Proxy @api) (Proxy @'[Domain]) hoistAPIHandler :: forall api r n. - HasServer api '[Domain] => + (HasServer api '[Domain]) => (forall x. Sem r x -> n x) -> API api r -> ServerT api n diff --git a/libs/wire-api/src/Wire/API/Routes/Bearer.hs b/libs/wire-api/src/Wire/API/Routes/Bearer.hs index 64a1baed79f..d215630f62f 100644 --- a/libs/wire-api/src/Wire/API/Routes/Bearer.hs +++ b/libs/wire-api/src/Wire/API/Routes/Bearer.hs @@ -30,7 +30,7 @@ import Wire.API.Routes.Version newtype Bearer a = Bearer {unBearer :: a} -instance FromHttpApiData a => FromHttpApiData (Bearer a) where +instance (FromHttpApiData a) => FromHttpApiData (Bearer a) where parseHeader h = case BS.splitAt 7 h of ("Bearer ", suffix) -> Bearer <$> parseHeader suffix _ -> Left "Invalid authorization scheme" @@ -47,12 +47,12 @@ type instance SpecialiseToVersion v (Bearer a :> api) = Bearer a :> SpecialiseToVersion v api -instance HasOpenApi api => HasOpenApi (Bearer a :> api) where +instance (HasOpenApi api) => HasOpenApi (Bearer a :> api) where toOpenApi _ = toOpenApi (Proxy @api) & security <>~ [SecurityRequirement $ InsOrdHashMap.singleton "ZAuth" []] -instance RoutesToPaths api => RoutesToPaths (Bearer a :> api) where +instance (RoutesToPaths api) => RoutesToPaths (Bearer a :> api) where getRoutes = getRoutes @api instance diff --git a/libs/wire-api/src/Wire/API/Routes/ClientAlgebra.hs b/libs/wire-api/src/Wire/API/Routes/ClientAlgebra.hs index abc2b28e283..bae5c5bbc74 100644 --- a/libs/wire-api/src/Wire/API/Routes/ClientAlgebra.hs +++ b/libs/wire-api/src/Wire/API/Routes/ClientAlgebra.hs @@ -34,14 +34,14 @@ import Wire.API.Routes.MultiVerb -- type, and @m R@ is always an algebra over @m@. -- -- Minimal definition: 'joinClient' | 'bindClient'. -class HasClient m api => HasClientAlgebra m api where +class (HasClient m api) => HasClientAlgebra m api where joinClient :: m (Client m api) -> Client m api joinClient x = bindClient @m @api x id bindClient :: m a -> (a -> Client m api) -> Client m api bindClient x f = joinClient @m @api (fmap f x) -instance HasClient m (Verb method s cs a) => HasClientAlgebra m (Verb method s cs a) where +instance (HasClient m (Verb method s cs a)) => HasClientAlgebra m (Verb method s cs a) where joinClient = join bindClient = (>>=) diff --git a/libs/wire-api/src/Wire/API/Routes/Cookies.hs b/libs/wire-api/src/Wire/API/Routes/Cookies.hs index 2449f074c76..24629d0f12f 100644 --- a/libs/wire-api/src/Wire/API/Routes/Cookies.hs +++ b/libs/wire-api/src/Wire/API/Routes/Cookies.hs @@ -63,7 +63,7 @@ type instance SpecialiseToVersion v (Cookies cs :> api) = Cookies cs :> SpecialiseToVersion v api -instance HasOpenApi api => HasOpenApi (Cookies cs :> api) where +instance (HasOpenApi api) => HasOpenApi (Cookies cs :> api) where toOpenApi _ = toOpenApi (Proxy @api) class CookieArgs (cs :: [Type]) where @@ -103,7 +103,7 @@ instance mkCookieMap :: [(ByteString, ByteString)] -> CookieMap mkCookieMap = foldr (\(k, v) -> M.insertWith (<>) k (pure v)) mempty -instance CookieArgs cs => FromHttpApiData (CookieTuple cs) where +instance (CookieArgs cs) => FromHttpApiData (CookieTuple cs) where parseHeader = mkTuple . mkCookieMap . parseCookies parseUrlPiece = parseHeader . T.encodeUtf8 @@ -126,5 +126,5 @@ instance ) hoistServerWithContext _ ctx f = mapArgs @cs (hoistServerWithContext (Proxy @api) ctx f) -instance RoutesToPaths api => RoutesToPaths (Cookies cs :> api) where +instance (RoutesToPaths api) => RoutesToPaths (Cookies cs :> api) where getRoutes = getRoutes @api diff --git a/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs b/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs index 43ca007abb1..7d31bedba95 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs @@ -241,7 +241,6 @@ type AccountAPI = :> QueryParam' [Optional, Strict] "ids" (CommaSeparatedList UserId) :> QueryParam' [Optional, Strict] "handles" (CommaSeparatedList Handle) :> QueryParam' [Optional, Strict] "email" (CommaSeparatedList Email) -- don't rename to `emails`, for backwards compat! - :> QueryParam' [Optional, Strict] "phone" (CommaSeparatedList Phone) -- don't rename to `phones`, for backwards compat! :> QueryParam' [ Optional, Strict, @@ -262,16 +261,14 @@ type AccountAPI = "iGetUserActivationCode" ( "users" :> "activation-code" - :> QueryParam' [Optional, Strict] "email" Email - :> QueryParam' [Optional, Strict] "phone" Phone + :> QueryParam' [Required, Strict] "email" Email :> Get '[Servant.JSON] GetActivationCodeResp ) :<|> Named "iGetUserPasswordResetCode" ( "users" :> "password-reset-code" - :> QueryParam' [Optional, Strict] "email" Email - :> QueryParam' [Optional, Strict] "phone" Phone + :> QueryParam' [Required, Strict] "email" Email :> Get '[Servant.JSON] GetPasswordResetCodeResp ) :<|> Named @@ -279,16 +276,14 @@ type AccountAPI = ( Summary "This endpoint can lead to the following events being sent: UserIdentityRemoved event to target user" :> "users" :> "revoke-identity" - :> QueryParam' [Optional, Strict] "email" Email - :> QueryParam' [Optional, Strict] "phone" Phone + :> QueryParam' [Required, Strict] "email" Email :> Post '[Servant.JSON] NoContent ) :<|> Named "iHeadBlacklist" ( "users" :> "blacklist" - :> QueryParam' [Optional, Strict] "email" Email - :> QueryParam' [Optional, Strict] "phone" Phone + :> QueryParam' [Required, Strict] "email" Email :> MultiVerb 'GET '[Servant.JSON] @@ -301,46 +296,14 @@ type AccountAPI = "iDeleteBlacklist" ( "users" :> "blacklist" - :> QueryParam' [Optional, Strict] "email" Email - :> QueryParam' [Optional, Strict] "phone" Phone + :> QueryParam' [Required, Strict] "email" Email :> Delete '[Servant.JSON] NoContent ) :<|> Named "iPostBlacklist" ( "users" :> "blacklist" - :> QueryParam' [Optional, Strict] "email" Email - :> QueryParam' [Optional, Strict] "phone" Phone - :> Post '[Servant.JSON] NoContent - ) - :<|> Named - "iGetPhonePrefix" - ( Summary - "given a phone number (or phone number prefix), see whether it is blocked \ - \via a prefix (and if so, via which specific prefix)" - :> "users" - :> "phone-prefixes" - :> Capture "prefix" PhonePrefix - :> MultiVerb - 'GET - '[Servant.JSON] - '[ RespondEmpty 404 "PhonePrefixNotFound", - Respond 200 "PhonePrefixesFound" [ExcludedPrefix] - ] - GetPhonePrefixResponse - ) - :<|> Named - "iDeletePhonePrefix" - ( "users" - :> "phone-prefixes" - :> Capture "prefix" PhonePrefix - :> Delete '[Servant.JSON] NoContent - ) - :<|> Named - "iPostPhonePrefix" - ( "users" - :> "phone-prefixes" - :> ReqBody '[Servant.JSON] ExcludedPrefix + :> QueryParam' [Required, Strict] "email" Email :> Post '[Servant.JSON] NoContent ) :<|> Named @@ -395,7 +358,7 @@ type AccountAPI = :> Put '[Servant.JSON] NoContent ) :<|> Named - "iPutHandle" + "iPutUserName" ( "users" :> Capture "uid" UserId :> "name" diff --git a/libs/wire-api/src/Wire/API/Routes/Internal/Brig/EJPD.hs b/libs/wire-api/src/Wire/API/Routes/Internal/Brig/EJPD.hs index d34bd9fb78a..38bb517cb58 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/Brig/EJPD.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Brig/EJPD.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE RecordWildCards #-} + -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2022 Wire Swiss GmbH @@ -21,28 +23,22 @@ module Wire.API.Routes.Internal.Brig.EJPD ( EJPDRequestBody (EJPDRequestBody, ejpdRequestBody), EJPDResponseBody (EJPDResponseBody, ejpdResponseBody), - EJPDResponseItem - ( EJPDResponseItem, - ejpdResponseUserId, - ejpdResponseTeamId, - ejpdResponseName, - ejpdResponseHandle, - ejpdResponseEmail, - ejpdResponsePhone, - ejpdResponsePushTokens, - ejpdResponseContacts, - ejpdResponseTeamContacts, - ejpdResponseConversations, - ejpdResponseAssets - ), + EJPDResponseItemRoot (..), + EJPDResponseItemLeaf (..), + EJPDConvInfo (..), + EJPDContact (..), + EJPDTeamContacts (..), + toEJPDResponseItemLeaf, ) where -import Data.Aeson hiding (json) +import Data.Aeson qualified as Aeson import Data.Handle (Handle) import Data.Id (ConvId, TeamId, UserId) -import Data.OpenApi (ToSchema) -import Deriving.Swagger (CamelToSnake, CustomSwagger (..), FieldLabelModifier, StripSuffix) +import Data.OpenApi qualified as OpenAPI +import Data.Qualified +import Data.Schema +import Data.Set as Set import Imports hiding (head) import Test.QuickCheck (Arbitrary) import Wire.API.Connection (Relation) @@ -54,69 +50,135 @@ import Wire.Arbitrary (GenericUniform (..)) newtype EJPDRequestBody = EJPDRequestBody {ejpdRequestBody :: [Handle]} deriving stock (Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform EJPDRequestBody) - deriving (ToSchema) via CustomSwagger '[FieldLabelModifier (CamelToSnake, StripSuffix "_body")] EJPDRequestBody + deriving (Aeson.ToJSON, Aeson.FromJSON, OpenAPI.ToSchema) via (Schema EJPDRequestBody) -newtype EJPDResponseBody = EJPDResponseBody {ejpdResponseBody :: [EJPDResponseItem]} +newtype EJPDResponseBody = EJPDResponseBody {ejpdResponseBody :: [EJPDResponseItemRoot]} deriving stock (Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform EJPDResponseBody) - deriving (ToSchema) via CustomSwagger '[FieldLabelModifier (CamelToSnake, StripSuffix "_body")] EJPDResponseBody - -data EJPDResponseItem = EJPDResponseItem - { ejpdResponseUserId :: UserId, - ejpdResponseTeamId :: Maybe TeamId, - ejpdResponseName :: Name, - ejpdResponseHandle :: Maybe Handle, - ejpdResponseEmail :: Maybe Email, - ejpdResponsePhone :: Maybe Phone, - ejpdResponsePushTokens :: Set Text, -- 'Wire.API.Push.V2.Token.Token', but that would produce an orphan instance. - ejpdResponseContacts :: Maybe (Set (Relation, EJPDResponseItem)), - ejpdResponseTeamContacts :: Maybe (Set EJPDResponseItem, NewListType), - ejpdResponseConversations :: Maybe (Set (Text, ConvId)), -- name, id - ejpdResponseAssets :: Maybe (Set Text) -- urls pointing to s3 resources + deriving (Aeson.ToJSON, Aeson.FromJSON, OpenAPI.ToSchema) via (Schema EJPDResponseBody) + +data EJPDResponseItemRoot = EJPDResponseItemRoot + { ejpdResponseRootUserId :: Qualified UserId, + ejpdResponseRootTeamId :: Maybe TeamId, + ejpdResponseRootName :: Name, + ejpdResponseRootHandle :: Maybe Handle, + ejpdResponseRootEmail :: Maybe Email, + ejpdResponseRootPhone :: Maybe Phone, + ejpdResponseRootPushTokens :: Set Text, -- 'Wire.API.Push.V2.Token.Token', but that would produce an orphan instance. + ejpdResponseRootContacts :: Maybe (Set EJPDContact), + ejpdResponseRootTeamContacts :: Maybe EJPDTeamContacts, + ejpdResponseRootConversations :: Maybe (Set EJPDConvInfo), + ejpdResponseRootAssets :: Maybe (Set Text) -- urls pointing to s3 resources + } + deriving stock (Eq, Ord, Show, Generic) + deriving (Arbitrary) via (GenericUniform EJPDResponseItemRoot) + +data EJPDResponseItemLeaf = EJPDResponseItemLeaf + { ejpdResponseLeafUserId :: Qualified UserId, + ejpdResponseLeafTeamId :: Maybe TeamId, + ejpdResponseLeafName :: Name, + ejpdResponseLeafHandle :: Maybe Handle, + ejpdResponseLeafEmail :: Maybe Email, + ejpdResponseLeafPhone :: Maybe Phone, + ejpdResponseLeafPushTokens :: Set Text, -- 'Wire.API.Push.V2.Token.Token', but that would produce an orphan instance. + ejpdResponseLeafConversations :: Maybe (Set EJPDConvInfo), + ejpdResponseLeafAssets :: Maybe (Set Text) -- urls pointing to s3 resources } deriving stock (Eq, Ord, Show, Generic) - deriving (Arbitrary) via (GenericUniform EJPDResponseItem) - deriving (ToSchema) via CustomSwagger '[FieldLabelModifier CamelToSnake] EJPDResponseItem - -instance ToJSON EJPDRequestBody where - toJSON (EJPDRequestBody hs) = object ["ejpd_request" .= hs] - -instance FromJSON EJPDRequestBody where - parseJSON = withObject "EJPDRequestBody" $ EJPDRequestBody <$$> (.: "ejpd_request") - -instance ToJSON EJPDResponseBody where - toJSON (EJPDResponseBody is) = object ["ejpd_response" .= is] - -instance FromJSON EJPDResponseBody where - parseJSON = withObject "EJPDResponseBody" $ EJPDResponseBody <$$> (.: "ejpd_response") - -instance ToJSON EJPDResponseItem where - toJSON rspi = - object - [ "ejpd_response_user_id" .= ejpdResponseUserId rspi, - "ejpd_response_team_id" .= ejpdResponseTeamId rspi, - "ejpd_response_name" .= ejpdResponseName rspi, - "ejpd_response_handle" .= ejpdResponseHandle rspi, - "ejpd_response_email" .= ejpdResponseEmail rspi, - "ejpd_response_phone" .= ejpdResponsePhone rspi, - "ejpd_response_push_tokens" .= ejpdResponsePushTokens rspi, - "ejpd_response_contacts" .= ejpdResponseContacts rspi, - "ejpd_response_team_contacts" .= ejpdResponseTeamContacts rspi, - "ejpd_response_conversations" .= ejpdResponseConversations rspi, - "ejpd_response_assets" .= ejpdResponseAssets rspi - ] - -instance FromJSON EJPDResponseItem where - parseJSON = withObject "EJPDResponseItem" $ \obj -> - EJPDResponseItem - <$> obj .: "ejpd_response_user_id" - <*> obj .:? "ejpd_response_team_id" - <*> obj .: "ejpd_response_name" - <*> obj .:? "ejpd_response_handle" - <*> obj .:? "ejpd_response_email" - <*> obj .:? "ejpd_response_phone" - <*> obj .: "ejpd_response_push_tokens" - <*> obj .:? "ejpd_response_contacts" - <*> obj .:? "ejpd_response_team_contacts" - <*> obj .:? "ejpd_response_conversations" - <*> obj .:? "ejpd_response_assets" + deriving (Arbitrary) via (GenericUniform EJPDResponseItemLeaf) + +data EJPDContact + = -- | local or remote contact with relation + EJPDContactFound + { ejpdContactRelation :: Relation, + ejpdContactFound :: EJPDResponseItemLeaf + } + deriving stock (Eq, Ord, Show, Generic) + deriving (Arbitrary) via (GenericUniform EJPDContact) + deriving (Aeson.ToJSON, Aeson.FromJSON, OpenAPI.ToSchema) via Schema EJPDContact + +data EJPDTeamContacts = EJPDTeamContacts + { ejpdTeamContacts :: Set EJPDResponseItemLeaf, + ejpdTeamContactsListType :: NewListType + } + deriving stock (Eq, Ord, Show, Generic) + deriving (Arbitrary) via (GenericUniform EJPDTeamContacts) + +data EJPDConvInfo = EJPDConvInfo {ejpdConvName :: Text, ejpdConvId :: Qualified ConvId} + deriving stock (Eq, Ord, Show, Generic) + deriving (Arbitrary) via (GenericUniform EJPDConvInfo) + deriving (Aeson.ToJSON, Aeson.FromJSON, OpenAPI.ToSchema) via Schema EJPDConvInfo + +---------------------------------------------------------------------- + +toEJPDResponseItemLeaf :: EJPDResponseItemRoot -> EJPDResponseItemLeaf +toEJPDResponseItemLeaf EJPDResponseItemRoot {..} = + EJPDResponseItemLeaf + { ejpdResponseLeafUserId = ejpdResponseRootUserId, + ejpdResponseLeafTeamId = ejpdResponseRootTeamId, + ejpdResponseLeafName = ejpdResponseRootName, + ejpdResponseLeafHandle = ejpdResponseRootHandle, + ejpdResponseLeafEmail = ejpdResponseRootEmail, + ejpdResponseLeafPhone = ejpdResponseRootPhone, + ejpdResponseLeafPushTokens = ejpdResponseRootPushTokens, + ejpdResponseLeafConversations = ejpdResponseRootConversations, + ejpdResponseLeafAssets = ejpdResponseRootAssets + } + +---------------------------------------------------------------------- + +instance ToSchema EJPDRequestBody where + schema = object "EJPDRequestBody" do + EJPDRequestBody <$> ejpdRequestBody .= field "EJPDRequest" (array schema) + +instance ToSchema EJPDResponseBody where + schema = object "EJPDResponseBody" do + EJPDResponseBody <$> ejpdResponseBody .= field "EJPDResponse" (array schema) + +instance ToSchema EJPDResponseItemRoot where + schema = object "EJPDResponseItemRoot" do + EJPDResponseItemRoot + <$> ejpdResponseRootUserId .= field "UserId" schema + <*> ejpdResponseRootTeamId .= maybe_ (optField "TeamId" schema) + <*> ejpdResponseRootName .= field "Name" schema + <*> ejpdResponseRootHandle .= maybe_ (optField "Handle" schema) + <*> ejpdResponseRootEmail .= maybe_ (optField "Email" schema) + <*> ejpdResponseRootPhone .= maybe_ (optField "Phone" schema) + <*> (Set.toList . ejpdResponseRootPushTokens) .= (Set.fromList <$> field "PushTokens" (array schema)) + <*> (fmap Set.toList . ejpdResponseRootContacts) .= (Set.fromList <$$> maybe_ (optField "Contacts" (array schema))) + <*> ejpdResponseRootTeamContacts .= maybe_ (optField "TeamContacts" schema) + <*> (fmap Set.toList . ejpdResponseRootConversations) .= (Set.fromList <$$> maybe_ (optField "Conversations" (array schema))) + <*> (fmap Set.toList . ejpdResponseRootAssets) .= (Set.fromList <$$> maybe_ (optField "Assets" (array schema))) + +instance ToSchema EJPDResponseItemLeaf where + schema = object "EJPDResponseItemLeaf" do + EJPDResponseItemLeaf + <$> ejpdResponseLeafUserId .= field "UserId" schema + <*> ejpdResponseLeafTeamId .= maybe_ (optField "TeamId" schema) + <*> ejpdResponseLeafName .= field "Name" schema + <*> ejpdResponseLeafHandle .= maybe_ (optField "Handle" schema) + <*> ejpdResponseLeafEmail .= maybe_ (optField "Email" schema) + <*> ejpdResponseLeafPhone .= maybe_ (optField "Phone" schema) + <*> (Set.toList . ejpdResponseLeafPushTokens) .= (Set.fromList <$> field "PushTokens" (array schema)) + <*> (fmap Set.toList . ejpdResponseLeafConversations) .= (Set.fromList <$$> maybe_ (optField "Conversations" (array schema))) + <*> (fmap Set.toList . ejpdResponseLeafAssets) .= (Set.fromList <$$> maybe_ (optField "Assets" (array schema))) + +instance ToSchema EJPDContact where + schema = + object "EJDPContact" do + EJPDContactFound + <$> ejpdContactRelation .= field "contact_relation" schema + <*> ejpdContactFound .= field "contact_item" schema + +instance ToSchema EJPDTeamContacts where + schema = object "EJPDTeamContacts" do + EJPDTeamContacts + <$> (Set.toList . ejpdTeamContacts) .= (Set.fromList <$> field "TeamContacts" (array schema)) + <*> ejpdTeamContactsListType .= field "ListType" schema + +instance ToSchema EJPDConvInfo where + schema = + object "EJPDConvInfo" $ + EJPDConvInfo + <$> ejpdConvName .= field "conv_name" schema + <*> ejpdConvId .= field "conv_id" schema diff --git a/libs/wire-api/src/Wire/API/Routes/Internal/Galley.hs b/libs/wire-api/src/Wire/API/Routes/Internal/Galley.hs index ff4c884ce42..8e7a8991d31 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/Galley.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Galley.hs @@ -38,6 +38,7 @@ import Wire.API.Event.Conversation import Wire.API.FederationStatus import Wire.API.MakesFederatedCall import Wire.API.Provider.Service (ServiceRef) +import Wire.API.Routes.Internal.Brig.EJPD import Wire.API.Routes.Internal.Galley.ConversationsIntra import Wire.API.Routes.Internal.Galley.TeamFeatureNoConfigMulti import Wire.API.Routes.Internal.Galley.TeamsIntra @@ -269,6 +270,7 @@ type InternalAPIBase = :<|> IFeatureAPI :<|> IFederationAPI :<|> IConversationAPI + :<|> IEJPDAPI type ILegalholdWhitelistedTeamsAPI = "legalhold" @@ -691,6 +693,16 @@ type IMiscAPI = :> MultiVerb1 'DELETE '[JSON] (RespondEmpty 200 "OK") ) +type IEJPDAPI = + Named + "get-conversations-by-user" + ( CanThrow 'NotConnected + :> "user" + :> Capture "user" UserId + :> "all-conversations" + :> Get '[Servant.JSON] [EJPDConvInfo] + ) + swaggerDoc :: OpenApi swaggerDoc = toOpenApi (Proxy @InternalAPI) diff --git a/libs/wire-api/src/Wire/API/Routes/MultiTablePaging.hs b/libs/wire-api/src/Wire/API/Routes/MultiTablePaging.hs index 0fc48cdaf06..2cdfaf692c9 100644 --- a/libs/wire-api/src/Wire/API/Routes/MultiTablePaging.hs +++ b/libs/wire-api/src/Wire/API/Routes/MultiTablePaging.hs @@ -67,12 +67,12 @@ type RequestSchemaConstraint name tables max def = (KnownNat max, KnownNat def, deriving via Schema (GetMultiTablePageRequest name tables max def) instance - RequestSchemaConstraint name tables max def => ToJSON (GetMultiTablePageRequest name tables max def) + (RequestSchemaConstraint name tables max def) => ToJSON (GetMultiTablePageRequest name tables max def) deriving via Schema (GetMultiTablePageRequest name tables max def) instance - RequestSchemaConstraint name tables max def => FromJSON (GetMultiTablePageRequest name tables max def) + (RequestSchemaConstraint name tables max def) => FromJSON (GetMultiTablePageRequest name tables max def) deriving via Schema (GetMultiTablePageRequest name tables max def) @@ -82,7 +82,7 @@ deriving via ) => S.ToSchema (GetMultiTablePageRequest name tables max def) -instance RequestSchemaConstraint name tables max def => ToSchema (GetMultiTablePageRequest name tables max def) where +instance (RequestSchemaConstraint name tables max def) => ToSchema (GetMultiTablePageRequest name tables max def) where schema = let addPagingStateDoc = description @@ -96,10 +96,10 @@ instance RequestSchemaConstraint name tables max def => ToSchema (GetMultiTableP <$> gmtprSize .= (fromMaybe (toRange (Proxy @def)) <$> optFieldWithDocModifier "size" addSizeDoc schema) <*> gmtprState .= maybe_ (optFieldWithDocModifier "paging_state" addPagingStateDoc schema) -textFromNat :: forall n. KnownNat n => Text +textFromNat :: forall n. (KnownNat n) => Text textFromNat = Text.pack . show . natVal $ Proxy @n -textFromSymbol :: forall s. KnownSymbol s => Text +textFromSymbol :: forall s. (KnownSymbol s) => Text textFromSymbol = Text.pack . symbolVal $ Proxy @s -- | The result of a multi-table paginated query. Contains the list of results, @@ -117,13 +117,13 @@ type PageSchemaConstraints name resultsKey tables a = (KnownSymbol resultsKey, K deriving via (Schema (MultiTablePage name resultsKey tables a)) instance - PageSchemaConstraints name resultsKey tables a => + (PageSchemaConstraints name resultsKey tables a) => ToJSON (MultiTablePage name resultsKey tables a) deriving via (Schema (MultiTablePage name resultsKey tables a)) instance - PageSchemaConstraints name resultsKey tables a => + (PageSchemaConstraints name resultsKey tables a) => FromJSON (MultiTablePage name resultsKey tables a) deriving via diff --git a/libs/wire-api/src/Wire/API/Routes/MultiTablePaging/State.hs b/libs/wire-api/src/Wire/API/Routes/MultiTablePaging/State.hs index 1fae94b78b4..e14c63c1332 100644 --- a/libs/wire-api/src/Wire/API/Routes/MultiTablePaging/State.hs +++ b/libs/wire-api/src/Wire/API/Routes/MultiTablePaging/State.hs @@ -45,25 +45,25 @@ data MultiTablePagingState (name :: Symbol) tables = MultiTablePagingState deriving stock (Show, Eq) deriving (ToJSON, FromJSON, S.ToSchema) via Schema (MultiTablePagingState name tables) -encodePagingState :: PagingTable tables => MultiTablePagingState name tables -> ByteString +encodePagingState :: (PagingTable tables) => MultiTablePagingState name tables -> ByteString encodePagingState (MultiTablePagingState table state) = let encodedTable = encodePagingTable table encodedState = fromMaybe "" state in BS.cons encodedTable encodedState -parsePagingState :: PagingTable tables => ByteString -> Either String (MultiTablePagingState name tables) +parsePagingState :: (PagingTable tables) => ByteString -> Either String (MultiTablePagingState name tables) parsePagingState = AB.parseOnly pagingStateParser -pagingStateParser :: PagingTable tables => AB.Parser (MultiTablePagingState name tables) +pagingStateParser :: (PagingTable tables) => AB.Parser (MultiTablePagingState name tables) pagingStateParser = do table <- AB.anyWord8 >>= decodePagingTable state <- (AB.endOfInput $> Nothing) <|> (Just <$> AB.takeByteString <* AB.endOfInput) pure $ MultiTablePagingState table state -instance PagingTable tables => ToHttpApiData (MultiTablePagingState name tables) where +instance (PagingTable tables) => ToHttpApiData (MultiTablePagingState name tables) where toQueryParam = (Text.decodeUtf8 . Base64Url.encode) . encodePagingState -instance PagingTable tables => FromHttpApiData (MultiTablePagingState name tables) where +instance (PagingTable tables) => FromHttpApiData (MultiTablePagingState name tables) where parseQueryParam = mapLeft Text.pack . (parsePagingState <=< (Base64Url.decode . Text.encodeUtf8)) @@ -74,7 +74,7 @@ instance PagingTable tables => FromHttpApiData (MultiTablePagingState name table class PagingTable t where -- Using 'Word8' because 256 tables ought to be enough. encodePagingTable :: t -> Word8 - decodePagingTable :: MonadFail m => Word8 -> m t + decodePagingTable :: (MonadFail m) => Word8 -> m t instance (PagingTable tables, KnownSymbol name) => ToSchema (MultiTablePagingState name tables) where schema = diff --git a/libs/wire-api/src/Wire/API/Routes/MultiVerb.hs b/libs/wire-api/src/Wire/API/Routes/MultiVerb.hs index 7c4e6dcd5ab..0ee626b9d98 100644 --- a/libs/wire-api/src/Wire/API/Routes/MultiVerb.hs +++ b/libs/wire-api/src/Wire/API/Routes/MultiVerb.hs @@ -155,7 +155,7 @@ class IsSwaggerResponse a where type family ResponseType a :: Type -class IsWaiBody (ResponseBody a) => IsResponse cs a where +class (IsWaiBody (ResponseBody a)) => IsResponse cs a where type ResponseStatus a :: Nat type ResponseBody a :: Type @@ -238,7 +238,7 @@ instance either UnrenderError UnrenderSuccess $ mimeUnrender (Proxy @ct) (responseBody output) -instance KnownStatus s => IsResponse cs (RespondAs '() s desc ()) where +instance (KnownStatus s) => IsResponse cs (RespondAs '() s desc ()) where type ResponseStatus (RespondAs '() s desc ()) = s type ResponseBody (RespondAs '() s desc ()) = () @@ -290,7 +290,7 @@ instance guard (responseStatusCode resp == statusVal (Proxy @s)) pure $ responseBody resp -instance KnownSymbol desc => IsSwaggerResponse (RespondStreaming s desc framing ct) where +instance (KnownSymbol desc) => IsSwaggerResponse (RespondStreaming s desc framing ct) where responseSwagger = pure $ mempty @@ -333,7 +333,7 @@ instance ServantHeaders '[] '[] where constructHeaders Nil = [] extractHeaders _ = Just Nil -headerName :: forall name. KnownSymbol name => HTTP.HeaderName +headerName :: forall name. (KnownSymbol name) => HTTP.HeaderName headerName = CI.mk . Text.encodeUtf8 @@ -378,7 +378,7 @@ instance where constructHeader x = [(headerName @name, toHeader x)] -instance ServantHeader h name x => ServantHeader (OptHeader h) name (Maybe x) where +instance (ServantHeader h name x) => ServantHeader (OptHeader h) name (Maybe x) where constructHeader = foldMap (constructHeader @h) instance @@ -391,7 +391,7 @@ instance desc = Text.pack (symbolVal (Proxy @desc)) sch = pure $ Inline $ S.toParamSchema (Proxy @a) -instance ToResponseHeader h => ToResponseHeader (OptHeader h) where +instance (ToResponseHeader h) => ToResponseHeader (OptHeader h) where toResponseHeader _ = toResponseHeader (Proxy @h) type instance ResponseType (WithHeaders hs a r) = a @@ -535,7 +535,7 @@ class AsUnion (as :: [Type]) (r :: Type) where -- | Unions can be used directly as handler return types using this trivial -- instance. -instance rs ~ ResponseTypes as => AsUnion as (Union rs) where +instance (rs ~ ResponseTypes as) => AsUnion as (Union rs) where toUnion = id fromUnion = id @@ -553,7 +553,7 @@ class InjectAfter as bs where instance InjectAfter '[] bs where injectAfter = id -instance InjectAfter as bs => InjectAfter (a ': as) bs where +instance (InjectAfter as bs) => InjectAfter (a ': as) bs where injectAfter = S . injectAfter @as @bs class InjectBefore as bs where @@ -562,7 +562,7 @@ class InjectBefore as bs where instance InjectBefore '[] bs where injectBefore x = case x of {} -instance InjectBefore as bs => InjectBefore (a ': as) bs where +instance (InjectBefore as bs) => InjectBefore (a ': as) bs where injectBefore (Z x) = Z x injectBefore (S x) = S (injectBefore @as @bs x) @@ -584,7 +584,7 @@ class EitherFromUnion as bs where instance EitherFromUnion '[] bs where eitherFromUnion _ g = Right . g -instance EitherFromUnion as bs => EitherFromUnion (a ': as) bs where +instance (EitherFromUnion as bs) => EitherFromUnion (a ': as) bs where eitherFromUnion f _ (Z x) = Left (f (Z x)) eitherFromUnion f g (S x) = eitherFromUnion @as @bs (f . S) g x @@ -598,7 +598,7 @@ maybeToUnion _ Nothing = injectAfter @as @'[()] (Z (I ())) maybeFromUnion :: forall as a. - EitherFromUnion as '[()] => + (EitherFromUnion as '[()]) => (Union as -> a) -> (Union (as .++ '[()]) -> Maybe a) maybeFromUnion f = leftToMaybe . eitherFromUnion @as @'[()] f (const (Z (I ()))) @@ -767,11 +767,11 @@ instance -- pick out an element from the map, if any exist. -- These will all have the same schemas, and we are reapplying the content types. foldMap (\c -> InsOrdHashMap.fromList $ (,c) <$> cs) - . listToMaybe - . toList + . listToMaybe + . toList refResps = S.Inline . addMime <$> resps -class Typeable a => IsWaiBody a where +class (Typeable a) => IsWaiBody a where responseToWai :: ResponseF a -> Wai.Response instance IsWaiBody LByteString where @@ -799,9 +799,9 @@ instance IsWaiBody (SourceIO ByteString) where (\chunk -> output (byteString chunk) *> flush) (responseBody r) -data SomeResponse = forall a. IsWaiBody a => SomeResponse (ResponseF a) +data SomeResponse = forall a. (IsWaiBody a) => SomeResponse (ResponseF a) -addContentType :: forall ct a. Accept ct => ResponseF a -> ResponseF a +addContentType :: forall ct a. (Accept ct) => ResponseF a -> ResponseF a addContentType = addContentType' (contentType (Proxy @ct)) addContentType' :: M.MediaType -> ResponseF a -> ResponseF a @@ -828,7 +828,7 @@ fromSomeResponse (SomeResponse Response {..}) = do class HasAcceptCheck cs where acceptCheck' :: Proxy cs -> AcceptHeader -> DelayedIO () -instance AllMime cs => HasAcceptCheck cs where +instance (AllMime cs) => HasAcceptCheck cs where acceptCheck' = acceptCheck instance HasAcceptCheck '() where @@ -869,7 +869,7 @@ instance method = reflectMethod (Proxy @method) -- taken from Servant.Client.Core.HasClient -getResponseContentType :: RunClient m => Response -> m M.MediaType +getResponseContentType :: (RunClient m) => Response -> m M.MediaType getResponseContentType response = case lookup "Content-Type" (toList (responseHeaders response)) of Nothing -> pure $ "application" M.// "octet-stream" diff --git a/libs/wire-api/src/Wire/API/Routes/Named.hs b/libs/wire-api/src/Wire/API/Routes/Named.hs index 5e8220818b5..d7aad87521a 100644 --- a/libs/wire-api/src/Wire/API/Routes/Named.hs +++ b/libs/wire-api/src/Wire/API/Routes/Named.hs @@ -42,7 +42,7 @@ newtype Named name x = Named {unnamed :: x} class RenderableSymbol a where renderSymbol :: Text -instance {-# OVERLAPPABLE #-} KnownSymbol a => RenderableSymbol a where +instance {-# OVERLAPPABLE #-} (KnownSymbol a) => RenderableSymbol a where renderSymbol = T.pack . show $ symbolVal (Proxy @a) instance {-# OVERLAPPING #-} (RenderableSymbol a, RenderableSymbol b) => RenderableSymbol '(a, b) where @@ -59,21 +59,21 @@ instance (HasOpenApi api, RenderableSymbol name) => HasOpenApi (Named name api) <> renderSymbol @name <> "]" -instance HasServer api ctx => HasServer (Named name api) ctx where +instance (HasServer api ctx) => HasServer (Named name api) ctx where type ServerT (Named name api) m = Named name (ServerT api m) route _ ctx action = route (Proxy @api) ctx (fmap unnamed action) hoistServerWithContext _ ctx f = fmap (hoistServerWithContext (Proxy @api) ctx f) -instance HasLink endpoint => HasLink (Named name endpoint) where +instance (HasLink endpoint) => HasLink (Named name endpoint) where type MkLink (Named name endpoint) a = MkLink endpoint a toLink toA _ = toLink toA (Proxy @endpoint) -instance RoutesToPaths api => RoutesToPaths (Named name api) where +instance (RoutesToPaths api) => RoutesToPaths (Named name api) where getRoutes = getRoutes @api -instance HasClient m api => HasClient m (Named n api) where +instance (HasClient m api) => HasClient m (Named n api) where type Client m (Named n api) = Client m api clientWithRoute pm _ req = clientWithRoute pm (Proxy @api) req hoistClientMonad pm _ f = hoistClientMonad pm (Proxy @api) f @@ -142,6 +142,8 @@ namedClient = clientIn (Proxy @endpoint) (Proxy @m) type family x ::> api +infixr 4 ::> + type instance x ::> (Named name api) = Named name (x :> api) diff --git a/libs/wire-api/src/Wire/API/Routes/Public.hs b/libs/wire-api/src/Wire/API/Routes/Public.hs index 73b6de1b3f6..44cb71c638e 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public.hs @@ -115,7 +115,7 @@ class instance HasTokenType 'ZLocalAuthUser -instance HasContextEntry ctx Domain => IsZType 'ZLocalAuthUser ctx where +instance (HasContextEntry ctx Domain) => IsZType 'ZLocalAuthUser ctx where type ZHeader 'ZLocalAuthUser = "Z-User" type ZParam 'ZLocalAuthUser = UserId type ZQualifiedParam 'ZLocalAuthUser = Local UserId @@ -228,7 +228,7 @@ type ZHostValue = Text type ZOptHostHeader = Header' '[Servant.Optional, Strict] "Z-Host" ZHostValue -instance HasOpenApi api => HasOpenApi (ZHostOpt :> api) where +instance (HasOpenApi api) => HasOpenApi (ZHostOpt :> api) where toOpenApi _ = toOpenApi (Proxy @api) type instance SpecialiseToVersion v (ZHostOpt :> api) = ZHostOpt :> SpecialiseToVersion v api @@ -249,19 +249,19 @@ type instance SpecialiseToVersion v (ZAuthServant t opts :> api) = ZAuthServant t opts :> SpecialiseToVersion v api -instance HasOpenApi api => HasOpenApi (ZAuthServant 'ZAuthUser _opts :> api) where +instance (HasOpenApi api) => HasOpenApi (ZAuthServant 'ZAuthUser _opts :> api) where toOpenApi _ = addZAuthSwagger (toOpenApi (Proxy @api)) -instance HasOpenApi api => HasOpenApi (ZAuthServant 'ZLocalAuthUser opts :> api) where +instance (HasOpenApi api) => HasOpenApi (ZAuthServant 'ZLocalAuthUser opts :> api) where toOpenApi _ = addZAuthSwagger (toOpenApi (Proxy @api)) -instance HasLink endpoint => HasLink (ZAuthServant usr opts :> endpoint) where +instance (HasLink endpoint) => HasLink (ZAuthServant usr opts :> endpoint) where type MkLink (ZAuthServant _ _ :> endpoint) a = MkLink endpoint a toLink toA _ = toLink toA (Proxy @endpoint) instance {-# OVERLAPPABLE #-} - HasOpenApi api => + (HasOpenApi api) => HasOpenApi (ZAuthServant ztype _opts :> api) where toOpenApi _ = toOpenApi (Proxy @api) @@ -319,10 +319,10 @@ instance hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s -instance RoutesToPaths api => RoutesToPaths (ZAuthServant ztype opts :> api) where +instance (RoutesToPaths api) => RoutesToPaths (ZAuthServant ztype opts :> api) where getRoutes = getRoutes @api -instance RoutesToPaths api => RoutesToPaths (ZHostOpt :> api) where +instance (RoutesToPaths api) => RoutesToPaths (ZHostOpt :> api) where getRoutes = getRoutes @api -- FUTUREWORK: Make a PR to the servant-swagger package with this instance @@ -341,19 +341,19 @@ instance where toOpenApi _ = addScopeDescription @scope (toOpenApi (Proxy @api)) -addScopeDescription :: forall scope. OAuth.IsOAuthScope scope => OpenApi -> OpenApi +addScopeDescription :: forall scope. (OAuth.IsOAuthScope scope) => OpenApi -> OpenApi addScopeDescription = allOperations . description %~ Just - . ( <> - "\nOAuth scope: `" - <> ( decodeUtf8With lenientDecode . toStrict . toByteString $ - OAuth.toOAuthScope @scope - ) - <> "`" - ) - . fold + . ( <> + "\nOAuth scope: `" + <> ( decodeUtf8With lenientDecode . toStrict . toByteString $ + OAuth.toOAuthScope @scope + ) + <> "`" + ) + . fold instance (HasServer api ctx) => HasServer (DescriptionOAuthScope scope :> api) ctx where type ServerT (DescriptionOAuthScope scope :> api) m = ServerT api m @@ -361,5 +361,5 @@ instance (HasServer api ctx) => HasServer (DescriptionOAuthScope scope :> api) c route _ = route (Proxy @api) hoistServerWithContext _ = hoistServerWithContext (Proxy @api) -instance RoutesToPaths api => RoutesToPaths (DescriptionOAuthScope scope :> api) where +instance (RoutesToPaths api) => RoutesToPaths (DescriptionOAuthScope scope :> api) where getRoutes = getRoutes @api 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 f81d8f1a399..8a9cbfc0842 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs @@ -297,7 +297,7 @@ type SelfAPI = "get-self" ( Summary "Get your own profile" :> DescriptionOAuthScope 'ReadSelf - :> ZUser + :> ZLocalUser :> "self" :> Get '[JSON] SelfProfile ) @@ -334,11 +334,11 @@ type SelfAPI = "put-self" ( Summary "Update your profile." :> MakesFederatedCall 'Brig "send-connection-action" - :> ZUser + :> ZLocalUser :> ZConn :> "self" :> ReqBody '[JSON] UserUpdate - :> MultiVerb 'PUT '[JSON] PutSelfResponses (Maybe UpdateProfileError) + :> MultiVerb1 'PUT '[JSON] (RespondEmpty 200 "User updated") ) :<|> Named "change-phone" @@ -361,7 +361,6 @@ type SelfAPI = \email address and a password." :> MakesFederatedCall 'Brig "send-connection-action" :> ZUser - :> ZConn :> "self" :> "phone" :> MultiVerb 'DELETE '[JSON] RemoveIdentityResponses (Maybe RemoveIdentityError) @@ -377,7 +376,6 @@ type SelfAPI = \phone number." :> MakesFederatedCall 'Brig "send-connection-action" :> ZUser - :> ZConn :> "self" :> "email" :> MultiVerb 'DELETE '[JSON] RemoveIdentityResponses (Maybe RemoveIdentityError) @@ -409,24 +407,24 @@ type SelfAPI = "change-locale" ( Summary "Change your locale." :> MakesFederatedCall 'Brig "send-connection-action" - :> ZUser + :> ZLocalUser :> ZConn :> "self" :> "locale" :> ReqBody '[JSON] LocaleUpdate - :> MultiVerb 'PUT '[JSON] '[RespondEmpty 200 "Local Changed"] () + :> MultiVerb1 'PUT '[JSON] (RespondEmpty 200 "Local Changed") ) :<|> Named "change-handle" ( Summary "Change your handle." :> MakesFederatedCall 'Brig "send-connection-action" :> MakesFederatedCall 'Brig "send-connection-action" - :> ZUser + :> ZLocalUser :> ZConn :> "self" :> "handle" :> ReqBody '[JSON] HandleUpdate - :> MultiVerb 'PUT '[JSON] ChangeHandleResponses (Maybe ChangeHandleError) + :> MultiVerb1 'PUT '[JSON] (RespondEmpty 200 "Handle Changed") ) :<|> Named "change-supported-protocols" @@ -481,8 +479,8 @@ type AccountAPI = ( Summary "Register a new user." :> Description "If the environment where the registration takes \ - \place is private and a registered email address or phone \ - \number is not whitelisted, a 403 error is returned." + \place is private and a registered email address \ + \is not whitelisted, a 403 error is returned." :> MakesFederatedCall 'Brig "send-connection-action" :> "register" :> ReqBody '[JSON] NewUserPublic @@ -550,12 +548,11 @@ type AccountAPI = -- docs/reference/user/activation.md {#RefActivationRequest} :<|> Named "post-activate-send" - ( Summary "Send (or resend) an email or phone activation code." + ( Summary "Send (or resend) an email activation code." :> CanThrow 'UserKeyExists :> CanThrow 'InvalidEmail :> CanThrow 'InvalidPhone :> CanThrow 'BlacklistedEmail - :> CanThrow 'BlacklistedPhone :> CanThrow 'CustomerExtensionBlockedDomain :> "activate" :> "send" @@ -565,8 +562,6 @@ type AccountAPI = :<|> Named "post-password-reset" ( Summary "Initiate a password reset." - :> CanThrow 'PasswordResetInProgress - :> CanThrow 'InvalidPasswordResetKey :> "password-reset" :> ReqBody '[JSON] NewPasswordReset :> MultiVerb 'POST '[JSON] '[RespondEmpty 201 "Password reset code created and sent by email."] () @@ -1484,7 +1479,6 @@ type AuthAPI = :> CanThrow 'InvalidEmail :> CanThrow 'UserKeyExists :> CanThrow 'BlacklistedEmail - :> CanThrow 'BlacklistedPhone :> CanThrow 'BadCredentials :> MultiVerb 'PUT diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Cargohold.hs b/libs/wire-api/src/Wire/API/Routes/Public/Cargohold.hs index a1dc8001504..d9c7ca0ed3e 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Cargohold.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Cargohold.hs @@ -59,12 +59,12 @@ type instance SpecialiseToVersion v ((tag :: PrincipalTag) :> api) = SpecialiseToVersion v (ApplyPrincipalPath tag api) -instance HasServer (ApplyPrincipalPath tag api) ctx => HasServer (tag :> api) ctx where +instance (HasServer (ApplyPrincipalPath tag api) ctx) => HasServer (tag :> api) ctx where type ServerT (tag :> api) m = ServerT (ApplyPrincipalPath tag api) m route _ = route (Proxy @(ApplyPrincipalPath tag api)) hoistServerWithContext _ = hoistServerWithContext (Proxy @(ApplyPrincipalPath tag api)) -instance RoutesToPaths (ApplyPrincipalPath tag api) => RoutesToPaths (tag :> api) where +instance (RoutesToPaths (ApplyPrincipalPath tag api)) => RoutesToPaths (tag :> api) where getRoutes = getRoutes @(ApplyPrincipalPath tag api) type AssetLocationHeader r = diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Galley/Feature.hs b/libs/wire-api/src/Wire/API/Routes/Public/Galley/Feature.hs index 3dab419273e..654f79657a2 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley/Feature.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley/Feature.hs @@ -88,7 +88,8 @@ type FeatureAPI = :<|> FeatureStatusGet OutlookCalIntegrationConfig :<|> FeatureStatusPut '[] '() OutlookCalIntegrationConfig :<|> From 'V5 ::> FeatureStatusGet MlsE2EIdConfig - :<|> From 'V5 ::> FeatureStatusPut '[] '() MlsE2EIdConfig + :<|> From 'V5 ::> Until 'V6 ::> Named "put-MlsE2EIdConfig@v5" (ZUser :> FeatureStatusBasePutPublic '() MlsE2EIdConfig) + :<|> From 'V6 ::> FeatureStatusPut '[] '() MlsE2EIdConfig :<|> From 'V5 ::> FeatureStatusGet MlsMigrationConfig :<|> From 'V5 ::> FeatureStatusPut '[] '() MlsMigrationConfig :<|> From 'V5 diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Galley/Messaging.hs b/libs/wire-api/src/Wire/API/Routes/Public/Galley/Messaging.hs index e079e33110d..d4b81661b79 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley/Messaging.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley/Messaging.hs @@ -131,7 +131,7 @@ data MessageNotSent a via (GenericAsUnion (MessageNotSentResponses a) (MessageNotSent a)) deriving anyclass (GSOP.Generic) -instance S.ToSchema a => S.ToSchema (MessageNotSent a) +instance (S.ToSchema a) => S.ToSchema (MessageNotSent a) type MessageNotSentResponses a = '[ ErrorResponse 'ConvNotFound, diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Proxy.hs b/libs/wire-api/src/Wire/API/Routes/Public/Proxy.hs index 4fa0e100c83..aaf0874111e 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Proxy.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Proxy.hs @@ -17,7 +17,7 @@ module Wire.API.Routes.Public.Proxy where -import Servant +import Servant hiding (RawM) import Servant.API.Extended.RawM (RawM) import Wire.API.Routes.API import Wire.API.Routes.Named 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 107ed1de9a5..e1f92b07998 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Spar.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Spar.hs @@ -167,8 +167,8 @@ data ScimSite tag route = ScimSite users :: route :- Header "Authorization" (Scim.Auth.AuthData tag) - :> "Users" - :> ToServantApi (Scim.User.UserSite tag) + :> "Users" + :> ToServantApi (Scim.User.UserSite tag) } deriving (Generic) diff --git a/libs/wire-api/src/Wire/API/Routes/SpecialiseToVersion.hs b/libs/wire-api/src/Wire/API/Routes/SpecialiseToVersion.hs index ac3b766e052..a2f29573f43 100644 --- a/libs/wire-api/src/Wire/API/Routes/SpecialiseToVersion.hs +++ b/libs/wire-api/src/Wire/API/Routes/SpecialiseToVersion.hs @@ -21,7 +21,7 @@ module Wire.API.Routes.SpecialiseToVersion where import Data.Singletons.Base.TH import GHC.TypeLits import Servant -import Servant.API.Extended.RawM +import Servant.API.Extended.RawM qualified as RawM import Wire.API.Deprecated import Wire.API.MakesFederatedCall import Wire.API.Routes.MultiVerb @@ -66,7 +66,7 @@ type instance SpecialiseToVersion v (MultiVerb m t r x) = MultiVerb m t r x -type instance SpecialiseToVersion v RawM = RawM +type instance SpecialiseToVersion v RawM.RawM = RawM.RawM type instance SpecialiseToVersion v (ReqBody t x :> api) = diff --git a/libs/wire-api/src/Wire/API/Routes/Version.hs b/libs/wire-api/src/Wire/API/Routes/Version.hs index f672efe25b7..2256e54ac69 100644 --- a/libs/wire-api/src/Wire/API/Routes/Version.hs +++ b/libs/wire-api/src/Wire/API/Routes/Version.hs @@ -68,7 +68,7 @@ import Data.Text.Encoding as Text import GHC.TypeLits import Imports hiding ((\\)) import Servant -import Servant.API.Extended.RawM +import Servant.API.Extended.RawM qualified as RawM import Wire.API.Deprecated import Wire.API.Routes.MultiVerb import Wire.API.Routes.Named hiding (unnamed) @@ -94,7 +94,7 @@ data Version = V0 | V1 | V2 | V3 | V4 | V5 | V6 -- which will cause `` and `fromEnum V` to diverge. `Enum` should not be understood as -- a bijection between meaningful integers and versions, but merely as a convenient way to say -- `allVersions = [minBound..]`. -versionInt :: Integral i => Version -> i +versionInt :: (Integral i) => Version -> i versionInt V0 = 0 versionInt V1 = 1 versionInt V2 = 2 @@ -123,8 +123,9 @@ instance ToSchema Version where instance FromHttpApiData Version where parseQueryParam v = note ("Unknown version: " <> v) $ getAlt $ - flip foldMap [minBound ..] $ \s -> - guard (versionText s == v) $> s + flip foldMap [minBound ..] $ + \s -> + guard (versionText s == v) $> s instance ToHttpApiData Version where toHeader = versionByteString @@ -175,7 +176,8 @@ instance ToSchema VersionInfo where schema = objectWithDocModifier "VersionInfo" (S.schema . S.example ?~ toJSON example) $ VersionInfo - <$> vinfoSupported .= vinfoObjectSchema schema + <$> vinfoSupported + .= vinfoObjectSchema schema <*> vinfoDevelopment .= field "development" (array schema) <*> vinfoFederation .= field "federation" schema <*> vinfoDomain .= field "domain" schema @@ -289,7 +291,7 @@ type instance SpecialiseToVersion v (MultiVerb m t r x) = MultiVerb m t r x -type instance SpecialiseToVersion v RawM = RawM +type instance SpecialiseToVersion v RawM.RawM = RawM.RawM type instance SpecialiseToVersion v (ReqBody t x :> api) = diff --git a/libs/wire-api/src/Wire/API/Routes/Versioned.hs b/libs/wire-api/src/Wire/API/Routes/Versioned.hs index 7707e3441e6..405ec783e00 100644 --- a/libs/wire-api/src/Wire/API/Routes/Versioned.hs +++ b/libs/wire-api/src/Wire/API/Routes/Versioned.hs @@ -39,7 +39,7 @@ data VersionedReqBody' v (mods :: [Type]) (ct :: [Type]) (a :: Type) type VersionedReqBody v = VersionedReqBody' v '[Required, Strict] -instance RoutesToPaths rest => RoutesToPaths (VersionedReqBody' v mods ct a :> rest) where +instance (RoutesToPaths rest) => RoutesToPaths (VersionedReqBody' v mods ct a :> rest) where getRoutes = getRoutes @rest instance @@ -78,7 +78,7 @@ data VersionedRespond v (s :: Nat) (desc :: Symbol) (a :: Type) type instance ResponseType (VersionedRespond v s desc a) = a instance - IsResponse cs (Respond s desc (Versioned v a)) => + (IsResponse cs (Respond s desc (Versioned v a))) => IsResponse cs (VersionedRespond v s desc a) where type ResponseStatus (VersionedRespond v s desc a) = ResponseStatus (Respond s desc a) @@ -106,9 +106,9 @@ newtype Versioned (v :: Version) a = Versioned {unVersioned :: a} instance Functor (Versioned v) where fmap f (Versioned a) = Versioned (f a) -deriving via Schema (Versioned v a) instance ToSchema (Versioned v a) => FromJSON (Versioned v a) +deriving via Schema (Versioned v a) instance (ToSchema (Versioned v a)) => FromJSON (Versioned v a) -deriving via Schema (Versioned v a) instance ToSchema (Versioned v a) => ToJSON (Versioned v a) +deriving via Schema (Versioned v a) instance (ToSchema (Versioned v a)) => ToJSON (Versioned v a) -- add version suffix to swagger schema to prevent collisions instance (SingI v, ToSchema (Versioned v a), Typeable a, Typeable v) => S.ToSchema (Versioned v a) where diff --git a/libs/wire-api/src/Wire/API/ServantProto.hs b/libs/wire-api/src/Wire/API/ServantProto.hs index 6e2dbd6140b..aba4621c91f 100644 --- a/libs/wire-api/src/Wire/API/ServantProto.hs +++ b/libs/wire-api/src/Wire/API/ServantProto.hs @@ -43,7 +43,7 @@ class ToProto a where instance Accept Proto where contentTypes _ = ("application" // "x-protobuf") :| [] -instance FromProto a => MimeUnrender Proto a where +instance (FromProto a) => MimeUnrender Proto a where mimeUnrender _ bs = fromProto (LBS.toStrict bs) -- | This wrapper can be used to get the raw protobuf representation of a type. @@ -54,8 +54,8 @@ data RawProto a = RawProto rpValue :: a } -instance FromProto a => FromProto (RawProto a) where +instance (FromProto a) => FromProto (RawProto a) where fromProto x = fmap (RawProto x) (fromProto x) -instance ToSchema a => ToSchema (RawProto a) where +instance (ToSchema a) => ToSchema (RawProto a) where declareNamedSchema _ = declareNamedSchema (Proxy @a) diff --git a/libs/wire-api/src/Wire/API/SwaggerServant.hs b/libs/wire-api/src/Wire/API/SwaggerServant.hs index 5c3918cf39c..8ea0729a504 100644 --- a/libs/wire-api/src/Wire/API/SwaggerServant.hs +++ b/libs/wire-api/src/Wire/API/SwaggerServant.hs @@ -37,12 +37,12 @@ data OmitDocs instance HasOpenApi (OmitDocs :> a) where toOpenApi _ = mempty -instance HasServer api ctx => HasServer (OmitDocs :> api) ctx where +instance (HasServer api ctx) => HasServer (OmitDocs :> api) ctx where type ServerT (OmitDocs :> api) m = ServerT api m route _ = route (Proxy :: Proxy api) hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt s -instance RoutesToPaths api => RoutesToPaths (OmitDocs :> api) where +instance (RoutesToPaths api) => RoutesToPaths (OmitDocs :> api) where getRoutes = getRoutes @api diff --git a/libs/wire-api/src/Wire/API/Team/Conversation.hs b/libs/wire-api/src/Wire/API/Team/Conversation.hs index 3822a614923..877ca425df3 100644 --- a/libs/wire-api/src/Wire/API/Team/Conversation.hs +++ b/libs/wire-api/src/Wire/API/Team/Conversation.hs @@ -68,7 +68,7 @@ instance ToSchema TeamConversation where (description ?~ managedDesc) (c (False :: Bool)) where - c :: A.ToJSON a => a -> ValueSchema SwaggerDoc () + c :: (A.ToJSON a) => a -> ValueSchema SwaggerDoc () c val = mkSchema mempty (const (pure ())) (const (pure (A.toJSON val))) newTeamConversation :: ConvId -> TeamConversation diff --git a/libs/wire-api/src/Wire/API/Team/Export.hs b/libs/wire-api/src/Wire/API/Team/Export.hs index 1f1d4b1462a..636950095bf 100644 --- a/libs/wire-api/src/Wire/API/Team/Export.hs +++ b/libs/wire-api/src/Wire/API/Team/Export.hs @@ -72,7 +72,7 @@ instance ToNamedRecord TeamExportUser where ("num_devices", secureCsvFieldToByteString (tExportNumDevices row)) ] -secureCsvFieldToByteString :: forall a. ToByteString a => a -> ByteString +secureCsvFieldToByteString :: forall a. (ToByteString a) => a -> ByteString secureCsvFieldToByteString = quoted . toByteString' instance DefaultOrdered TeamExportUser where @@ -98,7 +98,7 @@ allowEmpty :: (ByteString -> Parser a) -> ByteString -> Parser (Maybe a) allowEmpty _ "" = pure Nothing allowEmpty p str = Just <$> p str -parseByteString :: forall a. FromByteString a => ByteString -> Parser a +parseByteString :: forall a. (FromByteString a) => ByteString -> Parser a parseByteString bstr = case parseOnly (parser @a) (C.fromStrict (unquoted bstr)) of Left err -> fail err diff --git a/libs/wire-api/src/Wire/API/Team/Feature.hs b/libs/wire-api/src/Wire/API/Team/Feature.hs index 55319e388d4..f2fec9ce3d6 100644 --- a/libs/wire-api/src/Wire/API/Team/Feature.hs +++ b/libs/wire-api/src/Wire/API/Team/Feature.hs @@ -97,6 +97,7 @@ import Data.Attoparsec.ByteString qualified as Parser import Data.ByteString (fromStrict) import Data.ByteString.Conversion import Data.ByteString.UTF8 qualified as UTF8 +import Data.Default import Data.Domain (Domain) import Data.Either.Extra (maybeToEither) import Data.Id @@ -222,10 +223,10 @@ class FeatureTrivialConfig cfg where class HasDeprecatedFeatureName cfg where type DeprecatedFeatureName cfg :: Symbol -featureName :: forall cfg. KnownSymbol (FeatureSymbol cfg) => Text +featureName :: forall cfg. (KnownSymbol (FeatureSymbol cfg)) => Text featureName = T.pack $ symbolVal (Proxy @(FeatureSymbol cfg)) -featureNameBS :: forall cfg. KnownSymbol (FeatureSymbol cfg) => ByteString +featureNameBS :: forall cfg. (KnownSymbol (FeatureSymbol cfg)) => ByteString featureNameBS = UTF8.fromString $ symbolVal (Proxy @(FeatureSymbol cfg)) ---------------------------------------------------------------------- @@ -267,10 +268,10 @@ setLockStatus ls (WithStatusBase s _ c ttl) = WithStatusBase s (Identity ls) c t setConfig :: cfg -> WithStatus cfg -> WithStatus cfg setConfig = setConfig' -setConfig' :: forall (m :: Type -> Type) (cfg :: Type). Applicative m => cfg -> WithStatusBase m cfg -> WithStatusBase m cfg +setConfig' :: forall (m :: Type -> Type) (cfg :: Type). (Applicative m) => cfg -> WithStatusBase m cfg -> WithStatusBase m cfg setConfig' c (WithStatusBase s ls _ ttl) = WithStatusBase s ls (pure c) ttl -setTTL :: forall (m :: Type -> Type) (cfg :: Type). Applicative m => FeatureTTL -> WithStatusBase m cfg -> WithStatusBase m cfg +setTTL :: forall (m :: Type -> Type) (cfg :: Type). (Applicative m) => FeatureTTL -> WithStatusBase m cfg -> WithStatusBase m cfg setTTL ttl (WithStatusBase s ls c _) = WithStatusBase s ls c (pure ttl) setWsTTL :: FeatureTTL -> WithStatus cfg -> WithStatus cfg @@ -338,7 +339,7 @@ withStatus' = WithStatusBase -- | The ToJSON implementation of `WithStatusPatch` will encode the trivial config as `"config": {}` -- when the value is a `Just`, if it's `Nothing` it will be omitted, which is the important part. -instance ToSchema cfg => ToSchema (WithStatusPatch cfg) where +instance (ToSchema cfg) => ToSchema (WithStatusPatch cfg) where schema = object name $ WithStatusBase @@ -372,7 +373,7 @@ data WithStatusNoLock (cfg :: Type) = WithStatusNoLock deriving stock (Eq, Show, Generic, Typeable, Functor) deriving (ToJSON, FromJSON, S.ToSchema) via (Schema (WithStatusNoLock cfg)) -instance Arbitrary cfg => Arbitrary (WithStatusNoLock cfg) where +instance (Arbitrary cfg) => Arbitrary (WithStatusNoLock cfg) where arbitrary = WithStatusNoLock <$> arbitrary <*> arbitrary <*> arbitrary forgetLock :: WithStatus a -> WithStatusNoLock a @@ -1009,7 +1010,9 @@ instance FeatureTrivialConfig OutlookCalIntegrationConfig where data MlsE2EIdConfig = MlsE2EIdConfig { verificationExpiration :: NominalDiffTime, - acmeDiscoveryUrl :: Maybe HttpsUrl + acmeDiscoveryUrl :: Maybe HttpsUrl, + crlProxy :: Maybe HttpsUrl, + useProxyOnMobile :: Bool } deriving stock (Eq, Show, Generic) @@ -1021,6 +1024,8 @@ instance Arbitrary MlsE2EIdConfig where MlsE2EIdConfig <$> (fromIntegral <$> (arbitrary @Word32)) <*> arbitrary + <*> fmap Just arbitrary + <*> arbitrary instance ToSchema MlsE2EIdConfig where schema :: ValueSchema NamedSwaggerDoc MlsE2EIdConfig @@ -1029,6 +1034,8 @@ instance ToSchema MlsE2EIdConfig where MlsE2EIdConfig <$> (toSeconds . verificationExpiration) .= fieldWithDocModifier "verificationExpiration" veDesc (fromSeconds <$> schema) <*> acmeDiscoveryUrl .= maybe_ (optField "acmeDiscoveryUrl" schema) + <*> crlProxy .= maybe_ (optField "crlProxy" schema) + <*> useProxyOnMobile .= (fromMaybe False <$> optField "useProxyOnMobile" schema) where fromSeconds :: Int -> NominalDiffTime fromSeconds = fromIntegral @@ -1055,7 +1062,7 @@ instance IsFeatureConfig MlsE2EIdConfig where type FeatureSymbol MlsE2EIdConfig = "mlsE2EId" defFeatureStatus = withStatus FeatureStatusDisabled LockStatusUnlocked defValue FeatureTTLUnlimited where - defValue = MlsE2EIdConfig (fromIntegral @Int (60 * 60 * 24)) Nothing + defValue = MlsE2EIdConfig (fromIntegral @Int (60 * 60 * 24)) Nothing Nothing False featureSingleton = FeatureSingletonMlsE2EIdConfig objectSchema = field "config" schema @@ -1208,7 +1215,7 @@ instance Cass.Cql FeatureStatus where toCql FeatureStatusDisabled = Cass.CqlInt 0 toCql FeatureStatusEnabled = Cass.CqlInt 1 -defFeatureStatusNoLock :: IsFeatureConfig cfg => WithStatusNoLock cfg +defFeatureStatusNoLock :: (IsFeatureConfig cfg) => WithStatusNoLock cfg defFeatureStatusNoLock = forgetLock defFeatureStatus data AllFeatureConfigs = AllFeatureConfigs @@ -1236,6 +1243,31 @@ data AllFeatureConfigs = AllFeatureConfigs deriving stock (Eq, Show) deriving (FromJSON, ToJSON, S.ToSchema) via (Schema AllFeatureConfigs) +instance Default AllFeatureConfigs where + def = + AllFeatureConfigs + { afcLegalholdStatus = defFeatureStatus, + afcSSOStatus = defFeatureStatus, + afcTeamSearchVisibilityAvailable = defFeatureStatus, + afcSearchVisibilityInboundConfig = defFeatureStatus, + afcValidateSAMLEmails = defFeatureStatus, + afcDigitalSignatures = defFeatureStatus, + afcAppLock = defFeatureStatus, + afcFileSharing = defFeatureStatus, + afcClassifiedDomains = defFeatureStatus, + afcConferenceCalling = defFeatureStatus, + afcSelfDeletingMessages = defFeatureStatus, + afcGuestLink = defFeatureStatus, + afcSndFactorPasswordChallenge = defFeatureStatus, + afcMLS = defFeatureStatus, + afcExposeInvitationURLsToTeamAdmin = defFeatureStatus, + afcOutlookCalIntegration = defFeatureStatus, + afcMlsE2EId = defFeatureStatus, + afcMlsMigration = defFeatureStatus, + afcEnforceFileDownloadLocation = defFeatureStatus, + afcLimitedEventFanout = defFeatureStatus + } + instance ToSchema AllFeatureConfigs where schema = object "AllFeatureConfigs" $ diff --git a/libs/wire-api/src/Wire/API/Team/HardTruncationLimit.hs b/libs/wire-api/src/Wire/API/Team/HardTruncationLimit.hs index 0ec378cc1bd..47845ffc6a7 100644 --- a/libs/wire-api/src/Wire/API/Team/HardTruncationLimit.hs +++ b/libs/wire-api/src/Wire/API/Team/HardTruncationLimit.hs @@ -6,5 +6,5 @@ import Imports type HardTruncationLimit = (2000 :: Nat) -hardTruncationLimit :: Integral a => a +hardTruncationLimit :: (Integral a) => a hardTruncationLimit = fromIntegral $ natVal (Proxy @HardTruncationLimit) diff --git a/libs/wire-api/src/Wire/API/Team/Invitation.hs b/libs/wire-api/src/Wire/API/Team/Invitation.hs index 44cc508ab69..c51492dc19c 100644 --- a/libs/wire-api/src/Wire/API/Team/Invitation.hs +++ b/libs/wire-api/src/Wire/API/Team/Invitation.hs @@ -41,10 +41,11 @@ import Servant (FromHttpApiData (..), ToHttpApiData (..)) import URI.ByteString import Wire.API.Error import Wire.API.Error.Brig +import Wire.API.Locale (Locale) import Wire.API.Routes.MultiVerb import Wire.API.Team.Role (Role, defaultRole) import Wire.API.User.Identity (Email, Phone) -import Wire.API.User.Profile (Locale, Name) +import Wire.API.User.Profile (Name) import Wire.Arbitrary (Arbitrary, GenericUniform (..)) -------------------------------------------------------------------------------- diff --git a/libs/wire-api/src/Wire/API/Team/LegalHold.hs b/libs/wire-api/src/Wire/API/Team/LegalHold.hs index e25f3ec7577..c0bfa22047c 100644 --- a/libs/wire-api/src/Wire/API/Team/LegalHold.hs +++ b/libs/wire-api/src/Wire/API/Team/LegalHold.hs @@ -94,7 +94,8 @@ instance ToSchema LHServiceStatus where instance ToSchema ViewLegalHoldService where schema = object "ViewLegalHoldService" $ - toOutput .= recordSchema + toOutput + .= recordSchema `withParser` validateViewLegalHoldService where toOutput :: ViewLegalHoldService -> (LHServiceStatus, Maybe ViewLegalHoldServiceInfo) diff --git a/libs/wire-api/src/Wire/API/Team/LegalHold/External.hs b/libs/wire-api/src/Wire/API/Team/LegalHold/External.hs index 8dc5fd14366..a38b8ee5096 100644 --- a/libs/wire-api/src/Wire/API/Team/LegalHold/External.hs +++ b/libs/wire-api/src/Wire/API/Team/LegalHold/External.hs @@ -64,8 +64,10 @@ instance ToSchema RequestNewLegalHoldClient where instance ToJSON RequestNewLegalHoldClient where toJSON (RequestNewLegalHoldClient userId teamId) = object $ - "user_id" .= userId - # "team_id" .= teamId + "user_id" + .= userId + # "team_id" + .= teamId # [] instance FromJSON RequestNewLegalHoldClient where @@ -96,8 +98,10 @@ instance ToSchema NewLegalHoldClient where instance ToJSON NewLegalHoldClient where toJSON c = object $ - "prekeys" .= newLegalHoldClientPrekeys c - # "last_prekey" .= newLegalHoldClientLastKey c + "prekeys" + .= newLegalHoldClientPrekeys c + # "last_prekey" + .= newLegalHoldClientLastKey c # [] instance FromJSON NewLegalHoldClient where @@ -123,10 +127,14 @@ data LegalHoldServiceConfirm = LegalHoldServiceConfirm instance ToJSON LegalHoldServiceConfirm where toJSON (LegalHoldServiceConfirm clientId userId teamId refreshToken) = object $ - "client_id" .= clientId - # "user_id" .= userId - # "team_id" .= teamId - # "refresh_token" .= refreshToken + "client_id" + .= clientId + # "user_id" + .= userId + # "team_id" + .= teamId + # "refresh_token" + .= refreshToken # [] instance FromJSON LegalHoldServiceConfirm where @@ -151,8 +159,10 @@ data LegalHoldServiceRemove = LegalHoldServiceRemove instance ToJSON LegalHoldServiceRemove where toJSON (LegalHoldServiceRemove userId teamId) = object $ - "user_id" .= userId - # "team_id" .= teamId + "user_id" + .= userId + # "team_id" + .= teamId # [] instance FromJSON LegalHoldServiceRemove where diff --git a/libs/wire-api/src/Wire/API/Team/LegalHold/Internal.hs b/libs/wire-api/src/Wire/API/Team/LegalHold/Internal.hs index e706f472fc6..7b269033d94 100644 --- a/libs/wire-api/src/Wire/API/Team/LegalHold/Internal.hs +++ b/libs/wire-api/src/Wire/API/Team/LegalHold/Internal.hs @@ -49,11 +49,16 @@ data LegalHoldService = LegalHoldService instance ToJSON LegalHoldService where toJSON s = object $ - "team_id" .= legalHoldServiceTeam s - # "base_url" .= legalHoldServiceUrl s - # "fingerprint" .= legalHoldServiceFingerprint s - # "auth_token" .= legalHoldServiceToken s - # "public_key" .= legalHoldServiceKey s + "team_id" + .= legalHoldServiceTeam s + # "base_url" + .= legalHoldServiceUrl s + # "fingerprint" + .= legalHoldServiceFingerprint s + # "auth_token" + .= legalHoldServiceToken s + # "public_key" + .= legalHoldServiceKey s # [] instance FromJSON LegalHoldService where diff --git a/libs/wire-api/src/Wire/API/Team/Member.hs b/libs/wire-api/src/Wire/API/Team/Member.hs index 28c72a3808b..812c63c000d 100644 --- a/libs/wire-api/src/Wire/API/Team/Member.hs +++ b/libs/wire-api/src/Wire/API/Team/Member.hs @@ -117,11 +117,11 @@ data TeamMember' (tag :: PermissionTag) = TeamMember ntmNewTeamMember :: NewTeamMember' tag -> TeamMember' tag ntmNewTeamMember ntm = TeamMember ntm defUserLegalHoldStatus -deriving instance Eq (PermissionType tag) => Eq (TeamMember' tag) +deriving instance (Eq (PermissionType tag)) => Eq (TeamMember' tag) -deriving instance Ord (PermissionType tag) => Ord (TeamMember' tag) +deriving instance (Ord (PermissionType tag)) => Ord (TeamMember' tag) -deriving instance Show (PermissionType tag) => Show (TeamMember' tag) +deriving instance (Show (PermissionType tag)) => Show (TeamMember' tag) deriving via (GenericUniform TeamMember) instance Arbitrary TeamMember @@ -243,9 +243,9 @@ data TeamMemberList' (tag :: PermissionTag) = TeamMemberList } deriving stock (Generic) -deriving instance Eq (PermissionType tag) => Eq (TeamMemberList' tag) +deriving instance (Eq (PermissionType tag)) => Eq (TeamMemberList' tag) -deriving instance Show (PermissionType tag) => Show (TeamMemberList' tag) +deriving instance (Show (PermissionType tag)) => Show (TeamMemberList' tag) deriving via (GenericUniform (TeamMemberList' 'Optional)) instance Arbitrary (TeamMemberList' 'Optional) @@ -254,13 +254,13 @@ deriving via (GenericUniform TeamMemberList) instance Arbitrary TeamMemberList deriving via (Schema (TeamMemberList' tag)) instance - ToSchema (TeamMemberList' tag) => + (ToSchema (TeamMemberList' tag)) => FromJSON (TeamMemberList' tag) deriving via (Schema (TeamMemberList' tag)) instance - ToSchema (TeamMemberList' tag) => + (ToSchema (TeamMemberList' tag)) => ToJSON (TeamMemberList' tag) deriving via @@ -272,7 +272,7 @@ deriving via newTeamMemberList :: [TeamMember] -> ListType -> TeamMemberList newTeamMemberList = TeamMemberList -instance ToSchema (TeamMember' tag) => ToSchema (TeamMemberList' tag) where +instance (ToSchema (TeamMember' tag)) => ToSchema (TeamMemberList' tag) where schema = objectWithDocModifier "TeamMemberList" (description ?~ "list of team member") $ TeamMemberList diff --git a/libs/wire-api/src/Wire/API/Team/Role.hs b/libs/wire-api/src/Wire/API/Team/Role.hs index d4602394750..8b1060f3a7c 100644 --- a/libs/wire-api/src/Wire/API/Team/Role.hs +++ b/libs/wire-api/src/Wire/API/Team/Role.hs @@ -102,7 +102,7 @@ instance FromHttpApiData Role where flip foldMap [minBound .. maxBound] $ \s -> guard (T.pack (show s) == name) $> s -roleName :: IsString a => Role -> a +roleName :: (IsString a) => Role -> a roleName RoleOwner = "owner" roleName RoleAdmin = "admin" roleName RoleMember = "member" diff --git a/libs/wire-api/src/Wire/API/User.hs b/libs/wire-api/src/Wire/API/User.hs index f74380e1dd0..e24f63536f1 100644 --- a/libs/wire-api/src/Wire/API/User.hs +++ b/libs/wire-api/src/Wire/API/User.hs @@ -37,7 +37,6 @@ module Wire.API.User User (..), userId, userEmail, - userPhone, userSSOId, userIssuer, userSCIMExternalId, @@ -66,7 +65,6 @@ module Wire.API.User newUserInvitationCode, newUserTeam, newUserEmail, - newUserPhone, newUserSSOId, isNewUserEphemeral, isNewUserTeamMember, @@ -124,13 +122,6 @@ module Wire.API.User GetActivationCodeResp (..), GetPasswordResetCodeResp (..), CheckBlacklistResponse (..), - GetPhonePrefixResponse (..), - PhonePrefix (..), - parsePhonePrefix, - isValidPhonePrefix, - allPrefixes, - ExcludedPrefix (..), - PhoneBudgetTimeout (..), ManagedByUpdate (..), HavePendingInvitations (..), RichInfoUpdate (..), @@ -143,6 +134,7 @@ module Wire.API.User EmailVisibilityConfigWithViewer, -- * re-exports + module Wire.API.Locale, module Wire.API.User.Identity, module Wire.API.User.Profile, @@ -168,8 +160,6 @@ import Control.Lens (makePrisms, over, view, (.~), (?~), (^.)) import Data.Aeson (FromJSON (..), ToJSON (..), withText) import Data.Aeson.Types qualified as A import Data.Attoparsec.ByteString qualified as Parser -import Data.Attoparsec.Text qualified as TParser -import Data.Bifunctor qualified as Bifunctor import Data.Bits import Data.ByteString (toStrict) import Data.ByteString.Builder (toLazyByteString) @@ -197,7 +187,6 @@ import Data.Text qualified as T import Data.Text.Ascii import Data.Text.Encoding qualified as T import Data.Text.Encoding.Error -import Data.Time.Clock (NominalDiffTime) import Data.UUID (UUID, nil) import Data.UUID qualified as UUID import Deriving.Swagger @@ -214,6 +203,7 @@ import Wire.API.Conversation.Protocol import Wire.API.Error import Wire.API.Error.Brig import Wire.API.Error.Brig qualified as E +import Wire.API.Locale import Wire.API.Provider.Service (ServiceRef) import Wire.API.Routes.MultiVerb import Wire.API.Team (BindingNewTeam, bindingNewTeamObjectSchema) @@ -309,117 +299,6 @@ instance fromUnion (S (Z (I ()))) = YesBlacklisted fromUnion (S (S x)) = case x of {} -data GetPhonePrefixResponse = PhonePrefixNotFound | PhonePrefixesFound [ExcludedPrefix] - -instance - AsUnion - '[ RespondEmpty 404 "PhonePrefixNotFound", - Respond 200 "PhonePrefixesFound" [ExcludedPrefix] - ] - GetPhonePrefixResponse - where - toUnion PhonePrefixNotFound = Z (I ()) - toUnion (PhonePrefixesFound pfxs) = S (Z (I pfxs)) - fromUnion (Z (I ())) = PhonePrefixNotFound - fromUnion (S (Z (I pfxs))) = PhonePrefixesFound pfxs - fromUnion (S (S x)) = case x of {} - --- | PhonePrefix (for excluding from SMS/calling) -newtype PhonePrefix = PhonePrefix {fromPhonePrefix :: Text} - deriving (Eq, Show, Generic) - deriving (FromJSON, ToJSON, S.ToSchema) via Schema PhonePrefix - -instance Arbitrary PhonePrefix where - arbitrary = do - digits <- take 8 <$> QC.listOf1 (QC.elements ['0' .. '9']) - pure . PhonePrefix . T.pack $ "+" <> digits - -instance ToSchema PhonePrefix where - schema = fromPhonePrefix .= parsedText "PhonePrefix" phonePrefixParser - -instance S.ToParamSchema PhonePrefix where - toParamSchema _ = S.toParamSchema (Proxy @String) - -instance FromByteString PhonePrefix where - parser = parser >>= maybe (fail "Invalid phone") pure . parsePhonePrefix - -instance ToByteString PhonePrefix where - builder = builder . fromPhonePrefix - -instance FromHttpApiData PhonePrefix where - parseUrlPiece = Bifunctor.first T.pack . phonePrefixParser - -deriving instance C.Cql PhonePrefix - -phonePrefixParser :: Text -> Either String PhonePrefix -phonePrefixParser p = maybe err pure (parsePhonePrefix p) - where - err = - Left $ - "Invalid phone number prefix: [" - ++ show p - ++ "]. Expected format similar to E.164 (with 1-15 digits after the +)." - --- | Parses a phone number prefix with a mandatory leading '+'. -parsePhonePrefix :: Text -> Maybe PhonePrefix -parsePhonePrefix p - | isValidPhonePrefix p = Just $ PhonePrefix p - | otherwise = Nothing - --- | Checks whether a phone number prefix is valid, --- i.e. it is like a E.164 format phone number, but shorter --- (with a mandatory leading '+', followed by 1-15 digits.) -isValidPhonePrefix :: Text -> Bool -isValidPhonePrefix = isRight . TParser.parseOnly e164Prefix - where - e164Prefix :: TParser.Parser () - e164Prefix = - TParser.char '+' - *> TParser.count 1 TParser.digit - *> TParser.count 14 (optional TParser.digit) - *> TParser.endOfInput - --- | get all valid prefixes of a phone number or phone number prefix --- e.g. from +123456789 get prefixes ["+1", "+12", "+123", ..., "+123456789" ] -allPrefixes :: Text -> [PhonePrefix] -allPrefixes t = mapMaybe parsePhonePrefix (T.inits t) - -data ExcludedPrefix = ExcludedPrefix - { phonePrefix :: PhonePrefix, - comment :: Text - } - deriving (Eq, Show, Generic) - deriving (FromJSON, ToJSON, S.ToSchema) via Schema ExcludedPrefix - -instance ToSchema ExcludedPrefix where - schema = - object "ExcludedPrefix" $ - ExcludedPrefix - <$> phonePrefix .= field "phone_prefix" schema - <*> comment .= field "comment" schema - --- | If the budget for SMS and voice calls for a phone number --- has been exhausted within a certain time frame, this timeout --- indicates in seconds when another attempt may be made. -newtype PhoneBudgetTimeout = PhoneBudgetTimeout - {phoneBudgetTimeout :: NominalDiffTime} - deriving (Eq, Show, Generic) - deriving newtype (Arbitrary) - deriving (FromJSON, ToJSON, S.ToSchema) via Schema PhoneBudgetTimeout - -instance ToSchema PhoneBudgetTimeout where - schema = - object "PhoneBudgetTimeout" $ - PhoneBudgetTimeout - <$> phoneBudgetTimeout .= field "expires_in" nominalDiffTimeSchema - --- | (32bit precision) -nominalDiffTimeSchema :: ValueSchema NamedSwaggerDoc NominalDiffTime -nominalDiffTimeSchema = fromIntegral <$> roundDiffTime .= schema - where - roundDiffTime :: NominalDiffTime -> Int32 - roundDiffTime = round - newtype ManagedByUpdate = ManagedByUpdate {mbuManagedBy :: ManagedBy} deriving (Eq, Show, Generic) deriving newtype (Arbitrary) @@ -588,7 +467,7 @@ instance (KnownNat max, 1 <= max) => FromJSON (LimitedQualifiedUserIdList max) w parseJSON = A.withObject "LimitedQualifiedUserIdList" $ \o -> LimitedQualifiedUserIdList <$> o A..: "qualified_users" -instance 1 <= max => ToJSON (LimitedQualifiedUserIdList max) where +instance (1 <= max) => ToJSON (LimitedQualifiedUserIdList max) where toJSON e = A.object ["qualified_users" A..= qualifiedUsers e] -------------------------------------------------------------------------------- @@ -750,9 +629,6 @@ userObjectSchema = userEmail :: User -> Maybe Email userEmail = emailIdentity <=< userIdentity -userPhone :: User -> Maybe Phone -userPhone = phoneIdentity <=< userIdentity - userSSOId :: User -> Maybe UserSSOId userSSOId = ssoIdentity <=< userIdentity @@ -907,7 +783,6 @@ data RegisterError | RegisterErrorInvalidActivationCodeWrongCode | RegisterErrorInvalidEmail | RegisterErrorInvalidPhone - | RegisterErrorBlacklistedPhone | RegisterErrorBlacklistedEmail | RegisterErrorTooManyTeamMembers | RegisterErrorUserCreationRestricted @@ -925,7 +800,6 @@ type RegisterErrorResponses = ErrorResponse 'InvalidActivationCodeWrongCode, ErrorResponse 'InvalidEmail, ErrorResponse 'InvalidPhone, - ErrorResponse 'BlacklistedPhone, ErrorResponse 'BlacklistedEmail, ErrorResponse 'TooManyTeamMembers, ErrorResponse 'UserCreationRestricted @@ -1066,7 +940,8 @@ newUserFromSpar new = NewUser { newUserDisplayName = newUserSparDisplayName new, newUserUUID = Just $ newUserSparUUID new, - newUserIdentity = Just $ SSOIdentity (newUserSparSSOId new) Nothing Nothing, + newUserIdentity = Just $ SSOIdentity (newUserSparSSOId new) Nothing, + newUserPhone = Nothing, newUserPict = Nothing, newUserAssets = [], newUserAccentId = Nothing, @@ -1086,6 +961,7 @@ data NewUser = NewUser -- | use this as 'UserId' (if 'Nothing', call 'Data.UUID.nextRandom'). newUserUUID :: Maybe UUID, newUserIdentity :: Maybe UserIdentity, + newUserPhone :: Maybe Phone, -- | DEPRECATED newUserPict :: Maybe Pict, newUserAssets :: [Asset], @@ -1109,6 +985,7 @@ emptyNewUser name = { newUserDisplayName = name, newUserUUID = Nothing, newUserIdentity = Nothing, + newUserPhone = Nothing, newUserPict = Nothing, newUserAssets = [], newUserAccentId = Nothing, @@ -1131,6 +1008,7 @@ data NewUserRaw = NewUserRaw { newUserRawDisplayName :: Name, newUserRawUUID :: Maybe UUID, newUserRawEmail :: Maybe Email, + -- | This is deprecated and it should always be 'Nothing'. newUserRawPhone :: Maybe Phone, newUserRawSSOId :: Maybe UserSSOId, -- | DEPRECATED @@ -1138,6 +1016,7 @@ data NewUserRaw = NewUserRaw newUserRawAssets :: [Asset], newUserRawAccentId :: Maybe ColourId, newUserRawEmailCode :: Maybe ActivationCode, + -- | This is deprecated and it should always be 'Nothing'. newUserRawPhoneCode :: Maybe ActivationCode, newUserRawInvitationCode :: Maybe InvitationCode, newUserRawTeamCode :: Maybe InvitationCode, @@ -1206,7 +1085,7 @@ newUserToRaw NewUser {..} = { newUserRawDisplayName = newUserDisplayName, newUserRawUUID = newUserUUID, newUserRawEmail = emailIdentity =<< newUserIdentity, - newUserRawPhone = phoneIdentity =<< newUserIdentity, + newUserRawPhone = newUserPhone, newUserRawSSOId = ssoIdentity =<< newUserIdentity, newUserRawPict = newUserPict, newUserRawAssets = newUserAssets, @@ -1233,7 +1112,9 @@ newUserFromRaw NewUserRaw {..} = do (isJust newUserRawPassword) (isJust newUserRawSSOId) (newUserRawInvitationCode, newUserRawTeamCode, newUserRawTeam, newUserRawTeamId) - let identity = maybeUserIdentityFromComponents (newUserRawEmail, newUserRawPhone, newUserRawSSOId) + let identity = + maybeUserIdentityFromComponents + (newUserRawEmail, newUserRawSSOId) expiresIn <- case (newUserRawExpiresIn, identity) of (Just _, Just _) -> fail "Only users without an identity can expire" @@ -1243,6 +1124,7 @@ newUserFromRaw NewUserRaw {..} = do { newUserDisplayName = newUserRawDisplayName, newUserUUID = newUserRawUUID, newUserIdentity = identity, + newUserPhone = newUserRawPhone, newUserPict = newUserRawPict, newUserAssets = newUserRawAssets, newUserAccentId = newUserRawAccentId, @@ -1261,6 +1143,7 @@ newUserFromRaw NewUserRaw {..} = do instance Arbitrary NewUser where arbitrary = do newUserIdentity <- arbitrary + newUserPhone <- arbitrary newUserOrigin <- genUserOrigin newUserIdentity newUserDisplayName <- arbitrary newUserUUID <- QC.elements [Just nil, Nothing] @@ -1312,9 +1195,6 @@ newUserTeam nu = case newUserOrigin nu of newUserEmail :: NewUser -> Maybe Email newUserEmail = emailIdentity <=< newUserIdentity -newUserPhone :: NewUser -> Maybe Phone -newUserPhone = phoneIdentity <=< newUserIdentity - newUserSSOId :: NewUser -> Maybe UserSSOId newUserSSOId = ssoIdentity <=< newUserIdentity @@ -1618,7 +1498,6 @@ instance ToSchema PhoneUpdate where data ChangePhoneError = PhoneExists | InvalidNewPhone - | BlacklistedNewPhone deriving (Generic) deriving (AsUnion ChangePhoneErrorResponses) via GenericAsUnion ChangePhoneErrorResponses ChangePhoneError @@ -1626,8 +1505,7 @@ instance GSOP.Generic ChangePhoneError type ChangePhoneErrorResponses = [ ErrorResponse 'UserKeyExists, - ErrorResponse 'InvalidPhone, - ErrorResponse 'BlacklistedPhone + ErrorResponse 'InvalidPhone ] type ChangePhoneResponses = @@ -2045,7 +1923,7 @@ instance ToSchema SendVerificationCode where -- Unlike 'ProtocolTag', this does not include any transitional protocols used -- for migration. data BaseProtocolTag = BaseProtocolProteusTag | BaseProtocolMLSTag - deriving stock (Eq, Ord, Show, Generic) + deriving stock (Eq, Ord, Enum, Bounded, Show, Generic) deriving (Arbitrary) via (GenericUniform BaseProtocolTag) deriving (FromJSON, ToJSON, S.ToSchema) via (Schema BaseProtocolTag) diff --git a/libs/wire-api/src/Wire/API/User/Activation.hs b/libs/wire-api/src/Wire/API/User/Activation.hs index 8998854b2e2..ff21fc57ac7 100644 --- a/libs/wire-api/src/Wire/API/User/Activation.hs +++ b/libs/wire-api/src/Wire/API/User/Activation.hs @@ -48,8 +48,8 @@ import Data.Text.Ascii import Data.Tuple.Extra (fst3, snd3, thd3) import Imports import Servant (FromHttpApiData (..)) +import Wire.API.Locale import Wire.API.User.Identity -import Wire.API.User.Profile import Wire.Arbitrary (Arbitrary, GenericUniform (..)) -------------------------------------------------------------------------------- @@ -57,7 +57,7 @@ import Wire.Arbitrary (Arbitrary, GenericUniform (..)) -- | The target of an activation request. data ActivationTarget - = -- | An opaque key for some email or phone number awaiting activation. + = -- | An opaque key for some email awaiting activation. ActivateKey ActivationKey | -- | A known phone number awaiting activation. ActivatePhone Phone diff --git a/libs/wire-api/src/Wire/API/User/Auth.hs b/libs/wire-api/src/Wire/API/User/Auth.hs index 135c1cb89ba..ad49c8be0b8 100644 --- a/libs/wire-api/src/Wire/API/User/Auth.hs +++ b/libs/wire-api/src/Wire/API/User/Auth.hs @@ -38,6 +38,7 @@ module Wire.API.User.Auth Cookie (..), CookieLabel (..), RemoveCookies (..), + toUnitCookie, -- * Token AccessToken (..), @@ -59,6 +60,7 @@ module Wire.API.User.Auth ) where +import Cassandra import Control.Applicative import Control.Lens ((?~), (^.)) import Control.Lens.TH @@ -69,6 +71,7 @@ import Data.ByteString.Builder import Data.ByteString.Conversion import Data.ByteString.Lazy qualified as LBS import Data.Code as Code +import Data.Functor.Alt import Data.Handle (Handle) import Data.Id import Data.Json.Util @@ -125,7 +128,9 @@ loginObjectSchema = validate :: (Maybe Email, Maybe Phone, Maybe Handle) -> A.Parser LoginId validate (mEmail, mPhone, mHandle) = maybe (fail "'email', 'phone' or 'handle' required") pure $ - (LoginByEmail <$> mEmail) <|> (LoginByPhone <$> mPhone) <|> (LoginByHandle <$> mHandle) + (LoginByEmail <$> mEmail) + <|> (LoginByPhone <$> mPhone) + <|> (LoginByHandle <$> mHandle) -------------------------------------------------------------------------------- -- LoginCode @@ -137,6 +142,8 @@ newtype LoginCode = LoginCode deriving newtype (Arbitrary) deriving (FromJSON, ToJSON, S.ToSchema) via Schema LoginCode +deriving instance Cql LoginCode + instance ToSchema LoginCode where schema = LoginCode <$> fromLoginCode .= text "LoginCode" @@ -278,11 +285,20 @@ newtype CookieLabel = CookieLabel ToSchema ) +deriving instance Cql CookieLabel + newtype CookieId = CookieId {cookieIdNum :: Word32} deriving stock (Eq, Show, Generic) deriving newtype (ToSchema, FromJSON, ToJSON, Arbitrary) +instance Cql CookieId where + ctype = Cassandra.Tagged BigIntColumn + toCql = CqlBigInt . fromIntegral . cookieIdNum + + fromCql (CqlBigInt i) = pure (CookieId (fromIntegral i)) + fromCql _ = Left "fromCql: invalid cookie id" + data CookieType = -- | A session cookie. These are mainly intended for clients -- that are web browsers. For other clients, session cookies @@ -298,12 +314,25 @@ data CookieType deriving (Arbitrary) via (GenericUniform CookieType) deriving (FromJSON, ToJSON, S.ToSchema) via Schema CookieType +instance Cql CookieType where + ctype = Cassandra.Tagged IntColumn + + toCql SessionCookie = CqlInt 0 + toCql PersistentCookie = CqlInt 1 + + fromCql (CqlInt 0) = pure SessionCookie + fromCql (CqlInt 1) = pure PersistentCookie + fromCql _ = Left "fromCql: invalid cookie type" + instance ToSchema CookieType where schema = enum @Text "CookieType" $ element "session" SessionCookie <> element "persistent" PersistentCookie +toUnitCookie :: Cookie a -> Cookie () +toUnitCookie c = c {cookieValue = ()} + -------------------------------------------------------------------------------- -- Login @@ -504,7 +533,7 @@ instance FromHttpApiData SomeUserToken where parseHeader h = first T.pack $ fmap PlainUserToken (runParser parser h) - <|> fmap LHUserToken (runParser parser h) + fmap LHUserToken (runParser parser h) parseUrlPiece = parseHeader . T.encodeUtf8 instance FromByteString SomeUserToken where @@ -525,7 +554,7 @@ instance FromHttpApiData SomeAccessToken where parseHeader h = first T.pack $ fmap PlainAccessToken (runParser parser h) - <|> fmap LHAccessToken (runParser parser h) + fmap LHAccessToken (runParser parser h) parseUrlPiece = parseHeader . T.encodeUtf8 -- | Data that is returned to the client in the form of a cookie containing a diff --git a/libs/wire-api/src/Wire/API/User/Client.hs b/libs/wire-api/src/Wire/API/User/Client.hs index ecdc20531bd..35bbde4892d 100644 --- a/libs/wire-api/src/Wire/API/User/Client.hs +++ b/libs/wire-api/src/Wire/API/User/Client.hs @@ -180,7 +180,7 @@ instance ToSchema ClientCapabilityList where ClientCapabilityList <$> fromClientCapabilityList .= fmap runIdentity capabilitiesFieldSchema capabilitiesFieldSchema :: - FieldFunctor SwaggerDoc f => + (FieldFunctor SwaggerDoc f) => ObjectSchemaP SwaggerDoc (Set ClientCapability) (f (Set ClientCapability)) capabilitiesFieldSchema = Set.toList @@ -201,7 +201,7 @@ newtype UserClientMap a = UserClientMap deriving newtype (Semigroup, Monoid) deriving (FromJSON, ToJSON, Swagger.ToSchema) via Schema (UserClientMap a) -instance ToSchema a => ToSchema (UserClientMap a) where +instance (ToSchema a) => ToSchema (UserClientMap a) where schema = userClientMapSchema schema class WrapName doc where @@ -247,7 +247,7 @@ instance ToSchema UserClientPrekeyMap where ) ) -instance Arbitrary a => Arbitrary (UserClientMap a) where +instance (Arbitrary a) => Arbitrary (UserClientMap a) where arbitrary = UserClientMap <$> mapOf' arbitrary (mapOf' arbitrary arbitrary) newtype QualifiedUserClientMap a = QualifiedUserClientMap @@ -256,17 +256,17 @@ newtype QualifiedUserClientMap a = QualifiedUserClientMap deriving stock (Eq, Show, Functor) deriving (FromJSON, ToJSON, Swagger.ToSchema) via Schema (QualifiedUserClientMap a) -instance Semigroup a => Semigroup (QualifiedUserClientMap a) where +instance (Semigroup a) => Semigroup (QualifiedUserClientMap a) where (QualifiedUserClientMap m1) <> (QualifiedUserClientMap m2) = QualifiedUserClientMap $ Map.unionWith (Map.unionWith (Map.unionWith (<>))) m1 m2 -instance Semigroup (QualifiedUserClientMap a) => Monoid (QualifiedUserClientMap a) where +instance (Semigroup (QualifiedUserClientMap a)) => Monoid (QualifiedUserClientMap a) where mempty = QualifiedUserClientMap mempty -instance Arbitrary a => Arbitrary (QualifiedUserClientMap a) where +instance (Arbitrary a) => Arbitrary (QualifiedUserClientMap a) where arbitrary = QualifiedUserClientMap <$> mapOf' arbitrary (mapOf' arbitrary (mapOf' arbitrary arbitrary)) -instance ToSchema a => ToSchema (QualifiedUserClientMap a) where +instance (ToSchema a) => ToSchema (QualifiedUserClientMap a) where schema = qualifiedUserClientMapSchema schema qualifiedUserClientMapSchema :: diff --git a/libs/wire-api/src/Wire/API/User/Client/Prekey.hs b/libs/wire-api/src/Wire/API/User/Client/Prekey.hs index 9447da1b530..1a8c1edf9b5 100644 --- a/libs/wire-api/src/Wire/API/User/Client/Prekey.hs +++ b/libs/wire-api/src/Wire/API/User/Client/Prekey.hs @@ -94,8 +94,9 @@ instance ToSchema LastPrekey where schema = LastPrekey <$> unpackLastPrekey .= schema `withParser` check where check x = - x <$ guard (prekeyId x == lastPrekeyId) - <|> fail "Invalid last prekey ID" + x + <$ guard (prekeyId x == lastPrekeyId) + <|> fail "Invalid last prekey ID" instance Arbitrary LastPrekey where arbitrary = lastPrekey <$> arbitrary diff --git a/libs/wire-api/src/Wire/API/User/Identity.hs b/libs/wire-api/src/Wire/API/User/Identity.hs index 217c55d5864..b96ad4135fa 100644 --- a/libs/wire-api/src/Wire/API/User/Identity.hs +++ b/libs/wire-api/src/Wire/API/User/Identity.hs @@ -22,9 +22,9 @@ module Wire.API.User.Identity ( -- * UserIdentity UserIdentity (..), + isSSOIdentity, newIdentity, emailIdentity, - phoneIdentity, ssoIdentity, userIdentityObjectSchema, maybeUserIdentityObjectSchema, @@ -54,6 +54,7 @@ where import Cassandra qualified as C import Control.Applicative (optional) +import Control.Error (hush) import Control.Lens (dimap, over, (.~), (?~), (^.)) import Data.Aeson (FromJSON (..), ToJSON (..)) import Data.Aeson qualified as A @@ -71,8 +72,6 @@ import Data.Text qualified as Text import Data.Text.Encoding import Data.Text.Encoding.Error import Data.Text.Lazy qualified as LT -import Data.Time.Clock -import Data.Tuple.Extra (fst3, snd3, thd3) import Imports import SAML2.WebSSO (UserRef (..)) import SAML2.WebSSO.Test.Arbitrary () @@ -95,68 +94,54 @@ import Wire.Arbitrary (Arbitrary (arbitrary), GenericUniform (..)) -- | The private unique user identity that is used for login and -- account recovery. data UserIdentity - = FullIdentity Email Phone - | EmailIdentity Email - | PhoneIdentity Phone - | SSOIdentity UserSSOId (Maybe Email) (Maybe Phone) + = EmailIdentity Email + | SSOIdentity UserSSOId (Maybe Email) deriving stock (Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform UserIdentity) +isSSOIdentity :: UserIdentity -> Bool +isSSOIdentity (SSOIdentity _ _) = True +isSSOIdentity _ = False + userIdentityObjectSchema :: ObjectSchema SwaggerDoc UserIdentity userIdentityObjectSchema = - Just .= withParser maybeUserIdentityObjectSchema (maybe (fail "Missing 'email' or 'phone' or 'sso_id'.") pure) + Just .= withParser maybeUserIdentityObjectSchema (maybe (fail "Missing 'email' or 'sso_id'.") pure) maybeUserIdentityObjectSchema :: ObjectSchema SwaggerDoc (Maybe UserIdentity) maybeUserIdentityObjectSchema = dimap maybeUserIdentityToComponents maybeUserIdentityFromComponents userIdentityComponentsObjectSchema -type UserIdentityComponents = (Maybe Email, Maybe Phone, Maybe UserSSOId) +type UserIdentityComponents = (Maybe Email, Maybe UserSSOId) userIdentityComponentsObjectSchema :: ObjectSchema SwaggerDoc UserIdentityComponents userIdentityComponentsObjectSchema = - (,,) - <$> fst3 .= maybe_ (optField "email" schema) - <*> snd3 .= maybe_ (optField "phone" schema) - <*> thd3 .= maybe_ (optField "sso_id" genericToSchema) + (,) + <$> fst .= maybe_ (optField "email" schema) + <*> snd .= maybe_ (optField "sso_id" genericToSchema) maybeUserIdentityFromComponents :: UserIdentityComponents -> Maybe UserIdentity maybeUserIdentityFromComponents = \case - (maybeEmail, maybePhone, Just ssoid) -> Just $ SSOIdentity ssoid maybeEmail maybePhone - (Just email, Just phone, Nothing) -> Just $ FullIdentity email phone - (Just email, Nothing, Nothing) -> Just $ EmailIdentity email - (Nothing, Just phone, Nothing) -> Just $ PhoneIdentity phone - (Nothing, Nothing, Nothing) -> Nothing + (maybeEmail, Just ssoid) -> Just $ SSOIdentity ssoid maybeEmail + (Just email, Nothing) -> Just $ EmailIdentity email + (Nothing, Nothing) -> Nothing maybeUserIdentityToComponents :: Maybe UserIdentity -> UserIdentityComponents -maybeUserIdentityToComponents Nothing = (Nothing, Nothing, Nothing) -maybeUserIdentityToComponents (Just (FullIdentity email phone)) = (Just email, Just phone, Nothing) -maybeUserIdentityToComponents (Just (EmailIdentity email)) = (Just email, Nothing, Nothing) -maybeUserIdentityToComponents (Just (PhoneIdentity phone)) = (Nothing, Just phone, Nothing) -maybeUserIdentityToComponents (Just (SSOIdentity ssoid m_email m_phone)) = (m_email, m_phone, Just ssoid) - -newIdentity :: Maybe Email -> Maybe Phone -> Maybe UserSSOId -> Maybe UserIdentity -newIdentity email phone (Just sso) = Just $! SSOIdentity sso email phone -newIdentity Nothing Nothing Nothing = Nothing -newIdentity (Just e) Nothing Nothing = Just $! EmailIdentity e -newIdentity Nothing (Just p) Nothing = Just $! PhoneIdentity p -newIdentity (Just e) (Just p) Nothing = Just $! FullIdentity e p +maybeUserIdentityToComponents Nothing = (Nothing, Nothing) +maybeUserIdentityToComponents (Just (EmailIdentity email)) = (Just email, Nothing) +maybeUserIdentityToComponents (Just (SSOIdentity ssoid m_email)) = (m_email, Just ssoid) + +newIdentity :: Maybe Email -> Maybe UserSSOId -> Maybe UserIdentity +newIdentity email (Just sso) = Just $! SSOIdentity sso email +newIdentity (Just e) Nothing = Just $! EmailIdentity e +newIdentity Nothing Nothing = Nothing emailIdentity :: UserIdentity -> Maybe Email -emailIdentity (FullIdentity email _) = Just email emailIdentity (EmailIdentity email) = Just email -emailIdentity (PhoneIdentity _) = Nothing -emailIdentity (SSOIdentity _ (Just email) _) = Just email -emailIdentity (SSOIdentity _ Nothing _) = Nothing - -phoneIdentity :: UserIdentity -> Maybe Phone -phoneIdentity (FullIdentity _ phone) = Just phone -phoneIdentity (PhoneIdentity phone) = Just phone -phoneIdentity (EmailIdentity _) = Nothing -phoneIdentity (SSOIdentity _ _ (Just phone)) = Just phone -phoneIdentity (SSOIdentity _ _ Nothing) = Nothing +emailIdentity (SSOIdentity _ (Just email)) = Just email +emailIdentity (SSOIdentity _ _) = Nothing ssoIdentity :: UserIdentity -> Maybe UserSSOId -ssoIdentity (SSOIdentity ssoid _ _) = Just ssoid +ssoIdentity (SSOIdentity ssoid _) = Just ssoid ssoIdentity _ = Nothing -------------------------------------------------------------------------------- @@ -237,10 +222,12 @@ parseEmail t = case Text.split (== '@') t of -- is the dependency worth it just for validating the local part? validateEmail :: Email -> Either String Email validateEmail = - pure . uncurry Email + pure + . uncurry Email <=< validateDomain <=< validateExternalLib - <=< validateLength . fromEmail + <=< validateLength + . fromEmail where validateLength e | len <= 100 = Right e @@ -277,7 +264,8 @@ instance ToParamSchema Phone where instance ToSchema Phone where schema = over doc (S.description ?~ "E.164 phone number") $ - fromPhone .= parsedText "PhoneNumber" (maybe (Left "Invalid phone number. Expected E.164 format.") Right . parsePhone) + fromPhone + .= parsedText "PhoneNumber" (maybe (Left "Invalid phone number. Expected E.164 format.") Right . parsePhone) instance ToByteString Phone where builder = builder . fromPhone @@ -366,7 +354,8 @@ instance S.ToSchema UserSSOId where pure $ S.NamedSchema (Just "UserSSOId") $ mempty - & S.type_ ?~ S.OpenApiObject + & S.type_ + ?~ S.OpenApiObject & S.properties .~ [ ("tenant", tenantSchema), ("subject", subjectSchema), @@ -388,21 +377,6 @@ instance FromJSON UserSSOId where (Nothing, Nothing, Just eid) -> pure $ UserScimExternalId eid _ -> fail "either need tenant and subject, or scim_external_id, but not both" --- | If the budget for SMS and voice calls for a phone number --- has been exhausted within a certain time frame, this timeout --- indicates in seconds when another attempt may be made. -newtype PhoneBudgetTimeout = PhoneBudgetTimeout - {phoneBudgetTimeout :: NominalDiffTime} - deriving stock (Eq, Show, Generic) - deriving newtype (Arbitrary) - -instance FromJSON PhoneBudgetTimeout where - parseJSON = A.withObject "PhoneBudgetTimeout" $ \o -> - PhoneBudgetTimeout <$> o A..: "expires_in" - -instance ToJSON PhoneBudgetTimeout where - toJSON (PhoneBudgetTimeout t) = A.object ["expires_in" A..= t] - lenientlyParseSAMLIssuer :: Maybe LText -> A.Parser (Maybe SAML.Issuer) lenientlyParseSAMLIssuer mbtxt = forM mbtxt $ \txt -> do let asxml :: Either String SAML.Issuer @@ -416,7 +390,7 @@ lenientlyParseSAMLIssuer mbtxt = forM mbtxt $ \txt -> do err :: String err = "lenientlyParseSAMLIssuer: " <> show (asxml, asurl, mbtxt) - either (const $ fail err) pure $ asxml <|> asurl + maybe (fail err) pure $ hush asxml <|> hush asurl lenientlyParseSAMLNameID :: Maybe LText -> A.Parser (Maybe SAML.NameID) lenientlyParseSAMLNameID Nothing = pure Nothing @@ -439,23 +413,23 @@ lenientlyParseSAMLNameID (Just txt) = do err :: String err = "lenientlyParseSAMLNameID: " <> show (asxml, asemail, astxt, txt) - either - (const $ fail err) + maybe + (fail err) (pure . Just) - (asxml <|> asemail <|> astxt) + (hush asxml <|> hush asemail <|> hush astxt) -emailFromSAML :: HasCallStack => SAMLEmail.Email -> Email +emailFromSAML :: (HasCallStack) => SAMLEmail.Email -> Email emailFromSAML = fromJust . parseEmail . SAMLEmail.render -emailToSAML :: HasCallStack => Email -> SAMLEmail.Email +emailToSAML :: (HasCallStack) => Email -> SAMLEmail.Email emailToSAML = CI.original . fromRight (error "emailToSAML") . SAMLEmail.validate . toByteString -- | FUTUREWORK(fisx): if saml2-web-sso exported the 'NameID' constructor, we could make this -- function total without all that praying and hoping. -emailToSAMLNameID :: HasCallStack => Email -> SAML.NameID +emailToSAMLNameID :: (HasCallStack) => Email -> SAML.NameID emailToSAMLNameID = fromRight (error "impossible") . SAML.emailNameID . fromEmail -emailFromSAMLNameID :: HasCallStack => SAML.NameID -> Maybe Email +emailFromSAMLNameID :: (HasCallStack) => SAML.NameID -> Maybe Email emailFromSAMLNameID nid = case nid ^. SAML.nameID of SAML.UNameIDEmail email -> Just . emailFromSAML . CI.original $ email _ -> Nothing diff --git a/libs/wire-api/src/Wire/API/User/IdentityProvider.hs b/libs/wire-api/src/Wire/API/User/IdentityProvider.hs index 544e8718685..9100be731e2 100644 --- a/libs/wire-api/src/Wire/API/User/IdentityProvider.hs +++ b/libs/wire-api/src/Wire/API/User/IdentityProvider.hs @@ -21,7 +21,6 @@ module Wire.API.User.IdentityProvider where import Cassandra qualified as Cql import Control.Lens (makeLenses, (.~), (?~)) -import Control.Monad.Except import Data.Aeson import Data.Aeson.TH import Data.Aeson.Types (parseMaybe) @@ -211,10 +210,14 @@ instance ToSchema IdPMetadataInfo where pure $ NamedSchema (Just "IdPMetadataInfo") $ mempty - & properties .~ properties_ - & minProperties ?~ 1 - & maxProperties ?~ 1 - & type_ ?~ OpenApiObject + & properties + .~ properties_ + & minProperties + ?~ 1 + & maxProperties + ?~ 1 + & type_ + ?~ OpenApiObject where properties_ :: InsOrdHashMap Text (Referenced Schema) properties_ = diff --git a/libs/wire-api/src/Wire/API/User/Orphans.hs b/libs/wire-api/src/Wire/API/User/Orphans.hs index 5cb2e0225db..0f019fdc1f9 100644 --- a/libs/wire-api/src/Wire/API/User/Orphans.hs +++ b/libs/wire-api/src/Wire/API/User/Orphans.hs @@ -114,13 +114,13 @@ instance ToSchema SAML.SPMetadata where instance ToSchema Void where declareNamedSchema _ = declareNamedSchema (Proxy @String) -instance HasOpenApi route => HasOpenApi (SM.MultipartForm SM.Mem resp :> route) where +instance (HasOpenApi route) => HasOpenApi (SM.MultipartForm SM.Mem resp :> route) where toOpenApi _proxy = toOpenApi (Proxy @route) instance ToSchema SAML.IdPId where declareNamedSchema _ = declareNamedSchema (Proxy @UUID) -instance ToSchema a => ToSchema (SAML.IdPConfig a) where +instance (ToSchema a) => ToSchema (SAML.IdPConfig a) where declareNamedSchema = genericDeclareNamedSchema samlSchemaOptions instance ToSchema SAML.Issuer where diff --git a/libs/wire-api/src/Wire/API/User/Password.hs b/libs/wire-api/src/Wire/API/User/Password.hs index a4c3f92c2ae..f3955f3cd4f 100644 --- a/libs/wire-api/src/Wire/API/User/Password.hs +++ b/libs/wire-api/src/Wire/API/User/Password.hs @@ -24,6 +24,7 @@ module Wire.API.User.Password CompletePasswordReset (..), PasswordResetIdentity (..), PasswordResetKey (..), + mkPasswordResetKey, PasswordResetCode (..), -- * deprecated @@ -33,9 +34,13 @@ where import Cassandra qualified as C import Control.Lens ((?~)) +import Crypto.Hash import Data.Aeson qualified as A import Data.Aeson.Types (Parser) +import Data.ByteArray qualified as ByteArray +import Data.ByteString qualified as BS import Data.ByteString.Conversion +import Data.Id import Data.Misc (PlainTextPassword8) import Data.OpenApi qualified as S import Data.OpenApi.ParamSchema @@ -43,7 +48,7 @@ import Data.Proxy (Proxy (Proxy)) import Data.Range (Ranged (..)) import Data.Schema as Schema import Data.Text.Ascii -import Data.Tuple.Extra (fst3, snd3, thd3) +import Data.Tuple.Extra import Imports import Servant (FromHttpApiData (..)) import Wire.API.User.Identity @@ -53,49 +58,46 @@ import Wire.Arbitrary (Arbitrary, GenericUniform (..)) -- NewPasswordReset -- | The payload for initiating a password reset. -newtype NewPasswordReset = NewPasswordReset (Either Email Phone) +data NewPasswordReset + = NewPasswordReset Email + | -- | Resetting via phone is not really supported anymore, but this is still + -- here to support older versions of the endpoint. + NewPasswordResetUnsupportedPhone deriving stock (Eq, Show, Generic) - deriving newtype (Arbitrary) + deriving (Arbitrary) via (GenericUniform NewPasswordReset) deriving (A.ToJSON, A.FromJSON, S.ToSchema) via Schema NewPasswordReset instance ToSchema NewPasswordReset where schema = objectWithDocModifier "NewPasswordReset" objectDesc $ - NewPasswordReset - <$> (toTuple . unNewPasswordReset) Schema..= newPasswordResetObjectSchema + (toTuple .= newPasswordResetTupleObjectSchema) `withParser` fromTuple where - unNewPasswordReset :: NewPasswordReset -> Either Email Phone - unNewPasswordReset (NewPasswordReset v) = v - objectDesc :: NamedSwaggerDoc -> NamedSwaggerDoc objectDesc = description ?~ "Data to initiate a password reset" - newPasswordResetObjectSchema :: ObjectSchemaP SwaggerDoc (Maybe Email, Maybe Phone) (Either Email Phone) - newPasswordResetObjectSchema = withParser newPasswordResetTupleObjectSchema fromTuple + newPasswordResetTupleObjectSchema :: ObjectSchema SwaggerDoc (Maybe Email, Maybe Text) + newPasswordResetTupleObjectSchema = + (,) + <$> fst .= maybe_ (optFieldWithDocModifier "email" phoneDocs schema) + <*> snd .= maybe_ (optFieldWithDocModifier "phone" emailDocs schema) where - newPasswordResetTupleObjectSchema :: ObjectSchema SwaggerDoc (Maybe Email, Maybe Phone) - newPasswordResetTupleObjectSchema = - (,) - <$> fst .= maybe_ (optFieldWithDocModifier "email" phoneDocs schema) - <*> snd .= maybe_ (optFieldWithDocModifier "phone" emailDocs schema) - where - emailDocs :: NamedSwaggerDoc -> NamedSwaggerDoc - emailDocs = description ?~ "Email" + emailDocs :: NamedSwaggerDoc -> NamedSwaggerDoc + emailDocs = description ?~ "Email" - phoneDocs :: NamedSwaggerDoc -> NamedSwaggerDoc - phoneDocs = description ?~ "Phone" + phoneDocs :: NamedSwaggerDoc -> NamedSwaggerDoc + phoneDocs = description ?~ "Phone" - fromTuple :: (Maybe Email, Maybe Phone) -> Parser (Either Email Phone) + fromTuple :: (Maybe Email, Maybe a) -> Parser NewPasswordReset fromTuple = \case (Just _, Just _) -> fail "Only one of 'email' or 'phone' allowed." - (Just email, Nothing) -> pure $ Left email - (Nothing, Just phone) -> pure $ Right phone + (Just email, Nothing) -> pure $ NewPasswordReset email + (Nothing, Just _) -> pure NewPasswordResetUnsupportedPhone (Nothing, Nothing) -> fail "One of 'email' or 'phone' required." - toTuple :: Either Email Phone -> (Maybe Email, Maybe Phone) + toTuple :: NewPasswordReset -> (Maybe Email, Maybe Text) toTuple = \case - Left e -> (Just e, Nothing) - Right p -> (Nothing, Just p) + NewPasswordReset e -> (Just e, Nothing) + NewPasswordResetUnsupportedPhone -> (Nothing, Just "") -------------------------------------------------------------------------------- -- CompletePasswordReset @@ -172,9 +174,17 @@ data PasswordResetIdentity -- | Opaque identifier per user (SHA256 of the user ID). newtype PasswordResetKey = PasswordResetKey {fromPasswordResetKey :: AsciiBase64Url} - deriving stock (Eq, Show) + deriving stock (Eq, Show, Ord) deriving newtype (ToSchema, FromByteString, ToByteString, A.FromJSON, A.ToJSON, Arbitrary) +mkPasswordResetKey :: UserId -> PasswordResetKey +mkPasswordResetKey userId = + PasswordResetKey + . encodeBase64Url + . BS.pack + . ByteArray.unpack + $ hashWith SHA256 (toByteString' userId) + instance ToParamSchema PasswordResetKey where toParamSchema _ = toParamSchema (Proxy @Text) diff --git a/libs/wire-api/src/Wire/API/User/Profile.hs b/libs/wire-api/src/Wire/API/User/Profile.hs index 9a5e06883d2..022c0cc50cf 100644 --- a/libs/wire-api/src/Wire/API/User/Profile.hs +++ b/libs/wire-api/src/Wire/API/User/Profile.hs @@ -28,17 +28,6 @@ module Wire.API.User.Profile Asset (..), AssetSize (..), - -- * Locale - Locale (..), - locToText, - parseLocale, - Language (..), - lan2Text, - parseLanguage, - Country (..), - con2Text, - parseCountry, - -- * ManagedBy ManagedBy (..), defaultManagedBy, @@ -50,19 +39,14 @@ module Wire.API.User.Profile where import Cassandra qualified as C -import Control.Applicative (optional) -import Control.Error (hush, note) +import Control.Error (note) import Data.Aeson (FromJSON (..), ToJSON (..)) import Data.Aeson qualified as A import Data.Attoparsec.ByteString.Char8 (takeByteString) -import Data.Attoparsec.Text import Data.ByteString.Conversion -import Data.ISO3166_CountryCodes -import Data.LanguageCodes import Data.OpenApi qualified as S import Data.Range import Data.Schema -import Data.Text qualified as Text import Imports import Wire.API.Asset (AssetKey (..)) import Wire.API.User.Orphans () @@ -148,7 +132,7 @@ instance C.Cql Asset where 0 -> pure $! ImageAsset k s _ -> Left $ "unexpected user asset type: " ++ show t where - required :: C.Cql r => Text -> Either String r + required :: (C.Cql r) => Text -> Either String r required f = maybe (Left ("Asset: Missing required field '" ++ show f ++ "'")) @@ -188,87 +172,6 @@ instance C.Cql AssetSize where toCql AssetPreview = C.CqlInt 0 toCql AssetComplete = C.CqlInt 1 --------------------------------------------------------------------------------- --- Locale - -data Locale = Locale - { lLanguage :: Language, - lCountry :: Maybe Country - } - deriving stock (Eq, Ord, Generic) - deriving (Arbitrary) via (GenericUniform Locale) - deriving (FromJSON, ToJSON, S.ToSchema) via Schema Locale - -instance ToSchema Locale where - schema = locToText .= parsedText "Locale" (note err . parseLocale) - where - err = "Invalid locale. Expected (-)? format" - -instance Show Locale where - show = Text.unpack . locToText - -locToText :: Locale -> Text -locToText (Locale l c) = lan2Text l <> foldMap (("-" <>) . con2Text) c - -parseLocale :: Text -> Maybe Locale -parseLocale = hush . parseOnly localeParser - where - localeParser :: Parser Locale - localeParser = - Locale - <$> (languageParser "Language code") - <*> (optional (char '-' *> countryParser) "Country code") - --------------------------------------------------------------------------------- --- Language - -newtype Language = Language {fromLanguage :: ISO639_1} - deriving stock (Eq, Ord, Show, Generic) - deriving newtype (Arbitrary, S.ToSchema) - -instance C.Cql Language where - ctype = C.Tagged C.AsciiColumn - toCql = C.toCql . lan2Text - - fromCql (C.CqlAscii l) = case parseLanguage l of - Just l' -> pure l' - Nothing -> Left "Language: ISO 639-1 expected." - fromCql _ = Left "Language: ASCII expected" - -languageParser :: Parser Language -languageParser = codeParser "language" $ fmap Language . checkAndConvert isLower - -lan2Text :: Language -> Text -lan2Text = Text.toLower . Text.pack . show . fromLanguage - -parseLanguage :: Text -> Maybe Language -parseLanguage = hush . parseOnly languageParser - --------------------------------------------------------------------------------- --- Country - -newtype Country = Country {fromCountry :: CountryCode} - deriving stock (Eq, Ord, Show, Generic) - deriving newtype (Arbitrary, S.ToSchema) - -instance C.Cql Country where - ctype = C.Tagged C.AsciiColumn - toCql = C.toCql . con2Text - - fromCql (C.CqlAscii c) = case parseCountry c of - Just c' -> pure c' - Nothing -> Left "Country: ISO 3166-1-alpha2 expected." - fromCql _ = Left "Country: ASCII expected" - -countryParser :: Parser Country -countryParser = codeParser "country" $ fmap Country . checkAndConvert isUpper - -con2Text :: Country -> Text -con2Text = Text.pack . show . fromCountry - -parseCountry :: Text -> Maybe Country -parseCountry = hush . parseOnly countryParser - -------------------------------------------------------------------------------- -- ManagedBy @@ -357,18 +260,3 @@ instance C.Cql Pict where noPict :: Pict noPict = Pict [] - --------------------------------------------------------------------------------- --- helpers - --- Common language / country functions -checkAndConvert :: (Read a) => (Char -> Bool) -> String -> Maybe a -checkAndConvert f t = - if all f t - then readMaybe (map toUpper t) - else fail "Format not supported." - -codeParser :: String -> (String -> Maybe a) -> Parser a -codeParser err conv = do - code <- count 2 anyChar - maybe (fail err) pure (conv code) diff --git a/libs/wire-api/src/Wire/API/User/RichInfo.hs b/libs/wire-api/src/Wire/API/User/RichInfo.hs index d84ba4f3c2f..3796d811077 100644 --- a/libs/wire-api/src/Wire/API/User/RichInfo.hs +++ b/libs/wire-api/src/Wire/API/User/RichInfo.hs @@ -261,7 +261,7 @@ instance Arbitrary RichInfoMapAndList where arbitrary = mkRichInfoMapAndList <$> arbitrary -- | Uniform Resource Names used for serialization of 'RichInfo'. -richInfoMapURN, richInfoAssocListURN :: IsString s => s +richInfoMapURN, richInfoAssocListURN :: (IsString s) => s richInfoMapURN = "urn:ietf:params:scim:schemas:extension:wire:1.0:User" richInfoAssocListURN = "urn:wire:scim:schemas:profile:1.0" diff --git a/libs/wire-api/src/Wire/API/User/Saml.hs b/libs/wire-api/src/Wire/API/User/Saml.hs index f165a17f76c..fa97f24fb07 100644 --- a/libs/wire-api/src/Wire/API/User/Saml.hs +++ b/libs/wire-api/src/Wire/API/User/Saml.hs @@ -66,7 +66,7 @@ makeLenses ''VerdictFormat deriveJSON deriveJSONOptions ''VerdictFormat -mkVerdictGrantedFormatMobile :: MonadError String m => URI -> SetCookie -> UserId -> m URI +mkVerdictGrantedFormatMobile :: (MonadError String m) => URI -> SetCookie -> UserId -> m URI mkVerdictGrantedFormatMobile before cky uid = parseURI' . substituteVar @@ -80,7 +80,7 @@ mkVerdictGrantedFormatMobile before cky uid = . substituteVar "userid" (T.pack . show $ uid) $ renderURI before -mkVerdictDeniedFormatMobile :: MonadError String m => URI -> Text -> m URI +mkVerdictDeniedFormatMobile :: (MonadError String m) => URI -> Text -> m URI mkVerdictDeniedFormatMobile before lbl = parseURI' . substituteVar "label" lbl @@ -96,7 +96,7 @@ substituteVar' var val = T.intercalate val . T.splitOn var newtype TTL (tablename :: Symbol) = TTL {fromTTL :: Int32} deriving (Eq, Ord, Show, Num) -showTTL :: KnownSymbol a => TTL a -> String +showTTL :: (KnownSymbol a) => TTL a -> String showTTL (TTL i :: TTL a) = "TTL:" <> symbolVal (Proxy @a) <> ":" <> show i instance FromJSON (TTL a) where diff --git a/libs/wire-api/src/Wire/API/User/Scim.hs b/libs/wire-api/src/Wire/API/User/Scim.hs index d8482447523..e27bfcb26d2 100644 --- a/libs/wire-api/src/Wire/API/User/Scim.hs +++ b/libs/wire-api/src/Wire/API/User/Scim.hs @@ -83,6 +83,7 @@ import Web.Scim.Schema.Schema (Schema (CustomSchema)) import Web.Scim.Schema.Schema qualified as Scim import Web.Scim.Schema.User qualified as Scim import Web.Scim.Schema.User qualified as Scim.User +import Wire.API.Locale import Wire.API.Team.Role (Role) import Wire.API.User (emailFromSAMLNameID, urefToExternalIdUnsafe) import Wire.API.User.Identity (Email, fromEmail) @@ -168,11 +169,16 @@ instance FromJSON ScimTokenInfo where instance ToJSON ScimTokenInfo where toJSON s = A.object $ - "team" A..= stiTeam s - # "id" A..= stiId s - # "created_at" A..= stiCreatedAt s - # "idp" A..= stiIdP s - # "description" A..= stiDescr s + "team" + A..= stiTeam s + # "id" + A..= stiId s + # "created_at" + A..= stiCreatedAt s + # "idp" + A..= stiIdP s + # "description" + A..= stiDescr s # [] ---------------------------------------------------------------------------- diff --git a/libs/wire-api/src/Wire/API/User/Search.hs b/libs/wire-api/src/Wire/API/User/Search.hs index 435c7cf3998..dfeb601c4e0 100644 --- a/libs/wire-api/src/Wire/API/User/Search.hs +++ b/libs/wire-api/src/Wire/API/User/Search.hs @@ -107,7 +107,7 @@ instance Traversable SearchResult where newResults <- traverse f (searchResults r) pure $ r {searchResults = newResults} -instance ToSchema a => ToSchema (SearchResult a) where +instance (ToSchema a) => ToSchema (SearchResult a) where schema = object "SearchResult" $ SearchResult @@ -247,7 +247,7 @@ instance FromHttpApiData TeamUserSearchSortBy where flip foldMap [minBound .. maxBound] $ \s -> guard (teamUserSearchSortByName s == name) $> s -teamUserSearchSortByName :: IsString a => TeamUserSearchSortBy -> a +teamUserSearchSortByName :: (IsString a) => TeamUserSearchSortBy -> a teamUserSearchSortByName SortByName = "name" teamUserSearchSortByName SortByHandle = "handle" teamUserSearchSortByName SortByEmail = "email" @@ -283,7 +283,7 @@ instance FromHttpApiData TeamUserSearchSortOrder where flip foldMap [minBound .. maxBound] $ \s -> guard (teamUserSearchSortOrderName s == name) $> s -teamUserSearchSortOrderName :: IsString a => TeamUserSearchSortOrder -> a +teamUserSearchSortOrderName :: (IsString a) => TeamUserSearchSortOrder -> a teamUserSearchSortOrderName SortOrderAsc = "asc" teamUserSearchSortOrderName SortOrderDesc = "desc" diff --git a/libs/wire-api/src/Wire/API/UserEvent.hs b/libs/wire-api/src/Wire/API/UserEvent.hs index 59e5ff91502..41cbc98fe75 100644 --- a/libs/wire-api/src/Wire/API/UserEvent.hs +++ b/libs/wire-api/src/Wire/API/UserEvent.hs @@ -32,6 +32,7 @@ import Data.Schema import Imports import System.Logger.Message hiding (field, (.=)) import Wire.API.Connection +import Wire.API.Locale import Wire.API.Properties import Wire.API.Routes.Version import Wire.API.User @@ -107,7 +108,7 @@ instance ToSchema EventType where data UserEvent = UserCreated !User - | -- | A user is activated when the first user identity (email address or phone number) + | -- | A user is activated when the first user identity (email address) -- is verified. {#RefActivationEvent} UserActivated !User | -- | Account & API access of a user has been suspended. diff --git a/libs/wire-api/src/Wire/API/UserMap.hs b/libs/wire-api/src/Wire/API/UserMap.hs index 31f81392195..e0889e2832d 100644 --- a/libs/wire-api/src/Wire/API/UserMap.hs +++ b/libs/wire-api/src/Wire/API/UserMap.hs @@ -38,7 +38,7 @@ newtype UserMap a = UserMap {userMap :: Map UserId a} deriving stock (Eq, Show) deriving newtype (Semigroup, Monoid, ToJSON, FromJSON, Functor) -instance Arbitrary a => Arbitrary (UserMap a) where +instance (Arbitrary a) => Arbitrary (UserMap a) where arbitrary = UserMap <$> mapOf' arbitrary arbitrary type WrappedQualifiedUserMap a = Wrapped "qualified_user_map" (QualifiedUserMap a) @@ -53,7 +53,7 @@ instance Functor QualifiedUserMap where fmap f (QualifiedUserMap qMap) = QualifiedUserMap $ f <$$> qMap -instance Arbitrary a => Arbitrary (QualifiedUserMap a) where +instance (Arbitrary a) => Arbitrary (QualifiedUserMap a) where arbitrary = QualifiedUserMap <$> mapOf' arbitrary arbitrary instance (ToSchema a, ToJSON a, Arbitrary a) => ToSchema (UserMap (Set a)) where diff --git a/libs/wire-api/src/Wire/API/VersionInfo.hs b/libs/wire-api/src/Wire/API/VersionInfo.hs index 1d05a55e027..b7267028b60 100644 --- a/libs/wire-api/src/Wire/API/VersionInfo.hs +++ b/libs/wire-api/src/Wire/API/VersionInfo.hs @@ -107,7 +107,7 @@ instance clientWithRoute pm (Proxy @api) req hoistClientMonad pm _ f = hoistClientMonad pm (Proxy @api) f -instance RoutesToPaths api => RoutesToPaths (Until v :> api) where +instance (RoutesToPaths api) => RoutesToPaths (Until v :> api) where getRoutes = getRoutes @api instance @@ -155,5 +155,5 @@ instance clientWithRoute pm (Proxy @api) req hoistClientMonad pm _ f = hoistClientMonad pm (Proxy @api) f -instance RoutesToPaths api => RoutesToPaths (From v :> api) where +instance (RoutesToPaths api) => RoutesToPaths (From v :> api) where getRoutes = getRoutes @api diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated.hs index 9778eec5ec5..38c2fa673ea 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated.hs @@ -866,6 +866,9 @@ tests = ), ( Test.Wire.API.Golden.Generated.NewUser_user.testObject_NewUser_user_8, "testObject_NewUser_user_8.json" + ), + ( Test.Wire.API.Golden.Generated.NewUser_user.testObject_NewUser_user_9, + "testObject_NewUser_user_9.json" ) ], testGroup "Golden: NewUserPublic_user" $ @@ -984,7 +987,7 @@ tests = testGroup "Golden: Activate_user" $ testObjects [(Test.Wire.API.Golden.Generated.Activate_user.testObject_Activate_user_1, "testObject_Activate_user_1.json"), (Test.Wire.API.Golden.Generated.Activate_user.testObject_Activate_user_2, "testObject_Activate_user_2.json"), (Test.Wire.API.Golden.Generated.Activate_user.testObject_Activate_user_3, "testObject_Activate_user_3.json"), (Test.Wire.API.Golden.Generated.Activate_user.testObject_Activate_user_4, "testObject_Activate_user_4.json"), (Test.Wire.API.Golden.Generated.Activate_user.testObject_Activate_user_5, "testObject_Activate_user_5.json"), (Test.Wire.API.Golden.Generated.Activate_user.testObject_Activate_user_6, "testObject_Activate_user_6.json"), (Test.Wire.API.Golden.Generated.Activate_user.testObject_Activate_user_7, "testObject_Activate_user_7.json"), (Test.Wire.API.Golden.Generated.Activate_user.testObject_Activate_user_8, "testObject_Activate_user_8.json"), (Test.Wire.API.Golden.Generated.Activate_user.testObject_Activate_user_9, "testObject_Activate_user_9.json"), (Test.Wire.API.Golden.Generated.Activate_user.testObject_Activate_user_10, "testObject_Activate_user_10.json"), (Test.Wire.API.Golden.Generated.Activate_user.testObject_Activate_user_11, "testObject_Activate_user_11.json"), (Test.Wire.API.Golden.Generated.Activate_user.testObject_Activate_user_12, "testObject_Activate_user_12.json"), (Test.Wire.API.Golden.Generated.Activate_user.testObject_Activate_user_13, "testObject_Activate_user_13.json"), (Test.Wire.API.Golden.Generated.Activate_user.testObject_Activate_user_14, "testObject_Activate_user_14.json"), (Test.Wire.API.Golden.Generated.Activate_user.testObject_Activate_user_15, "testObject_Activate_user_15.json"), (Test.Wire.API.Golden.Generated.Activate_user.testObject_Activate_user_16, "testObject_Activate_user_16.json"), (Test.Wire.API.Golden.Generated.Activate_user.testObject_Activate_user_17, "testObject_Activate_user_17.json"), (Test.Wire.API.Golden.Generated.Activate_user.testObject_Activate_user_18, "testObject_Activate_user_18.json"), (Test.Wire.API.Golden.Generated.Activate_user.testObject_Activate_user_19, "testObject_Activate_user_19.json"), (Test.Wire.API.Golden.Generated.Activate_user.testObject_Activate_user_20, "testObject_Activate_user_20.json")], testGroup "Golden: ActivationResponse_user" $ - testObjects [(Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_1, "testObject_ActivationResponse_user_1.json"), (Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_2, "testObject_ActivationResponse_user_2.json"), (Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_3, "testObject_ActivationResponse_user_3.json"), (Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_4, "testObject_ActivationResponse_user_4.json"), (Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_5, "testObject_ActivationResponse_user_5.json"), (Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_6, "testObject_ActivationResponse_user_6.json"), (Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_7, "testObject_ActivationResponse_user_7.json"), (Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_8, "testObject_ActivationResponse_user_8.json"), (Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_9, "testObject_ActivationResponse_user_9.json"), (Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_10, "testObject_ActivationResponse_user_10.json"), (Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_11, "testObject_ActivationResponse_user_11.json"), (Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_12, "testObject_ActivationResponse_user_12.json"), (Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_13, "testObject_ActivationResponse_user_13.json"), (Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_14, "testObject_ActivationResponse_user_14.json"), (Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_15, "testObject_ActivationResponse_user_15.json"), (Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_16, "testObject_ActivationResponse_user_16.json"), (Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_17, "testObject_ActivationResponse_user_17.json"), (Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_18, "testObject_ActivationResponse_user_18.json"), (Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_19, "testObject_ActivationResponse_user_19.json"), (Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_20, "testObject_ActivationResponse_user_20.json")], + testObjects [(Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_1, "testObject_ActivationResponse_user_1.json"), (Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_2, "testObject_ActivationResponse_user_2.json"), (Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_3, "testObject_ActivationResponse_user_3.json"), (Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_4, "testObject_ActivationResponse_user_4.json"), (Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_5, "testObject_ActivationResponse_user_5.json"), (Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_6, "testObject_ActivationResponse_user_6.json"), (Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_7, "testObject_ActivationResponse_user_7.json"), (Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_8, "testObject_ActivationResponse_user_8.json"), (Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_9, "testObject_ActivationResponse_user_9.json"), (Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_10, "testObject_ActivationResponse_user_10.json")], testGroup "Golden: SendActivationCode_user" $ testObjects [(Test.Wire.API.Golden.Generated.SendActivationCode_user.testObject_SendActivationCode_user_1, "testObject_SendActivationCode_user_1.json"), (Test.Wire.API.Golden.Generated.SendActivationCode_user.testObject_SendActivationCode_user_2, "testObject_SendActivationCode_user_2.json"), (Test.Wire.API.Golden.Generated.SendActivationCode_user.testObject_SendActivationCode_user_3, "testObject_SendActivationCode_user_3.json"), (Test.Wire.API.Golden.Generated.SendActivationCode_user.testObject_SendActivationCode_user_4, "testObject_SendActivationCode_user_4.json"), (Test.Wire.API.Golden.Generated.SendActivationCode_user.testObject_SendActivationCode_user_5, "testObject_SendActivationCode_user_5.json"), (Test.Wire.API.Golden.Generated.SendActivationCode_user.testObject_SendActivationCode_user_6, "testObject_SendActivationCode_user_6.json"), (Test.Wire.API.Golden.Generated.SendActivationCode_user.testObject_SendActivationCode_user_7, "testObject_SendActivationCode_user_7.json"), (Test.Wire.API.Golden.Generated.SendActivationCode_user.testObject_SendActivationCode_user_8, "testObject_SendActivationCode_user_8.json"), (Test.Wire.API.Golden.Generated.SendActivationCode_user.testObject_SendActivationCode_user_9, "testObject_SendActivationCode_user_9.json"), (Test.Wire.API.Golden.Generated.SendActivationCode_user.testObject_SendActivationCode_user_10, "testObject_SendActivationCode_user_10.json"), (Test.Wire.API.Golden.Generated.SendActivationCode_user.testObject_SendActivationCode_user_11, "testObject_SendActivationCode_user_11.json"), (Test.Wire.API.Golden.Generated.SendActivationCode_user.testObject_SendActivationCode_user_12, "testObject_SendActivationCode_user_12.json"), (Test.Wire.API.Golden.Generated.SendActivationCode_user.testObject_SendActivationCode_user_13, "testObject_SendActivationCode_user_13.json"), (Test.Wire.API.Golden.Generated.SendActivationCode_user.testObject_SendActivationCode_user_14, "testObject_SendActivationCode_user_14.json"), (Test.Wire.API.Golden.Generated.SendActivationCode_user.testObject_SendActivationCode_user_15, "testObject_SendActivationCode_user_15.json"), (Test.Wire.API.Golden.Generated.SendActivationCode_user.testObject_SendActivationCode_user_16, "testObject_SendActivationCode_user_16.json"), (Test.Wire.API.Golden.Generated.SendActivationCode_user.testObject_SendActivationCode_user_17, "testObject_SendActivationCode_user_17.json"), (Test.Wire.API.Golden.Generated.SendActivationCode_user.testObject_SendActivationCode_user_18, "testObject_SendActivationCode_user_18.json"), (Test.Wire.API.Golden.Generated.SendActivationCode_user.testObject_SendActivationCode_user_19, "testObject_SendActivationCode_user_19.json"), (Test.Wire.API.Golden.Generated.SendActivationCode_user.testObject_SendActivationCode_user_20, "testObject_SendActivationCode_user_20.json")], testGroup "Golden: LoginId_user" $ @@ -1056,7 +1059,7 @@ tests = testGroup "Golden: UserSSOId_user" $ testObjects [(Test.Wire.API.Golden.Generated.UserSSOId_user.testObject_UserSSOId_user_2, "testObject_UserSSOId_user_2.json"), (Test.Wire.API.Golden.Generated.UserSSOId_user.testObject_UserSSOId_user_9, "testObject_UserSSOId_user_9.json"), (Test.Wire.API.Golden.Generated.UserSSOId_user.testObject_UserSSOId_user_13, "testObject_UserSSOId_user_13.json")], testGroup "Golden: NewPasswordReset_user" $ - testObjects [(Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_1, "testObject_NewPasswordReset_user_1.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_2, "testObject_NewPasswordReset_user_2.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_3, "testObject_NewPasswordReset_user_3.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_4, "testObject_NewPasswordReset_user_4.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_5, "testObject_NewPasswordReset_user_5.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_6, "testObject_NewPasswordReset_user_6.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_7, "testObject_NewPasswordReset_user_7.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_8, "testObject_NewPasswordReset_user_8.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_9, "testObject_NewPasswordReset_user_9.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_10, "testObject_NewPasswordReset_user_10.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_11, "testObject_NewPasswordReset_user_11.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_12, "testObject_NewPasswordReset_user_12.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_13, "testObject_NewPasswordReset_user_13.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_14, "testObject_NewPasswordReset_user_14.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_15, "testObject_NewPasswordReset_user_15.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_16, "testObject_NewPasswordReset_user_16.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_17, "testObject_NewPasswordReset_user_17.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_18, "testObject_NewPasswordReset_user_18.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_19, "testObject_NewPasswordReset_user_19.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_20, "testObject_NewPasswordReset_user_20.json")], + testObjects [(Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_1, "testObject_NewPasswordReset_user_1.json")], testGroup "Golden: PasswordResetKey_user" $ testObjects [(Test.Wire.API.Golden.Generated.PasswordResetKey_user.testObject_PasswordResetKey_user_1, "testObject_PasswordResetKey_user_1.json"), (Test.Wire.API.Golden.Generated.PasswordResetKey_user.testObject_PasswordResetKey_user_2, "testObject_PasswordResetKey_user_2.json"), (Test.Wire.API.Golden.Generated.PasswordResetKey_user.testObject_PasswordResetKey_user_3, "testObject_PasswordResetKey_user_3.json"), (Test.Wire.API.Golden.Generated.PasswordResetKey_user.testObject_PasswordResetKey_user_4, "testObject_PasswordResetKey_user_4.json"), (Test.Wire.API.Golden.Generated.PasswordResetKey_user.testObject_PasswordResetKey_user_5, "testObject_PasswordResetKey_user_5.json"), (Test.Wire.API.Golden.Generated.PasswordResetKey_user.testObject_PasswordResetKey_user_6, "testObject_PasswordResetKey_user_6.json"), (Test.Wire.API.Golden.Generated.PasswordResetKey_user.testObject_PasswordResetKey_user_7, "testObject_PasswordResetKey_user_7.json"), (Test.Wire.API.Golden.Generated.PasswordResetKey_user.testObject_PasswordResetKey_user_8, "testObject_PasswordResetKey_user_8.json"), (Test.Wire.API.Golden.Generated.PasswordResetKey_user.testObject_PasswordResetKey_user_9, "testObject_PasswordResetKey_user_9.json"), (Test.Wire.API.Golden.Generated.PasswordResetKey_user.testObject_PasswordResetKey_user_10, "testObject_PasswordResetKey_user_10.json"), (Test.Wire.API.Golden.Generated.PasswordResetKey_user.testObject_PasswordResetKey_user_11, "testObject_PasswordResetKey_user_11.json"), (Test.Wire.API.Golden.Generated.PasswordResetKey_user.testObject_PasswordResetKey_user_12, "testObject_PasswordResetKey_user_12.json"), (Test.Wire.API.Golden.Generated.PasswordResetKey_user.testObject_PasswordResetKey_user_13, "testObject_PasswordResetKey_user_13.json"), (Test.Wire.API.Golden.Generated.PasswordResetKey_user.testObject_PasswordResetKey_user_14, "testObject_PasswordResetKey_user_14.json"), (Test.Wire.API.Golden.Generated.PasswordResetKey_user.testObject_PasswordResetKey_user_15, "testObject_PasswordResetKey_user_15.json"), (Test.Wire.API.Golden.Generated.PasswordResetKey_user.testObject_PasswordResetKey_user_16, "testObject_PasswordResetKey_user_16.json"), (Test.Wire.API.Golden.Generated.PasswordResetKey_user.testObject_PasswordResetKey_user_17, "testObject_PasswordResetKey_user_17.json"), (Test.Wire.API.Golden.Generated.PasswordResetKey_user.testObject_PasswordResetKey_user_18, "testObject_PasswordResetKey_user_18.json"), (Test.Wire.API.Golden.Generated.PasswordResetKey_user.testObject_PasswordResetKey_user_19, "testObject_PasswordResetKey_user_19.json"), (Test.Wire.API.Golden.Generated.PasswordResetKey_user.testObject_PasswordResetKey_user_20, "testObject_PasswordResetKey_user_20.json")], testGroup "Golden: PasswordResetCode_user" $ @@ -1295,7 +1298,8 @@ tests = ], testGroup "Golden: WithStatus_team 12" $ testObjects - [ (Test.Wire.API.Golden.Generated.WithStatus_team.testObject_WithStatus_team_18, "testObject_WithStatus_team_18.json") + [ (Test.Wire.API.Golden.Generated.WithStatus_team.testObject_WithStatus_team_18, "testObject_WithStatus_team_18.json"), + (Test.Wire.API.Golden.Generated.WithStatus_team.testObject_WithStatus_team_19, "testObject_WithStatus_team_19.json") ], testGroup "Golden: InvitationRequest_team" $ testObjects [(Test.Wire.API.Golden.Generated.InvitationRequest_team.testObject_InvitationRequest_team_1, "testObject_InvitationRequest_team_1.json"), (Test.Wire.API.Golden.Generated.InvitationRequest_team.testObject_InvitationRequest_team_2, "testObject_InvitationRequest_team_2.json"), (Test.Wire.API.Golden.Generated.InvitationRequest_team.testObject_InvitationRequest_team_3, "testObject_InvitationRequest_team_3.json"), (Test.Wire.API.Golden.Generated.InvitationRequest_team.testObject_InvitationRequest_team_4, "testObject_InvitationRequest_team_4.json"), (Test.Wire.API.Golden.Generated.InvitationRequest_team.testObject_InvitationRequest_team_5, "testObject_InvitationRequest_team_5.json"), (Test.Wire.API.Golden.Generated.InvitationRequest_team.testObject_InvitationRequest_team_6, "testObject_InvitationRequest_team_6.json"), (Test.Wire.API.Golden.Generated.InvitationRequest_team.testObject_InvitationRequest_team_7, "testObject_InvitationRequest_team_7.json"), (Test.Wire.API.Golden.Generated.InvitationRequest_team.testObject_InvitationRequest_team_8, "testObject_InvitationRequest_team_8.json"), (Test.Wire.API.Golden.Generated.InvitationRequest_team.testObject_InvitationRequest_team_9, "testObject_InvitationRequest_team_9.json"), (Test.Wire.API.Golden.Generated.InvitationRequest_team.testObject_InvitationRequest_team_10, "testObject_InvitationRequest_team_10.json"), (Test.Wire.API.Golden.Generated.InvitationRequest_team.testObject_InvitationRequest_team_11, "testObject_InvitationRequest_team_11.json"), (Test.Wire.API.Golden.Generated.InvitationRequest_team.testObject_InvitationRequest_team_12, "testObject_InvitationRequest_team_12.json"), (Test.Wire.API.Golden.Generated.InvitationRequest_team.testObject_InvitationRequest_team_13, "testObject_InvitationRequest_team_13.json"), (Test.Wire.API.Golden.Generated.InvitationRequest_team.testObject_InvitationRequest_team_14, "testObject_InvitationRequest_team_14.json"), (Test.Wire.API.Golden.Generated.InvitationRequest_team.testObject_InvitationRequest_team_15, "testObject_InvitationRequest_team_15.json"), (Test.Wire.API.Golden.Generated.InvitationRequest_team.testObject_InvitationRequest_team_16, "testObject_InvitationRequest_team_16.json"), (Test.Wire.API.Golden.Generated.InvitationRequest_team.testObject_InvitationRequest_team_17, "testObject_InvitationRequest_team_17.json"), (Test.Wire.API.Golden.Generated.InvitationRequest_team.testObject_InvitationRequest_team_18, "testObject_InvitationRequest_team_18.json"), (Test.Wire.API.Golden.Generated.InvitationRequest_team.testObject_InvitationRequest_team_19, "testObject_InvitationRequest_team_19.json"), (Test.Wire.API.Golden.Generated.InvitationRequest_team.testObject_InvitationRequest_team_20, "testObject_InvitationRequest_team_20.json")], diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ActivationResponse_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ActivationResponse_user.hs index b4700eaeb43..020c4119ddd 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ActivationResponse_user.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ActivationResponse_user.hs @@ -19,18 +19,7 @@ module Test.Wire.API.Golden.Generated.ActivationResponse_user where import Imports (Bool (False, True), Maybe (Just, Nothing)) import Wire.API.User - ( Email (Email, emailDomain, emailLocal), - Phone (Phone, fromPhone), - UserIdentity - ( EmailIdentity, - FullIdentity, - PhoneIdentity, - SSOIdentity - ), - UserSSOId (UserSSOId, UserScimExternalId), - ) import Wire.API.User.Activation (ActivationResponse (..)) -import Wire.API.User.Identity (mkSimpleSampleUref) testObject_ActivationResponse_user_1 :: ActivationResponse testObject_ActivationResponse_user_1 = @@ -38,14 +27,13 @@ testObject_ActivationResponse_user_1 = { activatedIdentity = SSOIdentity (UserSSOId mkSimpleSampleUref) - (Just (Email {emailLocal = "\165918\rZ\a\ESC", emailDomain = "p\131777\62344"})) - Nothing, + (Just (Email {emailLocal = "\165918\rZ\a\ESC", emailDomain = "p\131777\62344"})), activatedFirst = False } testObject_ActivationResponse_user_2 :: ActivationResponse testObject_ActivationResponse_user_2 = - ActivationResponse {activatedIdentity = PhoneIdentity (Phone {fromPhone = "+7397347696479"}), activatedFirst = False} + ActivationResponse {activatedIdentity = EmailIdentity (Email "foo" "example.com"), activatedFirst = False} testObject_ActivationResponse_user_3 :: ActivationResponse testObject_ActivationResponse_user_3 = @@ -59,7 +47,7 @@ testObject_ActivationResponse_user_4 :: ActivationResponse testObject_ActivationResponse_user_4 = ActivationResponse { activatedIdentity = - FullIdentity (Email {emailLocal = "h\nPr3", emailDomain = ""}) (Phone {fromPhone = "+82309287"}), + EmailIdentity (Email {emailLocal = "h\nPr3", emailDomain = ""}), activatedFirst = True } @@ -74,7 +62,7 @@ testObject_ActivationResponse_user_5 = testObject_ActivationResponse_user_6 :: ActivationResponse testObject_ActivationResponse_user_6 = ActivationResponse - { activatedIdentity = SSOIdentity (UserScimExternalId "\an|") Nothing Nothing, + { activatedIdentity = SSOIdentity (UserScimExternalId "\an|") Nothing, activatedFirst = False } @@ -87,13 +75,13 @@ testObject_ActivationResponse_user_7 = testObject_ActivationResponse_user_8 :: ActivationResponse testObject_ActivationResponse_user_8 = - ActivationResponse {activatedIdentity = PhoneIdentity (Phone {fromPhone = "+0023160115015"}), activatedFirst = True} + ActivationResponse {activatedIdentity = EmailIdentity (Email "bar" "example.com"), activatedFirst = True} testObject_ActivationResponse_user_9 :: ActivationResponse testObject_ActivationResponse_user_9 = ActivationResponse { activatedIdentity = - FullIdentity (Email {emailLocal = "\ENQ?", emailDomain = ""}) (Phone {fromPhone = "+208573659013"}), + EmailIdentity (Email {emailLocal = "\ENQ?", emailDomain = ""}), activatedFirst = False } @@ -104,79 +92,3 @@ testObject_ActivationResponse_user_10 = EmailIdentity (Email {emailLocal = "\ACK3", emailDomain = "\f\1040847\1071035\EOT\1003280P\DEL"}), activatedFirst = False } - -testObject_ActivationResponse_user_11 :: ActivationResponse -testObject_ActivationResponse_user_11 = - ActivationResponse - { activatedIdentity = - EmailIdentity (Email {emailLocal = "z\126214m\146009<\1046292\a\DC31+*", emailDomain = "S\SO\125114"}), - activatedFirst = True - } - -testObject_ActivationResponse_user_12 :: ActivationResponse -testObject_ActivationResponse_user_12 = - ActivationResponse - { activatedIdentity = - EmailIdentity (Email {emailLocal = "d4p\r:\STXI5\167701\158743\GS\v", emailDomain = "\51121\100929"}), - activatedFirst = False - } - -testObject_ActivationResponse_user_13 :: ActivationResponse -testObject_ActivationResponse_user_13 = - ActivationResponse - { activatedIdentity = SSOIdentity (UserScimExternalId "#") Nothing (Just (Phone {fromPhone = "+6124426658"})), - activatedFirst = False - } - -testObject_ActivationResponse_user_14 :: ActivationResponse -testObject_ActivationResponse_user_14 = - ActivationResponse - { activatedIdentity = - SSOIdentity - (UserScimExternalId "\NUL\US\ETBY") - (Just (Email {emailLocal = "\66022", emailDomain = "\a\1081391"})) - Nothing, - activatedFirst = False - } - -testObject_ActivationResponse_user_15 :: ActivationResponse -testObject_ActivationResponse_user_15 = - ActivationResponse {activatedIdentity = PhoneIdentity (Phone {fromPhone = "+594453349310"}), activatedFirst = False} - -testObject_ActivationResponse_user_16 :: ActivationResponse -testObject_ActivationResponse_user_16 = - ActivationResponse - { activatedIdentity = - FullIdentity (Email {emailLocal = "r\FS,\"", emailDomain = "%R\n\164677^"}) (Phone {fromPhone = "+144713467"}), - activatedFirst = False - } - -testObject_ActivationResponse_user_17 :: ActivationResponse -testObject_ActivationResponse_user_17 = - ActivationResponse - { activatedIdentity = - SSOIdentity - (UserScimExternalId "") - (Just (Email {emailLocal = "\155143", emailDomain = "+)"})) - (Just (Phone {fromPhone = "+703448141"})), - activatedFirst = True - } - -testObject_ActivationResponse_user_18 :: ActivationResponse -testObject_ActivationResponse_user_18 = - ActivationResponse {activatedIdentity = PhoneIdentity (Phone {fromPhone = "+974462685543005"}), activatedFirst = True} - -testObject_ActivationResponse_user_19 :: ActivationResponse -testObject_ActivationResponse_user_19 = - ActivationResponse - { activatedIdentity = SSOIdentity (UserSSOId mkSimpleSampleUref) (Just (Email {emailLocal = "R", emailDomain = "K"})) Nothing, - activatedFirst = False - } - -testObject_ActivationResponse_user_20 :: ActivationResponse -testObject_ActivationResponse_user_20 = - ActivationResponse - { activatedIdentity = - FullIdentity (Email {emailLocal = "", emailDomain = "E"}) (Phone {fromPhone = "+73148778831190"}), - activatedFirst = False - } diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/BotUserView_provider.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/BotUserView_provider.hs index ea1d54154e9..b7f8b05f8c9 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/BotUserView_provider.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/BotUserView_provider.hs @@ -17,7 +17,7 @@ module Test.Wire.API.Golden.Generated.BotUserView_provider where -import Data.Handle (Handle (Handle, fromHandle)) +import Data.Handle (parseHandle) import Data.Id (Id (Id)) import Data.UUID qualified as UUID (fromString) import Imports (Maybe (Just, Nothing), fromJust) @@ -34,7 +34,7 @@ testObject_BotUserView_provider_1 = "\DC1\26122U5z$\CAN\GS t1\RS\\\STX\163323_4K\1108113\1030339\78439)\DC3\171456\FS\1039863\1089420n\7092\1008914\\4Nn;\171427)\182846y\SO\n|\DEL1#pK\51301b\t\132598+\SOH\5517\DELjJ\179985\191367Z `$" }, botUserViewColour = ColourId {fromColourId = -8}, - botUserViewHandle = Just (Handle {fromHandle = "fpa2vx"}), + botUserViewHandle = Just (fromJust (parseHandle "fpa2vx")), botUserViewTeam = Just (Id (fromJust (UUID.fromString "00000000-0000-0002-0000-000200000002"))) } @@ -48,7 +48,7 @@ testObject_BotUserView_provider_2 = "v\1099438\1020222\SOM\989617\t\ETB\\\1068888\187702nE7?\SOH:\r\1050763m \1065605}Y\989133b_\DLEDVa\1054567uJJ|\1086658\US)\DC3C" }, botUserViewColour = ColourId {fromColourId = -5}, - botUserViewHandle = Just (Handle {fromHandle = "mz"}), + botUserViewHandle = Just (fromJust (parseHandle "mz")), botUserViewTeam = Nothing } @@ -68,7 +68,7 @@ testObject_BotUserView_provider_4 = { botUserViewId = Id (fromJust (UUID.fromString "00000008-0000-0004-0000-000300000007")), botUserViewName = Name {fromName = "\SUB\STX)gKj\FS\1076685\v6cg\f]N!t\\\1017810\&8\70320\&7I\ETXCS\DC4e\FS\FS"}, botUserViewColour = ColourId {fromColourId = -2}, - botUserViewHandle = Just (Handle {fromHandle = "7.w"}), + botUserViewHandle = Just (fromJust (parseHandle "7.w")), botUserViewTeam = Just (Id (fromJust (UUID.fromString "00000004-0000-0000-0000-000200000000"))) } @@ -78,7 +78,7 @@ testObject_BotUserView_provider_5 = { botUserViewId = Id (fromJust (UUID.fromString "00000002-0000-0001-0000-000500000008")), botUserViewName = Name {fromName = "w"}, botUserViewColour = ColourId {fromColourId = -1}, - botUserViewHandle = Just (Handle {fromHandle = "tidlyhr"}), + botUserViewHandle = Just (fromJust (parseHandle "tidlyhr")), botUserViewTeam = Just (Id (fromJust (UUID.fromString "00000002-0000-0004-0000-000800000005"))) } @@ -93,7 +93,7 @@ testObject_BotUserView_provider_6 = }, botUserViewColour = ColourId {fromColourId = -5}, botUserViewHandle = - Just (Handle {fromHandle = "uz3cgdxtkev-40624m0eh_y06g-c9isv-ob.r84rneq2vm.440nxc_n44_3d0-6u9l7"}), + Just (fromJust (parseHandle "uz3cgdxtkev-40624m0eh_y06g-c9isv-ob.r84rneq2vm.440nxc_n44_3d0-6u9l7")), botUserViewTeam = Just (Id (fromJust (UUID.fromString "00000003-0000-0003-0000-000300000001"))) } @@ -107,7 +107,7 @@ testObject_BotUserView_provider_7 = "}$d}\RSY\1064459\1052613\96622np\1076823_\150435\1064267\&4rNy,U\1047882\&7\1005658\NAK2" }, botUserViewColour = ColourId {fromColourId = -1}, - botUserViewHandle = Just (Handle {fromHandle = "j4z9ty7y-wt_ldl_tddmmrhdfp4myz9fjrqdg2dkh5r9vxcs5z"}), + botUserViewHandle = Just (fromJust (parseHandle "j4z9ty7y-wt_ldl_tddmmrhdfp4myz9fjrqdg2dkh5r9vxcs5z")), botUserViewTeam = Just (Id (fromJust (UUID.fromString "00000006-0000-0004-0000-000300000004"))) } @@ -240,7 +225,7 @@ testObject_BotUserView_provider_16 = "W0\DC23\179352_\150603\&9\1081508\41244!\USNh\1010987\48629\1008710+\30291\147681S\23109\94906H[sp^\EOT(\r\184575\v>I{G\CAN\1090476\129048\FS\GS\181835K\1026670oOJ\USB]t\1042482L wY\1027509\11746\DC4l5Y\46221[,TcoF~_\ENQ\r\42008\136798\ETB" }, botUserViewColour = ColourId {fromColourId = -4}, - botUserViewHandle = Just (Handle {fromHandle = "_mvtpq.f"}), + botUserViewHandle = Just (fromJust (parseHandle "_mvtpq.f")), botUserViewTeam = Just (Id (fromJust (UUID.fromString "00000005-0000-0001-0000-000700000005"))) } @@ -254,7 +239,7 @@ testObject_BotUserView_provider_17 = ")o}s)\181243+0\EOT\154402C\1048068\1060448\SID[c c\r\1108938$'f6\1002325 ~|,A\f\32588\FSJ\1011697?\166257MJp\1738\DEL\DC2:}B'\DLEQ\54387\136046\1057923\DC2A\DC4\140654\SOH\r\1012989\DC1\188221\1007075?" }, botUserViewColour = ColourId {fromColourId = 1}, - botUserViewHandle = Just (Handle {fromHandle = "f.xl"}), + botUserViewHandle = Just (fromJust (parseHandle "f.xl")), botUserViewTeam = Nothing } @@ -268,7 +253,7 @@ testObject_BotUserView_provider_18 = "\988095\134570T^ff6\SOH6@\DEL\1025500%\1044243\FSvM_s\176\ETB$K\1095116.\NAKm[\US\128932\EOT\SOH)\178049f\134315\1041068\&0kTn!9\SIL\1024745\n\a\1029970\\K(\146913\150726\SUB\NUL\1000860^W?\SOn|-\nR<\1099109\1046581\1036758\157276\GSQu\NAK\46380\FS\50047\1049174\183149\1111902b4\USly\DEL`'X%$mW]k\1051138\98086" }, botUserViewColour = ColourId {fromColourId = -7}, - botUserViewHandle = Just (Handle {fromHandle = "b-p"}), + botUserViewHandle = Just (fromJust (parseHandle "b-p")), botUserViewTeam = Just (Id (fromJust (UUID.fromString "00000002-0000-0003-0000-000700000006"))) } @@ -279,12 +264,7 @@ testObject_BotUserView_provider_19 = botUserViewName = Name {fromName = "\CAN0\STX\STX\SOH='\b\ETX\119524Y8\1048503 \EMa\72317\134511,q\SOH'"}, botUserViewColour = ColourId {fromColourId = -1}, botUserViewHandle = - Just - ( Handle - { fromHandle = - "g_ms.jaq23mkzzhouss60itfsrux5lapflg0xqotoz76f-ori4aglkqwj-raa_wr4ypirq9c9-w17nwre3414mvmm-vgetkk-07k1dgekjrzcvk-_w33giuc8wcak590c29h457nks5xzpn6tq0wtcorgq7210uaminql8ygrklj3vh11p.sg-nrbnmm2.dxmo0zzhr3xco" - } - ), + Just (fromJust (parseHandle "g_ms.jaq23mkzzhouss60itfsrux5lapflg0xqotoz76f-ori4aglkqwj-raa_wr4ypirq9c9-w17nwre3414mvmm-vgetkk-07k1dgekjrzcvk-_w33giuc8wcak590c29h457nks5xzpn6tq0wtcorgq7210uaminql8ygrklj3vh11p.sg-nrbnmm2.dxmo0zzhr3xco")), botUserViewTeam = Just (Id (fromJust (UUID.fromString "00000006-0000-0000-0000-000400000008"))) } @@ -299,11 +279,6 @@ testObject_BotUserView_provider_20 = }, botUserViewColour = ColourId {fromColourId = -8}, botUserViewHandle = - Just - ( Handle - { fromHandle = - "p35n6vhgb5sh71n.-har73f0tp1urvyml_5ni8n01ommlrlx5chb9z7bhp_rehr1geua0--yxs5x3m3dgmvhy8-a-07gbc0owxv2d9mj_pqzss9op.ovxyrid8l36nkw1b5f4sr2.li7bmtmcwe76.zxj9lwbqtqt8v77v6ncnmebtl3whz6790x34rcyqe.jxc6glk2-7d.janj7d1.c70bjkjpzqp0pi64hoiei854tefqdlz246bht" - } - ), + Just (fromJust (parseHandle "p35n6vhgb5sh71n.-har73f0tp1urvyml_5ni8n01ommlrlx5chb9z7bhp_rehr1geua0--yxs5x3m3dgmvhy8-a-07gbc0owxv2d9mj_pqzss9op.ovxyrid8l36nkw1b5f4sr2.li7bmtmcwe76.zxj9lwbqtqt8v77v6ncnmebtl3whz6790x34rcyqe.jxc6glk2-7d.janj7d1.c70bjkjpzqp0pi64hoiei854tefqdlz246bht")), botUserViewTeam = Just (Id (fromJust (UUID.fromString "00000006-0000-0004-0000-000700000004"))) } diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/CompletePasswordReset_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/CompletePasswordReset_user.hs index a52b2589cb2..5881ee95222 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/CompletePasswordReset_user.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/CompletePasswordReset_user.hs @@ -17,20 +17,11 @@ module Test.Wire.API.Golden.Generated.CompletePasswordReset_user where -import Data.Misc (plainTextPassword8Unsafe) -import Data.Text.Ascii (AsciiChars (validate)) -import Imports (fromRight, undefined) -import Wire.API.User (Email (Email, emailDomain, emailLocal), Phone (Phone, fromPhone)) +import Data.Misc +import Data.Text.Ascii +import Imports +import Wire.API.User import Wire.API.User.Password - ( CompletePasswordReset (..), - PasswordResetCode (PasswordResetCode, fromPasswordResetCode), - PasswordResetIdentity - ( PasswordResetEmailIdentity, - PasswordResetIdentityKey, - PasswordResetPhoneIdentity - ), - PasswordResetKey (PasswordResetKey, fromPasswordResetKey), - ) testObject_CompletePasswordReset_user_1 :: CompletePasswordReset testObject_CompletePasswordReset_user_1 = diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/InvitationRequest_team.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/InvitationRequest_team.hs index ae61c5089ae..c76edfc41a2 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/InvitationRequest_team.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/InvitationRequest_team.hs @@ -20,15 +20,11 @@ module Test.Wire.API.Golden.Generated.InvitationRequest_team where import Data.ISO3166_CountryCodes (CountryCode (BJ, FJ, GH, LB, ME, NL, OM, PA, TC, TZ)) import Data.LanguageCodes qualified (ISO639_1 (AF, AR, DA, DV, KJ, KS, KU, LG, NN, NY, OM, SI)) import Imports (Maybe (Just, Nothing)) +import Wire.API.Locale import Wire.API.Team.Invitation (InvitationRequest (..)) import Wire.API.Team.Role (Role (RoleAdmin, RoleExternalPartner, RoleMember, RoleOwner)) import Wire.API.User.Identity (Email (Email, emailDomain, emailLocal), Phone (Phone, fromPhone)) -import Wire.API.User.Profile - ( Country (Country, fromCountry), - Language (Language), - Locale (Locale, lCountry, lLanguage), - Name (Name, fromName), - ) +import Wire.API.User.Profile (Name (Name, fromName)) testObject_InvitationRequest_team_1 :: InvitationRequest testObject_InvitationRequest_team_1 = diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/LoginId_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/LoginId_user.hs index f1c087404af..117789dfdf7 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/LoginId_user.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/LoginId_user.hs @@ -17,7 +17,8 @@ module Test.Wire.API.Golden.Generated.LoginId_user where -import Data.Handle (Handle (Handle, fromHandle)) +import Data.Handle (parseHandle) +import Data.Maybe import Wire.API.User (Email (Email, emailDomain, emailLocal), Phone (Phone, fromPhone)) import Wire.API.User.Auth (LoginId (..)) @@ -39,7 +40,7 @@ testObject_LoginId_user_3 = ) testObject_LoginId_user_4 :: LoginId -testObject_LoginId_user_4 = LoginByHandle (Handle {fromHandle = "7a8gg3v98"}) +testObject_LoginId_user_4 = LoginByHandle (fromJust (parseHandle "7a8gg3v98")) testObject_LoginId_user_5 :: LoginId testObject_LoginId_user_5 = LoginByPhone (Phone {fromPhone = "+041157889572"}) @@ -48,7 +49,7 @@ testObject_LoginId_user_6 :: LoginId testObject_LoginId_user_6 = LoginByPhone (Phone {fromPhone = "+2351341820189"}) testObject_LoginId_user_7 :: LoginId -testObject_LoginId_user_7 = LoginByHandle (Handle {fromHandle = "lb"}) +testObject_LoginId_user_7 = LoginByHandle (fromJust (parseHandle "lb")) testObject_LoginId_user_8 :: LoginId testObject_LoginId_user_8 = LoginByPhone (Phone {fromPhone = "+2831673805093"}) @@ -58,12 +59,7 @@ testObject_LoginId_user_9 = LoginByPhone (Phone {fromPhone = "+1091378734554"}) testObject_LoginId_user_10 :: LoginId testObject_LoginId_user_10 = - LoginByHandle - ( Handle - { fromHandle = - "z58-6fbjhtx11d8t6oplyijpkc2.fp_lf3kpk3_.qle4iecjun2xd0tpcordlg2bwv636v3cthpgwah3undqmuofgzp8ry6gc6g-n-kxnj7sl6771hxou7-t_ps_lu_t3.4ukz6dh6fkjq2i3aggtkbpzbd1162.qv.rbtb6e.90-xpayg65z9t9lk2aur452zcs9a" - } - ) + LoginByHandle (fromJust (parseHandle "z58-6fbjhtx11d8t6oplyijpkc2.fp_lf3kpk3_.qle4iecjun2xd0tpcordlg2bwv636v3cthpgwah3undqmuofgzp8ry6gc6g-n-kxnj7sl6771hxou7-t_ps_lu_t3.4ukz6dh6fkjq2i3aggtkbpzbd1162.qv.rbtb6e.90-xpayg65z9t9lk2aur452zcs9a")) testObject_LoginId_user_11 :: LoginId testObject_LoginId_user_11 = @@ -110,14 +106,14 @@ testObject_LoginId_user_16 = ) testObject_LoginId_user_17 :: LoginId -testObject_LoginId_user_17 = LoginByHandle (Handle {fromHandle = "e3iusdy"}) +testObject_LoginId_user_17 = LoginByHandle (fromJust (parseHandle "e3iusdy")) testObject_LoginId_user_18 :: LoginId testObject_LoginId_user_18 = - LoginByHandle (Handle {fromHandle = "8vpices3usz1dfs4u2lf_e3jendod_szl1z111_eoj4b7k7ajj-xo.qzbw4espf3smnz_"}) + LoginByHandle (fromJust (parseHandle "8vpices3usz1dfs4u2lf_e3jendod_szl1z111_eoj4b7k7ajj-xo.qzbw4espf3smnz_")) testObject_LoginId_user_19 :: LoginId -testObject_LoginId_user_19 = LoginByHandle (Handle {fromHandle = "3jzpp2bo8"}) +testObject_LoginId_user_19 = LoginByHandle (fromJust (parseHandle "3jzpp2bo8")) testObject_LoginId_user_20 :: LoginId testObject_LoginId_user_20 = LoginByEmail (Email {emailLocal = "", emailDomain = "\155899"}) diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Login_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Login_user.hs index cb3c93848e4..e0b6a4cf88a 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Login_user.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Login_user.hs @@ -18,11 +18,12 @@ module Test.Wire.API.Golden.Generated.Login_user where import Data.Code -import Data.Handle (Handle (Handle, fromHandle)) +import Data.Handle (parseHandle) +import Data.Maybe import Data.Misc (plainTextPassword6Unsafe) import Data.Range (unsafeRange) import Data.Text.Ascii (AsciiChars (validate)) -import Imports (Maybe (Just, Nothing), fromRight, undefined) +import Imports import Wire.API.User (Email (Email, emailDomain, emailLocal), Phone (Phone, fromPhone)) import Wire.API.User.Auth @@ -51,7 +52,7 @@ testObject_Login_user_3 :: Login testObject_Login_user_3 = PasswordLogin ( PasswordLoginData - (LoginByHandle (Handle {fromHandle = "c2wp.7s5."})) + (LoginByHandle (fromJust (parseHandle "c2wp.7s5."))) ( plainTextPassword6Unsafe "&\RS\DC4\1104052Z\11418n\SO\158691\1010906/\127253'\1063038m\1010345\"\9772\138717\RS(&\996590\SOf1Wf'I\SI\100286\1047270\1033961\DC1Jq\1050673Y\\Bedu@\1014647c\1003986D\53211\1050614S\144414\ETX\ETXW>\1005358\DC4\rSO8FXy\166833a\EM\170017\SUBNF\158145L\RS$5\NULk\RSz*s\148780\157980\v\175417\"SY\DEL\STX\994691\1103514ub5q\ENQ\1014299\vN.\t\183536:l\1105396\RS\1027721\a\168001\SO\vt\1098704W\SYN\1042396\1109979\a'v\ETB\64211\NAK\59538\STX \NAK\STX\49684,\1111630x\1047668^\1067127\27366I;\NAKb\1092049o\162763_\190546MME\1022528\SI\1096252H;\SO\ETBs\SO\1065937{Knlrd;\35750\DC4\SI\1075008TO\1090529\999639U\48787\1099927t\1068680^y\17268u$\DC1Jp\1054308\164905\164446\STX\"\1095399*\SO\1004302\32166\990924X\1098844\ETXsK}\b\143918\NUL0\988724\&12\171116\tM052\189551\EOT0\RS\986138\1084688{ji\ESC\1020800\27259&t \SI\ESCy\aL\136111\131558\994027\r\1054821ga,\DC4do,tx[I&\DC4h\DLE\ETX\DLEBpm\1002292-\a]/ZI\1033117q]w3n\46911e\23692kYo5\1090844'K\1089820}v\146759;\1018792\\=\41264\&8g\DLEg*has\44159\1006118\DC3\USYg?I\19462\NAKaW2\150415m\t}h\155161RbU\STX\ETBlz2!\DC3JW5\ESC\1026156U\SOg,rpO\5857]0\ESC\479\1005443F\SI\1045994\RS\SO\11908rl\1104306~\ACK+Mn{5\993784a\EM2\v{jM\ETBT\1058105$\DC1\1099974\GSj_~Z\1007141P\SOH\EOTo@TJhk\EOT\ETBk:-\96583[p\DLE\DC1\RS'\r\STXQ,,\1016866?H\rh\30225\rj\147982\DC2\\(u\ESCu\154705\1002696o\DC4\988492\1103465\1052034\DC1q\GS-\b\40807\DC1qW>\fys\8130,'\159954<" ) @@ -73,11 +74,7 @@ testObject_Login_user_5 = PasswordLogin ( PasswordLoginData ( LoginByHandle - ( Handle - { fromHandle = - "c372iaa_v5onjcck67rlzq4dn5_oxhtx7dpx7v82lp1rhx0e97i26--8r3c6k773bxtlzmkjc20-11_047ydua_o9_5u4sll_fl3ng_0sa." - } - ) + (fromJust (parseHandle "c372iaa_v5onjcck67rlzq4dn5_oxhtx7dpx7v82lp1rhx0e97i26--8r3c6k773bxtlzmkjc20-11_047ydua_o9_5u4sll_fl3ng_0sa.")) ) ( plainTextPassword6Unsafe "\120347\184756DU\1035832hp\1006715t~\DC2\SOH\STX*\1053210y1\1078382H\173223{e\\S\SO?c_7\t\DC4X\135187\&6\172722E\100168j\SUB\t\SYN\1088511>HO]60\990035\ETX\"+w,t\1066040\ak(b%u\151197`>b\1028272e\ACKc\151393\1107996)\12375\&7\1082464`\186313yO+v%\1033664\rc<\65764\&2>8u\1094258\1080669\1113623\75033a\179193\NAK=\EOT\1077021\&8R&j\1042630\ESC\t4sj-\991835\40404n\136765\1064089N\GS\\\1026123\72288\&5\r\97004(P!\DEL\29235\26855\b\1067772Mr~\65123\EMjt>Z\GS~\140732A\1031358\SO\\>\DC16\">%\45860\1084751I@u5\187891\vrY\r;7\1071052#\1078407\1016286\CAN'\63315\1041397\EM_I_zY\987300\149441\EMd\1039844cd\DEL\1061999\136326Cp3\26325\GSXj\n\46305jy\44050\58825\t-\19065\43336d\1046547L\SUBYF\ACKPOL\54766\DC2\DC1\DC1\DC2*\rH\DLE(?\DC3F\25820\DLE\r]\1069451j\170177 @\ENQT\1100685s\FSF2\NAK]8\a\DC3!\NAKW\176469\1110834K\1025058\1112222_%\1001818\1113069'\1098149\70360(#\SOHky\t\ETB!\17570\NAK\DC4\ESC{\119317U2LS'" @@ -126,7 +123,7 @@ testObject_Login_user_9 :: Login testObject_Login_user_9 = PasswordLogin ( PasswordLoginData - (LoginByHandle (Handle {fromHandle = "6bolp"})) + (LoginByHandle (fromJust (parseHandle "6bolp"))) ( plainTextPassword6Unsafe ">1/\t\NAK \1010386\1013311z\33488Bv\1109131(=<\SOq\1104556?L\6845\1066491\2972c\997644<&!\1103500\999823j~O3USw\DC2\ETX\a\ETB+\1024033Ny\31920(/Sco\STX{3\SIEh\SYN\1032591\1022672\27668-\FS.'\ENQX\98936\150419Ti3\1051250\"%\SYN\b\188444+\EOT\STX^\1108463)2bR\ACK\SIJB[\1045179&O9{w{aV\ENQgZ?3z\1065517\&8\4979\156950\990517`\1063252\"PE)uKq|w\SYN0\ESC. \ETX\73440sxW\160357\1001111m\ENQ7e)\77912\1008764:s\CANYj\9870\16356\ACK\USlTu\1110309I.\1087068O#kQ\RS!g\1062167\CANQ\US\172867\SYN\ACK|\"M\"P\US\ETX@ZPq\1016598gY\148621=\a\1057645l8\1041152\&3\995012\1022626CN<\147876gJ\1038434]\94932mX~\ACKw3\DLE\179764\&8\a6\EOT}\DLEi\DC3L5\1032336PY^|!Vz\ESC4\36208!iLa\12091\DC4\1059706\167964\GS:\1042431\149640h\\dLx\1087701\EM\194900\SUB\134635R%ps7\95168s\1074387fg\nIf\1067199\DC1l\SUB\1022871-n_\6065UY?4d]|c\\[T\ajS\18838\55046\37136aK\1025430\1112672\ETX\FSx+" ) diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewBotRequest_provider.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewBotRequest_provider.hs index b8088ef6121..2c98a252b64 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewBotRequest_provider.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewBotRequest_provider.hs @@ -20,7 +20,7 @@ module Test.Wire.API.Golden.Generated.NewBotRequest_provider where import Data.Domain -import Data.Handle (Handle (Handle, fromHandle)) +import Data.Handle (parseHandle) import Data.ISO3166_CountryCodes ( CountryCode ( AO, @@ -71,6 +71,7 @@ import Data.UUID qualified as UUID (fromString) import Imports (Maybe (Just, Nothing), fromJust, (.)) import Wire.API.Conversation.Member import Wire.API.Conversation.Role (parseRoleName) +import Wire.API.Locale import Wire.API.Provider.Bot ( BotUserView ( BotUserView, @@ -86,9 +87,6 @@ import Wire.API.Provider.External (NewBotRequest (..)) import Wire.API.Provider.Service (ServiceRef (ServiceRef, _serviceRefId, _serviceRefProvider)) import Wire.API.User.Profile ( ColourId (ColourId, fromColourId), - Country (Country, fromCountry), - Language (Language), - Locale (Locale, lCountry, lLanguage), Name (Name, fromName), ) @@ -161,7 +159,7 @@ testObject_NewBotRequest_provider_2 = { botUserViewId = Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000000")), botUserViewName = Name {fromName = "}\DLE&:\bp\ETB.+H\59688 \RS\SYNq\1068740\37311"}, botUserViewColour = ColourId {fromColourId = 1}, - botUserViewHandle = Just (Handle {fromHandle = "mwt6"}), + botUserViewHandle = Just (fromJust (parseHandle "mwt6")), botUserViewTeam = Nothing }, newBotConv = @@ -185,12 +183,7 @@ testObject_NewBotRequest_provider_3 = }, botUserViewColour = ColourId {fromColourId = 1}, botUserViewHandle = - Just - ( Handle - { fromHandle = - "h.cn77ac0vrssl3li_xktkmwmps_8s6y-ntsnv5e6i6pc4tihqh6t9paxuyxopod76mgse-4pyop9v.n6uhz5" - } - ), + Just (fromJust (parseHandle "h.cn77ac0vrssl3li_xktkmwmps_8s6y-ntsnv5e6i6pc4tihqh6t9paxuyxopod76mgse-4pyop9v.n6uhz5")), botUserViewTeam = Just (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000001"))) }, newBotConv = @@ -257,7 +250,7 @@ testObject_NewBotRequest_provider_5 = }, botUserViewColour = ColourId {fromColourId = -1}, botUserViewHandle = - Just (Handle {fromHandle = "dcd5u---q-5liar3qaixbwwjjrg-79a2k413z74whfyc-k_8jvle63fhs3v.mdncia29"}), + Just (fromJust (parseHandle "dcd5u---q-5liar3qaixbwwjjrg-79a2k413z74whfyc-k_8jvle63fhs3v.mdncia29")), botUserViewTeam = Just (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000000"))) }, newBotConv = @@ -280,7 +273,7 @@ testObject_NewBotRequest_provider_6 = "vK!_\DLE:\ESCI0\168602U\144178\b\NUL*\70679%\SUBvf7\59967\&7\1022395\51118\NULQn\1098780_\1052931]FIF\NUL\994410m?a\DC1\134034+\US\1016849[U\1056197v\rU$:\986190\SOm[\987847\1007064\DC1H\DEL\ENQ$_^e8e\1085721E')y\33670\EMR\v[Z\f)\SI\DC4\119067\137276\1039160c;'\170985\1064339\51122\RS\43522\ENQj\8110\1098421\\\133676PL|n\ETB\984318\1038283" }, botUserViewColour = ColourId {fromColourId = 1}, - botUserViewHandle = Just (Handle {fromHandle = "chuc8zlscl1gioct"}), + botUserViewHandle = Just (fromJust (parseHandle "chuc8zlscl1gioct")), botUserViewTeam = Just (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000001"))) }, newBotConv = @@ -350,7 +343,7 @@ testObject_NewBotRequest_provider_7 = { botUserViewId = Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000000")), botUserViewName = Name {fromName = "]\98090\DEL\SO\GSq{9\143048j\135048"}, botUserViewColour = ColourId {fromColourId = 1}, - botUserViewHandle = Just (Handle {fromHandle = "kfgs"}), + botUserViewHandle = Just (fromJust (parseHandle "kfgs")), botUserViewTeam = Just (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000000"))) }, newBotConv = @@ -369,7 +362,7 @@ testObject_NewBotRequest_provider_8 = { botUserViewId = Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000001")), botUserViewName = Name {fromName = "0H\164007\1094020\CAN\1063257\v1\1064417\1068260(r"}, botUserViewColour = ColourId {fromColourId = 1}, - botUserViewHandle = Just (Handle {fromHandle = ".x1v4"}), + botUserViewHandle = Just (fromJust (parseHandle ".x1v4")), botUserViewTeam = Nothing }, newBotConv = @@ -450,7 +443,7 @@ testObject_NewBotRequest_provider_10 = "\28714+w\1052759*KHRC\DC3\DC2\69702\&0\1043100u1vT\ACK\94716\SUB}\65128\"P\1054449\&3\fb_\CAN\EOT\133649B55t\SUB\29069\&8\21614\1091434I\166155\135568\29529\1084846\SUBf\1077482\SUB\9091\151919\&3\GS?U\145649\SI0\1046380\996945\&1\ESC\STX8\46655g\146307\1068045?|\GSn\a+8|\166543#H|+\1054950|\1082601\1070384\&86o\95174" }, botUserViewColour = ColourId {fromColourId = 1}, - botUserViewHandle = Just (Handle {fromHandle = "hy4dc"}), + botUserViewHandle = Just (fromJust (parseHandle "hy4dc")), botUserViewTeam = Nothing }, newBotConv = @@ -473,7 +466,7 @@ testObject_NewBotRequest_provider_11 = "\1034857\ENQ<\ETB\1067175`pv6$?U1\f\1061\900\&6GB\SUB\154475\1039582{W@\1013922\1106400w\1040667Z\trO\1058683e\66911\25986x*YUj\nf\53235lg\ESCs_\1046674S2[\DC2e\1101653\1004868=\CAN\36589,#\1035811\1105438\DC2{2>\DC3*\EM\23235%\bfn\180748\&9<\ETBc\181499\69937Qr\146682\n" }, botUserViewColour = ColourId {fromColourId = -1}, - botUserViewHandle = Just (Handle {fromHandle = "pt-g.o"}), + botUserViewHandle = Just (fromJust (parseHandle "pt-g.o")), botUserViewTeam = Just (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000001"))) }, newBotConv = @@ -496,12 +489,7 @@ testObject_NewBotRequest_provider_12 = }, botUserViewColour = ColourId {fromColourId = 0}, botUserViewHandle = - Just - ( Handle - { fromHandle = - "2mbu57j9i5av3tl5qq3defu9ydjatm7y-bgi4nznqyvcbmdn66pma5ice6famcazb892aqtzz2_zclckldrjh6nq69sz_2p0qx99p6t2ogt9ewzzq2olgge32jyt6kmwgmzvdbeti-iygnitchblkicol8m83a8n-a2ip-yy27z2llzu7" - } - ), + Just (fromJust (parseHandle "2mbu57j9i5av3tl5qq3defu9ydjatm7y-bgi4nznqyvcbmdn66pma5ice6famcazb892aqtzz2_zclckldrjh6nq69sz_2p0qx99p6t2ogt9ewzzq2olgge32jyt6kmwgmzvdbeti-iygnitchblkicol8m83a8n-a2ip-yy27z2llzu7")), botUserViewTeam = Just (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000000"))) }, newBotConv = @@ -521,12 +509,7 @@ testObject_NewBotRequest_provider_13 = botUserViewName = Name {fromName = "6`k)?\189080V"}, botUserViewColour = ColourId {fromColourId = 0}, botUserViewHandle = - Just - ( Handle - { fromHandle = - "7g_a0on27rzpz7cfzl3hle6v7dwv.db.to.ief5xzr3eu.vr5jb57_z5t3ahmggm9oddsd-quxc1uv4xkr7ncg9ff9zicgsjenafoxe4jbtrzjagqy84xrvt7iv_dcpe7_iiyg3tpeg8fh2osxf7dv01ueygahrdokoa-2ya37r6g0b0u3j416qnnk.404lffdz" - } - ), + Just (fromJust (parseHandle "7g_a0on27rzpz7cfzl3hle6v7dwv.db.to.ief5xzr3eu.vr5jb57_z5t3ahmggm9oddsd-quxc1uv4xkr7ncg9ff9zicgsjenafoxe4jbtrzjagqy84xrvt7iv_dcpe7_iiyg3tpeg8fh2osxf7dv01ueygahrdokoa-2ya37r6g0b0u3j416qnnk.404lffdz")), botUserViewTeam = Just (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000001"))) }, newBotConv = @@ -569,7 +552,7 @@ testObject_NewBotRequest_provider_14 = "\"\161008Z9\b\57817\94488\34531yX\SYN\989653/\SUB\SUB/B\1089073B\EM?\n\119029zz\1063844\1079191T\SO]\1045646\1020565d\b[\183600\&3\35869\US\1074551\985034BVTBC8&\t\1085747\135733aRR\1071408e <(]\NAK" }, botUserViewColour = ColourId {fromColourId = -1}, - botUserViewHandle = Just (Handle {fromHandle = "ho"}), + botUserViewHandle = Just (fromJust (parseHandle "ho")), botUserViewTeam = Just (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000000"))) }, newBotConv = @@ -615,7 +598,7 @@ testObject_NewBotRequest_provider_16 = "N\ESCE`W:\"9\"\14840\DC2g_\"<\1047945\1062839GGQ/g\54646*\1005815|Sh)-\DC3&e-Y&&:\147317\1053744TWo\ETX\1010161\1009736@\SI>q\ETB\11622c\1068700|k\SOH\1090490 Dqwr\SI r\30804\161971\1014628?u\1021253AH\64817A\SOH\181530\1052127\SOHF\997870V\ACKkY\997171-\1081803\998604]'" }, botUserViewColour = ColourId {fromColourId = 1}, - botUserViewHandle = Just (Handle {fromHandle = "o8opul3h"}), + botUserViewHandle = Just (fromJust (parseHandle "o8opul3h")), botUserViewTeam = Just (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000001"))) }, newBotConv = @@ -687,7 +670,7 @@ testObject_NewBotRequest_provider_18 = "\1038532\EMz\SUB%\139660__DO}\54713\50053\CAN\47274\DELZ\13914w8<\1009245\1001975\184118\ESC\32164{|\ACK3_)\DC3]f$\1112650;Pj0\ETB\a\DC2k\nG\SUBr\145903\&2}\DC3.\EOTB\SOH\CAN\162312\EOT\145691\ETB\1087729).\41256\tNwq\1022524\59021\1088435" }, botUserViewColour = ColourId {fromColourId = 0}, - botUserViewHandle = Just (Handle {fromHandle = "gcmc3fjd3ire.maquq87awi"}), + botUserViewHandle = Just (fromJust (parseHandle "gcmc3fjd3ire.maquq87awi")), botUserViewTeam = Nothing }, newBotConv = @@ -765,12 +748,7 @@ testObject_NewBotRequest_provider_20 = }, botUserViewColour = ColourId {fromColourId = 0}, botUserViewHandle = - Just - ( Handle - { fromHandle = - "th4n3ndvnpp49es-gz55m5nnya_d.mcna7zg2t-t.xhcz6xbh17cg0.trdfgmo8whrtkl9fqdi8jg7d3nlh03p.bpumzn-.89h4.i75x6gx.x7kos0x4hqc.31hy78ckr6502kun7u7_b1a.8mw3oo3ylv.k29_zei793az7xlfaes1wa2gvu4tad52v5-w8rz9o-ivftxq5-nz87uhlm" - } - ), + Just (fromJust (parseHandle "th4n3ndvnpp49es-gz55m5nnya_d.mcna7zg2t-t.xhcz6xbh17cg0.trdfgmo8whrtkl9fqdi8jg7d3nlh03p.bpumzn-.89h4.i75x6gx.x7kos0x4hqc.31hy78ckr6502kun7u7_b1a.8mw3oo3ylv.k29_zei793az7xlfaes1wa2gvu4tad52v5-w8rz9o-ivftxq5-nz87uhlm")), botUserViewTeam = Just (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000001"))) }, newBotConv = diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewPasswordReset_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewPasswordReset_user.hs index d978208f4c9..f21c63bcbe2 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewPasswordReset_user.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewPasswordReset_user.hs @@ -17,124 +17,14 @@ module Test.Wire.API.Golden.Generated.NewPasswordReset_user where -import Imports (Either (Left, Right)) -import Wire.API.User (Email (Email, emailDomain, emailLocal), Phone (Phone, fromPhone)) -import Wire.API.User.Password (NewPasswordReset (..)) +import Wire.API.User +import Wire.API.User.Password testObject_NewPasswordReset_user_1 :: NewPasswordReset testObject_NewPasswordReset_user_1 = NewPasswordReset - ( Left - ( Email - { emailLocal = "\1007057b\1098950\&9#\34943\DLEX2o\6661\171973\60563t", - emailDomain = "\1080376\60900\DC1\41907s\f\98453}\CAN\SO\n8\SUBz\169687\n\154344Zdb#\SUB4IM8\67225+" - } - ) + ( Email + { emailLocal = "\1007057b\1098950\&9#\34943\DLEX2o\6661\171973\60563t", + emailDomain = "\1080376\60900\DC1\41907s\f\98453}\CAN\SO\n8\SUBz\169687\n\154344Zdb#\SUB4IM8\67225+" + } ) - -testObject_NewPasswordReset_user_2 :: NewPasswordReset -testObject_NewPasswordReset_user_2 = NewPasswordReset (Right (Phone {fromPhone = "+529329682"})) - -testObject_NewPasswordReset_user_3 :: NewPasswordReset -testObject_NewPasswordReset_user_3 = NewPasswordReset (Right (Phone {fromPhone = "+41719978"})) - -testObject_NewPasswordReset_user_4 :: NewPasswordReset -testObject_NewPasswordReset_user_4 = NewPasswordReset (Right (Phone {fromPhone = "+607957193"})) - -testObject_NewPasswordReset_user_5 :: NewPasswordReset -testObject_NewPasswordReset_user_5 = NewPasswordReset (Right (Phone {fromPhone = "+83279556464710"})) - -testObject_NewPasswordReset_user_6 :: NewPasswordReset -testObject_NewPasswordReset_user_6 = - NewPasswordReset - ( Left - ( Email - { emailLocal = "\152884", - emailDomain = - "pkTt\1001860,K\1102090C\53037\&2\1035134\1067347s\n\r\1067827\1098299+\41929\DEL:\GS[\194887MbEC\NUL" - } - ) - ) - -testObject_NewPasswordReset_user_7 :: NewPasswordReset -testObject_NewPasswordReset_user_7 = - NewPasswordReset - ( Left - ( Email - { emailLocal = "N\189885V'}\985226\a3", - emailDomain = "*\SYNjF\18337\"~Z\58036\41350z\138497bN\131493\8948)I3\t\EOT\1042981\1077394,\DC4" - } - ) - ) - -testObject_NewPasswordReset_user_8 :: NewPasswordReset -testObject_NewPasswordReset_user_8 = - NewPasswordReset - ( Left - ( Email - { emailLocal = "(a\34126'CKj\ESC\EM\1051534", - emailDomain = "?\986742D\135082\1012625\&7\1076206eh\18902gS\1090140}\1073865n_" - } - ) - ) - -testObject_NewPasswordReset_user_9 :: NewPasswordReset -testObject_NewPasswordReset_user_9 = - NewPasswordReset - ( Left - ( Email - { emailLocal = "\ETXji\b\a\995206\1001044\120664'\8103k\RS+", - emailDomain = - "\FS:\ETX\f\1071180\&5\22603t\135200>\174985IE\1065671M\DC2g\SUBAO\159061\&3\"\1000816H\54341c\129145\44991\&6" - } - ) - ) - -testObject_NewPasswordReset_user_10 :: NewPasswordReset -testObject_NewPasswordReset_user_10 = - NewPasswordReset - ( Left - ( Email - { emailLocal = "P\1065495m#\bo\n?n\170449\RSnr\"^c\1033506\\'g\53693l", - emailDomain = "/?\17268\1093472\SUBt\ETXv" - } - ) - ) - -testObject_NewPasswordReset_user_11 :: NewPasswordReset -testObject_NewPasswordReset_user_11 = NewPasswordReset (Right (Phone {fromPhone = "+009509628647"})) - -testObject_NewPasswordReset_user_12 :: NewPasswordReset -testObject_NewPasswordReset_user_12 = - NewPasswordReset - (Left (Email {emailLocal = "9G\144799", emailDomain = "\986254\SYN\1003426\182313\SI\STX\US\NAKgP \987001"})) - -testObject_NewPasswordReset_user_13 :: NewPasswordReset -testObject_NewPasswordReset_user_13 = NewPasswordReset (Right (Phone {fromPhone = "+33232954574312"})) - -testObject_NewPasswordReset_user_14 :: NewPasswordReset -testObject_NewPasswordReset_user_14 = NewPasswordReset (Right (Phone {fromPhone = "+314850099"})) - -testObject_NewPasswordReset_user_15 :: NewPasswordReset -testObject_NewPasswordReset_user_15 = - NewPasswordReset - ( Left - (Email {emailLocal = "\139234\21486\ETX 9\ESC0!\ETX\1007793\ETXxBxL=DL\25894/\r\7651", emailDomain = "$56f!/"}) - ) - -testObject_NewPasswordReset_user_16 :: NewPasswordReset -testObject_NewPasswordReset_user_16 = - NewPasswordReset - (Left (Email {emailLocal = "w\SOHspQ(\25060\EOT\"\\\ETXrbE\n5\111158D", emailDomain = "ps!\t\178810"})) - -testObject_NewPasswordReset_user_17 :: NewPasswordReset -testObject_NewPasswordReset_user_17 = NewPasswordReset (Right (Phone {fromPhone = "+560530602858"})) - -testObject_NewPasswordReset_user_18 :: NewPasswordReset -testObject_NewPasswordReset_user_18 = NewPasswordReset (Right (Phone {fromPhone = "+2603603795"})) - -testObject_NewPasswordReset_user_19 :: NewPasswordReset -testObject_NewPasswordReset_user_19 = NewPasswordReset (Right (Phone {fromPhone = "+002938255629"})) - -testObject_NewPasswordReset_user_20 :: NewPasswordReset -testObject_NewPasswordReset_user_20 = NewPasswordReset (Right (Phone {fromPhone = "+77098859488192"})) diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewUserPublic_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewUserPublic_user.hs index dd4280f8b41..e51c5ce8aff 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewUserPublic_user.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewUserPublic_user.hs @@ -38,7 +38,8 @@ testObject_NewUserPublic_user_1 = { newUserDisplayName = Name {fromName = "\\sY4]u\1033976\DLE\1027259\FS\ETX \US\ETB\1066640dw;}\1073386@\184511\r8"}, newUserUUID = Nothing, - newUserIdentity = Just (PhoneIdentity (Phone {fromPhone = "+35453839"})), + newUserIdentity = Just (EmailIdentity (Email {emailLocal = "test", emailDomain = "example.com"})), + newUserPhone = Nothing, newUserPict = Nothing, newUserAssets = [ ImageAsset (AssetKeyV3 (Id (fromJust (UUID.fromString "5cd81cc4-c643-4e9c-849c-c596a88c27fd"))) AssetExpiring) (Just AssetComplete), @@ -52,8 +53,7 @@ testObject_NewUserPublic_user_1 = { fromActivationCode = fromRight undefined (validate "cfTQLlhl6H6sYloQXsghILggxWoGhM2WGbxjzm0=") } ), - newUserPhoneCode = - Just (ActivationCode {fromActivationCode = fromRight undefined (validate "wCWrnJoscPLT")}), + newUserPhoneCode = Nothing, newUserOrigin = Just ( NewUserOriginTeamUser diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewUser_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewUser_user.hs index d596164f75c..5d0a458757c 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewUser_user.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewUser_user.hs @@ -39,31 +39,8 @@ import Imports (Maybe (Just, Nothing), fromJust, fromRight, undefined, (.)) import Wire.API.Asset import Wire.API.Team (BindingNewTeam (..), Icon (..), NewTeam (..)) import Wire.API.User - ( Asset (ImageAsset), - AssetSize (..), - BindingNewTeamUser (..), - ColourId (ColourId, fromColourId), - Country (Country, fromCountry), - Email (Email, emailDomain, emailLocal), - InvitationCode (InvitationCode, fromInvitationCode), - Language (Language), - Locale (Locale, lCountry, lLanguage), - ManagedBy (ManagedByWire), - Name (Name, fromName), - NewTeamUser (..), - NewUser (..), - NewUserOrigin (..), - Pict (Pict, fromPict), - UserIdentity - ( EmailIdentity, - PhoneIdentity, - SSOIdentity - ), - emptyNewUser, - ) import Wire.API.User.Activation (ActivationCode (ActivationCode, fromActivationCode)) import Wire.API.User.Auth (CookieLabel (CookieLabel, cookieLabelText)) -import Wire.API.User.Identity (Phone (..), UserSSOId (UserSSOId), mkSimpleSampleUref) testObject_NewUser_user_1 :: NewUser testObject_NewUser_user_1 = @@ -75,6 +52,7 @@ testObject_NewUser_user_1 = }, newUserUUID = (Just . toUUID) (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000"))), newUserIdentity = Just (EmailIdentity (Email {emailLocal = "S\ENQX\1076723$\STX\"\1110507e\1015716\24831\1031964L\ETB", emailDomain = "P.b"})), + newUserPhone = Nothing, newUserPict = Just (Pict {fromPict = []}), newUserAssets = [ ImageAsset (AssetKeyV3 (Id (fromJust (UUID.fromString "5cd81cc4-c643-4e9c-849c-c596a88c27fd"))) AssetExpiring) (Just AssetPreview), @@ -83,7 +61,7 @@ testObject_NewUser_user_1 = ], newUserAccentId = Just (ColourId {fromColourId = -7404}), newUserEmailCode = Just (ActivationCode {fromActivationCode = fromRight undefined (validate "1YgaHo0=")}), - newUserPhoneCode = Just (ActivationCode {fromActivationCode = fromRight undefined (validate "z1OeJQ==")}), + newUserPhoneCode = Nothing, newUserOrigin = Just ( NewUserOriginInvitationCode @@ -143,7 +121,7 @@ testObject_NewUser_user_6 = (Name {fromName = "test name"}) ) { newUserOrigin = Just (NewUserOriginTeamUser (NewTeamMemberSSO tid)), - newUserIdentity = Just (SSOIdentity (UserSSOId mkSimpleSampleUref) Nothing Nothing) + newUserIdentity = Just (SSOIdentity (UserSSOId mkSimpleSampleUref) Nothing) } where tid = Id (fromJust (UUID.fromString "00007b0e-0000-3489-0000-075c00005be7")) @@ -154,7 +132,7 @@ testObject_NewUser_user_7 = (Name {fromName = "test name"}) ) { newUserOrigin = Just (NewUserOriginTeamUser (NewTeamCreator user)), - newUserIdentity = Just (PhoneIdentity (Phone "+12345678")), + newUserIdentity = Just (EmailIdentity (Email "12345678" "example.com")), newUserPassword = Just (plainTextPassword8Unsafe "12345678") } where @@ -184,6 +162,26 @@ testObject_NewUser_user_8 = (Name {fromName = "test name"}) ) { newUserOrigin = Just (NewUserOriginTeamUser (NewTeamMember invCode)), - newUserIdentity = Just (PhoneIdentity (Phone "+12345678")), + newUserIdentity = + Just + ( EmailIdentity + ( Email + { emailLocal = "S\ENQX\1076723$\STX\"\1110507e\1015716\24831\1031964L\ETB", + emailDomain = "P.b" + } + ) + ), newUserPassword = Just (plainTextPassword8Unsafe "12345678") } + +testObject_NewUser_user_9 :: NewUser +testObject_NewUser_user_9 = + testObject_NewUser_user_1 + { newUserPhoneCode = + Just + ( ActivationCode + { fromActivationCode = + fromRight undefined (validate "z1OeJQ==") + } + ) + } diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/RTCConfiguration_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/RTCConfiguration_user.hs index 29c9555f4ba..19dc8b1c9f9 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/RTCConfiguration_user.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/RTCConfiguration_user.hs @@ -752,7 +752,7 @@ testObject_RTCConfiguration_user_7 = } ) ) - (mkSFTUsername (secondsToNominalDiffTime 12) "username") + (mkSFTUsername False (secondsToNominalDiffTime 12) "username") "credential" ] ) diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/SFTServer_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/SFTServer_user.hs index b34fc94d32e..a109e29d241 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/SFTServer_user.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/SFTServer_user.hs @@ -47,5 +47,5 @@ testObject_SFTServer_user_1 = } ) ) - (mkSFTUsername (secondsToNominalDiffTime 12) "username") + (mkSFTUsername True (secondsToNominalDiffTime 12) "username") "credential" diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/SelfProfile_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/SelfProfile_user.hs index 8347f901b60..d2ad435f18c 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/SelfProfile_user.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/SelfProfile_user.hs @@ -20,7 +20,7 @@ module Test.Wire.API.Golden.Generated.SelfProfile_user where import Data.Domain (Domain (Domain, _domainText)) -import Data.Handle (Handle (Handle, fromHandle)) +import Data.Handle import Data.ISO3166_CountryCodes (CountryCode (PA)) import Data.Id (Id (Id)) import Data.Json.Util (readUTCTimeMillis) @@ -42,7 +42,7 @@ testObject_SelfProfile_user_1 = qDomain = Domain {_domainText = "n0-994.m-226.f91.vg9p-mj-j2"} }, userIdentity = - Just (FullIdentity (Email {emailLocal = "\a", emailDomain = ""}) (Phone {fromPhone = "+6171884202"})), + Just (EmailIdentity (Email {emailLocal = "\a", emailDomain = ""})), userDisplayName = Name {fromName = "@\1457\2598\66242\US\1104967l+\137302\&6\996495^\162211Mu\t"}, userPict = Pict {fromPict = []}, userAssets = [], @@ -57,7 +57,7 @@ testObject_SelfProfile_user_1 = _serviceRefProvider = Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000001")) } ), - userHandle = Just (Handle {fromHandle = "do9-5"}), + userHandle = Just (fromJust (parseHandle "do9-5")), userExpire = Just (fromJust (readUTCTimeMillis "1864-05-07T21:09:29.342Z")), userTeam = Just (Id (fromJust (UUID.fromString "00000001-0000-0002-0000-000000000002"))), userManagedBy = ManagedByScim, diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/SendActivationCode_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/SendActivationCode_user.hs index 03758db46bd..9ef7d361f43 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/SendActivationCode_user.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/SendActivationCode_user.hs @@ -71,7 +71,11 @@ testObject_SendActivationCode_user_4 = testObject_SendActivationCode_user_5 :: SendActivationCode testObject_SendActivationCode_user_5 = - SendActivationCode {saUserKey = Right (Phone {fromPhone = "+883124214493"}), saLocale = Nothing, saCall = False} + SendActivationCode + { saUserKey = Left (Email {emailLocal = "test", emailDomain = "example.com"}), + saLocale = Nothing, + saCall = False + } testObject_SendActivationCode_user_6 :: SendActivationCode testObject_SendActivationCode_user_6 = diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/UserProfile_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/UserProfile_user.hs index e0790e3d8c6..44f9d311e39 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/UserProfile_user.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/UserProfile_user.hs @@ -20,7 +20,7 @@ module Test.Wire.API.Golden.Generated.UserProfile_user where import Data.Domain (Domain (Domain, _domainText)) -import Data.Handle (Handle (Handle, fromHandle)) +import Data.Handle import Data.Id (Id (Id)) import Data.Json.Util (readUTCTimeMillis) import Data.LegalHold (UserLegalHoldStatus (..)) @@ -73,12 +73,7 @@ testObject_UserProfile_user_2 = } ), profileHandle = - Just - ( Handle - { fromHandle = - "emsonpvo3-x_4ys4qjtjtkfgx.mag6pi2ldq.77m5vnsn_tte41r-0vwgklpeejr1t4se0bknu4tsuqs-njzh34-ba_mj8lm5x6aro4o.2wsqe0ldx" - } - ), + Just (fromJust (parseHandle "emsonpvo3-x_4ys4qjtjtkfgx.mag6pi2ldq.77m5vnsn_tte41r-0vwgklpeejr1t4se0bknu4tsuqs-njzh34-ba_mj8lm5x6aro4o.2wsqe0ldx")), profileExpire = Just (fromJust (readUTCTimeMillis "1864-05-09T01:42:22.437Z")), profileTeam = Just (Id (fromJust (UUID.fromString "00000000-0000-0002-0000-000200000002"))), profileEmail = Just (Email {emailLocal = "\172353 ", emailDomain = ""}), diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/User_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/User_user.hs index c744ea8f57a..42e501c6f2b 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/User_user.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/User_user.hs @@ -20,7 +20,7 @@ module Test.Wire.API.Golden.Generated.User_user where import Data.Domain (Domain (Domain, _domainText)) -import Data.Handle (Handle (Handle, fromHandle)) +import Data.Handle import Data.ISO3166_CountryCodes ( CountryCode ( MQ, @@ -77,7 +77,7 @@ testObject_User_user_2 = { qUnqualified = Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000200000001")), qDomain = Domain {_domainText = "k.vbg.p"} }, - userIdentity = Just (PhoneIdentity (Phone {fromPhone = "+837934954"})), + userIdentity = Just (EmailIdentity (Email "foo" "example.com")), userDisplayName = Name { fromName = @@ -129,7 +129,7 @@ testObject_User_user_3 = _serviceRefProvider = Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000000")) } ), - userHandle = Just (Handle {fromHandle = "1c"}), + userHandle = Just (fromJust (parseHandle "1c")), userExpire = Just (fromJust (readUTCTimeMillis "1864-05-09T20:12:05.821Z")), userTeam = Just (Id (fromJust (UUID.fromString "00000002-0000-0001-0000-000200000000"))), userManagedBy = ManagedByWire, @@ -145,7 +145,7 @@ testObject_User_user_4 = qDomain = Domain {_domainText = "28b.cqb"} }, userIdentity = - Just (SSOIdentity (UserScimExternalId "") (Just (Email {emailLocal = "", emailDomain = ""})) Nothing), + Just (SSOIdentity (UserScimExternalId "") (Just (Email {emailLocal = "", emailDomain = ""}))), userDisplayName = Name { fromName = @@ -164,12 +164,7 @@ testObject_User_user_4 = } ), userHandle = - Just - ( Handle - { fromHandle = - "iw2-.udd2l7-7yg3dfg.wzn4vx3hjhch8.--5t6uyjqk93twv-a2pce8p1xjh7387nztzu.q" - } - ), + Just (fromJust (parseHandle "iw2-.udd2l7-7yg3dfg.wzn4vx3hjhch8.--5t6uyjqk93twv-a2pce8p1xjh7387nztzu.q")), userExpire = Just (fromJust (readUTCTimeMillis "1864-05-09T14:25:26.089Z")), userTeam = Just (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000002"))), userManagedBy = ManagedByScim, @@ -185,7 +180,7 @@ testObject_User_user_5 = qDomain = Domain {_domainText = "28b.cqb"} }, userIdentity = - Just (FullIdentity (Email {emailLocal = "", emailDomain = ""}) (Phone {fromPhone = "+837934954"})), + Just (EmailIdentity (Email {emailLocal = "bar", emailDomain = "example.com"})), userDisplayName = Name { fromName = @@ -204,12 +199,7 @@ testObject_User_user_5 = } ), userHandle = - Just - ( Handle - { fromHandle = - "iw2-.udd2l7-7yg3dfg.wzn4vx3hjhch8.--5t6uyjqk93twv-a2pce8p1xjh7387nztzu.q" - } - ), + Just (fromJust (parseHandle "iw2-.udd2l7-7yg3dfg.wzn4vx3hjhch8.--5t6uyjqk93twv-a2pce8p1xjh7387nztzu.q")), userExpire = Just (fromJust (readUTCTimeMillis "1864-05-09T14:25:26.089Z")), userTeam = Just (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000002"))), userManagedBy = ManagedByScim, diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/WithStatus_team.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/WithStatus_team.hs index 22ea58eba03..78523389109 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/WithStatus_team.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/WithStatus_team.hs @@ -19,7 +19,9 @@ module Test.Wire.API.Golden.Generated.WithStatus_team where +import Data.ByteString.Conversion (parser, runParser) import Data.Domain +import Data.Misc import Imports import Wire.API.Team.Feature hiding (withStatus) import Wire.API.Team.Feature qualified as F @@ -83,6 +85,23 @@ testObject_WithStatus_team_18 = ( MlsE2EIdConfig (fromIntegral @Int (60 * 60 * 24)) Nothing + (either (\e -> error (show e)) Just $ parseHttpsUrl "https://example.com") + False + ) + +parseHttpsUrl :: ByteString -> Either String HttpsUrl +parseHttpsUrl url = runParser parser url + +testObject_WithStatus_team_19 :: WithStatus MlsE2EIdConfig +testObject_WithStatus_team_19 = + withStatus + FeatureStatusEnabled + LockStatusLocked + ( MlsE2EIdConfig + (fromIntegral @Int (60 * 60 * 24)) + (either (\e -> error (show e)) Just $ parseHttpsUrl "https://example.com") + Nothing + True ) withStatus :: FeatureStatus -> LockStatus -> cfg -> WithStatus cfg diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Runner.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Runner.hs index 6a458413d84..a7db1f7594d 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Runner.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Runner.hs @@ -147,7 +147,7 @@ testFromJSONFailureWithMsg msg path = do where failurePrefix = show (typeRep @a) <> ": FromJSON of " <> path -assertRight :: Show a => Either a b -> IO b +assertRight :: (Show a) => Either a b -> IO b assertRight = \case Left a -> assertFailure $ "Expected Right, got Left: " <> show a diff --git a/libs/wire-api/test/golden/fromJSON/testObject_NewUserPublic_user_1-2.json b/libs/wire-api/test/golden/fromJSON/testObject_NewUserPublic_user_1-2.json index 1d92088b8d5..b766fba68f4 100644 --- a/libs/wire-api/test/golden/fromJSON/testObject_NewUserPublic_user_1-2.json +++ b/libs/wire-api/test/golden/fromJSON/testObject_NewUserPublic_user_1-2.json @@ -16,13 +16,12 @@ "type": "image" } ], + "email": "test@example.com", "email_code": "cfTQLlhl6H6sYloQXsghILggxWoGhM2WGbxjzm0=", "label": ">>Mp१𤘇9:󺰽􋼒\u0010D1j󾮢􂊠;􄆇󳸪f#]", "locale": "so", "managed_by": "wire", "name": "\\sY4]u󼛸\u0010󺲻\u001c\u0003 \u001f\u0017􄚐dw;}􆃪@𭂿\r8", "password": "dX󹊒赲󶻎ht𘙏󴰏\u0007>\u0018\u000bO95\u0015\n(𩝙󻞌嶝f]_𪀮\u00002FQbNS=6g󿷼P𢲾􃨫󰧽􅤹M\u001e7\u0016~\u0017m󽎭\u0006\u0001\u000bkgmBp\u0017w悬𩓯f󹼮%Q\u0004𢔶kP|G𥬅\u0017B-\nJWH(8)4$󱠶<7𭨖\u001cI\u0008A\u0010\r?󹀊\u0008\u00085\u0006󶟨d \u00166􍉶G\u0018\u0008\t=qG􃁰 D\u0002vV\tYpg󸋮吝q\n \u0017L􁼛-􏕋\u0013󺃝F7Q􊔜]揃i?\r\u0010\u001b{=􎕻_?e􇢹%\u000eR󱆼\u001b+\u000ef\u0017q:g\\Rk馍𪝞[l\u0015􉜀VK\njwp\u00043TJྏEj\u0002R7d83ON\u0017q獿\u0019𮣜N8\n\u000f󻦼u:GꓻFZ\u001c<\u0015揤7􉖬tH󿳸;hbS{ꮯ\u001csMs󲷒9B4􀷾35c(~CUc󸇪\\V_XD3>Mp१𤘇9:󺰽􋼒\u0010D1j󾮢􂊠;􄆇󳸪f#]", "locale": "so", "managed_by": "scim", "name": "\\sY4]u󼛸\u0010󺲻\u001c\u0003 \u001f\u0017􄚐dw;}􆃪@𭂿\r8", - "password": "dX󹊒赲󶻎ht𘙏󴰏\u0007>\u0018\u000bO95\u0015\n(𩝙󻞌嶝f]_𪀮\u00002FQbNS=6g󿷼P𢲾􃨫󰧽􅤹M\u001e7\u0016~\u0017m󽎭\u0006\u0001\u000bkgmBp\u0017w悬𩓯f󹼮%Q\u0004𢔶kP|G𥬅\u0017B-\nJWH(8)4$󱠶<7𭨖\u001cI\u0008A\u0010\r?󹀊\u0008\u00085\u0006󶟨d \u00166􍉶G\u0018\u0008\t=qG􃁰 D\u0002vV\tYpg󸋮吝q\n \u0017L􁼛-􏕋\u0013󺃝F7Q􊔜]揃i?\r\u0010\u001b{=􎕻_?e􇢹%\u000eR󱆼\u001b+\u000ef\u0017q:g\\Rk馍𪝞[l\u0015􉜀VK\njwp\u00043TJྏEj\u0002R7d83ON\u0017q獿\u0019𮣜N8\n\u000f󻦼u:GꓻFZ\u001c<\u0015揤7􉖬tH󿳸;hbS{ꮯ\u001csMs󲷒9B4􀷾35c(~CUc󸇪\\V_XD3\u0018\u000bO95\u0015\n(𩝙󻞌嶝f]_𪀮\u00002FQbNS=6g󿷼P𢲾􃨫󰧽􅤹M\u001e7\u0016~\u0017m󽎭\u0006\u0001\u000bkgmBp\u0017w悬𩓯f󹼮%Q\u0004𢔶kP|G𥬅\u0017B-\nJWH(8)4$󱠶<7𭨖\u001cI\u0008A\u0010\r?󹀊\u0008\u00085\u0006󶟨d \u00166􍉶G\u0018\u0008\t=qG􃁰 D\u0002vV\tYpg󸋮吝q\n \u0017L􁼛-􏕋\u0013󺃝F7Q􊔜]揃i?\r\u0010\u001b{=􎕻_?e􇢹%\u000eR󱆼\u001b+\u000ef\u0017q:g\\Rk馍𪝞[l\u0015􉜀VK\njwp\u00043TJྏEj\u0002R7d83ON\u0017q獿\u0019𮣜N8\n\u000f󻦼u:GꓻFZ\u001c<\u0015揤7􉖬tH󿳸;hbS{ꮯ\u001csMs󲷒9B4􀷾35c(~CUc󸇪\\V_XD3me@example.com", - "tenant": "http://example.com/" - } -} diff --git a/libs/wire-api/test/golden/testObject_ActivationResponse_user_2.json b/libs/wire-api/test/golden/testObject_ActivationResponse_user_2.json index 03b9bf0eda7..7f4dc0a99de 100644 --- a/libs/wire-api/test/golden/testObject_ActivationResponse_user_2.json +++ b/libs/wire-api/test/golden/testObject_ActivationResponse_user_2.json @@ -1,4 +1,4 @@ { - "first": false, - "phone": "+7397347696479" + "email": "foo@example.com", + "first": false } diff --git a/libs/wire-api/test/golden/testObject_ActivationResponse_user_20.json b/libs/wire-api/test/golden/testObject_ActivationResponse_user_20.json deleted file mode 100644 index 8632977b231..00000000000 --- a/libs/wire-api/test/golden/testObject_ActivationResponse_user_20.json +++ /dev/null @@ -1,5 +0,0 @@ -{ - "email": "@E", - "first": false, - "phone": "+73148778831190" -} diff --git a/libs/wire-api/test/golden/testObject_ActivationResponse_user_4.json b/libs/wire-api/test/golden/testObject_ActivationResponse_user_4.json index 93dce573572..2fc240718b3 100644 --- a/libs/wire-api/test/golden/testObject_ActivationResponse_user_4.json +++ b/libs/wire-api/test/golden/testObject_ActivationResponse_user_4.json @@ -1,5 +1,4 @@ { "email": "h\nPr3@", - "first": true, - "phone": "+82309287" + "first": true } diff --git a/libs/wire-api/test/golden/testObject_ActivationResponse_user_8.json b/libs/wire-api/test/golden/testObject_ActivationResponse_user_8.json index 513dc4fb48e..38b2903f340 100644 --- a/libs/wire-api/test/golden/testObject_ActivationResponse_user_8.json +++ b/libs/wire-api/test/golden/testObject_ActivationResponse_user_8.json @@ -1,4 +1,4 @@ { - "first": true, - "phone": "+0023160115015" + "email": "bar@example.com", + "first": true } diff --git a/libs/wire-api/test/golden/testObject_ActivationResponse_user_9.json b/libs/wire-api/test/golden/testObject_ActivationResponse_user_9.json index 0d2dac853ad..83a3641e055 100644 --- a/libs/wire-api/test/golden/testObject_ActivationResponse_user_9.json +++ b/libs/wire-api/test/golden/testObject_ActivationResponse_user_9.json @@ -1,5 +1,4 @@ { "email": "\u0005?@", - "first": false, - "phone": "+208573659013" + "first": false } diff --git a/libs/wire-api/test/golden/testObject_NewPasswordReset_user_10.json b/libs/wire-api/test/golden/testObject_NewPasswordReset_user_10.json deleted file mode 100644 index 152a1896f54..00000000000 --- a/libs/wire-api/test/golden/testObject_NewPasswordReset_user_10.json +++ /dev/null @@ -1,3 +0,0 @@ -{ - "email": "P􄈗m#\u0008o\n?n𩧑\u001enr\"^c󼔢\\'g톽l@/?䍴􊽠\u001at\u0003v" -} diff --git a/libs/wire-api/test/golden/testObject_NewPasswordReset_user_11.json b/libs/wire-api/test/golden/testObject_NewPasswordReset_user_11.json deleted file mode 100644 index 107ab814813..00000000000 --- a/libs/wire-api/test/golden/testObject_NewPasswordReset_user_11.json +++ /dev/null @@ -1,3 +0,0 @@ -{ - "phone": "+009509628647" -} diff --git a/libs/wire-api/test/golden/testObject_NewPasswordReset_user_12.json b/libs/wire-api/test/golden/testObject_NewPasswordReset_user_12.json deleted file mode 100644 index fcd31ea90cb..00000000000 --- a/libs/wire-api/test/golden/testObject_NewPasswordReset_user_12.json +++ /dev/null @@ -1,3 +0,0 @@ -{ - "email": "9G𣖟@󰲎\u0016󴾢𬠩\u000f\u0002\u001f\u0015gP 󰽹" -} diff --git a/libs/wire-api/test/golden/testObject_NewPasswordReset_user_13.json b/libs/wire-api/test/golden/testObject_NewPasswordReset_user_13.json deleted file mode 100644 index 3f76fe2e7d2..00000000000 --- a/libs/wire-api/test/golden/testObject_NewPasswordReset_user_13.json +++ /dev/null @@ -1,3 +0,0 @@ -{ - "phone": "+33232954574312" -} diff --git a/libs/wire-api/test/golden/testObject_NewPasswordReset_user_14.json b/libs/wire-api/test/golden/testObject_NewPasswordReset_user_14.json deleted file mode 100644 index 6efa3b1c7ed..00000000000 --- a/libs/wire-api/test/golden/testObject_NewPasswordReset_user_14.json +++ /dev/null @@ -1,3 +0,0 @@ -{ - "phone": "+314850099" -} diff --git a/libs/wire-api/test/golden/testObject_NewPasswordReset_user_15.json b/libs/wire-api/test/golden/testObject_NewPasswordReset_user_15.json deleted file mode 100644 index 5365ea04b92..00000000000 --- a/libs/wire-api/test/golden/testObject_NewPasswordReset_user_15.json +++ /dev/null @@ -1,3 +0,0 @@ -{ - "email": "𡿢叮\u0003 9\u001b0!\u0003󶂱\u0003xBxL=DL攦/\rᷣ@$56f!/" -} diff --git a/libs/wire-api/test/golden/testObject_NewPasswordReset_user_16.json b/libs/wire-api/test/golden/testObject_NewPasswordReset_user_16.json deleted file mode 100644 index 523c1e8b58d..00000000000 --- a/libs/wire-api/test/golden/testObject_NewPasswordReset_user_16.json +++ /dev/null @@ -1,3 +0,0 @@ -{ - "email": "w\u0001spQ(懤\u0004\"\\\u0003rbE\n5𛈶D@ps!\t𫩺" -} diff --git a/libs/wire-api/test/golden/testObject_NewPasswordReset_user_17.json b/libs/wire-api/test/golden/testObject_NewPasswordReset_user_17.json deleted file mode 100644 index 658a71b4a85..00000000000 --- a/libs/wire-api/test/golden/testObject_NewPasswordReset_user_17.json +++ /dev/null @@ -1,3 +0,0 @@ -{ - "phone": "+560530602858" -} diff --git a/libs/wire-api/test/golden/testObject_NewPasswordReset_user_18.json b/libs/wire-api/test/golden/testObject_NewPasswordReset_user_18.json deleted file mode 100644 index 50822cea0e1..00000000000 --- a/libs/wire-api/test/golden/testObject_NewPasswordReset_user_18.json +++ /dev/null @@ -1,3 +0,0 @@ -{ - "phone": "+2603603795" -} diff --git a/libs/wire-api/test/golden/testObject_NewPasswordReset_user_19.json b/libs/wire-api/test/golden/testObject_NewPasswordReset_user_19.json deleted file mode 100644 index 4625c19bd3c..00000000000 --- a/libs/wire-api/test/golden/testObject_NewPasswordReset_user_19.json +++ /dev/null @@ -1,3 +0,0 @@ -{ - "phone": "+002938255629" -} diff --git a/libs/wire-api/test/golden/testObject_NewPasswordReset_user_2.json b/libs/wire-api/test/golden/testObject_NewPasswordReset_user_2.json deleted file mode 100644 index 68395a3ba7c..00000000000 --- a/libs/wire-api/test/golden/testObject_NewPasswordReset_user_2.json +++ /dev/null @@ -1,3 +0,0 @@ -{ - "phone": "+529329682" -} diff --git a/libs/wire-api/test/golden/testObject_NewPasswordReset_user_3.json b/libs/wire-api/test/golden/testObject_NewPasswordReset_user_3.json deleted file mode 100644 index 56f49e6a58f..00000000000 --- a/libs/wire-api/test/golden/testObject_NewPasswordReset_user_3.json +++ /dev/null @@ -1,3 +0,0 @@ -{ - "phone": "+41719978" -} diff --git a/libs/wire-api/test/golden/testObject_NewPasswordReset_user_4.json b/libs/wire-api/test/golden/testObject_NewPasswordReset_user_4.json deleted file mode 100644 index 174d2ed33e6..00000000000 --- a/libs/wire-api/test/golden/testObject_NewPasswordReset_user_4.json +++ /dev/null @@ -1,3 +0,0 @@ -{ - "phone": "+607957193" -} diff --git a/libs/wire-api/test/golden/testObject_NewPasswordReset_user_5.json b/libs/wire-api/test/golden/testObject_NewPasswordReset_user_5.json deleted file mode 100644 index 0a8a0a8911b..00000000000 --- a/libs/wire-api/test/golden/testObject_NewPasswordReset_user_5.json +++ /dev/null @@ -1,3 +0,0 @@ -{ - "phone": "+83279556464710" -} diff --git a/libs/wire-api/test/golden/testObject_NewPasswordReset_user_6.json b/libs/wire-api/test/golden/testObject_NewPasswordReset_user_6.json deleted file mode 100644 index f62f1d3b713..00000000000 --- a/libs/wire-api/test/golden/testObject_NewPasswordReset_user_6.json +++ /dev/null @@ -1,3 +0,0 @@ -{ - "email": "𥔴@pkTt󴦄,K􍄊C켭2󼭾􄥓s\n\r􄬳􌈻+ꏉ:\u001d[真MbEC\u0000" -} diff --git a/libs/wire-api/test/golden/testObject_NewPasswordReset_user_7.json b/libs/wire-api/test/golden/testObject_NewPasswordReset_user_7.json deleted file mode 100644 index 72d7e3149eb..00000000000 --- a/libs/wire-api/test/golden/testObject_NewPasswordReset_user_7.json +++ /dev/null @@ -1,3 +0,0 @@ -{ - "email": "N𮖽V'}󰢊\u00073@*\u0016jF䞡\"~Zꆆz𡴁bN𠆥⋴)I3\t\u0004󾨥􇂒,\u0014" -} diff --git a/libs/wire-api/test/golden/testObject_NewPasswordReset_user_8.json b/libs/wire-api/test/golden/testObject_NewPasswordReset_user_8.json deleted file mode 100644 index d4f4083f802..00000000000 --- a/libs/wire-api/test/golden/testObject_NewPasswordReset_user_8.json +++ /dev/null @@ -1,3 +0,0 @@ -{ - "email": "(a蕎'CKj\u001b\u0019􀮎@?󰹶D𠾪󷎑7􆯮eh䧖gS􊉜}􆋉n_" -} diff --git a/libs/wire-api/test/golden/testObject_NewPasswordReset_user_9.json b/libs/wire-api/test/golden/testObject_NewPasswordReset_user_9.json deleted file mode 100644 index 43051dc8735..00000000000 --- a/libs/wire-api/test/golden/testObject_NewPasswordReset_user_9.json +++ /dev/null @@ -1,3 +0,0 @@ -{ - "email": "\u0003ji\u0008\u0007󲾆󴙔𝝘'ᾧk\u001e+@\u001c:\u0003\u000c􅡌5塋t𡀠>𪮉IE􄋇M\u0012g\u001aAO𦵕3\"󴕰H푅c🡹꾿6" -} diff --git a/libs/wire-api/test/golden/testObject_NewUserPublic_user_1.json b/libs/wire-api/test/golden/testObject_NewUserPublic_user_1.json index 9f90a680a18..a22cdbd6852 100644 --- a/libs/wire-api/test/golden/testObject_NewUserPublic_user_1.json +++ b/libs/wire-api/test/golden/testObject_NewUserPublic_user_1.json @@ -16,14 +16,13 @@ "type": "image" } ], + "email": "test@example.com", "email_code": "cfTQLlhl6H6sYloQXsghILggxWoGhM2WGbxjzm0=", "label": ">>Mp१𤘇9:󺰽􋼒\u0010D1j󾮢􂊠;􄆇󳸪f#]", "locale": "so", "managed_by": "wire", "name": "\\sY4]u󼛸\u0010󺲻\u001c\u0003 \u001f\u0017􄚐dw;}􆃪@𭂿\r8", "password": "dX󹊒赲󶻎ht𘙏󴰏\u0007>\u0018\u000bO95\u0015\n(𩝙󻞌嶝f]_𪀮\u00002FQbNS=6g󿷼P𢲾􃨫󰧽􅤹M\u001e7\u0016~\u0017m󽎭\u0006\u0001\u000bkgmBp\u0017w悬𩓯f󹼮%Q\u0004𢔶kP|G𥬅\u0017B-\nJWH(8)4$󱠶<7𭨖\u001cI\u0008A\u0010\r?󹀊\u0008\u00085\u0006󶟨d \u00166􍉶G\u0018\u0008\t=qG􃁰 D\u0002vV\tYpg󸋮吝q\n \u0017L􁼛-􏕋\u0013󺃝F7Q􊔜]揃i?\r\u0010\u001b{=􎕻_?e􇢹%\u000eR󱆼\u001b+\u000ef\u0017q:g\\Rk馍𪝞[l\u0015􉜀VK\njwp\u00043TJྏEj\u0002R7d83ON\u0017q獿\u0019𮣜N8\n\u000f󻦼u:GꓻFZ\u001c<\u0015揤7􉖬tH󿳸;hbS{ꮯ\u001csMs󲷒9B4􀷾35c(~CUc󸇪\\V_XD3䎆᳦\u0005-􃭧𘨛7W@)!$%v{\u000c\n_I6􉱮츜]r􍶔\u0002Gi_L\u0005@tr<讃2Dr䂇\\\u000b8쁽\u0014􅈿e\u0008𮞲𑚜srN蜨旗Qk+赥󳼩O\\c6󼉭X󺩽􆓖VV\\󴀯^􍺔\u0014(P~y\u000f(\nrO󽖎U=$󽩻k󷀘7.\u0015[dn􃊾粷_\u0000󳞑\u000bNVd햲z󻓕pV6\u001e𨭗#/m􄊮w\u0015沐u𣎯\u000fs\u0011𡔱^A𗔌>\u001a#\u0019sC!3#`𧂅q𐅄\\VrnT\u0010\u0016􂹙\u0014\u0002𦍺󵅅\u0012d 󻆃#\u0018𫺦/k㤣X\"I\u000fO,`GU+\u0011\"\n럲n)\u001b􂰕x󸨾􋽯%\u0012\u000fVr\u000c󾾡H`🚇W\u001c\u0015􀛞vii\u001c\u0007\u0005󵙼&d\u001d𣶇󲅊.􊈄j󶈟$=a_s\u0010Q󹇪\u000e\u000c\u0003󸽌B\u0005\u0018L\u0002_ZX\u0015 h_sGj)󿬂|\u0000\u000f\rlUN)\u0006\u0011`8\u000c󸫲󳼍\u0008,A\u0011\tt/0lT􅪡\u0007}\u0016j\u000f\u0007z|\u0005𥕰J,26󹰅\u00039⮫0\u0019w'\u0000O&g\u001fF0󴞭kg\u0002\u0011|Q􀁨\u001aM𠌸󽣾vuPgVp𬆇)/䎆᳦\u0005-􃭧𘨛7W@)!$%v{\u000c\n_I6􉱮츜]r􍶔\u0002Gi_L\u0005@tr<讃2Dr䂇\\\u000b8쁽\u0014􅈿e\u0008𮞲𑚜srN蜨旗Qk+赥󳼩O\\c6󼉭X󺩽􆓖VV\\󴀯^􍺔\u0014(P~y\u000f(\nrO󽖎U=$󽩻k󷀘7.\u0015[dn􃊾粷_\u0000󳞑\u000bNVd햲z󻓕pV6\u001e𨭗#/m􄊮w\u0015沐u𣎯\u000fs\u0011𡔱^A𗔌>\u001a#\u0019sC!3#`𧂅q𐅄\\VrnT\u0010\u0016􂹙\u0014\u0002𦍺󵅅\u0012d 󻆃#\u0018𫺦/k㤣X\"I\u000fO,`GU+\u0011\"\n럲n)\u001b􂰕x󸨾􋽯%\u0012\u000fVr\u000c󾾡H`🚇W\u001c\u0015􀛞vii\u001c\u0007\u0005󵙼&d\u001d𣶇󲅊.􊈄j󶈟$=a_s\u0010Q󹇪\u000e\u000c\u0003󸽌B\u0005\u0018L\u0002_ZX\u0015 h_sGj)󿬂|\u0000\u000f\rlUN)\u0006\u0011`8\u000c󸫲󳼍\u0008,A\u0011\tt/0lT􅪡\u0007}\u0016j\u000f\u0007z|\u0005𥕰J,26󹰅\u00039⮫0\u0019w'\u0000O&g\u001fF0󴞭kg\u0002\u0011|Q􀁨\u001aM𠌸󽣾vuPgVp𬆇)/f<7\u000eq|6\u0011\u0019󳟧􁗄\u001bf󷯶𩣇\u0013bnVAj`^L\u000c󿮁\u001fLI\u0005!􃈈\u0017`󾒁\u0003e曉\u001aK|", - "phone": "+837934954", "picture": [], "qualified_id": { "domain": "28b.cqb", diff --git a/libs/wire-api/test/golden/testObject_WithStatus_team_18.json b/libs/wire-api/test/golden/testObject_WithStatus_team_18.json index 43f81b018eb..d634f8d2c09 100644 --- a/libs/wire-api/test/golden/testObject_WithStatus_team_18.json +++ b/libs/wire-api/test/golden/testObject_WithStatus_team_18.json @@ -1,5 +1,7 @@ { "config": { + "crlProxy": "https://example.com", + "useProxyOnMobile": false, "verificationExpiration": 86400 }, "lockStatus": "locked", diff --git a/libs/wire-api/test/golden/testObject_WithStatus_team_19.json b/libs/wire-api/test/golden/testObject_WithStatus_team_19.json new file mode 100644 index 00000000000..c73bd3a33d4 --- /dev/null +++ b/libs/wire-api/test/golden/testObject_WithStatus_team_19.json @@ -0,0 +1,10 @@ +{ + "config": { + "acmeDiscoveryUrl": "https://example.com", + "useProxyOnMobile": true, + "verificationExpiration": 86400 + }, + "lockStatus": "locked", + "status": "enabled", + "ttl": "unlimited" +} diff --git a/libs/wire-api/test/unit/Test/Wire/API/MLS.hs b/libs/wire-api/test/unit/Test/Wire/API/MLS.hs index e98ae87e01f..b6fcf5d945f 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/MLS.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/MLS.hs @@ -280,7 +280,7 @@ createGroup tmp store groupName removalKey gid = do Nothing liftIO $ BS.writeFile (tmp groupName) groupJSON -decodeMLSError :: ParseMLS a => ByteString -> a +decodeMLSError :: (ParseMLS a) => ByteString -> a decodeMLSError s = case decodeMLS' s of Left e -> error ("Could not parse MLS object: " <> Text.unpack e) Right x -> x @@ -293,7 +293,7 @@ userClientQid usr c = <> "@" <> T.unpack (domainText (qDomain usr)) -spawn :: HasCallStack => CreateProcess -> Maybe ByteString -> IO ByteString +spawn :: (HasCallStack) => CreateProcess -> Maybe ByteString -> IO ByteString spawn cp minput = do (mout, ex) <- withCreateProcess cp diff --git a/libs/wire-api/test/unit/Test/Wire/API/Password.hs b/libs/wire-api/test/unit/Test/Wire/API/Password.hs index 43f5e5c7728..e55bf2ff6cf 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Password.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Password.hs @@ -32,6 +32,14 @@ tests = testCase "verify old scrypt password still works" testHashingOldScrypt ] +testHashPasswordScrypt :: IO () +testHashPasswordScrypt = do + pwd <- genPassword + hashed <- mkSafePasswordScrypt pwd + let (correct, status) = verifyPasswordWithStatus pwd hashed + assertBool "Password could not be verified" correct + assertEqual "Password could not be verified" status PasswordStatusOk + testHashPasswordArgon2id :: IO () testHashPasswordArgon2id = do pwd <- genPassword 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 aefaa6cb8cd..bec9d3c96f1 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 @@ -39,6 +39,7 @@ import Wire.API.CustomBackend qualified as CustomBackend import Wire.API.Event.Conversation qualified as Event.Conversation import Wire.API.Event.Team qualified as Event.Team import Wire.API.FederationStatus qualified as FederationStatus +import Wire.API.Locale qualified as Locale import Wire.API.Message qualified as Message import Wire.API.OAuth qualified as OAuth import Wire.API.Properties qualified as Properties @@ -49,6 +50,7 @@ import Wire.API.Provider.Service qualified as Provider.Service import Wire.API.Provider.Service.Tag qualified as Provider.Service.Tag import Wire.API.Push.Token qualified as Push.Token import Wire.API.Routes.FederationDomainConfig qualified as FederationDomainConfig +import Wire.API.Routes.Internal.Brig.EJPD qualified as EJPD import Wire.API.Routes.Internal.Galley.TeamsIntra qualified as TeamsIntra import Wire.API.Routes.Version qualified as Routes.Version import Wire.API.SystemSettings qualified as SystemSettings @@ -136,6 +138,7 @@ tests = testRoundTrip @Conversation.Role.ConversationRolesList, testRoundTrip @Conversation.Typing.TypingStatus, testRoundTrip @CustomBackend.CustomBackend, + testRoundTrip @EJPD.EJPDContact, testRoundTrip @Event.Conversation.Event, testRoundTrip @Event.Conversation.EventType, testRoundTrip @Event.Conversation.SimpleMember, @@ -149,6 +152,7 @@ tests = testRoundTrip @FederationDomainConfig.FederationStrategy, testRoundTrip @FederationStatus.FederationStatus, testRoundTrip @FederationStatus.RemoteDomains, + testRoundTrip @Locale.Locale, testRoundTrip @Message.Priority, testRoundTrip @Message.OtrRecipients, testRoundTrip @Message.NewOtrMessage, @@ -323,7 +327,6 @@ tests = testRoundTrip @User.Profile.ColourId, testRoundTrip @User.Profile.AssetSize, testRoundTrip @User.Profile.Asset, - testRoundTrip @User.Profile.Locale, testRoundTrip @User.Profile.ManagedBy, testRoundTrip @User.RichInfo.RichField, testRoundTrip @User.RichInfo.RichInfoAssocList, diff --git a/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/MLS.hs b/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/MLS.hs index d8b6ec7f552..e68b24d6718 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/MLS.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/MLS.hs @@ -88,7 +88,7 @@ class ArbitraryFramedContent a where newtype MessageGenerator fc = MessageGenerator {unMessageGenerator :: Message} deriving newtype (ParseMLS, SerialiseMLS, Eq, Show) -instance ArbitraryFramedContent fc => Arbitrary (MessageGenerator fc) where +instance (ArbitraryFramedContent fc) => Arbitrary (MessageGenerator fc) where arbitrary = fmap MessageGenerator $ do fc <- arbitraryFramedContent @fc diff --git a/libs/wire-api/test/unit/Test/Wire/API/User.hs b/libs/wire-api/test/unit/Test/Wire/API/User.hs index d8f9a115376..2a5fa7d31e1 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/User.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/User.hs @@ -129,19 +129,13 @@ parseIdentityTests = (=#=) _ bad = error $ "=#=: impossible: " <> show bad in testGroup "parseIdentity" - [ testCase "FullIdentity" $ - Right (Just (FullIdentity hemail hphone)) =#= [email, phone], - testCase "EmailIdentity" $ + [ testCase "EmailIdentity" $ Right (Just (EmailIdentity hemail)) =#= [email], - testCase "PhoneIdentity" $ - Right (Just (PhoneIdentity hphone)) =#= [phone], testCase "SSOIdentity" $ do - Right (Just (SSOIdentity hssoid Nothing Nothing)) =#= [ssoid] - Right (Just (SSOIdentity hssoid Nothing (Just hphone))) =#= [ssoid, phone] - Right (Just (SSOIdentity hssoid (Just hemail) Nothing)) =#= [ssoid, email] - Right (Just (SSOIdentity hssoid (Just hemail) (Just hphone))) =#= [ssoid, email, phone], - testCase "Bad phone" $ - Left "Error in $.phone: Invalid phone number. Expected E.164 format." =#= [badphone], + Right (Just (SSOIdentity hssoid Nothing)) =#= [ssoid] + Right (Just (SSOIdentity hssoid (Just hemail))) =#= [ssoid, email], + testCase "Phone not part of identity any more" $ + Right Nothing =#= [badphone], testCase "Bad email" $ Left "Error in $.email: Invalid email. Expected '@'." =#= [bademail], testCase "Nothing" $ @@ -151,8 +145,6 @@ parseIdentityTests = hemail = Email "me" "example.com" email = ("email", "me@example.com") bademail = ("email", "justme") - hphone = Phone "+493012345678" - phone = ("phone", "+493012345678") badphone = ("phone", "__@@") hssoid = UserSSOId mkSimpleSampleUref ssoid = ("sso_id", toJSON hssoid) diff --git a/libs/wire-api/wire-api.cabal b/libs/wire-api/wire-api.cabal index 9c9087dcf58..5c37e1dbca2 100644 --- a/libs/wire-api/wire-api.cabal +++ b/libs/wire-api/wire-api.cabal @@ -15,11 +15,12 @@ common common-all ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path - -Wredundant-constraints + -Wredundant-constraints -Wunused-packages default-extensions: AllowAmbiguousTypes BangPatterns + BlockArguments ConstraintKinds DataKinds DefaultSignatures @@ -67,6 +68,7 @@ library -- cabal-fmt: expand src exposed-modules: + Wire.API.Allowlists Wire.API.ApplyMods Wire.API.Asset Wire.API.Bot @@ -101,6 +103,7 @@ library Wire.API.FederationUpdate Wire.API.Internal.BulkPush Wire.API.Internal.Notification + Wire.API.Locale Wire.API.MakesFederatedCall Wire.API.Message Wire.API.Message.Proto @@ -247,7 +250,6 @@ library build-depends: , aeson >=2.0.1.0 , asn1-encoding - , async , attoparsec >=0.10 , base >=4 && <5 , base64-bytestring >=1.0 @@ -267,6 +269,7 @@ library , crypton , crypton-x509 , currency-codes >=2.0 + , data-default , deriving-aeson >=0.2 , deriving-swagger2 , either @@ -308,6 +311,7 @@ library , saml2-web-sso , schema-profunctor , scientific + , semigroupoids , servant , servant-client , servant-client-core @@ -601,7 +605,7 @@ test-suite wire-api-golden-tests Test.Wire.API.Golden.Run Test.Wire.API.Golden.Runner - ghc-options: -threaded -with-rtsopts=-N + ghc-options: -threaded -with-rtsopts=-N -Wunused-packages hs-source-dirs: test/golden build-depends: , aeson >=2.0.1.0 @@ -611,7 +615,6 @@ test-suite wire-api-golden-tests , bytestring , bytestring-conversion , containers >=0.5 - , crypton , currency-codes , either , imports @@ -668,18 +671,17 @@ test-suite wire-api-tests hs-source-dirs: test/unit build-depends: - , aeson >=2.0.1.0 + , aeson >=2.0.1.0 , aeson-qq , async , base , binary , bytestring - , bytestring-arbitrary >=0.1.3 + , bytestring-arbitrary >=0.1.3 , bytestring-conversion , cassava - , containers >=0.5 + , containers >=0.5 , crypton - , either , filepath , hex , hspec @@ -693,7 +695,6 @@ test-suite wire-api-tests , process , QuickCheck , random - , saml2-web-sso , schema-profunctor , servant , servant-server @@ -703,13 +704,12 @@ test-suite wire-api-tests , tasty-hunit , tasty-quickcheck , text - , types-common >=0.16 + , types-common >=0.16 , unliftio , uuid , vector , wai , wire-api - , wire-message-proto-lens - ghc-options: -threaded -with-rtsopts=-N + ghc-options: -threaded -with-rtsopts=-N -Wunused-packages default-language: GHC2021 diff --git a/libs/wire-subsystems/default.nix b/libs/wire-subsystems/default.nix index 7d5e5e02060..ab5d6d19a48 100644 --- a/libs/wire-subsystems/default.nix +++ b/libs/wire-subsystems/default.nix @@ -6,7 +6,7 @@ , aeson , amazonka , amazonka-core -, amazonka-sqs +, amazonka-ses , async , base , base16-bytestring @@ -16,17 +16,22 @@ , cassandra-util , containers , cql +, crypton , currency-codes , data-default +, data-timeout , errors , exceptions , extended , extra , gitignoreSource , gundeck-types +, HaskellNet +, HaskellNet-SSL , HsOpenSSL , hspec , hspec-discover +, html-entities , http-client , http-types , http2-manager @@ -34,28 +39,39 @@ , iso639 , lens , lib +, memory , mime , mime-mail +, network , network-conduit-tls +, pipes , polysemy , polysemy-plugin , polysemy-time , polysemy-wire-zoo +, postie , QuickCheck , quickcheck-instances +, random +, resource-pool , resourcet , retry , servant , servant-client-core , stomp-queue +, streaming-commons , string-conversions +, template , text , time +, time-out +, time-units , tinylog , transformers , transitive-anns , types-common , unliftio +, unordered-containers , uuid , wai-utilities , wire-api @@ -69,7 +85,7 @@ mkDerivation { aeson amazonka amazonka-core - amazonka-sqs + amazonka-ses async base base16-bytestring @@ -79,41 +95,53 @@ mkDerivation { cassandra-util containers cql + crypton currency-codes data-default + data-timeout errors exceptions extended extra gundeck-types + HaskellNet + HaskellNet-SSL HsOpenSSL hspec + html-entities http-client http-types http2-manager imports iso639 lens + memory mime mime-mail + network network-conduit-tls polysemy polysemy-plugin polysemy-time polysemy-wire-zoo QuickCheck + resource-pool resourcet retry servant servant-client-core stomp-queue + template text time + time-out + time-units tinylog transformers transitive-anns types-common unliftio + unordered-containers uuid wai-utilities wire-api @@ -126,21 +154,32 @@ mkDerivation { bilge bytestring containers + crypton data-default + errors extended gundeck-types hspec imports iso639 + lens + mime-mail + network + pipes polysemy polysemy-plugin polysemy-time polysemy-wire-zoo + postie QuickCheck quickcheck-instances + random servant-client-core + streaming-commons string-conversions + text time + tinylog transformers types-common wire-api diff --git a/libs/wire-subsystems/src/Wire/AWS.hs b/libs/wire-subsystems/src/Wire/AWS.hs new file mode 100644 index 00000000000..b462db9a6cc --- /dev/null +++ b/libs/wire-subsystems/src/Wire/AWS.hs @@ -0,0 +1,31 @@ +module Wire.AWS where + +import Amazonka (Env, runResourceT) +import Amazonka.Core.Lens.Internal qualified as AWS +import Amazonka.Send as AWS +import Amazonka.Types qualified as AWS +import Control.Lens +import Imports +import Network.HTTP.Client +import Polysemy +import Polysemy.Input + +sendCatch :: + ( Member (Input Amazonka.Env) r, + Member (Embed IO) r, + AWS.AWSRequest req, + Typeable req, + Typeable (AWS.AWSResponse req) + ) => + req -> + Sem r (Either AWS.Error (AWS.AWSResponse req)) +sendCatch req = do + env <- input + embed . AWS.trying AWS._Error . runResourceT . AWS.send env $ req + +canRetry :: Either AWS.Error a -> Bool +canRetry (Right _) = False +canRetry (Left e) = case e of + AWS.TransportError (HttpExceptionRequest _ ResponseTimeout) -> True + AWS.ServiceError se | se ^. AWS.serviceError_code == AWS.ErrorCode "RequestThrottled" -> True + _ -> False diff --git a/services/brig/src/Brig/Effects/PasswordResetStore.hs b/libs/wire-subsystems/src/Wire/AuthenticationSubsystem.hs similarity index 64% rename from services/brig/src/Brig/Effects/PasswordResetStore.hs rename to libs/wire-subsystems/src/Wire/AuthenticationSubsystem.hs index aab8274893e..9b669979bd8 100644 --- a/services/brig/src/Brig/Effects/PasswordResetStore.hs +++ b/libs/wire-subsystems/src/Wire/AuthenticationSubsystem.hs @@ -16,25 +16,19 @@ -- with this program. If not, see . {-# LANGUAGE TemplateHaskell #-} -module Brig.Effects.PasswordResetStore where +module Wire.AuthenticationSubsystem where -import Brig.Types.User (PasswordResetPair) -import Data.Id +import Data.Misc import Imports import Polysemy -import Wire.API.User.Identity +import Wire.API.User import Wire.API.User.Password +import Wire.UserKeyStore -data PasswordResetStore m a where - CreatePasswordResetCode :: - UserId -> - Either Email Phone -> - PasswordResetStore m PasswordResetPair - LookupPasswordResetCode :: - UserId -> - PasswordResetStore m (Maybe PasswordResetCode) - VerifyPasswordResetCode :: - PasswordResetPair -> - PasswordResetStore m (Maybe UserId) +data AuthenticationSubsystem m a where + CreatePasswordResetCode :: EmailKey -> AuthenticationSubsystem m () + ResetPassword :: PasswordResetIdentity -> PasswordResetCode -> PlainTextPassword8 -> AuthenticationSubsystem m () + -- For testing + InternalLookupPasswordResetCode :: EmailKey -> AuthenticationSubsystem m (Maybe PasswordResetPair) -makeSem ''PasswordResetStore +makeSem ''AuthenticationSubsystem diff --git a/libs/wire-subsystems/src/Wire/AuthenticationSubsystem/Error.hs b/libs/wire-subsystems/src/Wire/AuthenticationSubsystem/Error.hs new file mode 100644 index 00000000000..5efede38c26 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/AuthenticationSubsystem/Error.hs @@ -0,0 +1,45 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2024 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . +module Wire.AuthenticationSubsystem.Error + ( AuthenticationSubsystemError (..), + authenticationSubsystemErrorToHttpError, + ) +where + +import Imports +import Wire.API.Error +import Wire.API.Error.Brig qualified as E +import Wire.Error + +data AuthenticationSubsystemError + = AuthenticationSubsystemInvalidPasswordResetKey + | AuthenticationSubsystemResetPasswordMustDiffer + | AuthenticationSubsystemInvalidPasswordResetCode + | AuthenticationSubsystemInvalidPhone + | AuthenticationSubsystemAllowListError + deriving (Eq, Show) + +instance Exception AuthenticationSubsystemError + +authenticationSubsystemErrorToHttpError :: AuthenticationSubsystemError -> HttpError +authenticationSubsystemErrorToHttpError = + StdError . \case + AuthenticationSubsystemInvalidPasswordResetKey -> errorToWai @E.InvalidPasswordResetKey + AuthenticationSubsystemInvalidPasswordResetCode -> errorToWai @E.InvalidPasswordResetCode + AuthenticationSubsystemResetPasswordMustDiffer -> errorToWai @E.ResetPasswordMustDiffer + AuthenticationSubsystemInvalidPhone -> errorToWai @E.InvalidPhone + AuthenticationSubsystemAllowListError -> errorToWai @E.AllowlistError diff --git a/libs/wire-subsystems/src/Wire/AuthenticationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/AuthenticationSubsystem/Interpreter.hs new file mode 100644 index 00000000000..94024d5b4cf --- /dev/null +++ b/libs/wire-subsystems/src/Wire/AuthenticationSubsystem/Interpreter.hs @@ -0,0 +1,251 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Wire.AuthenticationSubsystem.Interpreter + ( interpretAuthenticationSubsystem, + passwordResetCodeTtl, + module Wire.AuthenticationSubsystem.Error, + ) +where + +import Data.ByteString.Conversion +import Data.Id +import Data.Misc +import Data.Qualified +import Data.Time +import Imports hiding (lookup) +import Polysemy +import Polysemy.Error +import Polysemy.Input +import Polysemy.TinyLog (TinyLog) +import Polysemy.TinyLog qualified as Log +import System.Logger +import Wire.API.Allowlists (AllowlistEmailDomains) +import Wire.API.Allowlists qualified as AllowLists +import Wire.API.Password +import Wire.API.User +import Wire.API.User.Password +import Wire.AuthenticationSubsystem +import Wire.AuthenticationSubsystem.Error +import Wire.EmailSubsystem +import Wire.HashPassword +import Wire.PasswordResetCodeStore +import Wire.PasswordStore +import Wire.Sem.Now +import Wire.Sem.Now qualified as Now +import Wire.SessionStore +import Wire.UserKeyStore +import Wire.UserSubsystem (UserSubsystem, getLocalUserAccountByUserKey) + +interpretAuthenticationSubsystem :: + forall r. + ( Member PasswordResetCodeStore r, + Member Now r, + Member (Error AuthenticationSubsystemError) r, + Member TinyLog r, + Member HashPassword r, + Member SessionStore r, + Member (Input (Local ())) r, + Member (Input (Maybe AllowlistEmailDomains)) r, + Member UserSubsystem r, + Member PasswordStore r, + Member EmailSubsystem r + ) => + InterpreterFor AuthenticationSubsystem r +interpretAuthenticationSubsystem = interpret $ \case + CreatePasswordResetCode userKey -> createPasswordResetCodeImpl userKey + ResetPassword ident resetCode newPassword -> resetPasswordImpl ident resetCode newPassword + InternalLookupPasswordResetCode userKey -> internalLookupPasswordResetCodeImpl userKey + +maxAttempts :: Int32 +maxAttempts = 3 + +passwordResetCodeTtl :: NominalDiffTime +passwordResetCodeTtl = 3600 -- 60 minutes + +-- This type is not exported and used for internal control flow only +data PasswordResetError + = AllowListError + | InvalidResetKey + | InProgress + deriving (Show) + +instance Exception PasswordResetError where + displayException AllowListError = "email domain is not allowed for password reset" + displayException InvalidResetKey = "invalid reset key for password reset" + displayException InProgress = "password reset already in progress" + +createPasswordResetCodeImpl :: + forall r. + ( Member PasswordResetCodeStore r, + Member Now r, + Member (Input (Local ())) r, + Member (Input (Maybe AllowlistEmailDomains)) r, + Member TinyLog r, + Member UserSubsystem r, + Member EmailSubsystem r + ) => + EmailKey -> + Sem r () +createPasswordResetCodeImpl target = + logPasswordResetError =<< runError do + allowListOk <- (\e -> AllowLists.verify e (emailKeyOrig target)) <$> input + unless allowListOk $ throw AllowListError + user <- lookupActiveUserByUserKey target >>= maybe (throw InvalidResetKey) pure + let uid = userId user + Log.debug $ field "user" (toByteString uid) . field "action" (val "User.beginPasswordReset") + + mExistingCode <- lookupPasswordResetCode uid + when (isJust mExistingCode) $ + throw InProgress + + let key = mkPasswordResetKey uid + now <- Now.get + code <- generateEmailCode + codeInsert + key + (PRQueryData code uid (Identity maxAttempts) (Identity (passwordResetCodeTtl `addUTCTime` now))) + (round passwordResetCodeTtl) + sendPasswordResetMail (emailKeyOrig target) (key, code) (Just user.userLocale) + pure () + where + -- `PasswordResetError` are errors that we don't want to leak to the caller. + -- Therefore we handle them here and only log without propagating them. + logPasswordResetError :: Either PasswordResetError () -> Sem r () + logPasswordResetError = \case + Left e -> + Log.err $ + field "action" (val "User.beginPasswordReset") + . field "error" (displayException e) + Right v -> pure v + +lookupActiveUserIdByUserKey :: + (Member UserSubsystem r, Member (Input (Local ())) r) => + EmailKey -> + Sem r (Maybe UserId) +lookupActiveUserIdByUserKey target = + userId <$$> lookupActiveUserByUserKey target + +lookupActiveUserByUserKey :: + (Member UserSubsystem r, Member (Input (Local ())) r) => + EmailKey -> + Sem r (Maybe User) +lookupActiveUserByUserKey target = do + localUnit <- input + let ltarget = qualifyAs localUnit target + mUser <- getLocalUserAccountByUserKey ltarget + case mUser of + Just user -> do + pure $ + if user.accountStatus == Active + then Just user.accountUser + else Nothing + Nothing -> pure Nothing + +internalLookupPasswordResetCodeImpl :: + ( Member PasswordResetCodeStore r, + Member Now r, + Member (Input (Local ())) r, + Member UserSubsystem r + ) => + EmailKey -> + Sem r (Maybe PasswordResetPair) +internalLookupPasswordResetCodeImpl key = do + mUser <- lookupActiveUserIdByUserKey key + case mUser of + Just user -> do + mCode <- lookupPasswordResetCode user + let k = mkPasswordResetKey user + pure $ (k,) <$> mCode + Nothing -> pure Nothing + +lookupPasswordResetCode :: + ( Member PasswordResetCodeStore r, + Member Now r + ) => + UserId -> + Sem r (Maybe PasswordResetCode) +lookupPasswordResetCode u = do + let key = mkPasswordResetKey u + now <- Now.get + validate now =<< codeSelect key + where + validate now (Just (PRQueryData c _ _ (Just t))) | t > now = pure $ Just c + validate _ _ = pure Nothing + +resetPasswordImpl :: + forall r. + ( Member PasswordResetCodeStore r, + Member Now r, + Member (Input (Local ())) r, + Member (Error AuthenticationSubsystemError) r, + Member TinyLog r, + Member UserSubsystem r, + Member HashPassword r, + Member SessionStore r, + Member PasswordStore r + ) => + PasswordResetIdentity -> + PasswordResetCode -> + PlainTextPassword8 -> + Sem r () +resetPasswordImpl ident code pw = do + key <- passwordResetKeyFromIdentity + + muid :: Maybe UserId <- verify (key, code) + case muid of + Nothing -> throw AuthenticationSubsystemInvalidPasswordResetCode + Just uid -> do + Log.debug $ field "user" (toByteString uid) . field "action" (val "User.completePasswordReset") + checkNewIsDifferent uid pw + hashedPw <- hashPassword pw + upsertHashedPassword uid hashedPw + codeDelete key + deleteAllCookies uid + where + passwordResetKeyFromIdentity :: Sem r PasswordResetKey + passwordResetKeyFromIdentity = case ident of + PasswordResetIdentityKey k -> pure k + PasswordResetEmailIdentity e -> do + mUserId <- lookupActiveUserIdByUserKey (mkEmailKey e) + let mResetKey = mkPasswordResetKey <$> mUserId + maybe (throw AuthenticationSubsystemInvalidPasswordResetKey) pure mResetKey + PasswordResetPhoneIdentity _ -> do + throw AuthenticationSubsystemInvalidPhone + + checkNewIsDifferent :: UserId -> PlainTextPassword' t -> Sem r () + checkNewIsDifferent uid newPassword = do + mCurrentPassword <- lookupHashedPassword uid + case mCurrentPassword of + Just currentPassword + | (verifyPassword newPassword currentPassword) -> throw AuthenticationSubsystemResetPasswordMustDiffer + _ -> pure () + + verify :: PasswordResetPair -> Sem r (Maybe UserId) + verify (k, c) = do + now <- Now.get + passwordResetData <- codeSelect k + case passwordResetData of + Just (PRQueryData codeInDB u _ (Just t)) | c == codeInDB && t >= now -> pure (Just u) + Just (PRQueryData codeInDB u (Just n) (Just t)) | n > 1 && t > now -> do + -- If we only update retries, there is a chance that this races with + -- the PasswordResetCodeTtl and we have a situation where only retries is non-null for + -- a given key. To avoid this, we insert the whole row again. + codeInsert k (PRQueryData codeInDB u (Identity (n - 1)) (Identity t)) (round passwordResetCodeTtl) + pure Nothing + Just PRQueryData {} -> codeDelete k $> Nothing + Nothing -> pure Nothing diff --git a/libs/wire-subsystems/src/Wire/DeleteQueue/InMemory.hs b/libs/wire-subsystems/src/Wire/DeleteQueue/InMemory.hs index cd9400c7f54..9818ea7228a 100644 --- a/libs/wire-subsystems/src/Wire/DeleteQueue/InMemory.hs +++ b/libs/wire-subsystems/src/Wire/DeleteQueue/InMemory.hs @@ -6,7 +6,7 @@ import Polysemy.State import Wire.DeleteQueue import Wire.InternalEvent -inMemoryDeleteQueueInterpreter :: Member (State [InternalNotification]) r => InterpreterFor DeleteQueue r +inMemoryDeleteQueueInterpreter :: (Member (State [InternalNotification]) r) => InterpreterFor DeleteQueue r inMemoryDeleteQueueInterpreter = interpret $ \case EnqueueUserDeletion uid -> modify (\l -> DeleteUser uid : l) EnqueueClientDeletion cid uid mConnId -> modify (\l -> DeleteClient cid uid mConnId : l) diff --git a/libs/wire-subsystems/src/Wire/EmailSending.hs b/libs/wire-subsystems/src/Wire/EmailSending.hs new file mode 100644 index 00000000000..88b2a937646 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/EmailSending.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Wire.EmailSending where + +import Network.Mail.Mime (Mail) +import Polysemy (makeSem) + +data EmailSending m r where + SendMail :: Mail -> EmailSending m () + +makeSem ''EmailSending diff --git a/libs/wire-subsystems/src/Wire/EmailSending/SES.hs b/libs/wire-subsystems/src/Wire/EmailSending/SES.hs new file mode 100644 index 00000000000..4c367da1b4c --- /dev/null +++ b/libs/wire-subsystems/src/Wire/EmailSending/SES.hs @@ -0,0 +1,70 @@ +module Wire.EmailSending.SES where + +import Amazonka (Env) +import Amazonka.Data.Text as AWS +import Amazonka.SES qualified as SES +import Amazonka.SES.Lens qualified as SES +import Amazonka.Types qualified as AWS +import Control.Lens +import Control.Monad.Catch +import Control.Retry +import Data.ByteString.Lazy qualified as BL +import Data.Text qualified as Text +import Imports +import Network.HTTP.Types +import Network.Mail.Mime (Mail, addressEmail, mailFrom, mailTo, renderMail') +import Polysemy +import Polysemy.Input +import Wire.AWS +import Wire.EmailSending + +emailViaSESInterpreter :: + (Member (Embed IO) r) => + Amazonka.Env -> + InterpreterFor EmailSending r +emailViaSESInterpreter env = + interpret $ + runInputConst env . \case + SendMail mail -> sendMailAWSImpl mail + +sendMailAWSImpl :: + ( Member (Input Amazonka.Env) r, + Member (Embed IO) r + ) => + Mail -> + Sem r () +sendMailAWSImpl m = do + body <- liftIO $ BL.toStrict <$> renderMail' m + let raw = + SES.newSendRawEmail (SES.newRawMessage body) + & SES.sendRawEmail_destinations ?~ fmap addressEmail (mailTo m) + & SES.sendRawEmail_source ?~ addressEmail (mailFrom m) + resp <- retrying retry5x (\_ -> pure . canRetry) $ const (sendCatch raw) + void . embed $ either check pure resp + where + check x = case x of + -- To map rejected domain names by SES to 400 responses, in order + -- not to trigger false 5xx alerts. Upfront domain name validation + -- is only according to the syntax rules of RFC5322 but additional + -- constraints may be applied by email servers (in this case SES). + -- Since such additional constraints are neither standardised nor + -- documented in the cases of SES, we can only handle the errors + -- after the fact. + AWS.ServiceError se + | (se ^. AWS.serviceError_status == status400) + && ("Invalid domain name" `Text.isPrefixOf` AWS.toText (se ^. AWS.serviceError_code)) -> + throwM SESInvalidDomain + _ -> throwM (EmailSendingAWSGeneralError x) + +data EmailSendingAWSError where + SESInvalidDomain :: EmailSendingAWSError + EmailSendingAWSGeneralError :: (Show e, AWS.AsError e) => e -> EmailSendingAWSError + +deriving instance Show EmailSendingAWSError + +deriving instance Typeable EmailSendingAWSError + +instance Exception EmailSendingAWSError + +retry5x :: (Monad m) => RetryPolicyM m +retry5x = limitRetries 5 <> exponentialBackoff 100000 diff --git a/services/brig/src/Brig/SMTP.hs b/libs/wire-subsystems/src/Wire/EmailSending/SMTP.hs similarity index 90% rename from services/brig/src/Brig/SMTP.hs rename to libs/wire-subsystems/src/Wire/EmailSending/SMTP.hs index 75694ee3c11..5c71f8a2c84 100644 --- a/services/brig/src/Brig/SMTP.hs +++ b/libs/wire-subsystems/src/Wire/EmailSending/SMTP.hs @@ -17,10 +17,10 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Brig.SMTP - ( sendMail, - initSMTP, - sendMail', +module Wire.EmailSending.SMTP + ( initSMTP, + emailViaSMTPInterpreter, + sendMailWithDuration, initSMTP', SMTPConnType (..), SMTP (..), @@ -32,7 +32,6 @@ where import Control.Concurrent.Async (wait, withAsyncWithUnmask) import Control.Exception qualified as CE (throw) -import Control.Lens import Control.Monad.Catch import Control.Timeout (timeout) import Data.Aeson @@ -45,16 +44,20 @@ import Network.HaskellNet.SMTP qualified as SMTP import Network.HaskellNet.SMTP.SSL qualified as SMTP import Network.Mail.Mime import Network.Socket (PortNumber) +import Polysemy import System.Logger qualified as Logger import System.Logger.Class hiding (create) +import Wire.EmailSending + +emailViaSMTPInterpreter :: (Member (Embed IO) r) => Logger -> SMTP -> InterpreterFor EmailSending r +emailViaSMTPInterpreter logger smtp = interpret \case + SendMail mail -> sendMailImpl logger smtp mail newtype Username = Username Text newtype Password = Password Text -data SMTP = SMTP - { _pool :: !(Pool SMTP.SMTPConnection) - } +data SMTP = SMTP {pool :: !(Pool SMTP.SMTPConnection)} data SMTPConnType = Plain @@ -62,10 +65,6 @@ data SMTPConnType | SSL deriving (Eq, Show) -deriveJSON defaultOptions {constructorTagModifier = map toLower} ''SMTPConnType - -makeLenses ''SMTP - data SMTPPoolException = SMTPUnauthorized | SMTPConnectionTimeout deriving (Eq, Show) @@ -221,17 +220,19 @@ ensureSMTPConnectionTimeout timeoutDuration action = -- a timeout happens and on every other network failure. -- -- `defaultTimeoutDuration` is used as timeout duration for all actions. -sendMail :: (MonadIO m) => Logger -> SMTP -> Mail -> m () -sendMail = sendMail' defaultTimeoutDuration +sendMailImpl :: (MonadIO m) => Logger -> SMTP -> Mail -> m () +sendMailImpl = sendMailWithDuration defaultTimeoutDuration -- | `sendMail` with configurable timeout duration -- -- This is mostly useful for testing. (We don't want to waste the amount of -- `defaultTimeoutDuration` in tests with waiting.) -sendMail' :: forall t m. (MonadIO m, TimeUnit t) => t -> Logger -> SMTP -> Mail -> m () -sendMail' timeoutDuration lg s m = liftIO $ withResource (s ^. pool) sendMail'' +sendMailWithDuration :: forall t m. (MonadIO m, TimeUnit t) => t -> Logger -> SMTP -> Mail -> m () +sendMailWithDuration timeoutDuration lg smtp m = liftIO $ withResource smtp.pool sendMailWithConn where - sendMail'' :: SMTP.SMTPConnection -> IO () - sendMail'' c = + sendMailWithConn :: SMTP.SMTPConnection -> IO () + sendMailWithConn c = logExceptionOrResult lg "Sending mail via SMTP" $ ensureSMTPConnectionTimeout timeoutDuration (SMTP.sendMail m c) + +deriveJSON defaultOptions {constructorTagModifier = map toLower} ''SMTPConnType diff --git a/libs/wire-subsystems/src/Wire/EmailSubsystem.hs b/libs/wire-subsystems/src/Wire/EmailSubsystem.hs new file mode 100644 index 00000000000..13f0093ddd8 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/EmailSubsystem.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Wire.EmailSubsystem where + +import Data.Code qualified as Code +import Imports +import Polysemy +import Wire.API.Locale +import Wire.API.User +import Wire.API.User.Activation (ActivationCode, ActivationKey) +import Wire.API.User.Client (Client (..)) + +data EmailSubsystem m a where + SendPasswordResetMail :: Email -> PasswordResetPair -> Maybe Locale -> EmailSubsystem m () + SendVerificationMail :: Email -> ActivationKey -> ActivationCode -> Maybe Locale -> EmailSubsystem m () + SendCreateScimTokenVerificationMail :: Email -> Code.Value -> Maybe Locale -> EmailSubsystem m () + SendLoginVerificationMail :: Email -> Code.Value -> Maybe Locale -> EmailSubsystem m () + SendActivationMail :: Email -> Name -> ActivationKey -> ActivationCode -> Maybe Locale -> EmailSubsystem m () + SendEmailAddressUpdateMail :: Email -> Name -> ActivationKey -> ActivationCode -> Maybe Locale -> EmailSubsystem m () + SendNewClientEmail :: Email -> Name -> Client -> Locale -> EmailSubsystem m () + SendAccountDeletionEmail :: Email -> Name -> Code.Key -> Code.Value -> Locale -> EmailSubsystem m () + SendTeamActivationMail :: Email -> Name -> ActivationKey -> ActivationCode -> Maybe Locale -> Text -> EmailSubsystem m () + SendTeamDeletionVerificationMail :: Email -> Code.Value -> Maybe Locale -> EmailSubsystem m () + +makeSem ''EmailSubsystem diff --git a/libs/wire-subsystems/src/Wire/EmailSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/EmailSubsystem/Interpreter.hs new file mode 100644 index 00000000000..519c5101cb0 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/EmailSubsystem/Interpreter.hs @@ -0,0 +1,411 @@ +{-# LANGUAGE RecordWildCards #-} + +module Wire.EmailSubsystem.Interpreter + ( emailSubsystemInterpreter, + mkMimeAddress, + ) +where + +import Data.Code qualified as Code +import Data.Json.Util +import Data.Range (fromRange) +import Data.Text qualified as Text +import Data.Text.Ascii qualified as Ascii +import Data.Text.Lazy (toStrict) +import Imports +import Network.Mail.Mime +import Polysemy +import Wire.API.Locale +import Wire.API.User +import Wire.API.User.Activation +import Wire.API.User.Client (Client (..)) +import Wire.API.User.Password +import Wire.EmailSending (EmailSending, sendMail) +import Wire.EmailSubsystem +import Wire.EmailSubsystem.Template + +emailSubsystemInterpreter :: (Member EmailSending r) => Localised UserTemplates -> TemplateBranding -> InterpreterFor EmailSubsystem r +emailSubsystemInterpreter tpls branding = interpret \case + SendPasswordResetMail email (key, code) mLocale -> sendPasswordResetMailImpl tpls branding email key code mLocale + SendVerificationMail email key code mLocale -> sendVerificationMailImpl tpls branding email key code mLocale + SendTeamDeletionVerificationMail email code mLocale -> sendTeamDeletionVerificationMailImpl tpls branding email code mLocale + SendCreateScimTokenVerificationMail email code mLocale -> sendCreateScimTokenVerificationMailImpl tpls branding email code mLocale + SendLoginVerificationMail email code mLocale -> sendLoginVerificationMailImpl tpls branding email code mLocale + SendActivationMail email name key code mLocale -> sendActivationMailImpl tpls branding email name key code mLocale + SendEmailAddressUpdateMail email name key code mLocale -> sendEmailAddressUpdateMailImpl tpls branding email name key code mLocale + SendTeamActivationMail email name key code mLocale teamName -> sendTeamActivationMailImpl tpls branding email name key code mLocale teamName + SendNewClientEmail email name client locale -> sendNewClientEmailImpl tpls branding email name client locale + SendAccountDeletionEmail email name key code locale -> sendAccountDeletionEmailImpl tpls branding email name key code locale + +------------------------------------------------------------------------------- +-- Verification Email for +-- - Login +-- - Creation of ScimToken +-- - Team Deletion + +sendTeamDeletionVerificationMailImpl :: + (Member EmailSending r) => + Localised UserTemplates -> + TemplateBranding -> + Email -> + Code.Value -> + Maybe Locale -> + Sem r () +sendTeamDeletionVerificationMailImpl userTemplates branding email code mLocale = do + let tpl = verificationTeamDeletionEmail . snd $ forLocale mLocale userTemplates + sendMail $ renderSecondFactorVerificationEmail email code tpl branding + +sendCreateScimTokenVerificationMailImpl :: + (Member EmailSending r) => + Localised UserTemplates -> + TemplateBranding -> + Email -> + Code.Value -> + Maybe Locale -> + Sem r () +sendCreateScimTokenVerificationMailImpl userTemplates branding email code mLocale = do + let tpl = verificationScimTokenEmail . snd $ forLocale mLocale userTemplates + sendMail $ renderSecondFactorVerificationEmail email code tpl branding + +sendLoginVerificationMailImpl :: + (Member EmailSending r) => + Localised UserTemplates -> + TemplateBranding -> + Email -> + Code.Value -> + Maybe Locale -> + Sem r () +sendLoginVerificationMailImpl userTemplates branding email code mLocale = do + let tpl = verificationLoginEmail . snd $ forLocale mLocale userTemplates + sendMail $ renderSecondFactorVerificationEmail email code tpl branding + +renderSecondFactorVerificationEmail :: + Email -> + Code.Value -> + SecondFactorVerificationEmailTemplate -> + TemplateBranding -> + Mail +renderSecondFactorVerificationEmail email codeValue SecondFactorVerificationEmailTemplate {..} branding = + (emptyMail from) + { mailTo = [to], + mailHeaders = + [ ("Subject", toStrict subj), + ("X-Zeta-Purpose", "SecondFactorVerification"), + ("X-Zeta-Code", code) + ], + mailParts = [[plainPart txt, htmlPart html]] + } + where + from = Address (Just sndFactorVerificationEmailSenderName) (fromEmail sndFactorVerificationEmailSender) + to = Address Nothing (fromEmail email) + txt = renderTextWithBranding sndFactorVerificationEmailBodyText replace branding + html = renderHtmlWithBranding sndFactorVerificationEmailBodyHtml replace branding + subj = renderTextWithBranding sndFactorVerificationEmailSubject replace branding + code = Ascii.toText (fromRange codeValue.asciiValue) + replace :: Text -> Text + replace "email" = fromEmail email + replace "code" = code + replace x = x + +------------------------------------------------------------------------------- +-- Activation Email + +sendActivationMailImpl :: + (Member EmailSending r) => + Localised UserTemplates -> + TemplateBranding -> + Email -> + Name -> + ActivationKey -> + ActivationCode -> + Maybe Locale -> + Sem r () +sendActivationMailImpl userTemplates branding email name akey acode mLocale = do + let tpl = activationEmail . snd $ forLocale mLocale userTemplates + sendMail $ renderActivationMail email name akey acode tpl branding + +sendEmailAddressUpdateMailImpl :: + (Member EmailSending r) => + Localised UserTemplates -> + TemplateBranding -> + Email -> + Name -> + ActivationKey -> + ActivationCode -> + Maybe Locale -> + Sem r () +sendEmailAddressUpdateMailImpl userTemplates branding email name akey acode mLocale = do + let tpl = activationEmailUpdate . snd $ forLocale mLocale userTemplates + sendMail $ renderActivationMail email name akey acode tpl branding + +renderActivationMail :: Email -> Name -> ActivationKey -> ActivationCode -> ActivationEmailTemplate -> TemplateBranding -> Mail +renderActivationMail email name akey@(ActivationKey key) acode@(ActivationCode code) ActivationEmailTemplate {..} branding = + (emptyMail from) + { mailTo = [to], + -- To make automated processing possible, the activation code is also added to + -- headers. {#RefActivationEmailHeaders} + mailHeaders = + [ ("Subject", toStrict subj), + ("X-Zeta-Purpose", "Activation"), + ("X-Zeta-Key", Ascii.toText key), + ("X-Zeta-Code", Ascii.toText code) + ], + mailParts = [[plainPart txt, htmlPart html]] + } + where + from, to :: Address + from = Address (Just activationEmailSenderName) (fromEmail activationEmailSender) + to = mkMimeAddress name email + + txt, html, subj :: LText + txt = renderTextWithBranding activationEmailBodyText replace branding + html = renderHtmlWithBranding activationEmailBodyHtml replace branding + subj = renderTextWithBranding activationEmailSubject replace branding + + replace :: Text -> Text + replace "url" = renderActivationUrl activationEmailUrl akey acode branding + replace "email" = fromEmail email + replace "name" = fromName name + replace x = x + +renderActivationUrl :: Template -> ActivationKey -> ActivationCode -> TemplateBranding -> Text +renderActivationUrl t (ActivationKey k) (ActivationCode c) branding = + toStrict $ renderTextWithBranding t replace branding + where + replace :: Text -> Text + replace "key" = Ascii.toText k + replace "code" = Ascii.toText c + replace x = x + +------------------------------------------------------------------------------- +-- Team Activation Email + +sendTeamActivationMailImpl :: + (Member EmailSending r) => + Localised UserTemplates -> + TemplateBranding -> + Email -> + Name -> + ActivationKey -> + ActivationCode -> + Maybe Locale -> + Text -> + Sem r () +sendTeamActivationMailImpl userTemplates branding email name akey acode mLocale teamName = do + let tpl = teamActivationEmail . snd $ forLocale mLocale userTemplates + sendMail $ renderTeamActivationMail email name teamName akey acode tpl branding + +renderTeamActivationMail :: Email -> Name -> Text -> ActivationKey -> ActivationCode -> TeamActivationEmailTemplate -> TemplateBranding -> Mail +renderTeamActivationMail email name teamName akey@(ActivationKey key) acode@(ActivationCode code) TeamActivationEmailTemplate {..} branding = + (emptyMail from) + { mailTo = [to], + mailHeaders = + [ ("Subject", toStrict subj), + ("X-Zeta-Purpose", "Activation"), + ("X-Zeta-Key", Ascii.toText key), + ("X-Zeta-Code", Ascii.toText code) + ], + mailParts = [[plainPart txt, htmlPart html]] + } + where + from, to :: Address + from = Address (Just teamActivationEmailSenderName) (fromEmail teamActivationEmailSender) + to = mkMimeAddress name email + txt, html, subj :: LText + txt = renderTextWithBranding teamActivationEmailBodyText replace branding + html = renderHtmlWithBranding teamActivationEmailBodyHtml replace branding + subj = renderTextWithBranding teamActivationEmailSubject replace branding + replace :: Text -> Text + replace "url" = renderActivationUrl teamActivationEmailUrl akey acode branding + replace "email" = fromEmail email + replace "name" = fromName name + replace "team" = teamName + replace x = x + +------------------------------------------------------------------------------- +-- Verification Email + +sendVerificationMailImpl :: + (Member EmailSending r) => + Localised UserTemplates -> + TemplateBranding -> + Email -> + ActivationKey -> + ActivationCode -> + Maybe Locale -> + Sem r () +sendVerificationMailImpl userTemplates branding email akey acode mLocale = do + let tpl = verificationEmail . snd $ forLocale mLocale userTemplates + sendMail $ renderVerificationMail email akey acode tpl branding + +renderVerificationMail :: Email -> ActivationKey -> ActivationCode -> VerificationEmailTemplate -> TemplateBranding -> Mail +renderVerificationMail email akey acode VerificationEmailTemplate {..} branding = + (emptyMail from) + { mailTo = [to], + -- To make automated processing possible, the activation code is also added to + -- headers. {#RefActivationEmailHeaders} + mailHeaders = + [ ("Subject", toStrict subj), + ("X-Zeta-Purpose", "Verification"), + ("X-Zeta-Code", Ascii.toText code) + ], + mailParts = [[plainPart txt, htmlPart html]] + } + where + (ActivationKey _, ActivationCode code) = (akey, acode) + from = Address (Just verificationEmailSenderName) (fromEmail verificationEmailSender) + to = Address Nothing (fromEmail email) + txt = renderTextWithBranding verificationEmailBodyText replace branding + html = renderHtmlWithBranding verificationEmailBodyHtml replace branding + subj = renderTextWithBranding verificationEmailSubject replace branding + replace "code" = Ascii.toText code + replace "email" = fromEmail email + replace x = x + +------------------------------------------------------------------------------- +-- Password Reset Email + +sendPasswordResetMailImpl :: + (Member EmailSending r) => + Localised UserTemplates -> + TemplateBranding -> + Email -> + PasswordResetKey -> + PasswordResetCode -> + Maybe Locale -> + Sem r () +sendPasswordResetMailImpl userTemplates branding email pkey pcode mLocale = do + let tpl = passwordResetEmail . snd $ forLocale mLocale userTemplates + sendMail $ renderPwResetMail email pkey pcode tpl branding + +renderPwResetMail :: Email -> PasswordResetKey -> PasswordResetCode -> PasswordResetEmailTemplate -> TemplateBranding -> Mail +renderPwResetMail email pkey pcode PasswordResetEmailTemplate {..} branding = + (emptyMail from) + { mailTo = [to], + mailHeaders = + [ ("Subject", toStrict subj), + ("X-Zeta-Purpose", "PasswordReset"), + ("X-Zeta-Key", Ascii.toText key), + ("X-Zeta-Code", Ascii.toText code) + ], + mailParts = [[plainPart txt, htmlPart html]] + } + where + (PasswordResetKey key, PasswordResetCode code) = (pkey, pcode) + from = Address (Just passwordResetEmailSenderName) (fromEmail passwordResetEmailSender) + to = Address Nothing (fromEmail email) + txt = renderTextWithBranding passwordResetEmailBodyText replace branding + html = renderHtmlWithBranding passwordResetEmailBodyHtml replace branding + subj = renderTextWithBranding passwordResetEmailSubject replace branding + replace "url" = renderPwResetUrl passwordResetEmailUrl (pkey, pcode) branding + replace x = x + +renderPwResetUrl :: Template -> PasswordResetPair -> TemplateBranding -> Text +renderPwResetUrl t (PasswordResetKey k, PasswordResetCode c) branding = + toStrict $ renderTextWithBranding t replace branding + where + replace "key" = Ascii.toText k + replace "code" = Ascii.toText c + replace x = x + +------------------------------------------------------------------------------- +-- New Client Email + +sendNewClientEmailImpl :: + (Member EmailSending r) => + Localised UserTemplates -> + TemplateBranding -> + Email -> + Name -> + Client -> + Locale -> + Sem r () +sendNewClientEmailImpl userTemplates branding email name client locale = do + let tpl = newClientEmail . snd $ forLocale (Just locale) userTemplates + sendMail $ renderNewClientEmail email name locale client tpl branding + +renderNewClientEmail :: Email -> Name -> Locale -> Client -> NewClientEmailTemplate -> TemplateBranding -> Mail +renderNewClientEmail email name locale Client {..} NewClientEmailTemplate {..} branding = + (emptyMail from) + { mailTo = [to], + mailHeaders = + [ ("Subject", toStrict subj), + ("X-Zeta-Purpose", "NewDevice") + ], + mailParts = [[plainPart txt, htmlPart html]] + } + where + from = Address (Just newClientEmailSenderName) (fromEmail newClientEmailSender) + to = mkMimeAddress name email + txt = renderTextWithBranding newClientEmailBodyText replace branding + html = renderHtmlWithBranding newClientEmailBodyHtml replace branding + subj = renderTextWithBranding newClientEmailSubject replace branding + replace "name" = fromName name + replace "label" = fromMaybe "N/A" clientLabel + replace "model" = fromMaybe "N/A" clientModel + replace "date" = + formatDateTime + "%A %e %B %Y, %H:%M - %Z" + (timeLocale locale) + (fromUTCTimeMillis clientTime) + replace x = x + +------------------------------------------------------------------------------- +-- Deletion Email + +sendAccountDeletionEmailImpl :: + (Member EmailSending r) => + Localised UserTemplates -> + TemplateBranding -> + Email -> + Name -> + Code.Key -> + Code.Value -> + Locale -> + Sem r () +sendAccountDeletionEmailImpl userTemplates branding email name key code locale = do + let tpl = deletionEmail . snd $ forLocale (Just locale) userTemplates + sendMail $ renderDeletionEmail email name key code tpl branding + +renderDeletionEmail :: Email -> Name -> Code.Key -> Code.Value -> DeletionEmailTemplate -> TemplateBranding -> Mail +renderDeletionEmail email name cKey cValue DeletionEmailTemplate {..} branding = + (emptyMail from) + { mailTo = [to], + mailHeaders = + [ ("Subject", toStrict subj), + ("X-Zeta-Purpose", "Delete"), + ("X-Zeta-Key", key), + ("X-Zeta-Code", code) + ], + mailParts = [[plainPart txt, htmlPart html]] + } + where + from = Address (Just deletionEmailSenderName) (fromEmail deletionEmailSender) + to = mkMimeAddress name email + txt = renderTextWithBranding deletionEmailBodyText replace1 branding + html = renderHtmlWithBranding deletionEmailBodyHtml replace1 branding + subj = renderTextWithBranding deletionEmailSubject replace1 branding + key = Ascii.toText (fromRange (Code.asciiKey cKey)) + code = Ascii.toText (fromRange (Code.asciiValue cValue)) + replace1 "url" = toStrict (renderTextWithBranding deletionEmailUrl replace2 branding) + replace1 "email" = fromEmail email + replace1 "name" = fromName name + replace1 x = x + replace2 "key" = key + replace2 "code" = code + replace2 x = x + +------------------------------------------------------------------------------- +-- MIME Conversions + +-- | Construct a MIME 'Address' from the given display 'Name' and 'Email' +-- address that does not exceed 320 bytes in length when rendered for use +-- in SMTP, which is a safe limit for most mail servers (including those of +-- Amazon SES). The display name is only included if it fits within that +-- limit, otherwise it is dropped. +mkMimeAddress :: Name -> Email -> Address +mkMimeAddress name email = + let addr = Address (Just (fromName name)) (fromEmail email) + in if Text.compareLength (renderAddress addr) 320 == GT + then Address Nothing (fromEmail email) + else addr diff --git a/libs/wire-subsystems/src/Wire/EmailSubsystem/Template.hs b/libs/wire-subsystems/src/Wire/EmailSubsystem/Template.hs new file mode 100644 index 00000000000..9c123e1c0e3 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/EmailSubsystem/Template.hs @@ -0,0 +1,204 @@ +{-# LANGUAGE StrictData #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Wire.EmailSubsystem.Template + ( Localised (..), + TemplateBranding, + forLocale, + + -- * templates + UserTemplates (..), + ActivationSmsTemplate (..), + VerificationEmailTemplate (..), + ActivationEmailTemplate (..), + TeamActivationEmailTemplate (..), + ActivationCallTemplate (..), + PasswordResetSmsTemplate (..), + PasswordResetEmailTemplate (..), + LoginSmsTemplate (..), + LoginCallTemplate (..), + DeletionSmsTemplate (..), + DeletionEmailTemplate (..), + NewClientEmailTemplate (..), + SecondFactorVerificationEmailTemplate (..), + + -- * Re-exports + Template, + renderTextWithBranding, + renderHtmlWithBranding, + ) +where + +import Data.Map qualified as Map +import Data.Text.Lazy qualified as Lazy +import Data.Text.Template +import HTMLEntities.Text qualified as HTML +import Imports +import Wire.API.Locale +import Wire.API.User + +-- | Lookup a localised item from a 'Localised' structure. +forLocale :: + -- | 'Just' the preferred locale or 'Nothing' for + -- the default locale. + Maybe Locale -> + -- | The 'Localised' structure. + Localised a -> + -- | Pair of the effectively chosen locale and the + -- associated value. + (Locale, a) +forLocale pref t = case pref of + Just l -> fromMaybe (locDefault t) (select l) + Nothing -> locDefault t + where + select l = + let l' = l {lCountry = Nothing} + loc = Map.lookup l (locOther t) + lan = Map.lookup l' (locOther t) + in (l,) <$> loc <|> (l',) <$> lan + +-- | See 'genTemplateBranding'. +type TemplateBranding = Text -> Text + +-- | Localised templates. +data Localised a = Localised + { locDefault :: (Locale, a), + locOther :: (Map Locale a) + } + +-- | Uses a replace and a branding function, to replaces all placeholders from the +-- given template to produce a Text. To be used on plain text templates +renderTextWithBranding :: Template -> (Text -> Text) -> TemplateBranding -> Lazy.Text +renderTextWithBranding tpl replace branding = render tpl (replace . branding) + +-- | Uses a replace and a branding function to replace all placeholders from the +-- given template to produce a Text. To be used on HTML templates +renderHtmlWithBranding :: Template -> (Text -> Text) -> TemplateBranding -> Lazy.Text +renderHtmlWithBranding tpl replace branding = render tpl (HTML.text . replace . branding) + +data UserTemplates = UserTemplates + { activationSms :: ActivationSmsTemplate, + activationCall :: ActivationCallTemplate, + verificationEmail :: VerificationEmailTemplate, + activationEmail :: ActivationEmailTemplate, + activationEmailUpdate :: ActivationEmailTemplate, + teamActivationEmail :: TeamActivationEmailTemplate, + passwordResetSms :: PasswordResetSmsTemplate, + passwordResetEmail :: PasswordResetEmailTemplate, + loginSms :: LoginSmsTemplate, + loginCall :: LoginCallTemplate, + deletionSms :: DeletionSmsTemplate, + deletionEmail :: DeletionEmailTemplate, + newClientEmail :: NewClientEmailTemplate, + verificationLoginEmail :: SecondFactorVerificationEmailTemplate, + verificationScimTokenEmail :: SecondFactorVerificationEmailTemplate, + verificationTeamDeletionEmail :: SecondFactorVerificationEmailTemplate + } + +data ActivationSmsTemplate = ActivationSmsTemplate + { activationSmslUrl :: Template, + activationSmsText :: Template, + activationSmsSender :: Text + } + +data ActivationCallTemplate = ActivationCallTemplate + { activationCallText :: Template + } + +data VerificationEmailTemplate = VerificationEmailTemplate + { verificationEmailUrl :: Template, + verificationEmailSubject :: Template, + verificationEmailBodyText :: Template, + verificationEmailBodyHtml :: Template, + verificationEmailSender :: Email, + verificationEmailSenderName :: Text + } + +data ActivationEmailTemplate = ActivationEmailTemplate + { activationEmailUrl :: Template, + activationEmailSubject :: Template, + activationEmailBodyText :: Template, + activationEmailBodyHtml :: Template, + activationEmailSender :: Email, + activationEmailSenderName :: Text + } + +data TeamActivationEmailTemplate = TeamActivationEmailTemplate + { teamActivationEmailUrl :: Template, + teamActivationEmailSubject :: Template, + teamActivationEmailBodyText :: Template, + teamActivationEmailBodyHtml :: Template, + teamActivationEmailSender :: Email, + teamActivationEmailSenderName :: Text + } + +data DeletionEmailTemplate = DeletionEmailTemplate + { deletionEmailUrl :: Template, + deletionEmailSubject :: Template, + deletionEmailBodyText :: Template, + deletionEmailBodyHtml :: Template, + deletionEmailSender :: Email, + deletionEmailSenderName :: Text + } + +data PasswordResetEmailTemplate = PasswordResetEmailTemplate + { passwordResetEmailUrl :: Template, + passwordResetEmailSubject :: Template, + passwordResetEmailBodyText :: Template, + passwordResetEmailBodyHtml :: Template, + passwordResetEmailSender :: Email, + passwordResetEmailSenderName :: Text + } + +data PasswordResetSmsTemplate = PasswordResetSmsTemplate + { passwordResetSmsText :: Template, + passwordResetSmsSender :: Text + } + +data LoginSmsTemplate = LoginSmsTemplate + { loginSmsUrl :: Template, + loginSmsText :: Template, + loginSmsSender :: Text + } + +data LoginCallTemplate = LoginCallTemplate + { loginCallText :: Template + } + +data DeletionSmsTemplate = DeletionSmsTemplate + { deletionSmsUrl :: Template, + deletionSmsText :: Template, + deletionSmsSender :: Text + } + +data NewClientEmailTemplate = NewClientEmailTemplate + { newClientEmailSubject :: Template, + newClientEmailBodyText :: Template, + newClientEmailBodyHtml :: Template, + newClientEmailSender :: Email, + newClientEmailSenderName :: Text + } + +data SecondFactorVerificationEmailTemplate = SecondFactorVerificationEmailTemplate + { sndFactorVerificationEmailSubject :: Template, + sndFactorVerificationEmailBodyText :: Template, + sndFactorVerificationEmailBodyHtml :: Template, + sndFactorVerificationEmailSender :: Email, + sndFactorVerificationEmailSenderName :: Text + } diff --git a/libs/wire-subsystems/src/Wire/Error.hs b/libs/wire-subsystems/src/Wire/Error.hs new file mode 100644 index 00000000000..1710571d161 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/Error.hs @@ -0,0 +1,35 @@ +module Wire.Error where + +import Data.Aeson +import Data.Aeson.KeyMap qualified as KeyMap +import Data.ByteString qualified as BS +import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text +import Imports +import Network.HTTP.Types +import Network.Wai.Utilities.Error qualified as Wai + +-- | Error thrown to the user +data HttpError where + StdError :: !Wai.Error -> HttpError + RichError :: (ToJSON a) => !Wai.Error -> !a -> [Header] -> HttpError + +instance Show HttpError where + show (StdError werr) = "StdError (" <> show werr <> ")" + show e@(RichError _ _ headers) = "RichError (json = " <> Text.unpack (Text.decodeUtf8 $ BS.toStrict $ encode e) <> ", headers = " <> show headers <> ")" + +instance Exception HttpError + +errorLabel :: HttpError -> LText +errorLabel (StdError e) = Wai.label e +errorLabel (RichError e _ _) = Wai.label e + +errorStatus :: HttpError -> Status +errorStatus (StdError e) = Wai.code e +errorStatus (RichError e _ _) = Wai.code e + +instance ToJSON HttpError where + toJSON (StdError e) = toJSON e + toJSON (RichError e x _) = case (toJSON e, toJSON x) of + (Object o1, Object o2) -> Object (KeyMap.union o1 o2) + (j, _) -> j diff --git a/libs/wire-subsystems/src/Wire/FederationAPIAccess.hs b/libs/wire-subsystems/src/Wire/FederationAPIAccess.hs index 9065f9f8c3b..e251043c8ae 100644 --- a/libs/wire-subsystems/src/Wire/FederationAPIAccess.hs +++ b/libs/wire-subsystems/src/Wire/FederationAPIAccess.hs @@ -12,7 +12,7 @@ import Wire.API.Federation.Error data FederationAPIAccess (fedM :: Component -> Type -> Type) m a where RunFederatedEither :: - KnownComponent c => + (KnownComponent c) => Remote x -> fedM c a -> FederationAPIAccess fedM m (Either FederationError a) diff --git a/libs/wire-subsystems/src/Wire/GalleyAPIAccess.hs b/libs/wire-subsystems/src/Wire/GalleyAPIAccess.hs index 09222ca2261..b039bff1303 100644 --- a/libs/wire-subsystems/src/Wire/GalleyAPIAccess.hs +++ b/libs/wire-subsystems/src/Wire/GalleyAPIAccess.hs @@ -26,6 +26,7 @@ import Imports import Network.Wai.Utilities.Error qualified as Wai import Polysemy import Wire.API.Conversation +import Wire.API.Routes.Internal.Brig.EJPD (EJPDConvInfo) import Wire.API.Routes.Internal.Galley.TeamsIntra qualified as Team import Wire.API.Team import Wire.API.Team.Conversation qualified as Conv @@ -122,5 +123,8 @@ data GalleyAPIAccess m a where Maybe ConnId -> Qualified ConvId -> GalleyAPIAccess m Conversation + GetEJPDConvInfo :: + UserId -> + GalleyAPIAccess m [EJPDConvInfo] makeSem ''GalleyAPIAccess diff --git a/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs b/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs index 8363fcaf4a2..e05584e9a36 100644 --- a/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs +++ b/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs @@ -40,6 +40,7 @@ import Servant.API (toHeader) import System.Logger.Message import Util.Options import Wire.API.Conversation hiding (Member) +import Wire.API.Routes.Internal.Brig.EJPD (EJPDConvInfo) import Wire.API.Routes.Internal.Galley.TeamsIntra qualified as Team import Wire.API.Routes.Version import Wire.API.Team @@ -86,6 +87,7 @@ interpretGalleyAPIAccessToRpc disabledVersions galleyEndpoint = GetExposeInvitationURLsToTeamAdmin id' -> getTeamExposeInvitationURLsToTeamAdmin id' IsMLSOne2OneEstablished lusr qother -> checkMLSOne2OneEstablished lusr qother UnblockConversation lusr mconn qcnv -> unblockConversation v lusr mconn qcnv + GetEJPDConvInfo uid -> getEJPDConvInfo uid galleyRequest :: (Member Rpc r, Member (Input Endpoint) r) => (Request -> Request) -> Sem r (Response (Maybe LByteString)) galleyRequest req = do @@ -574,3 +576,22 @@ unblockConversation v lusr mconn (Qualified cnv cdom) = do remote :: ByteString -> Msg -> Msg remote = field "remote" + +getEJPDConvInfo :: + forall r. + ( Member TinyLog r, + Member (Error ParseException) r, + Member (Input Endpoint) r, + Member Rpc r + ) => + UserId -> + Sem r [EJPDConvInfo] +getEJPDConvInfo uid = do + debug $ + remote "galley" + . msg (val "get conversation info for ejpd") + decodeBodyOrThrow "galley" =<< galleyRequest getReq + where + getReq = + method GET + . paths ["i", "user", toByteString' uid, "all-conversations"] diff --git a/libs/wire-subsystems/src/Wire/HashPassword.hs b/libs/wire-subsystems/src/Wire/HashPassword.hs new file mode 100644 index 00000000000..54c65c3ee74 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/HashPassword.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Wire.HashPassword where + +import Data.Misc +import Imports +import Polysemy +import Wire.API.Password (Password) +import Wire.API.Password qualified as Password + +data HashPassword m a where + HashPassword :: PlainTextPassword8 -> HashPassword m Password + +makeSem ''HashPassword + +runHashPassword :: (Member (Embed IO) r) => InterpreterFor HashPassword r +runHashPassword = interpret $ \case + HashPassword pw -> liftIO $ Password.mkSafePasswordScrypt pw diff --git a/services/brig/src/Brig/Effects/CodeStore.hs b/libs/wire-subsystems/src/Wire/PasswordResetCodeStore.hs similarity index 59% rename from services/brig/src/Brig/Effects/CodeStore.hs rename to libs/wire-subsystems/src/Wire/PasswordResetCodeStore.hs index 96f3e7c63be..dbf5502fc4a 100644 --- a/services/brig/src/Brig/Effects/CodeStore.hs +++ b/libs/wire-subsystems/src/Wire/PasswordResetCodeStore.hs @@ -16,7 +16,7 @@ -- with this program. If not, see . {-# LANGUAGE TemplateHaskell #-} -module Brig.Effects.CodeStore where +module Wire.PasswordResetCodeStore where import Data.Id import Data.Time.Clock @@ -33,18 +33,20 @@ data PRQueryData f = PRQueryData prqdTimeout :: f UTCTime } -data CodeStore m a where - MkPasswordResetKey :: UserId -> CodeStore m PasswordResetKey - GenerateEmailCode :: CodeStore m PasswordResetCode - GeneratePhoneCode :: CodeStore m PasswordResetCode - CodeSelect :: - PasswordResetKey -> - CodeStore m (Maybe (PRQueryData Maybe)) - CodeInsert :: - PasswordResetKey -> - PRQueryData Identity -> - Int32 -> - CodeStore m () - CodeDelete :: PasswordResetKey -> CodeStore m () - -makeSem ''CodeStore +deriving instance Show (PRQueryData Identity) + +deriving instance Eq (PRQueryData Maybe) + +deriving instance Show (PRQueryData Maybe) + +mapPRQueryData :: (forall a. (f1 a -> f2 a)) -> PRQueryData f1 -> PRQueryData f2 +mapPRQueryData f prqd = prqd {prqdRetries = f prqd.prqdRetries, prqdTimeout = f prqd.prqdTimeout} + +data PasswordResetCodeStore m a where + GenerateEmailCode :: PasswordResetCodeStore m PasswordResetCode + GeneratePhoneCode :: PasswordResetCodeStore m PasswordResetCode + CodeSelect :: PasswordResetKey -> PasswordResetCodeStore m (Maybe (PRQueryData Maybe)) + CodeInsert :: PasswordResetKey -> PRQueryData Identity -> Int32 -> PasswordResetCodeStore m () + CodeDelete :: PasswordResetKey -> PasswordResetCodeStore m () + +makeSem ''PasswordResetCodeStore diff --git a/services/brig/src/Brig/Effects/CodeStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/PasswordResetCodeStore/Cassandra.hs similarity index 81% rename from services/brig/src/Brig/Effects/CodeStore/Cassandra.hs rename to libs/wire-subsystems/src/Wire/PasswordResetCodeStore/Cassandra.hs index 26d4d2c7f32..74bdd0ca1f7 100644 --- a/services/brig/src/Brig/Effects/CodeStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/PasswordResetCodeStore/Cassandra.hs @@ -16,37 +16,34 @@ -- with this program. If not, see . {-# LANGUAGE RecordWildCards #-} -module Brig.Effects.CodeStore.Cassandra - ( codeStoreToCassandra, +module Wire.PasswordResetCodeStore.Cassandra + ( passwordResetCodeStoreToCassandra, interpretClientToIO, ) where -import Brig.Effects.CodeStore import Cassandra -import Data.ByteString.Conversion (toByteString') import Data.Id import Data.Text (pack) import Data.Text.Ascii import Data.Time.Clock import Imports import OpenSSL.BN (randIntegerZeroToNMinusOne) -import OpenSSL.EVP.Digest (digestBS, getDigestByName) import OpenSSL.Random (randBytes) import Polysemy import Text.Printf import Wire.API.User.Password +import Wire.PasswordResetCodeStore -codeStoreToCassandra :: +passwordResetCodeStoreToCassandra :: forall m r a. (MonadClient m, Member (Embed m) r) => - Sem (CodeStore ': r) a -> + Sem (PasswordResetCodeStore ': r) a -> Sem r a -codeStoreToCassandra = +passwordResetCodeStoreToCassandra = interpret $ embed @m . \case - MkPasswordResetKey uid -> mkPwdResetKey uid GenerateEmailCode -> genEmailCode GeneratePhoneCode -> genPhoneCode CodeSelect prk -> @@ -74,21 +71,16 @@ codeStoreToCassandra = toRecord (prqdCode, prqdUser, prqdRetries, prqdTimeout) = PRQueryData {..} -genEmailCode :: MonadIO m => m PasswordResetCode +genEmailCode :: (MonadIO m) => m PasswordResetCode genEmailCode = PasswordResetCode . encodeBase64Url <$> liftIO (randBytes 24) -genPhoneCode :: MonadIO m => m PasswordResetCode +genPhoneCode :: (MonadIO m) => m PasswordResetCode genPhoneCode = PasswordResetCode . unsafeFromText . pack . printf "%06d" <$> liftIO (randIntegerZeroToNMinusOne 1000000) -mkPwdResetKey :: MonadIO m => UserId -> m PasswordResetKey -mkPwdResetKey u = do - d <- liftIO $ getDigestByName "SHA256" >>= maybe (error "SHA256 not found") pure - pure . PasswordResetKey . encodeBase64Url . digestBS d $ toByteString' u - interpretClientToIO :: - Member (Final IO) r => + (Member (Final IO) r) => ClientState -> Sem (Embed Cassandra.Client ': r) a -> Sem r a diff --git a/libs/wire-subsystems/src/Wire/PasswordStore.hs b/libs/wire-subsystems/src/Wire/PasswordStore.hs new file mode 100644 index 00000000000..48a358aa827 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/PasswordStore.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Wire.PasswordStore where + +import Data.Id +import Imports +import Polysemy +import Wire.API.Password + +data PasswordStore m a where + UpsertHashedPassword :: UserId -> Password -> PasswordStore m () + LookupHashedPassword :: UserId -> PasswordStore m (Maybe Password) + +makeSem ''PasswordStore diff --git a/libs/wire-subsystems/src/Wire/PasswordStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/PasswordStore/Cassandra.hs new file mode 100644 index 00000000000..933faeb298d --- /dev/null +++ b/libs/wire-subsystems/src/Wire/PasswordStore/Cassandra.hs @@ -0,0 +1,36 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Wire.PasswordStore.Cassandra (interpretPasswordStore) where + +import Cassandra +import Data.Id +import Imports +import Polysemy +import Polysemy.Embed +import Wire.API.Password (Password) +import Wire.PasswordStore + +interpretPasswordStore :: (Member (Embed IO) r) => ClientState -> InterpreterFor PasswordStore r +interpretPasswordStore casClient = + interpret $ + runEmbedded (runClient casClient) . \case + UpsertHashedPassword uid password -> embed $ updatePasswordImpl uid password + LookupHashedPassword uid -> embed $ lookupPasswordImpl uid + +lookupPasswordImpl :: (MonadClient m) => UserId -> m (Maybe Password) +lookupPasswordImpl u = + (runIdentity =<<) + <$> retry x1 (query1 passwordSelect (params LocalQuorum (Identity u))) + +updatePasswordImpl :: (MonadClient m) => UserId -> Password -> m () +updatePasswordImpl u p = do + retry x5 $ write userPasswordUpdate (params LocalQuorum (p, u)) + +------------------------------------------------------------------------ +-- Queries + +passwordSelect :: PrepQuery R (Identity UserId) (Identity (Maybe Password)) +passwordSelect = "SELECT password FROM user WHERE id = ?" + +userPasswordUpdate :: PrepQuery W (Password, UserId) () +userPasswordUpdate = {- `IF EXISTS`, but that requires benchmarking -} "UPDATE user SET password = ? WHERE id = ?" diff --git a/libs/wire-subsystems/src/Wire/Rpc.hs b/libs/wire-subsystems/src/Wire/Rpc.hs index b7589d6128f..99f52727867 100644 --- a/libs/wire-subsystems/src/Wire/Rpc.hs +++ b/libs/wire-subsystems/src/Wire/Rpc.hs @@ -35,7 +35,7 @@ data Rpc m a where makeSem ''Rpc -runRpcWithHttp :: Member (Embed IO) r => Manager -> RequestId -> Sem (Rpc : r) a -> Sem r a +runRpcWithHttp :: (Member (Embed IO) r) => Manager -> RequestId -> Sem (Rpc : r) a -> Sem r a runRpcWithHttp mgr reqId = interpret $ \case Rpc serviceName ep req -> embed $ runHttpRpc mgr reqId $ rpcImpl serviceName ep req diff --git a/libs/wire-subsystems/src/Wire/SessionStore.hs b/libs/wire-subsystems/src/Wire/SessionStore.hs new file mode 100644 index 00000000000..35c4c8355c7 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/SessionStore.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-ambiguous-fields #-} + +module Wire.SessionStore where + +import Cassandra +import Data.Id +import Data.Time.Clock +import Imports +import Polysemy +import Test.QuickCheck +import Wire.API.User.Auth + +newtype TTL = TTL {ttlSeconds :: Int32} + deriving (Show, Eq) + deriving newtype (Cql, Arbitrary) + +data SessionStore m a where + InsertCookie :: UserId -> Cookie () -> Maybe TTL -> SessionStore m () + LookupCookie :: UserId -> UTCTime -> CookieId -> SessionStore m (Maybe (Cookie ())) + ListCookies :: UserId -> SessionStore m [Cookie ()] + DeleteAllCookies :: UserId -> SessionStore m () + DeleteCookies :: UserId -> [Cookie ()] -> SessionStore m () + +makeSem ''SessionStore diff --git a/services/brig/src/Brig/User/Auth/DB/Cookie.hs b/libs/wire-subsystems/src/Wire/SessionStore/Cassandra.hs similarity index 71% rename from services/brig/src/Brig/User/Auth/DB/Cookie.hs rename to libs/wire-subsystems/src/Wire/SessionStore/Cassandra.hs index c0d43ef2341..109b3660055 100644 --- a/services/brig/src/Brig/User/Auth/DB/Cookie.hs +++ b/libs/wire-subsystems/src/Wire/SessionStore/Cassandra.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2022 Wire Swiss GmbH @@ -16,21 +14,29 @@ -- -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . +module Wire.SessionStore.Cassandra (interpretSessionStoreCassandra) where -module Brig.User.Auth.DB.Cookie where - -import Brig.User.Auth.DB.Instances () import Cassandra import Data.Id import Data.Time.Clock import Imports +import Polysemy +import Polysemy.Embed import Wire.API.User.Auth +import Wire.SessionStore -newtype TTL = TTL {ttlSeconds :: Int32} - deriving (Cql) +interpretSessionStoreCassandra :: (Member (Embed IO) r) => ClientState -> InterpreterFor SessionStore r +interpretSessionStoreCassandra casClient = + interpret $ + runEmbedded (runClient casClient) . \case + InsertCookie uid cookie ttl -> embed $ insertCookieImpl uid cookie ttl + LookupCookie uid utc cid -> embed $ lookupCookieImpl uid utc cid + ListCookies uid -> embed $ listCookiesImpl uid + DeleteAllCookies uid -> embed $ deleteAllCookiesImpl uid + DeleteCookies uid cc -> embed $ deleteCookiesImpl uid cc -insertCookie :: MonadClient m => UserId -> Cookie a -> Maybe TTL -> m () -insertCookie u ck ttl = +insertCookieImpl :: (MonadClient m) => UserId -> Cookie () -> Maybe TTL -> m () +insertCookieImpl u ck ttl = let i = cookieId ck x = cookieExpires ck c = cookieCreated ck @@ -45,8 +51,8 @@ insertCookie u ck ttl = "INSERT INTO user_cookies (user, expires, id, type, created, label, succ_id) \ \VALUES (?, ?, ?, ?, ?, ?, ?) USING TTL ?" -lookupCookie :: MonadClient m => UserId -> UTCTime -> CookieId -> m (Maybe (Cookie ())) -lookupCookie u t c = +lookupCookieImpl :: (MonadClient m) => UserId -> UTCTime -> CookieId -> m (Maybe (Cookie ())) +lookupCookieImpl u t c = fmap mkCookie <$> retry x1 (query1 cql (params LocalQuorum (u, t, c))) where mkCookie (typ, created, label, csucc) = @@ -65,8 +71,8 @@ lookupCookie u t c = \FROM user_cookies \ \WHERE user = ? AND expires = ? AND id = ?" -listCookies :: MonadClient m => UserId -> m [Cookie ()] -listCookies u = +listCookiesImpl :: (MonadClient m) => UserId -> m [Cookie ()] +listCookiesImpl u = map toCookie <$> retry x1 (query cql (params LocalQuorum (Identity u))) where cql :: PrepQuery R (Identity UserId) (CookieId, UTCTime, UTCTime, CookieType, Maybe CookieLabel, Maybe CookieId) @@ -87,8 +93,8 @@ listCookies u = cookieValue = () } -deleteCookies :: MonadClient m => UserId -> [Cookie a] -> m () -deleteCookies u cs = retry x5 . batch $ do +deleteCookiesImpl :: (MonadClient m) => UserId -> [Cookie ()] -> m () +deleteCookiesImpl u cs = retry x5 . batch $ do setType BatchUnLogged setConsistency LocalQuorum for_ cs $ \c -> addPrepQuery cql (u, cookieExpires c, cookieId c) @@ -96,8 +102,8 @@ deleteCookies u cs = retry x5 . batch $ do cql :: PrepQuery W (UserId, UTCTime, CookieId) () cql = "DELETE FROM user_cookies WHERE user = ? AND expires = ? AND id = ?" -deleteAllCookies :: MonadClient m => UserId -> m () -deleteAllCookies u = retry x5 (write cql (params LocalQuorum (Identity u))) +deleteAllCookiesImpl :: (MonadClient m) => UserId -> m () +deleteAllCookiesImpl u = retry x5 (write cql (params LocalQuorum (Identity u))) where cql :: PrepQuery W (Identity UserId) () cql = "DELETE FROM user_cookies WHERE user = ?" diff --git a/libs/wire-subsystems/src/Wire/StoredUser.hs b/libs/wire-subsystems/src/Wire/StoredUser.hs index b6fb20cb073..b2ace0784cb 100644 --- a/libs/wire-subsystems/src/Wire/StoredUser.hs +++ b/libs/wire-subsystems/src/Wire/StoredUser.hs @@ -7,8 +7,11 @@ import Data.Handle import Data.Id import Data.Json.Util import Data.Qualified +import Data.Set qualified as S import Database.CQL.Protocol (Record (..), TupleType, recordInstance) +import GHC.Records import Imports +import Wire.API.Locale import Wire.API.Provider.Service import Wire.API.User import Wire.Arbitrary @@ -39,19 +42,43 @@ data StoredUser = StoredUser recordInstance ''StoredUser +setStoredUserName :: Name -> StoredUser -> StoredUser +setStoredUserName newName user = user {name = newName} + +setStoredUserSupportedProtocols :: Set BaseProtocolTag -> StoredUser -> StoredUser +setStoredUserSupportedProtocols newProtocols user = user {supportedProtocols = Just newProtocols} + +setStoredUserPict :: Pict -> StoredUser -> StoredUser +setStoredUserPict newPict user = user {pict = Just newPict} + +setStoredUserAssets :: [Asset] -> StoredUser -> StoredUser +setStoredUserAssets newAssets user = user {assets = Just newAssets} + +setStoredUserAccentId :: ColourId -> StoredUser -> StoredUser +setStoredUserAccentId newAccentId user = user {accentId = newAccentId} + +setStoredUserLocale :: Locale -> StoredUser -> StoredUser +setStoredUserLocale newLocale user = + user + { language = Just newLocale.lLanguage, + country = newLocale.lCountry + } + +setStoredUserHandle :: Handle -> StoredUser -> StoredUser +setStoredUserHandle newHandle user = user {handle = Just newHandle} + hasPendingInvitation :: StoredUser -> Bool hasPendingInvitation u = u.status == Just PendingInvitation mkUserFromStored :: Domain -> Locale -> StoredUser -> User mkUserFromStored domain defaultLocale storedUser = - let ident = toIdentity storedUser.activated storedUser.email storedUser.phone storedUser.ssoId - deleted = Just Deleted == storedUser.status + let deleted = Just Deleted == storedUser.status expiration = if storedUser.status == Just Ephemeral then storedUser.expires else Nothing loc = toLocale defaultLocale (storedUser.language, storedUser.country) svc = newServiceRef <$> storedUser.serviceId <*> storedUser.providerId in User { userQualifiedId = (Qualified storedUser.id domain), - userIdentity = ident, + userIdentity = storedUser.identity, userDisplayName = storedUser.name, userPict = (fromMaybe noPict storedUser.pict), userAssets = (fromMaybe [] storedUser.assets), @@ -62,10 +89,18 @@ mkUserFromStored domain defaultLocale storedUser = userHandle = storedUser.handle, userExpire = expiration, userTeam = storedUser.teamId, - userManagedBy = (fromMaybe ManagedByWire storedUser.managedBy), - userSupportedProtocols = (fromMaybe defSupportedProtocols storedUser.supportedProtocols) + userManagedBy = fromMaybe ManagedByWire storedUser.managedBy, + userSupportedProtocols = case storedUser.supportedProtocols of + Nothing -> defSupportedProtocols + Just ps -> if S.null ps then defSupportedProtocols else ps } +mkAccountFromStored :: Domain -> Locale -> StoredUser -> UserAccount +mkAccountFromStored domain defaultLocale storedUser = + UserAccount + (mkUserFromStored domain defaultLocale storedUser) + (fromMaybe Active storedUser.status) + toLocale :: Locale -> (Maybe Language, Maybe Country) -> Locale toLocale _ (Just l, c) = Locale l c toLocale l _ = l @@ -80,12 +115,15 @@ toIdentity :: -- | Whether the user is activated Bool -> Maybe Email -> - Maybe Phone -> Maybe UserSSOId -> Maybe UserIdentity -toIdentity True (Just e) (Just p) Nothing = Just $! FullIdentity e p -toIdentity True (Just e) Nothing Nothing = Just $! EmailIdentity e -toIdentity True Nothing (Just p) Nothing = Just $! PhoneIdentity p -toIdentity True email phone (Just ssoid) = Just $! SSOIdentity ssoid email phone -toIdentity True Nothing Nothing Nothing = Nothing -toIdentity False _ _ _ = Nothing +toIdentity True (Just e) Nothing = Just $! EmailIdentity e +toIdentity True email (Just ssoid) = Just $! SSOIdentity ssoid email +toIdentity True Nothing Nothing = Nothing +toIdentity False _ _ = Nothing + +instance HasField "identity" StoredUser (Maybe UserIdentity) where + getField user = toIdentity user.activated user.email user.ssoId + +instance HasField "locale" StoredUser (Maybe Locale) where + getField user = Locale <$> user.language <*> pure user.country diff --git a/libs/wire-subsystems/src/Wire/UserEvents.hs b/libs/wire-subsystems/src/Wire/UserEvents.hs new file mode 100644 index 00000000000..0288dee8d92 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/UserEvents.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Wire.UserEvents where + +import Data.Id +import Imports +import Polysemy +import Wire.API.UserEvent + +data UserEvents m a where + GenerateUserEvent :: UserId -> Maybe ConnId -> UserEvent -> UserEvents m () + +makeSem ''UserEvents diff --git a/libs/wire-subsystems/src/Wire/UserKeyStore.hs b/libs/wire-subsystems/src/Wire/UserKeyStore.hs new file mode 100644 index 00000000000..5683c25b763 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/UserKeyStore.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Wire.UserKeyStore where + +import Data.Id +import Data.Text qualified as Text +import Imports +import Polysemy +import Test.QuickCheck +import Wire.API.User + +-- | An 'EmailKey' is an 'Email' in a form that serves as a unique lookup key. +data EmailKey = EmailKey + { emailKeyUniq :: !Text, + emailKeyOrig :: !Email + } + deriving (Ord) + +instance Show EmailKey where + showsPrec _ = shows . emailKeyUniq + +instance Eq EmailKey where + (EmailKey k _) == (EmailKey k' _) = k == k' + +instance Arbitrary EmailKey where + arbitrary = mkEmailKey <$> arbitrary + +-- | Turn an 'Email' into an 'EmailKey'. +-- +-- The following transformations are performed: +-- +-- * Both local and domain parts are forced to lowercase to make +-- e-mail addresses fully case-insensitive. +-- * "+" suffixes on the local part are stripped unless the domain +-- part is contained in a trusted whitelist. +mkEmailKey :: Email -> EmailKey +mkEmailKey orig@(Email localPart domain) = + let uniq = Text.toLower localPart' <> "@" <> Text.toLower domain + in EmailKey uniq orig + where + localPart' + | domain `notElem` trusted = Text.takeWhile (/= '+') localPart + | otherwise = localPart + trusted = ["wearezeta.com", "wire.com", "simulator.amazonses.com"] + +data UserKeyStore m a where + LookupKey :: EmailKey -> UserKeyStore m (Maybe UserId) + InsertKey :: UserId -> EmailKey -> UserKeyStore m () + DeleteKey :: EmailKey -> UserKeyStore m () + DeleteKeyForUser :: UserId -> EmailKey -> UserKeyStore m () + KeyAvailable :: EmailKey -> Maybe UserId -> UserKeyStore m Bool + ClaimKey :: EmailKey -> UserId -> UserKeyStore m Bool + +makeSem ''UserKeyStore diff --git a/libs/wire-subsystems/src/Wire/UserKeyStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/UserKeyStore/Cassandra.hs new file mode 100644 index 00000000000..a7e65a99ff4 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/UserKeyStore/Cassandra.hs @@ -0,0 +1,92 @@ +module Wire.UserKeyStore.Cassandra (interpretUserKeyStoreCassandra) where + +import Cassandra +import Data.Id +import Imports +import Polysemy +import Polysemy.Embed +import Wire.UserKeyStore +import Wire.UserStore + +interpretUserKeyStoreCassandra :: (Member (Embed IO) r, Member UserStore r) => ClientState -> InterpreterFor UserKeyStore r +interpretUserKeyStoreCassandra casClient = + interpret $ + runEmbedded (runClient casClient) . \case + LookupKey key -> embed $ lookupKeyImpl key + InsertKey uid key -> embed $ insertKeyImpl uid key + DeleteKey key -> embed $ deleteKeyImpl key + DeleteKeyForUser uid key -> embed $ deleteKeyForUserImpl uid key + ClaimKey key uid -> claimKeyImpl casClient key uid + KeyAvailable key uid -> keyAvailableImpl casClient key uid + +-- | Claim an 'EmailKey' for a user. +claimKeyImpl :: + (Member (Embed IO) r, Member UserStore r) => + ClientState -> + -- | The key to claim. + EmailKey -> + -- | The user claiming the key. + UserId -> + Sem r Bool +claimKeyImpl client k u = do + free <- keyAvailableImpl client k (Just u) + when free (runClient client $ insertKeyImpl u k) + pure free + +-- | Check whether an 'EmailKey' is available. +-- A key is available if it is not already activated for another user or +-- if the other user and the user looking to claim the key are the same. +keyAvailableImpl :: + (Member (Embed IO) r, Member UserStore r) => + ClientState -> + -- | The key to check. + EmailKey -> + -- | The user looking to claim the key, if any. + Maybe UserId -> + Sem r Bool +keyAvailableImpl client k u = do + o <- runClient client $ lookupKeyImpl k + case (o, u) of + (Nothing, _) -> pure True + (Just x, Just y) | x == y -> pure True + (Just x, _) -> not <$> isActivated x + +lookupKeyImpl :: (MonadClient m) => EmailKey -> m (Maybe UserId) +lookupKeyImpl k = + fmap runIdentity + <$> retry x1 (query1 keySelect (params LocalQuorum (Identity $ emailKeyUniq k))) + +insertKeyImpl :: UserId -> EmailKey -> Client () +insertKeyImpl u k = do + retry x5 $ write keyInsert (params LocalQuorum (emailKeyUniq k, u)) + +deleteKeyImpl :: (MonadClient m) => EmailKey -> m () +deleteKeyImpl k = do + retry x5 $ write keyDelete (params LocalQuorum (Identity $ emailKeyUniq k)) + +-- | Delete `EmailKey` for `UserId` +-- +-- This function ensures that keys of other users aren't accidentally deleted. +-- E.g. the email address or phone number of a partially deleted user could +-- already belong to a new user. To not interrupt deletion flows (that may be +-- executed several times due to cassandra not supporting transactions) +-- `deleteKeyImplForUser` does not fail for missing keys or keys that belong to +-- another user: It always returns `()` as result. +deleteKeyForUserImpl :: (MonadClient m) => UserId -> EmailKey -> m () +deleteKeyForUserImpl uid k = do + mbKeyUid <- lookupKeyImpl k + case mbKeyUid of + Just keyUid | keyUid == uid -> deleteKeyImpl k + _ -> pure () + +-------------------------------------------------------------------------------- +-- Queries + +keyInsert :: PrepQuery W (Text, UserId) () +keyInsert = "INSERT INTO user_keys (key, user) VALUES (?, ?)" + +keySelect :: PrepQuery R (Identity Text) (Identity UserId) +keySelect = "SELECT user FROM user_keys WHERE key = ?" + +keyDelete :: PrepQuery W (Identity Text) () +keyDelete = "DELETE FROM user_keys WHERE key = ?" diff --git a/libs/wire-subsystems/src/Wire/UserStore.hs b/libs/wire-subsystems/src/Wire/UserStore.hs index 7e7d689d691..fc4260a5a3d 100644 --- a/libs/wire-subsystems/src/Wire/UserStore.hs +++ b/libs/wire-subsystems/src/Wire/UserStore.hs @@ -1,13 +1,73 @@ {-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-ambiguous-fields #-} module Wire.UserStore where +import Data.Default +import Data.Handle import Data.Id import Imports import Polysemy +import Polysemy.Error +import Wire.API.User +import Wire.Arbitrary import Wire.StoredUser +-- | Update of any "simple" attributes (ones that do not involve locking, like handle, or +-- validation protocols, like email). +-- +-- | see 'UserProfileUpdate'. +data StoredUserUpdate = MkStoredUserUpdate + { name :: Maybe Name, + pict :: Maybe Pict, + assets :: Maybe [Asset], + accentId :: Maybe ColourId, + locale :: Maybe Locale, + supportedProtocols :: Maybe (Set BaseProtocolTag) + } + deriving stock (Eq, Ord, Show, Generic) + deriving (Arbitrary) via GenericUniform StoredUserUpdate + +instance Default StoredUserUpdate where + def = MkStoredUserUpdate Nothing Nothing Nothing Nothing Nothing Nothing + +-- | Update user handle (this involves several http requests for locking the required handle). +-- The old/previous handle (for deciding idempotency). +data StoredUserHandleUpdate = MkStoredUserHandleUpdate + { old :: Maybe Handle, + new :: Handle + } + deriving stock (Eq, Ord, Show, Generic) + deriving (Arbitrary) via GenericUniform StoredUserHandleUpdate + +data StoredUserUpdateError = StoredUserUpdateHandleExists + +-- | Effect containing database logic around 'StoredUser'. (Example: claim handle lock is +-- database logic; validate handle is application logic.) data UserStore m a where GetUser :: UserId -> UserStore m (Maybe StoredUser) + UpdateUser :: UserId -> StoredUserUpdate -> UserStore m () + UpdateUserHandleEither :: UserId -> StoredUserHandleUpdate -> UserStore m (Either StoredUserUpdateError ()) + DeleteUser :: User -> UserStore m () + -- | This operation looks up a handle but is guaranteed to not give you stale locks. + -- It is potentially slower and less resilient than 'GlimpseHandle'. + LookupHandle :: Handle -> UserStore m (Maybe UserId) + -- | The interpretation for 'LookupHandle' and 'GlimpseHandle' + -- may differ in terms of how consistent they are. If that + -- matters for the interpretation, this operation may give you stale locks, + -- but is faster and more resilient. + GlimpseHandle :: Handle -> UserStore m (Maybe UserId) + LookupStatus :: UserId -> UserStore m (Maybe AccountStatus) + -- | Whether the account has been activated by verifying + -- an email address or phone number. + IsActivated :: UserId -> UserStore m Bool + LookupLocale :: UserId -> UserStore m (Maybe (Maybe Language, Maybe Country)) makeSem ''UserStore + +updateUserHandle :: + (Member UserStore r, Member (Error StoredUserUpdateError) r) => + UserId -> + StoredUserHandleUpdate -> + Sem r () +updateUserHandle uid update = either throw pure =<< updateUserHandleEither uid update diff --git a/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs index c1715d0aa3d..cba7356f22e 100644 --- a/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs @@ -1,28 +1,178 @@ -module Wire.UserStore.Cassandra where +module Wire.UserStore.Cassandra (interpretUserStoreCassandra) where import Cassandra +import Data.Handle import Data.Id import Database.CQL.Protocol import Imports import Polysemy import Polysemy.Embed +import Polysemy.Error +import Wire.API.User hiding (DeleteUser) import Wire.StoredUser import Wire.UserStore +import Wire.UserStore.Unique -interpretUserStoreCassandra :: Member (Embed IO) r => ClientState -> InterpreterFor UserStore r +interpretUserStoreCassandra :: (Member (Embed IO) r) => ClientState -> InterpreterFor UserStore r interpretUserStoreCassandra casClient = interpret $ runEmbedded (runClient casClient) . \case GetUser uid -> getUserImpl uid + UpdateUser uid update -> embed $ updateUserImpl uid update + UpdateUserHandleEither uid update -> embed $ updateUserHandleEitherImpl uid update + DeleteUser user -> embed $ deleteUserImpl user + LookupHandle hdl -> embed $ lookupHandleImpl LocalQuorum hdl + GlimpseHandle hdl -> embed $ lookupHandleImpl One hdl + LookupStatus uid -> embed $ lookupStatusImpl uid + IsActivated uid -> embed $ isActivatedImpl uid + LookupLocale uid -> embed $ lookupLocaleImpl uid -getUserImpl :: Member (Embed Client) r => UserId -> Sem r (Maybe StoredUser) +getUserImpl :: (Member (Embed Client) r) => UserId -> Sem r (Maybe StoredUser) getUserImpl uid = embed $ do mUserTuple <- retry x1 $ query1 selectUser (params LocalQuorum (Identity uid)) pure $ asRecord <$> mUserTuple +updateUserImpl :: UserId -> StoredUserUpdate -> Client () +updateUserImpl uid update = + retry x5 $ batch do + -- PERFORMANCE(fisx): if a user changes 4 attributes with one request, the database will + -- be hit with one request for each attribute. this is probably fine, since this + -- operation is not heavily used. (also, the four operations are batched, which may or + -- may not help.) + setType BatchLogged + setConsistency LocalQuorum + for_ update.name \n -> addPrepQuery userDisplayNameUpdate (n, uid) + for_ update.pict \p -> addPrepQuery userPictUpdate (p, uid) + for_ update.assets \a -> addPrepQuery userAssetsUpdate (a, uid) + for_ update.locale \a -> addPrepQuery userLocaleUpdate (a.lLanguage, a.lCountry, uid) + for_ update.accentId \c -> addPrepQuery userAccentIdUpdate (c, uid) + for_ update.supportedProtocols \a -> addPrepQuery userSupportedProtocolsUpdate (a, uid) + +updateUserHandleEitherImpl :: UserId -> StoredUserHandleUpdate -> Client (Either StoredUserUpdateError ()) +updateUserHandleEitherImpl uid update = + runM $ runError do + claimed <- embed $ claimHandleImpl uid update.old update.new + unless claimed $ throw StoredUserUpdateHandleExists + +-- | Claim a new handle for an existing 'User': validate it, and in case of success, assign it +-- to user and mark it as taken. +claimHandleImpl :: UserId -> Maybe Handle -> Handle -> Client Bool +claimHandleImpl uid oldHandle newHandle = + isJust <$> do + owner <- lookupHandleImpl LocalQuorum newHandle + case owner of + Just uid' | uid /= uid' -> pure Nothing + _ -> do + let key = "@" <> fromHandle newHandle + withClaim uid key (30 # Minute) $ + do + -- Record ownership + retry x5 $ write handleInsert (params LocalQuorum (newHandle, uid)) + -- Update profile + result <- updateHandle uid newHandle + -- Free old handle (if it changed) + for_ (mfilter (/= newHandle) oldHandle) $ + freeHandleImpl uid + pure result + where + updateHandle :: UserId -> Handle -> Client () + updateHandle u h = retry x5 $ write userHandleUpdate (params LocalQuorum (h, u)) + +-- | Free a 'Handle', making it available to be claimed again. +freeHandleImpl :: UserId -> Handle -> Client () +freeHandleImpl uid h = do + mbHandleUid <- lookupHandleImpl LocalQuorum h + case mbHandleUid of + Just handleUid | handleUid == uid -> do + retry x5 $ write handleDelete (params LocalQuorum (Identity h)) + let key = "@" <> fromHandle h + deleteClaim uid key (30 # Minute) + _ -> pure () -- this shouldn't happen, the call side should always check that `h` and `uid` belong to the same account. + +-- | Sending an empty 'Handle' here causes C* to throw "Key may not be empty" +-- error. +lookupHandleImpl :: Consistency -> Handle -> Client (Maybe UserId) +lookupHandleImpl consistencyLevel h = do + (runIdentity =<<) + <$> retry x1 (query1 handleSelect (params consistencyLevel (Identity h))) + +deleteUserImpl :: User -> Client () +deleteUserImpl user = do + for_ (userHandle user) \h -> + freeHandleImpl (userId user) h + retry x5 $ + write + updateUserToTombstone + ( params + LocalQuorum + (Deleted, Name "default", defaultAccentId, noPict, [], userId user) + ) + +lookupStatusImpl :: UserId -> Client (Maybe AccountStatus) +lookupStatusImpl u = + (runIdentity =<<) + <$> retry x1 (query1 statusSelect (params LocalQuorum (Identity u))) + +isActivatedImpl :: UserId -> Client Bool +isActivatedImpl uid = + (== Just (Identity True)) + <$> retry x1 (query1 activatedSelect (params LocalQuorum (Identity uid))) + +lookupLocaleImpl :: UserId -> Client (Maybe (Maybe Language, Maybe Country)) +lookupLocaleImpl u = do + retry x1 (query1 localeSelect (params LocalQuorum (Identity u))) + +-------------------------------------------------------------------------------- +-- Queries + selectUser :: PrepQuery R (Identity UserId) (TupleType StoredUser) selectUser = "SELECT id, name, picture, email, phone, sso_id, accent_id, assets, \ \activated, status, expires, language, country, provider, service, \ \handle, team, managed_by, supported_protocols \ \FROM user where id = ?" + +userDisplayNameUpdate :: PrepQuery W (Name, UserId) () +userDisplayNameUpdate = "UPDATE user SET name = ? WHERE id = ?" + +userPictUpdate :: PrepQuery W (Pict, UserId) () +userPictUpdate = "UPDATE user SET picture = ? WHERE id = ?" + +userAssetsUpdate :: PrepQuery W ([Asset], UserId) () +userAssetsUpdate = "UPDATE user SET assets = ? WHERE id = ?" + +userAccentIdUpdate :: PrepQuery W (ColourId, UserId) () +userAccentIdUpdate = "UPDATE user SET accent_id = ? WHERE id = ?" + +userLocaleUpdate :: PrepQuery W (Language, Maybe Country, UserId) () +userLocaleUpdate = "UPDATE user SET language = ?, country = ? WHERE id = ?" + +userSupportedProtocolsUpdate :: PrepQuery W (Imports.Set BaseProtocolTag, UserId) () +userSupportedProtocolsUpdate = "UPDATE user SET supported_protocols = ? WHERE id = ?" + +handleInsert :: PrepQuery W (Handle, UserId) () +handleInsert = "INSERT INTO user_handle (handle, user) VALUES (?, ?)" + +handleSelect :: PrepQuery R (Identity Handle) (Identity (Maybe UserId)) +handleSelect = "SELECT user FROM user_handle WHERE handle = ?" + +handleDelete :: PrepQuery W (Identity Handle) () +handleDelete = "DELETE FROM user_handle WHERE handle = ?" + +userHandleUpdate :: PrepQuery W (Handle, UserId) () +userHandleUpdate = "UPDATE user SET handle = ? WHERE id = ?" + +updateUserToTombstone :: PrepQuery W (AccountStatus, Name, ColourId, Pict, [Asset], UserId) () +updateUserToTombstone = + "UPDATE user SET status = ?, name = ?,\ + \ accent_id = ?, picture = ?, assets = ?, handle = null, country = null,\ + \ language = null, email = null, phone = null, sso_id = null WHERE id = ?" + +statusSelect :: PrepQuery R (Identity UserId) (Identity (Maybe AccountStatus)) +statusSelect = "SELECT status FROM user WHERE id = ?" + +activatedSelect :: PrepQuery R (Identity UserId) (Identity Bool) +activatedSelect = "SELECT activated FROM user WHERE id = ?" + +localeSelect :: PrepQuery R (Identity UserId) (Maybe Language, Maybe Country) +localeSelect = "SELECT language, country FROM user WHERE id = ?" diff --git a/services/brig/src/Brig/Unique.hs b/libs/wire-subsystems/src/Wire/UserStore/Unique.hs similarity index 91% rename from services/brig/src/Brig/Unique.hs rename to libs/wire-subsystems/src/Wire/UserStore/Unique.hs index 58c95630a8a..f6abeddd433 100644 --- a/services/brig/src/Brig/Unique.hs +++ b/libs/wire-subsystems/src/Wire/UserStore/Unique.hs @@ -17,7 +17,7 @@ -- | Temporary exclusive claims on 'Text'ual values which may be subject -- to contention, i.e. where strong guarantees on uniqueness are desired. -module Brig.Unique +module Wire.UserStore.Unique ( withClaim, deleteClaim, lookupClaims, @@ -43,7 +43,6 @@ import Imports -- and is responsible for turning the temporary claim into permanent -- ownership, if desired. withClaim :: - MonadClient m => -- | The 'Id' associated with the claim. Id a -> -- | The value on which to acquire the claim. @@ -51,11 +50,11 @@ withClaim :: -- | The minimum timeout (i.e. duration) of the claim. Timeout -> -- | The computation to run with a successful claim. - IO b -> + Client b -> -- | 'Just b' if the claim was successful and the 'IO' -- computation completed within the given timeout. - m (Maybe b) -withClaim u v t io = do + Client (Maybe b) +withClaim u v t act = do claims <- lookupClaims v case claims of [] -> claim -- Free @@ -68,13 +67,14 @@ withClaim u v t io = do retry x5 $ write upsertQuery $ params LocalQuorum (ttl * 2, C.Set [u], v) claimed <- (== [u]) <$> lookupClaims v if claimed - then liftIO $ timeout (fromIntegral ttl # Second) io + then do + act' <- clientToIO act + liftIO $ timeout (fromIntegral ttl # Second) act' else pure Nothing upsertQuery :: PrepQuery W (Int32, C.Set (Id a), Text) () upsertQuery = "UPDATE unique_claims USING TTL ? SET claims = claims + ? WHERE value = ?" deleteClaim :: - MonadClient m => -- | The 'Id' associated with the claim. Id a -> -- | The value on which to acquire the claim. @@ -84,16 +84,16 @@ deleteClaim :: -- never use), so removing a claim is an update operation on the database. -- Therefore, we reset the TTL the same way we reset it in 'withClaim'.) Timeout -> - m () + Client () deleteClaim u v t = do let ttl = max minTtl (fromIntegral (t #> Second)) retry x5 $ write cql $ params LocalQuorum (ttl * 2, C.Set [u], v) where cql :: PrepQuery W (Int32, C.Set (Id a), Text) () - cql = {- `IF EXISTS`, but that requires benchmarking -} "UPDATE unique_claims USING TTL ? SET claims = claims - ? WHERE value = ?" + cql = "UPDATE unique_claims USING TTL ? SET claims = claims - ? WHERE value = ?" -- | Lookup the current claims on a value. -lookupClaims :: MonadClient m => Text -> m [Id a] +lookupClaims :: (MonadClient m) => Text -> m [Id a] lookupClaims v = fmap (maybe [] (fromSet . runIdentity)) $ retry x1 $ @@ -103,6 +103,11 @@ lookupClaims v = cql :: PrepQuery R (Identity Text) (Identity (C.Set (Id a))) cql = "SELECT claims FROM unique_claims WHERE value = ?" +clientToIO :: Client a -> Client (IO a) +clientToIO act = do + s <- ask + pure $ runClient s act + minTtl :: Int32 minTtl = 60 -- Seconds diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem.hs b/libs/wire-subsystems/src/Wire/UserSubsystem.hs index ae344ec3361..16f53f23f1d 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem.hs @@ -2,28 +2,92 @@ module Wire.UserSubsystem where +import Data.Default +import Data.Handle (Handle) import Data.Id import Data.Qualified import Imports import Polysemy import Wire.API.Federation.Error import Wire.API.User +import Wire.Arbitrary +import Wire.UserKeyStore + +-- | Who is performing this update operation? (Single source of truth: users managed by SCIM +-- can't be updated by clients and vice versa.) +data UpdateOriginType + = -- | Call originates from the SCIM api in spar. + UpdateOriginScim + | -- | Call originates from wire client (mobile, web, or team-management). + UpdateOriginWireClient + deriving (Show, Eq, Ord, Generic) + deriving (Arbitrary) via GenericUniform UpdateOriginType + +-- | Simple updates (as opposed to, eg., handle, where we need to manage locks). +-- +-- This is isomorphic to 'StoredUserUpdate', but we keep the two types separate because they +-- belong to different abstractions / levels (UserSubsystem vs. UserStore), and they may +-- change independently in the future ('UserStoreUpdate' may grow more fields for other +-- operations). +data UserProfileUpdate = MkUserProfileUpdate + { name :: Maybe Name, + pict :: Maybe Pict, -- DEPRECATED + assets :: Maybe [Asset], + accentId :: Maybe ColourId, + locale :: Maybe Locale, + supportedProtocols :: Maybe (Set BaseProtocolTag) + } + deriving stock (Eq, Ord, Show, Generic) + deriving (Arbitrary) via GenericUniform UserProfileUpdate + +instance Default UserProfileUpdate where + def = + MkUserProfileUpdate + { name = Nothing, + pict = Nothing, -- DEPRECATED + assets = Nothing, + accentId = Nothing, + locale = Nothing, + supportedProtocols = Nothing + } data UserSubsystem m a where -- | First arg is for authorization only. GetUserProfiles :: Local UserId -> [Qualified UserId] -> UserSubsystem m [UserProfile] -- | Sometimes we don't have any identity of a requesting user, and local profiles are public. GetLocalUserProfiles :: Local [UserId] -> UserSubsystem m [UserProfile] + -- | Self profile contains things not present in Profile. + GetSelfProfile :: Local UserId -> UserSubsystem m (Maybe SelfProfile) -- | These give us partial success and hide concurrency in the interpreter. -- FUTUREWORK: it would be better to return errors as `Map Domain FederationError`, but would clients like that? GetUserProfilesWithErrors :: Local UserId -> [Qualified UserId] -> UserSubsystem m ([(Qualified UserId, FederationError)], [UserProfile]) + -- | Simple updates (as opposed to, eg., handle, where we need to manage locks). Empty fields are ignored (not deleted). + UpdateUserProfile :: Local UserId -> Maybe ConnId -> UpdateOriginType -> UserProfileUpdate -> UserSubsystem m () + -- | parse and lookup a handle, return what the operation has found + CheckHandle :: Text {- use Handle here? -} -> UserSubsystem m CheckHandleResp + -- | checks a number of 'Handle's for availability and returns at most 'Word' amount of them + CheckHandles :: [Handle] -> Word -> UserSubsystem m [Handle] + -- | parses a handle, this may fail so it's effectful + UpdateHandle :: Local UserId -> Maybe ConnId -> UpdateOriginType -> Text {- use Handle here? -} -> UserSubsystem m () + GetLocalUserAccountByUserKey :: Local EmailKey -> UserSubsystem m (Maybe UserAccount) + -- | returns the user's locale or the default locale if the users exists + LookupLocaleWithDefault :: Local UserId -> UserSubsystem m (Maybe Locale) + +-- | the return type of 'CheckHandle' +data CheckHandleResp + = CheckHandleFound + | CheckHandleNotFound + deriving stock (Eq, Ord, Show) makeSem ''UserSubsystem -getUserProfile :: Member UserSubsystem r => Local UserId -> Qualified UserId -> Sem r (Maybe UserProfile) +getUserProfile :: (Member UserSubsystem r) => Local UserId -> Qualified UserId -> Sem r (Maybe UserProfile) getUserProfile luid targetUser = listToMaybe <$> getUserProfiles luid [targetUser] -getLocalUserProfile :: Member UserSubsystem r => Local UserId -> Sem r (Maybe UserProfile) +getLocalUserProfile :: (Member UserSubsystem r) => Local UserId -> Sem r (Maybe UserProfile) getLocalUserProfile targetUser = listToMaybe <$> getLocalUserProfiles ((: []) <$> targetUser) + +updateSupportedProtocols :: (Member UserSubsystem r) => Local UserId -> UpdateOriginType -> Set BaseProtocolTag -> Sem r () +updateSupportedProtocols uid mb prots = updateUserProfile uid Nothing mb (def {supportedProtocols = Just prots}) diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Error.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Error.hs new file mode 100644 index 00000000000..40006412b47 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Error.hs @@ -0,0 +1,32 @@ +module Wire.UserSubsystem.Error where + +import Imports +import Wire.API.Error +import Wire.API.Error.Brig qualified as E +import Wire.Error + +-- | All errors that are thrown by the user subsystem are subsumed under this sum type. +data UserSubsystemError + = -- | user is managed by scim or e2ei is enabled + -- FUTUREWORK(mangoiv): the name should probably resemble that + UserSubsystemDisplayNameManagedByScim + | UserSubsystemHandleManagedByScim + | UserSubsystemLocaleManagedByScim + | UserSubsystemNoIdentity + | UserSubsystemHandleExists + | UserSubsystemInvalidHandle + | UserSubsystemProfileNotFound + deriving (Eq, Show) + +userSubsystemErrorToHttpError :: UserSubsystemError -> HttpError +userSubsystemErrorToHttpError = + StdError . \case + UserSubsystemProfileNotFound -> errorToWai @E.UserNotFound + UserSubsystemDisplayNameManagedByScim -> errorToWai @E.NameManagedByScim + UserSubsystemLocaleManagedByScim -> errorToWai @E.LocaleManagedByScim + UserSubsystemNoIdentity -> errorToWai @E.NoIdentity + UserSubsystemHandleExists -> errorToWai @E.HandleExists + UserSubsystemInvalidHandle -> errorToWai @E.InvalidHandle + UserSubsystemHandleManagedByScim -> errorToWai @E.HandleManagedByScim + +instance Exception UserSubsystemError diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/HandleBlacklist.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/HandleBlacklist.hs new file mode 100644 index 00000000000..c4878f685ec --- /dev/null +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/HandleBlacklist.hs @@ -0,0 +1,56 @@ +module Wire.UserSubsystem.HandleBlacklist + ( isBlacklistedHandle, + ) +where + +import Control.Exception (assert) +import Data.Handle (Handle, parseHandle) +import Data.HashSet qualified as HashSet +import Imports + +-- | A blacklisted handle cannot be chosen by a (regular) user. +isBlacklistedHandle :: Handle -> Bool +isBlacklistedHandle = (`HashSet.member` blacklist) + +blacklist :: HashSet Handle +blacklist = assert good (HashSet.fromList (fromJust <$> parsed)) + where + good = all isJust parsed + parsed = parseHandle <$> raw + raw = + [ "account", + "admin", + "administrator", + "all", + "android", + "anna", + "avs", + "backend", + "bot", + "cs", + "design", + "dev", + "developer", + "development", + "everyone", + "help", + "helpdesk", + "hr", + "info", + "ios", + "legal", + "management", + "news", + "otto", + "payment", + "product", + "purchase", + "qa", + "support", + "team", + "user", + "web", + "wire", + "wirebot", + "wireteam" + ] diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs index 948d4689b24..945f128e700 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE RecordWildCards #-} + module Wire.UserSubsystem.Interpreter ( runUserSubsystem, UserSubsystemConfig (..), @@ -7,6 +9,8 @@ where import Control.Lens (view) import Control.Monad.Trans.Maybe import Data.Either.Extra +import Data.Handle (Handle) +import Data.Handle qualified as Handle import Data.Id import Data.Json.Util import Data.LegalHold @@ -19,8 +23,11 @@ import Polysemy.Input import Servant.Client.Core import Wire.API.Federation.API import Wire.API.Federation.Error -import Wire.API.Team.Member +import Wire.API.Team.Feature +import Wire.API.Team.Member hiding (userId) import Wire.API.User +import Wire.API.UserEvent +import Wire.Arbitrary import Wire.DeleteQueue import Wire.FederationAPIAccess import Wire.GalleyAPIAccess @@ -28,21 +35,32 @@ import Wire.Sem.Concurrency import Wire.Sem.Now (Now) import Wire.Sem.Now qualified as Now import Wire.StoredUser -import Wire.UserStore -import Wire.UserSubsystem (UserSubsystem (..)) +import Wire.UserEvents +import Wire.UserKeyStore +import Wire.UserStore as UserStore +import Wire.UserSubsystem +import Wire.UserSubsystem.Error +import Wire.UserSubsystem.HandleBlacklist data UserSubsystemConfig = UserSubsystemConfig { emailVisibilityConfig :: EmailVisibilityConfig, defaultLocale :: Locale } + deriving (Show) + +instance Arbitrary UserSubsystemConfig where + arbitrary = UserSubsystemConfig <$> arbitrary <*> arbitrary runUserSubsystem :: ( Member GalleyAPIAccess r, Member UserStore r, + Member UserKeyStore r, Member (Concurrency 'Unsafe) r, -- FUTUREWORK: subsystems should implement concurrency inside interpreters, not depend on this dangerous effect. Member (Error FederationError) r, + Member (Error UserSubsystemError) r, Member (FederationAPIAccess fedM) r, Member DeleteQueue r, + Member UserEvents r, Member Now r, RunClient (fedM 'Brig), FederationMonad fedM, @@ -50,10 +68,42 @@ runUserSubsystem :: ) => UserSubsystemConfig -> InterpreterFor UserSubsystem r -runUserSubsystem cfg = interpret $ \case - GetUserProfiles self others -> runInputConst cfg $ getUserProfilesImpl self others - GetLocalUserProfiles others -> runInputConst cfg $ getLocalUserProfilesImpl others - GetUserProfilesWithErrors self others -> runInputConst cfg $ getUserProfilesWithErrorsImpl self others +runUserSubsystem cfg = runInputConst cfg . interpretUserSubsystem . raiseUnder + +interpretUserSubsystem :: + ( Member GalleyAPIAccess r, + Member UserStore r, + Member UserKeyStore r, + Member (Concurrency 'Unsafe) r, + Member (Error FederationError) r, + Member (Error UserSubsystemError) r, + Member (FederationAPIAccess fedM) r, + Member (Input UserSubsystemConfig) r, + Member DeleteQueue r, + Member UserEvents r, + Member Now r, + RunClient (fedM 'Brig), + FederationMonad fedM, + Typeable fedM + ) => + InterpreterFor UserSubsystem r +interpretUserSubsystem = interpret \case + GetUserProfiles self others -> getUserProfilesImpl self others + GetLocalUserProfiles others -> getLocalUserProfilesImpl others + GetSelfProfile self -> getSelfProfileImpl self + GetUserProfilesWithErrors self others -> getUserProfilesWithErrorsImpl self others + UpdateUserProfile self mconn mb update -> updateUserProfileImpl self mconn mb update + CheckHandle uhandle -> checkHandleImpl uhandle + CheckHandles hdls cnt -> checkHandlesImpl hdls cnt + UpdateHandle uid mconn mb uhandle -> updateHandleImpl uid mconn mb uhandle + GetLocalUserAccountByUserKey userKey -> getLocalUserAccountByUserKeyImpl userKey + LookupLocaleWithDefault luid -> lookupLocaleOrDefaultImpl luid + +lookupLocaleOrDefaultImpl :: (Member UserStore r, Member (Input UserSubsystemConfig) r) => Local UserId -> Sem r (Maybe Locale) +lookupLocaleOrDefaultImpl luid = do + mLangCountry <- UserStore.lookupLocale (tUnqualified luid) + defLocale <- inputs defaultLocale + pure (toLocale defLocale <$> mLangCountry) -- | Obtain user profiles for a list of users as they can be seen by -- a given user 'self'. If 'self' is an unknown 'UserId', return '[]'. @@ -149,7 +199,7 @@ getUserProfilesLocalPart requestingUser luids = do <$> traverse getRequestingUserInfo requestingUser -- FUTUREWORK: (in the interpreters where it makes sense) pull paginated lists from the DB, -- not just single rows. - catMaybes <$> traverse (getLocalUserProfile emailVisibilityConfigWithViewer) (sequence luids) + catMaybes <$> traverse (getLocalUserProfileImpl emailVisibilityConfigWithViewer) (sequence luids) where getRequestingUserInfo :: Local UserId -> Sem r (Maybe (TeamId, TeamMember)) getRequestingUserInfo self = do @@ -165,7 +215,7 @@ getUserProfilesLocalPart requestingUser luids = do Nothing -> pure Nothing Just tid -> (tid,) <$$> getTeamMember (tUnqualified self) tid -getLocalUserProfile :: +getLocalUserProfileImpl :: forall r. ( Member UserStore r, Member GalleyAPIAccess r, @@ -176,7 +226,7 @@ getLocalUserProfile :: EmailVisibilityConfigWithViewer -> Local UserId -> Sem r (Maybe UserProfile) -getLocalUserProfile emailVisibilityConfigWithViewer luid = do +getLocalUserProfileImpl emailVisibilityConfigWithViewer luid = do let domain = tDomain luid locale <- inputs defaultLocale runMaybeT $ do @@ -190,6 +240,35 @@ getLocalUserProfile emailVisibilityConfigWithViewer luid = do lift $ deleteLocalIfExpired user pure usrProfile +getSelfProfileImpl :: + ( Member (Input UserSubsystemConfig) r, + Member UserStore r, + Member GalleyAPIAccess r + ) => + Local UserId -> + Sem r (Maybe SelfProfile) +getSelfProfileImpl self = do + defLocale <- inputs defaultLocale + mStoredUser <- getUser (tUnqualified self) + mHackedUser <- traverse hackForBlockingHandleChangeForE2EIdTeams mStoredUser + let mUser = mkUserFromStored (tDomain self) defLocale <$> mHackedUser + pure (SelfProfile <$> mUser) + where + -- \| This is a hack! + -- + -- Background: + -- - https://wearezeta.atlassian.net/browse/WPB-6189. + -- - comments in `testUpdateHandle` in `/integration`. + -- + -- FUTUREWORK: figure out a better way for clients to detect E2EId (V6?) + hackForBlockingHandleChangeForE2EIdTeams :: (Member GalleyAPIAccess r) => StoredUser -> Sem r StoredUser + hackForBlockingHandleChangeForE2EIdTeams user = do + e2eid <- hasE2EId user + pure $ + if e2eid && isJust user.handle + then user {managedBy = Just ManagedByScim} + else user + -- | ephemeral users past their expiry date are queued for deletion deleteLocalIfExpired :: forall r. (Member DeleteQueue r, Member Now r) => User -> Sem r () deleteLocalIfExpired user = @@ -238,3 +317,161 @@ getUserProfilesWithErrorsImpl self others = do renderBucketError :: (FederationError, Qualified [UserId]) -> [(Qualified UserId, FederationError)] renderBucketError (err, qlist) = (,err) . (flip Qualified (qDomain qlist)) <$> qUnqualified qlist + +-- | Some fields cannot be overwritten by clients for scim-managed users; some others if e2eid +-- is used. If a client attempts to overwrite any of these, throw `UserSubsystem*ManagedByScim`. +guardLockedFields :: + ( Member (Error UserSubsystemError) r, + Member GalleyAPIAccess r + ) => + StoredUser -> + UpdateOriginType -> + UserProfileUpdate -> + Sem r () +guardLockedFields user updateOrigin (MkUserProfileUpdate {..}) = do + let idempName = isNothing name || name == Just user.name + idempLocale = isNothing locale || locale == user.locale + scim = updateOrigin == UpdateOriginWireClient && user.managedBy == Just ManagedByScim + e2eid <- hasE2EId user + when ((scim || e2eid) && not idempName) do + throw UserSubsystemDisplayNameManagedByScim + when (scim {- e2eid does not matter, it's not part of the e2eid cert! -} && not idempLocale) do + throw UserSubsystemLocaleManagedByScim + +guardLockedHandleField :: + ( Member GalleyAPIAccess r, + Member (Error UserSubsystemError) r + ) => + StoredUser -> + UpdateOriginType -> + Handle -> + Sem r () +guardLockedHandleField user updateOrigin handle = do + let idemp = Just handle == user.handle + scim = updateOrigin == UpdateOriginWireClient && user.managedBy == Just ManagedByScim + hasHandle = isJust user.handle + e2eid <- hasE2EId user + when ((scim || (e2eid && hasHandle)) && not idemp) do + throw UserSubsystemHandleManagedByScim + +updateUserProfileImpl :: + ( Member UserStore r, + Member (Error UserSubsystemError) r, + Member UserEvents r, + Member GalleyAPIAccess r + ) => + Local UserId -> + Maybe ConnId -> + UpdateOriginType -> + UserProfileUpdate -> + Sem r () +updateUserProfileImpl (tUnqualified -> uid) mconn updateOrigin update = do + user <- getUser uid >>= note UserSubsystemProfileNotFound + guardLockedFields user updateOrigin update + mapError (\StoredUserUpdateHandleExists -> UserSubsystemHandleExists) $ + updateUser uid (storedUserUpdate update) + generateUserEvent uid mconn (mkProfileUpdateEvent uid update) + +storedUserUpdate :: UserProfileUpdate -> StoredUserUpdate +storedUserUpdate update = + MkStoredUserUpdate + { name = update.name, + pict = update.pict, + assets = update.assets, + accentId = update.accentId, + locale = update.locale, + supportedProtocols = update.supportedProtocols + } + +mkProfileUpdateEvent :: UserId -> UserProfileUpdate -> UserEvent +mkProfileUpdateEvent uid update = + UserUpdated $ + (emptyUserUpdatedData uid) + { eupName = update.name, + eupPict = update.pict, + eupAccentId = update.accentId, + eupAssets = update.assets, + eupLocale = update.locale, + eupSupportedProtocols = update.supportedProtocols + } + +mkProfileUpdateHandleEvent :: UserId -> Handle -> UserEvent +mkProfileUpdateHandleEvent uid handle = + UserUpdated $ (emptyUserUpdatedData uid) {eupHandle = Just handle} + +getLocalUserAccountByUserKeyImpl :: + ( Member UserStore r, + Member UserKeyStore r, + Member (Input UserSubsystemConfig) r + ) => + Local EmailKey -> + Sem r (Maybe UserAccount) +getLocalUserAccountByUserKeyImpl target = runMaybeT $ do + config <- lift input + uid <- MaybeT $ lookupKey (tUnqualified target) + user <- MaybeT $ getUser uid + pure $ mkAccountFromStored (tDomain target) config.defaultLocale user + +-------------------------------------------------------------------------------- +-- Update Handle + +updateHandleImpl :: + ( Member (Error UserSubsystemError) r, + Member GalleyAPIAccess r, + Member UserEvents r, + Member UserStore r + ) => + Local UserId -> + Maybe ConnId -> + UpdateOriginType -> + Text -> + Sem r () +updateHandleImpl (tUnqualified -> uid) mconn updateOrigin uhandle = do + newHandle :: Handle <- note UserSubsystemInvalidHandle $ Handle.parseHandle uhandle + when (isBlacklistedHandle newHandle) $ + throw UserSubsystemInvalidHandle + user <- getUser uid >>= note UserSubsystemNoIdentity + guardLockedHandleField user updateOrigin newHandle + when (isNothing user.identity) $ + throw UserSubsystemNoIdentity + mapError (\StoredUserUpdateHandleExists -> UserSubsystemHandleExists) $ + UserStore.updateUserHandle uid (MkStoredUserHandleUpdate user.handle newHandle) + generateUserEvent uid mconn (mkProfileUpdateHandleEvent uid newHandle) + +checkHandleImpl :: (Member (Error UserSubsystemError) r, Member UserStore r) => Text -> Sem r CheckHandleResp +checkHandleImpl uhandle = do + xhandle :: Handle <- Handle.parseHandle uhandle & maybe (throw UserSubsystemInvalidHandle) pure + when (isBlacklistedHandle xhandle) $ + throw UserSubsystemInvalidHandle + owner <- lookupHandle xhandle + if isJust owner + then -- Handle is taken (=> getHandleInfo will return 200) + pure CheckHandleFound + else -- Handle is free and can be taken + pure CheckHandleNotFound + +hasE2EId :: (Member GalleyAPIAccess r) => StoredUser -> Sem r Bool +hasE2EId user = + wsStatus . afcMlsE2EId + <$> getAllFeatureConfigsForUser (Just user.id) <&> \case + FeatureStatusEnabled -> True + FeatureStatusDisabled -> False + +-------------------------------------------------------------------------------- +-- Check Handles + +-- | checks for handles @check@ to be available and returns +-- at maximum @num@ of them +checkHandlesImpl :: (Member UserStore r) => [Handle] -> Word -> Sem r [Handle] +checkHandlesImpl check num = reverse <$> collectFree [] check num + where + collectFree free _ 0 = pure free + collectFree free [] _ = pure free + collectFree free (h : hs) n = + if isBlacklistedHandle h + then collectFree free hs n + else do + owner <- glimpseHandle h + case owner of + Nothing -> collectFree (h : free) hs (n - 1) + Just _ -> collectFree free hs n diff --git a/libs/wire-subsystems/src/Wire/VerificationCode.hs b/libs/wire-subsystems/src/Wire/VerificationCode.hs new file mode 100644 index 00000000000..1caea31049d --- /dev/null +++ b/libs/wire-subsystems/src/Wire/VerificationCode.hs @@ -0,0 +1,116 @@ +module Wire.VerificationCode + ( Code (..), + Key (..), + Scope (..), + Value (..), + KeyValuePair (..), + Timeout (..), + Retries (..), + codeToKeyValuePair, + scopeFromAction, + ) +where + +import Cassandra hiding (Value) +import Data.Code +import Data.UUID (UUID) +import Imports hiding (lookup) +import Wire.API.User qualified as User +import Wire.API.User.Identity +import Wire.Arbitrary + +-- Note [Unique keys] +-- +-- We want unique, stable keys that we can associate the secret values with. +-- Using the plain natural identifiers (e.g. e-mail addresses or phone numbers) +-- has a few downsides: +-- +-- * The keys are often placed in URLs for verification purposes, +-- giving them unnecessary exposure. +-- * If the keys are not opaque, it can be harder to change their +-- structure, possibly embedding additional information. +-- * Since the keys are often placed in URLs, they must only contain +-- URL-safe characters or otherwise require appropriate encoding. +-- +-- Therefore we use the following simple construction: +-- +-- * Compute the SHA-256 truncated to 120 bits of the plain, normalised, +-- utf8-encoded natural identifier (i.e. e-mail address or phone number). +-- * Apply URL-safe base64 encoding to yield the final key of length 20. +-- +-- Truncation of SHA-2 outputs is a safe and common practice, only reducing +-- collision resistance (e.g. after 2^60 for truncated SHA-256/120 due to the +-- birthday paradox). Collisions have no security implications in this context; +-- at most it enables verification of one random e-mail address or phone +-- number via another, at least one of which must be accessible. It is only +-- important that keys be sufficiently unique and random collisions rare +-- while keeping the length reasonably short, so that keys may be used in +-- length-constrained contexts (e.g. SMS) or even be spelled out or typed. + +-------------------------------------------------------------------------------- +-- Code + +data Code = Code + { codeKey :: !Key, + codeScope :: !Scope, + codeValue :: !Value, + -- | This field is actually used as number of allowed "tries" rather than + -- "retries", so if a code has a retries = 1, verification can only be tried + -- once, and it cannot actually be "re"-tried after that. + codeRetries :: !Retries, + codeTTL :: !Timeout, + codeFor :: !Email, + codeAccount :: !(Maybe UUID) + } + deriving (Eq, Show) + +scopeFromAction :: User.VerificationAction -> Scope +scopeFromAction = \case + User.CreateScimToken -> CreateScimToken + User.Login -> AccountLogin + User.DeleteTeam -> DeleteTeam + +codeToKeyValuePair :: Code -> KeyValuePair +codeToKeyValuePair code = KeyValuePair code.codeKey code.codeValue + +-- | The same 'Key' can exist with different 'Value's in different +-- 'Scope's at the same time. +data Scope + = AccountDeletion + | IdentityVerification + | PasswordReset + | AccountLogin + | AccountApproval + | CreateScimToken + | DeleteTeam + deriving (Eq, Show, Ord, Generic) + deriving (Arbitrary) via GenericUniform Scope + +instance Cql Scope where + ctype = Tagged IntColumn + + toCql AccountDeletion = CqlInt 1 + toCql IdentityVerification = CqlInt 2 + toCql PasswordReset = CqlInt 3 + toCql AccountLogin = CqlInt 4 + toCql AccountApproval = CqlInt 5 + toCql CreateScimToken = CqlInt 6 + toCql DeleteTeam = CqlInt 7 + + fromCql (CqlInt 1) = pure AccountDeletion + fromCql (CqlInt 2) = pure IdentityVerification + fromCql (CqlInt 3) = pure PasswordReset + fromCql (CqlInt 4) = pure AccountLogin + fromCql (CqlInt 5) = pure AccountApproval + fromCql (CqlInt 6) = pure CreateScimToken + fromCql (CqlInt 7) = pure DeleteTeam + fromCql _ = Left "fromCql: Scope: int expected" + +newtype Retries = Retries {numRetries :: Word8} + deriving (Eq, Show, Ord, Num, Integral, Enum, Real, Arbitrary) + +instance Cql Retries where + ctype = Tagged IntColumn + toCql = CqlInt . fromIntegral . numRetries + fromCql (CqlInt n) = pure (Retries (fromIntegral n)) + fromCql _ = Left "fromCql: Retries: int expected" diff --git a/libs/wire-subsystems/src/Wire/VerificationCodeGen.hs b/libs/wire-subsystems/src/Wire/VerificationCodeGen.hs new file mode 100644 index 00000000000..7290a0fbae4 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/VerificationCodeGen.hs @@ -0,0 +1,110 @@ +module Wire.VerificationCodeGen + ( VerificationCodeGen (genKey), + mkVerificationCodeGen, + mk6DigitVerificationCodeGen, + mkKey, + generateVerificationCode, + ) +where + +import Crypto.Hash +import Data.ByteArray qualified as BA +import Data.ByteString qualified as BS +import Data.Code +import Data.Range +import Data.Text qualified as Text +import Data.Text.Ascii qualified as Ascii +import Data.Text.Encoding qualified as Text +import Data.UUID (UUID) +import Imports hiding (lookup) +import Polysemy +import Text.Printf +import Wire.API.User.Identity +import Wire.Arbitrary +import Wire.Sem.Random +import Wire.Sem.Random qualified as Random +import Wire.UserKeyStore +import Wire.VerificationCode + +-------------------------------------------------------------------------------- +-- VerificationCodeGeneration + +data RandomValueType + = Random6DigitNumber + | Random15Bytes + deriving (Show, Eq, Generic) + deriving (Arbitrary) via GenericUniform RandomValueType + +-- | A contextual string that is hashed into the key to yield distinct keys in +-- different contexts for the same email address. +-- TODO: newtype KeyContext = KeyContext ByteString +data VerificationCodeGen = VerificationCodeGen + { genFor :: !Email, + genKey :: !Key, -- Note [Unique keys] + genValueType :: !RandomValueType + } + deriving (Show, Eq, Generic) + deriving (Arbitrary) via GenericUniform VerificationCodeGen + +-- | Initialise a 'Code' 'VerificationCodeGen'erator for a given natural key. +-- This generates a link for emails and a 6-digit code for phone. See also: +-- `mk6DigitVerificationCodeGen`. +mkVerificationCodeGen :: Email -> VerificationCodeGen +mkVerificationCodeGen email = + VerificationCodeGen email (mkKey email) Random15Bytes + +-- | Initialise a 'Code' 'VerificationCodeGen'erator for a given natural key. +-- This generates a 6-digit code, matter whether it is sent to a phone or to an +-- email address. See also: `mkVerificationCodeGen`. +mk6DigitVerificationCodeGen :: Email -> VerificationCodeGen +mk6DigitVerificationCodeGen email = VerificationCodeGen email (mkKey email) Random6DigitNumber + +mkKey :: Email -> Key +mkKey email = + Key + . unsafeRange + . Ascii.encodeBase64Url + . BS.take 15 + . BA.convert + . hash @_ @SHA256 + . Text.encodeUtf8 + . emailKeyUniq + $ mkEmailKey email + +-- | VerificationCodeGenerate a new 'Code'. +generateVerificationCode :: + (Member Random r) => + -- | The 'VerificationCodeGen'erator to use. + VerificationCodeGen -> + -- | The scope of the generated code. + Scope -> + -- | Maximum verification attempts. + Retries -> + -- | Time-to-live in seconds. + Timeout -> + -- | Associated account ID. + Maybe UUID -> + Sem r Code +generateVerificationCode gen scope retries ttl account = do + let key = genKey gen + val <- genValue gen.genValueType + pure $ mkCode key val + where + mkCode key val = + Code + { codeKey = key, + codeValue = val, + codeScope = scope, + codeRetries = retries, + codeTTL = ttl, + codeFor = genFor gen, + codeAccount = account + } + +genValue :: (Member Random r) => RandomValueType -> Sem r Value +genValue Random15Bytes = + Value . unsafeRange . Ascii.encodeBase64Url + <$> Random.bytes 15 +genValue Random6DigitNumber = + Value . unsafeRange . Ascii.unsafeFromText . Text.pack . printf "%06d" + <$> Random.nDigitNumber 6 diff --git a/libs/wire-subsystems/src/Wire/VerificationCodeStore.hs b/libs/wire-subsystems/src/Wire/VerificationCodeStore.hs new file mode 100644 index 00000000000..335c1f370ff --- /dev/null +++ b/libs/wire-subsystems/src/Wire/VerificationCodeStore.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Wire.VerificationCodeStore where + +import Data.RetryAfter +import Imports +import Polysemy +import Wire.VerificationCode + +data VerificationCodeStore m a where + InsertCode :: Code -> VerificationCodeStore m () + LookupCode :: Key -> Scope -> VerificationCodeStore m (Maybe Code) + DeleteCode :: Key -> Scope -> VerificationCodeStore m () + InsertThrottle :: Key -> Scope -> Word -> VerificationCodeStore m () + LookupThrottle :: Key -> Scope -> VerificationCodeStore m (Maybe RetryAfter) + +makeSem ''VerificationCodeStore diff --git a/libs/wire-subsystems/src/Wire/VerificationCodeStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/VerificationCodeStore/Cassandra.hs new file mode 100644 index 00000000000..e2e013ec62d --- /dev/null +++ b/libs/wire-subsystems/src/Wire/VerificationCodeStore/Cassandra.hs @@ -0,0 +1,83 @@ +module Wire.VerificationCodeStore.Cassandra where + +import Cassandra hiding (Value) +import Data.RetryAfter +import Data.UUID +import Imports +import Polysemy +import Polysemy.Embed +import Wire.API.User.Identity +import Wire.VerificationCode +import Wire.VerificationCodeStore + +interpretVerificationCodeStoreCassandra :: (Member (Embed IO) r) => ClientState -> InterpreterFor VerificationCodeStore r +interpretVerificationCodeStoreCassandra casClient = + interpret $ + runEmbedded (runClient casClient) . \case + InsertCode code -> embed $ insertCodeImpl code + LookupCode key scope -> embed $ lookupCodeImpl key scope + DeleteCode key scope -> embed $ deleteCodeImpl key scope + InsertThrottle key scope ttl -> embed $ insertThrottleImpl key scope ttl + LookupThrottle key scope -> embed $ lookupThrottleImpl key scope + +insertCodeImpl :: (MonadClient m) => Code -> m () +insertCodeImpl c = do + let k = codeKey c + let s = codeScope c + let v = codeValue c + let r = fromIntegral (codeRetries c) + let a = codeAccount c + let e = codeFor c + let t = round (codeTTL c) + retry x5 (write cql (params LocalQuorum (k, s, v, r, e, a, t))) + where + cql :: PrepQuery W (Key, Scope, Value, Retries, Email, Maybe UUID, Int32) () + cql = + "INSERT INTO vcodes (key, scope, value, retries, email, account) \ + \VALUES (?, ?, ?, ?, ?, ?) USING TTL ?" + +-- | Lookup a pending code. +lookupCodeImpl :: (MonadClient m) => Key -> Scope -> m (Maybe Code) +lookupCodeImpl k s = toCode <$$> retry x1 (query1 cql (params LocalQuorum (k, s))) + where + cql :: PrepQuery R (Key, Scope) (Value, Int32, Retries, Email, Maybe UUID) + cql = + "SELECT value, ttl(value), retries, email, account \ + \FROM vcodes WHERE key = ? AND scope = ?" + + toCode :: (Value, Int32, Retries, Email, Maybe UUID) -> Code + toCode (val, ttl, retries, email, account) = + Code + { codeKey = k, + codeScope = s, + codeValue = val, + codeTTL = Timeout (fromIntegral ttl), + codeRetries = retries, + codeFor = email, + codeAccount = account + } + +-- | Delete a code associated with the given key and scope. +deleteCodeImpl :: (MonadClient m) => Key -> Scope -> m () +deleteCodeImpl k s = retry x5 $ write cql (params LocalQuorum (k, s)) + where + cql :: PrepQuery W (Key, Scope) () + cql = "DELETE FROM vcodes WHERE key = ? AND scope = ?" + +lookupThrottleImpl :: (MonadClient m) => Key -> Scope -> m (Maybe RetryAfter) +lookupThrottleImpl 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 = ?" + +insertThrottleImpl :: (MonadClient m) => Key -> Scope -> Word -> m () +insertThrottleImpl k s t = do + 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 ?" diff --git a/libs/wire-subsystems/src/Wire/VerificationCodeSubsystem.hs b/libs/wire-subsystems/src/Wire/VerificationCodeSubsystem.hs new file mode 100644 index 00000000000..bfca9135e15 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/VerificationCodeSubsystem.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Wire.VerificationCodeSubsystem where + +import Data.ByteString.Conversion +import Data.Code +import Data.RetryAfter +import Data.UUID (UUID) +import Imports hiding (lookup) +import Polysemy +import Wire.API.Error +import Wire.API.Error.Brig qualified as E +import Wire.Error +import Wire.VerificationCode +import Wire.VerificationCodeGen + +data VerificationCodeSubsystemError + = VerificationCodeThrottled RetryAfter + deriving (Show, Eq) + +verificationCodeSubsystemErrorToHttpError :: VerificationCodeSubsystemError -> HttpError +verificationCodeSubsystemErrorToHttpError = \case + VerificationCodeThrottled t -> + RichError + (errorToWai @E.VerificationCodeThrottled) + () + [("Retry-After", toByteString' (retryAfterSeconds t))] + +newtype CodeAlreadyExists = CodeAlreadyExists Code + deriving (Show, Eq) + +data VerificationCodeSubsystem m a where + CreateCode :: + -- | The 'Gen'erator to use. + VerificationCodeGen -> + -- | The scope of the generated code. + Scope -> + -- | Maximum verification attempts. + Retries -> + -- | Time-to-live in seconds. + Timeout -> + -- | Associated account ID. + Maybe UUID -> + VerificationCodeSubsystem m (Either CodeAlreadyExists Code) + CreateCodeOverwritePrevious :: + -- | The 'Gen'erator to use. + VerificationCodeGen -> + -- | The scope of the generated code. + Scope -> + -- | Maximum verification attempts. + Retries -> + -- | Time-to-live in seconds. + Timeout -> + -- | Associated account ID. + Maybe UUID -> + VerificationCodeSubsystem m Code + -- Returns the 'Code' iff verification suceeds. + VerifyCode :: Key -> Scope -> Value -> VerificationCodeSubsystem m (Maybe Code) + DeleteCode :: Key -> Scope -> VerificationCodeSubsystem m () + -- For internal endpoints + InternalLookupCode :: Key -> Scope -> VerificationCodeSubsystem m (Maybe Code) + +makeSem ''VerificationCodeSubsystem diff --git a/libs/wire-subsystems/src/Wire/VerificationCodeSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/VerificationCodeSubsystem/Interpreter.hs new file mode 100644 index 00000000000..156be1cbd90 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/VerificationCodeSubsystem/Interpreter.hs @@ -0,0 +1,89 @@ +module Wire.VerificationCodeSubsystem.Interpreter where + +import Data.Code +import Data.RetryAfter (RetryAfter) +import Data.UUID +import Imports +import Polysemy +import Polysemy.Error +import Polysemy.Input +import Wire.Arbitrary +import Wire.Sem.Random +import Wire.VerificationCode +import Wire.VerificationCodeGen +import Wire.VerificationCodeStore as Store hiding (DeleteCode) +import Wire.VerificationCodeSubsystem + +interpretVerificationCodeSubsystem :: + ( Member VerificationCodeStore r, + Member Random r, + Member (Error VerificationCodeSubsystemError) r, + Member (Input VerificationCodeThrottleTTL) r + ) => + InterpreterFor VerificationCodeSubsystem r +interpretVerificationCodeSubsystem = interpret $ \case + CreateCode gen scope retries timeout mId -> createCodeImpl gen scope retries timeout mId + CreateCodeOverwritePrevious gen scope retries timeout mId -> createCodeOverwritePreviousImpl gen scope retries timeout mId + VerifyCode key scope val -> verifyCodeImpl key scope val + DeleteCode key scope -> Store.deleteCode key scope + InternalLookupCode key scope -> Store.lookupCode key scope + +newtype VerificationCodeThrottleTTL = VerificationCodeThrottleTTL Word + deriving (Show, Eq, Arbitrary, Num, Enum, Ord, Real, Integral) + +createCodeImpl :: + ( Member VerificationCodeStore r, + Member Random r, + Member (Error VerificationCodeSubsystemError) r, + Member (Input VerificationCodeThrottleTTL) r + ) => + VerificationCodeGen -> + Scope -> + Retries -> + Timeout -> + Maybe UUID -> + Sem r (Either CodeAlreadyExists Code) +createCodeImpl gen scope retries timeout mId = + lookupCode gen.genKey scope >>= \case + Just c -> pure . Left $ CodeAlreadyExists c + Nothing -> + Right <$> createCodeOverwritePreviousImpl gen scope retries timeout mId + +createCodeOverwritePreviousImpl :: + ( Member VerificationCodeStore r, + Member Random r, + Member (Error VerificationCodeSubsystemError) r, + Member (Input VerificationCodeThrottleTTL) r + ) => + VerificationCodeGen -> + Scope -> + Retries -> + Timeout -> + Maybe UUID -> + Sem r Code +createCodeOverwritePreviousImpl gen scope retries timeout mId = do + code <- generateVerificationCode gen scope retries timeout mId + maybe (pure code) (throw . VerificationCodeThrottled) =<< insert code + +insert :: (Member VerificationCodeStore r, Member (Input VerificationCodeThrottleTTL) r) => Code -> Sem r (Maybe RetryAfter) +insert code = do + VerificationCodeThrottleTTL ttl <- input + mRetryAfter <- lookupThrottle (codeKey code) (codeScope code) + case mRetryAfter of + Just ra -> pure (Just ra) + Nothing -> do + insertThrottle code.codeKey code.codeScope ttl + insertCode code + pure Nothing + +-- | Lookup and verify the code for the given key and scope +-- against the given value. +verifyCodeImpl :: (Member VerificationCodeStore r) => Key -> Scope -> Value -> Sem r (Maybe Code) +verifyCodeImpl k s v = lookupCode k s >>= maybe (pure Nothing) continue + where + continue c + | codeValue c == v && codeRetries c > 0 = pure (Just c) + | codeRetries c > 0 = do + insertCode (c {codeRetries = codeRetries c - 1}) + pure Nothing + | otherwise = pure Nothing diff --git a/libs/wire-subsystems/test/unit/Wire/AuthenticationSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/AuthenticationSubsystem/InterpreterSpec.hs new file mode 100644 index 00000000000..39dda77c340 --- /dev/null +++ b/libs/wire-subsystems/test/unit/Wire/AuthenticationSubsystem/InterpreterSpec.hs @@ -0,0 +1,313 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module Wire.AuthenticationSubsystem.InterpreterSpec (spec) where + +import Data.Domain +import Data.Id +import Data.Misc (PlainTextPassword8) +import Data.Qualified +import Data.Time +import Imports +import Polysemy +import Polysemy.Error +import Polysemy.Input +import Polysemy.State +import Polysemy.TinyLog +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck +import Wire.API.Allowlists (AllowlistEmailDomains (AllowlistEmailDomains)) +import Wire.API.Password +import Wire.API.User +import Wire.API.User qualified as User +import Wire.API.User.Auth +import Wire.API.User.Password +import Wire.AuthenticationSubsystem +import Wire.AuthenticationSubsystem.Interpreter +import Wire.EmailSubsystem +import Wire.HashPassword +import Wire.MockInterpreters +import Wire.PasswordResetCodeStore +import Wire.PasswordStore +import Wire.Sem.Logger.TinyLog +import Wire.Sem.Now (Now) +import Wire.SessionStore +import Wire.UserKeyStore +import Wire.UserSubsystem + +type AllEffects = + [ Error AuthenticationSubsystemError, + HashPassword, + Now, + State UTCTime, + Input (Local ()), + Input (Maybe AllowlistEmailDomains), + SessionStore, + State (Map UserId [Cookie ()]), + PasswordStore, + State (Map UserId Password), + PasswordResetCodeStore, + State (Map PasswordResetKey (PRQueryData Identity)), + TinyLog, + EmailSubsystem, + State (Map Email [SentMail]), + UserSubsystem + ] + +interpretDependencies :: Domain -> [UserAccount] -> Map UserId Password -> Maybe [Text] -> Sem AllEffects a -> Either AuthenticationSubsystemError a +interpretDependencies localDomain preexistingUsers preexistingPasswords mAllowedEmailDomains = + run + . userSubsystemTestInterpreter preexistingUsers + . evalState mempty + . emailSubsystemInterpreter + . discardTinyLogs + . evalState mempty + . inMemoryPasswordResetCodeStore + . evalState preexistingPasswords + . inMemoryPasswordStoreInterpreter + . evalState mempty + . inMemorySessionStoreInterpreter + . runInputConst (AllowlistEmailDomains <$> mAllowedEmailDomains) + . runInputConst (toLocalUnsafe localDomain ()) + . evalState defaultTime + . interpretNowAsState + . staticHashPasswordInterpreter + . runError + +spec :: Spec +spec = describe "AuthenticationSubsystem.Interpreter" do + describe "password reset" do + prop "password reset should work with the email being used as password reset key" $ + \email userNoEmail (cookiesWithTTL :: [(Cookie (), Maybe TTL)]) mPreviousPassword newPassword -> + let user = userNoEmail {userIdentity = Just $ EmailIdentity email} + uid = User.userId user + localDomain = userNoEmail.userQualifiedId.qDomain + Right (newPasswordHash, cookiesAfterReset) = + interpretDependencies localDomain [UserAccount user Active] mempty Nothing + . interpretAuthenticationSubsystem + $ do + forM_ mPreviousPassword (hashPassword >=> upsertHashedPassword uid) + mapM_ (uncurry (insertCookie uid)) cookiesWithTTL + + createPasswordResetCode (mkEmailKey email) + (_, code) <- expect1ResetPasswordEmail email + resetPassword (PasswordResetEmailIdentity email) code newPassword + + (,) <$> lookupHashedPassword uid <*> listCookies uid + in mPreviousPassword /= Just newPassword ==> + (fmap (verifyPassword newPassword) newPasswordHash === Just True) + .&&. (cookiesAfterReset === []) + + prop "password reset should work with the returned password reset key" $ + \email userNoEmail (cookiesWithTTL :: [(Cookie (), Maybe TTL)]) mPreviousPassword newPassword -> + let user = userNoEmail {userIdentity = Just $ EmailIdentity email} + uid = User.userId user + localDomain = userNoEmail.userQualifiedId.qDomain + Right (newPasswordHash, cookiesAfterReset) = + interpretDependencies localDomain [UserAccount user Active] mempty Nothing + . interpretAuthenticationSubsystem + $ do + forM_ mPreviousPassword (hashPassword >=> upsertHashedPassword uid) + mapM_ (uncurry (insertCookie uid)) cookiesWithTTL + + createPasswordResetCode (mkEmailKey email) + (passwordResetKey, code) <- expect1ResetPasswordEmail email + resetPassword (PasswordResetIdentityKey passwordResetKey) code newPassword + + (,) <$> lookupHashedPassword uid <*> listCookies uid + in mPreviousPassword /= Just newPassword ==> + (fmap (verifyPassword newPassword) newPasswordHash === Just True) + .&&. (cookiesAfterReset === []) + + prop "reset code is not generated when email is not in allow list" $ + \email localDomain -> + let createPasswordResetCodeResult = + interpretDependencies localDomain [] mempty (Just ["example.com"]) + . interpretAuthenticationSubsystem + $ createPasswordResetCode (mkEmailKey email) + <* expectNoEmailSent + in emailDomain email /= "example.com" ==> + createPasswordResetCodeResult === Right () + + prop "reset code is generated when email is in allow list" $ + \email userNoEmail -> + let user = userNoEmail {userIdentity = Just $ EmailIdentity email} + localDomain = userNoEmail.userQualifiedId.qDomain + createPasswordResetCodeResult = + interpretDependencies localDomain [UserAccount user Active] mempty (Just [emailDomain email]) + . interpretAuthenticationSubsystem + $ createPasswordResetCode (mkEmailKey email) + in counterexample ("expected Right, got: " <> show createPasswordResetCodeResult) $ + isRight createPasswordResetCodeResult + + prop "reset code is not generated for when user's status is not Active" $ + \email userNoEmail status -> + let user = userNoEmail {userIdentity = Just $ EmailIdentity email} + localDomain = userNoEmail.userQualifiedId.qDomain + createPasswordResetCodeResult = + interpretDependencies localDomain [UserAccount user status] mempty Nothing + . interpretAuthenticationSubsystem + $ createPasswordResetCode (mkEmailKey email) + <* expectNoEmailSent + in status /= Active ==> + createPasswordResetCodeResult === Right () + + prop "reset code is not generated for when there is no user for the email" $ + \email localDomain -> + let createPasswordResetCodeResult = + interpretDependencies localDomain [] mempty Nothing + . interpretAuthenticationSubsystem + $ createPasswordResetCode (mkEmailKey email) + <* expectNoEmailSent + in createPasswordResetCodeResult === Right () + + prop "reset code is only generated once" $ + \email userNoEmail newPassword -> + let user = userNoEmail {userIdentity = Just $ EmailIdentity email} + uid = User.userId user + localDomain = userNoEmail.userQualifiedId.qDomain + Right (newPasswordHash, mCaughtException) = + interpretDependencies localDomain [UserAccount user Active] mempty Nothing + . interpretAuthenticationSubsystem + $ do + createPasswordResetCode (mkEmailKey email) + (_, code) <- expect1ResetPasswordEmail email + + mCaughtExc <- catchExpectedError $ createPasswordResetCode (mkEmailKey email) + + -- Reset password still works with previously generated reset code + resetPassword (PasswordResetEmailIdentity email) code newPassword + + (,mCaughtExc) <$> lookupHashedPassword uid + in (fmap (verifyPassword newPassword) newPasswordHash === Just True) + .&&. (mCaughtException === Nothing) + + prop "reset code is not accepted after expiry" $ + \email userNoEmail oldPassword newPassword -> + let user = userNoEmail {userIdentity = Just $ EmailIdentity email} + uid = User.userId user + localDomain = userNoEmail.userQualifiedId.qDomain + Right (passwordInDB, resetPasswordResult) = + interpretDependencies localDomain [UserAccount user Active] mempty Nothing + . interpretAuthenticationSubsystem + $ do + upsertHashedPassword uid =<< hashPassword oldPassword + createPasswordResetCode (mkEmailKey email) + (_, code) <- expect1ResetPasswordEmail email + + passTime (passwordResetCodeTtl + 1) + + mCaughtExc <- catchExpectedError $ resetPassword (PasswordResetEmailIdentity email) code newPassword + (,mCaughtExc) <$> lookupHashedPassword uid + in resetPasswordResult === Just AuthenticationSubsystemInvalidPasswordResetCode + .&&. verifyPasswordProp oldPassword passwordInDB + + prop "password reset is not allowed with arbitrary codes when no other codes exist" $ + \email userNoEmail resetCode oldPassword newPassword -> + let user = userNoEmail {userIdentity = Just $ EmailIdentity email} + uid = User.userId user + localDomain = userNoEmail.userQualifiedId.qDomain + Right (passwordInDB, resetPasswordResult) = + interpretDependencies localDomain [UserAccount user Active] mempty Nothing + . interpretAuthenticationSubsystem + $ do + upsertHashedPassword uid =<< hashPassword oldPassword + mCaughtExc <- catchExpectedError $ resetPassword (PasswordResetEmailIdentity email) resetCode newPassword + (,mCaughtExc) <$> lookupHashedPassword uid + in resetPasswordResult === Just AuthenticationSubsystemInvalidPasswordResetCode + .&&. verifyPasswordProp oldPassword passwordInDB + + prop "password reset doesn't work if email is wrong" $ + \email wrongEmail userNoEmail resetCode oldPassword newPassword -> + let user = userNoEmail {userIdentity = Just $ EmailIdentity email} + uid = User.userId user + localDomain = userNoEmail.userQualifiedId.qDomain + Right (passwordInDB, resetPasswordResult) = + interpretDependencies localDomain [UserAccount user Active] mempty Nothing + . interpretAuthenticationSubsystem + $ do + hashAndUpsertPassword uid oldPassword + mCaughtExc <- catchExpectedError $ resetPassword (PasswordResetEmailIdentity wrongEmail) resetCode newPassword + (,mCaughtExc) <$> lookupHashedPassword uid + in email /= wrongEmail ==> + resetPasswordResult === Just AuthenticationSubsystemInvalidPasswordResetKey + .&&. verifyPasswordProp oldPassword passwordInDB + + prop "only 3 wrong password reset attempts are allowed" $ + \email userNoEmail arbitraryResetCode oldPassword newPassword (Upto4 wrongResetAttempts) -> + let user = userNoEmail {userIdentity = Just $ EmailIdentity email} + uid = User.userId user + localDomain = userNoEmail.userQualifiedId.qDomain + Right (passwordHashInDB, correctResetCode, wrongResetErrors, resetPassworedWithCorectCodeResult) = + interpretDependencies localDomain [UserAccount user Active] mempty Nothing + . interpretAuthenticationSubsystem + $ do + upsertHashedPassword uid =<< hashPassword oldPassword + createPasswordResetCode (mkEmailKey email) + (_, generatedResetCode) <- expect1ResetPasswordEmail email + + wrongResetErrs <- + replicateM wrongResetAttempts $ + catchExpectedError $ + resetPassword (PasswordResetEmailIdentity email) arbitraryResetCode newPassword + + mFinalResetErr <- catchExpectedError $ resetPassword (PasswordResetEmailIdentity email) generatedResetCode newPassword + (,generatedResetCode,wrongResetErrs,mFinalResetErr) <$> lookupHashedPassword uid + expectedFinalResetResult = + if wrongResetAttempts >= 3 + then Just AuthenticationSubsystemInvalidPasswordResetCode + else Nothing + expectedFinalPassword = + if wrongResetAttempts >= 3 + then oldPassword + else newPassword + in correctResetCode /= arbitraryResetCode ==> + wrongResetErrors == replicate wrongResetAttempts (Just AuthenticationSubsystemInvalidPasswordResetCode) + .&&. resetPassworedWithCorectCodeResult === expectedFinalResetResult + .&&. verifyPasswordProp expectedFinalPassword passwordHashInDB + + describe "internalLookupPasswordResetCode" do + prop "should find password reset code by email" $ + \email userNoEmail newPassword -> + let user = userNoEmail {userIdentity = Just $ EmailIdentity email} + uid = User.userId user + localDomain = userNoEmail.userQualifiedId.qDomain + Right passwordHashInDB = + interpretDependencies localDomain [UserAccount user Active] mempty Nothing + . interpretAuthenticationSubsystem + $ do + void $ createPasswordResetCode (mkEmailKey email) + mLookupRes <- internalLookupPasswordResetCode (mkEmailKey email) + for_ mLookupRes $ \(_, code) -> resetPassword (PasswordResetEmailIdentity email) code newPassword + lookupHashedPassword uid + in verifyPasswordProp newPassword passwordHashInDB + +newtype Upto4 = Upto4 Int + deriving newtype (Show, Eq) + +instance Arbitrary Upto4 where + arbitrary = Upto4 <$> elements [0 .. 4] + +verifyPasswordProp :: PlainTextPassword8 -> Maybe Password -> Property +verifyPasswordProp plainTextPassword passwordHash = + counterexample ("Password doesn't match, plainText=" <> show plainTextPassword <> ", passwordHash=" <> show passwordHash) $ + fmap (verifyPassword plainTextPassword) passwordHash == Just True + +hashAndUpsertPassword :: (Member PasswordStore r, Member HashPassword r) => UserId -> PlainTextPassword8 -> Sem r () +hashAndUpsertPassword uid password = + upsertHashedPassword uid =<< hashPassword password + +expect1ResetPasswordEmail :: (Member (State (Map Email [SentMail])) r) => Email -> Sem r PasswordResetPair +expect1ResetPasswordEmail email = + getEmailsSentTo email + <&> \case + [] -> error "no emails sent" + [SentMail _ (PasswordResetMail resetPair)] -> resetPair + wrongEmails -> error $ "Wrong emails sent: " <> show wrongEmails + +expectNoEmailSent :: (Member (State (Map Email [SentMail])) r) => Sem r () +expectNoEmailSent = do + emails <- get + if null emails + then pure () + else error $ "Expected no emails sent, got: " <> show emails diff --git a/libs/wire-subsystems/src/Wire/MiniBackend.hs b/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs similarity index 55% rename from libs/wire-subsystems/src/Wire/MiniBackend.hs rename to libs/wire-subsystems/test/unit/Wire/MiniBackend.hs index 9ff7e22e0b3..d1fea2a4012 100644 --- a/libs/wire-subsystems/src/Wire/MiniBackend.hs +++ b/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs @@ -1,4 +1,26 @@ -module Wire.MiniBackend where +module Wire.MiniBackend + ( -- * Mini backends + MiniBackend (..), + AllErrors, + MiniBackendEffects, + interpretFederationStack, + runFederationStack, + interpretNoFederationStack, + runNoFederationStackState, + interpretNoFederationStackState, + runNoFederationStack, + runAllErrorsUnsafe, + runErrorUnsafe, + miniLocale, + + -- * Mini events + MiniEvent (..), + + -- * Quickcheck helpers + NotPendingStoredUser (..), + PendingStoredUser (..), + ) +where import Data.Default (Default (def)) import Data.Domain @@ -9,34 +31,43 @@ import Data.Map.Lazy qualified as LM import Data.Map.Strict qualified as M import Data.Proxy import Data.Qualified -import Data.Set qualified as S import Data.Time import Data.Type.Equality import Imports import Polysemy import Polysemy.Error import Polysemy.Input +import Polysemy.Internal import Polysemy.State +import Polysemy.TinyLog import Servant.Client.Core +import System.Logger qualified as Log import Test.QuickCheck import Type.Reflection import Wire.API.Federation.API import Wire.API.Federation.Component import Wire.API.Federation.Error -import Wire.API.Team.Member -import Wire.API.User hiding (DeleteUser) +import Wire.API.Team.Feature +import Wire.API.Team.Member hiding (userId) +import Wire.API.User as User hiding (DeleteUser) +import Wire.API.User.Password import Wire.DeleteQueue import Wire.DeleteQueue.InMemory import Wire.FederationAPIAccess import Wire.FederationAPIAccess.Interpreter as FI import Wire.GalleyAPIAccess -import Wire.InternalEvent +import Wire.InternalEvent hiding (DeleteUser) +import Wire.MockInterpreters +import Wire.PasswordResetCodeStore import Wire.Sem.Concurrency import Wire.Sem.Concurrency.Sequential -import Wire.Sem.Now +import Wire.Sem.Now hiding (get) import Wire.StoredUser +import Wire.UserEvents +import Wire.UserKeyStore import Wire.UserStore import Wire.UserSubsystem +import Wire.UserSubsystem.Error import Wire.UserSubsystem.Interpreter newtype PendingStoredUser = PendingStoredUser StoredUser @@ -52,32 +83,51 @@ newtype NotPendingStoredUser = NotPendingStoredUser StoredUser instance Arbitrary NotPendingStoredUser where arbitrary = do - user <- arbitrary + user <- arbitrary `suchThat` \user -> isJust user.identity notPendingStatus <- elements (Nothing : map Just [Active, Suspended, Deleted, Ephemeral]) pure $ NotPendingStoredUser (user {status = notPendingStatus}) -type GetUserProfileEffects = +type AllErrors = + [ Error UserSubsystemError, + Error FederationError + ] + +type MiniBackendEffects = [ UserSubsystem, GalleyAPIAccess, UserStore, + State [StoredUser], + UserKeyStore, + State (Map EmailKey UserId), DeleteQueue, + UserEvents, State [InternalNotification], + State MiniBackend, + State [MiniEvent], Now, Input UserSubsystemConfig, + Input (Local ()), FederationAPIAccess MiniFederationMonad, - Concurrency 'Unsafe, - Error FederationError + TinyLog, + Concurrency 'Unsafe ] -- | a type representing the state of a single backend data MiniBackend = MkMiniBackend { -- | this is morally the same as the users stored in the actual backend -- invariant: for each key, the user.id and the key are the same - users :: Set StoredUser + users :: [StoredUser], + userKeys :: Map EmailKey UserId, + passwordResetCodes :: Map PasswordResetKey (PRQueryData Identity) } instance Default MiniBackend where - def = MkMiniBackend {users = mempty} + def = + MkMiniBackend + { users = mempty, + userKeys = mempty, + passwordResetCodes = mempty + } -- | represents an entire federated, stateful world of backends newtype MiniFederation = MkMiniFederation @@ -100,12 +150,12 @@ instance RunClient (MiniFederationMonad comp) where data SubsystemOperationList where TNil :: SubsystemOperationList - (:::) :: Typeable a => (Component, Text, a) -> SubsystemOperationList -> SubsystemOperationList + (:::) :: (Typeable a) => (Component, Text, a) -> SubsystemOperationList -> SubsystemOperationList infixr 5 ::: lookupSubsystemOperation :: - Typeable a => + (Typeable a) => -- | The type to compare to (Component, Text, Proxy a) -> -- | what to return when none of the types match @@ -167,7 +217,7 @@ miniGetAllProfiles = do pure $ map (\u -> mkUserProfileWithEmail Nothing (mkUserFromStored dom miniLocale u) defUserLegalHoldStatus) - (S.toList users) + users miniGetUsersByIds :: [UserId] -> MiniFederationMonad 'Brig [UserProfile] miniGetUsersByIds userIds = runOnOwnBackend do @@ -187,75 +237,138 @@ runMiniFederation ownDomain backends = . runInputConst MkMiniContext {ownDomain = ownDomain} . unMiniFederation -interpretNowConst :: - UTCTime -> - Sem (Now : r) a -> +noOpLogger :: + Sem (Logger (Log.Msg -> Log.Msg) ': r) a -> Sem r a -interpretNowConst time = interpret \case - Wire.Sem.Now.Get -> pure time +noOpLogger = interpret $ \case + Log _lvl _msg -> pure () runFederationStack :: - [StoredUser] -> + (HasCallStack) => + MiniBackend -> Map Domain MiniBackend -> Maybe TeamMember -> UserSubsystemConfig -> - Sem GetUserProfileEffects a -> + Sem (MiniBackendEffects `Append` AllErrors) a -> a -runFederationStack allLocalUsers fedBackends teamMember cfg = - let unsafeError e = error $ "Unexpected error: " <> displayException e - in either unsafeError Imports.id - . runFederationStackEither - allLocalUsers - fedBackends - teamMember - cfg - -runFederationStackEither :: - [StoredUser] -> - -- | the available backend +runFederationStack localBackend fedBackends teamMember cfg = + runAllErrorsUnsafe + . interpretFederationStack + localBackend + fedBackends + teamMember + cfg + +interpretFederationStack :: + (HasCallStack, Members AllErrors r) => + -- | the local backend + MiniBackend -> + -- | the available backends Map Domain MiniBackend -> Maybe TeamMember -> UserSubsystemConfig -> - Sem GetUserProfileEffects a -> - Either FederationError a -runFederationStackEither allLocalUsers backends teamMember cfg = - run - . runError - . sequentiallyPerformConcurrency - . miniFederationAPIAccess backends - . runInputConst cfg - . interpretNowConst (UTCTime (ModifiedJulianDay 0) 0) - . evalState [] - . inMemoryDeleteQueueInterpreter - . staticUserStoreInterpreter allLocalUsers - . miniGalleyAPIAccess teamMember - . runUserSubsystem cfg + Sem (MiniBackendEffects `Append` r) a -> + Sem r a +interpretFederationStack localBackend remoteBackends teamMember cfg = + snd <$$> interpretFederationStackState localBackend remoteBackends teamMember cfg + +interpretFederationStackState :: + (HasCallStack, Members AllErrors r) => + -- | the local backend + MiniBackend -> + -- | the available backends + Map Domain MiniBackend -> + Maybe TeamMember -> + UserSubsystemConfig -> + Sem (MiniBackendEffects `Append` r) a -> + Sem r (MiniBackend, a) +interpretFederationStackState localBackend backends teamMember = + interpretMaybeFederationStackState (miniFederationAPIAccess backends) localBackend teamMember def runNoFederationStack :: - [StoredUser] -> + MiniBackend -> Maybe TeamMember -> UserSubsystemConfig -> - Sem GetUserProfileEffects a -> + Sem (MiniBackendEffects `Append` AllErrors) a -> a -runNoFederationStack allUsers teamMember cfg = - run - . runErrorUnsafe - . sequentiallyPerformConcurrency - . emptyFederationAPIAcesss +runNoFederationStack localBackend teamMember cfg = + -- (A 'runNoFederationStackEither' variant of this that returns 'AllErrors' in an 'Either' + -- would be nice, but is complicated by the fact that we not only have 'UserSubsystemErrors', + -- but other errors as well. Maybe just wait with this until we have a better idea how we + -- want to do errors?) + runAllErrorsUnsafe . interpretNoFederationStack localBackend teamMember def cfg + +runNoFederationStackState :: + (HasCallStack) => + MiniBackend -> + Maybe TeamMember -> + UserSubsystemConfig -> + Sem (MiniBackendEffects `Append` AllErrors) a -> + (MiniBackend, a) +runNoFederationStackState localBackend teamMember cfg = + runAllErrorsUnsafe . interpretNoFederationStackState localBackend teamMember def cfg + +interpretNoFederationStack :: + (Members AllErrors r) => + MiniBackend -> + Maybe TeamMember -> + AllFeatureConfigs -> + UserSubsystemConfig -> + Sem (MiniBackendEffects `Append` r) a -> + Sem r a +interpretNoFederationStack localBackend teamMember galleyConfigs cfg = + snd <$$> interpretNoFederationStackState localBackend teamMember galleyConfigs cfg + +interpretNoFederationStackState :: + (Members AllErrors r) => + MiniBackend -> + Maybe TeamMember -> + AllFeatureConfigs -> + UserSubsystemConfig -> + Sem (MiniBackendEffects `Append` r) a -> + Sem r (MiniBackend, a) +interpretNoFederationStackState = interpretMaybeFederationStackState emptyFederationAPIAcesss + +interpretMaybeFederationStackState :: + (Members AllErrors r) => + InterpreterFor (FederationAPIAccess MiniFederationMonad) (Logger (Log.Msg -> Log.Msg) : Concurrency 'Unsafe : r) -> + MiniBackend -> + Maybe TeamMember -> + AllFeatureConfigs -> + UserSubsystemConfig -> + Sem (MiniBackendEffects `Append` r) a -> + Sem r (MiniBackend, a) +interpretMaybeFederationStackState maybeFederationAPIAccess localBackend teamMember galleyConfigs cfg = + sequentiallyPerformConcurrency + . noOpLogger + . maybeFederationAPIAccess + . runInputConst (toLocalUnsafe (Domain "localdomain") ()) . runInputConst cfg . interpretNowConst (UTCTime (ModifiedJulianDay 0) 0) . evalState [] + . runState localBackend + . evalState [] + . miniEventInterpreter . inMemoryDeleteQueueInterpreter - . staticUserStoreInterpreter allUsers - . miniGalleyAPIAccess teamMember + . liftUserKeyStoreState + . inMemoryUserKeyStoreInterpreter + . liftUserStoreState + . inMemoryUserStoreInterpreter + . miniGalleyAPIAccess teamMember galleyConfigs . runUserSubsystem cfg -runErrorUnsafe :: Exception e => InterpreterFor (Error e) r -runErrorUnsafe action = do - res <- runError action - case res of - Left e -> error $ "Unexpected error: " <> displayException e - Right x -> pure x +liftUserKeyStoreState :: (Member (State MiniBackend) r) => Sem (State (Map EmailKey UserId) : r) a -> Sem r a +liftUserKeyStoreState = interpret $ \case + Polysemy.State.Get -> gets (.userKeys) + Put newUserKeys -> modify $ \b -> b {userKeys = newUserKeys} + +liftUserStoreState :: (Member (State MiniBackend) r) => Sem (State [StoredUser] : r) a -> Sem r a +liftUserStoreState = interpret $ \case + Polysemy.State.Get -> gets (.users) + Put newUsers -> modify $ \b -> b {users = newUsers} + +runAllErrorsUnsafe :: forall a. (HasCallStack) => Sem AllErrors a -> a +runAllErrorsUnsafe = run . runErrorUnsafe . runErrorUnsafe emptyFederationAPIAcesss :: InterpreterFor (FederationAPIAccess MiniFederationMonad) r emptyFederationAPIAcesss = interpret $ \case @@ -263,6 +376,7 @@ emptyFederationAPIAcesss = interpret $ \case miniFederationAPIAccess :: forall a r. + (HasCallStack) => Map Domain MiniBackend -> Sem (FederationAPIAccess MiniFederationMonad : r) a -> Sem r a @@ -277,12 +391,3 @@ miniFederationAPIAccess online = do RunFederatedConcurrently _remotes _rpc -> error "unimplemented: RunFederatedConcurrently" RunFederatedBucketed _domain _rpc -> error "unimplemented: RunFederatedBucketed" IsFederationConfigured -> pure True - -staticUserStoreInterpreter :: [StoredUser] -> InterpreterFor UserStore r -staticUserStoreInterpreter allUsers = interpret $ \case - GetUser uid -> pure $ find (\user -> user.id == uid) allUsers - -miniGalleyAPIAccess :: Maybe TeamMember -> InterpreterFor GalleyAPIAccess r -miniGalleyAPIAccess member = interpret $ \case - GetTeamMember _ _ -> pure member - _ -> error "uninterpreted effect: GalleyAPIAccess" diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters.hs new file mode 100644 index 00000000000..9145369b703 --- /dev/null +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters.hs @@ -0,0 +1,19 @@ +module Wire.MockInterpreters (module MockInterpreters) where + +-- Run this from project root to generate the imports: +-- ls libs/wire-subsystems/test/unit/Wire/MockInterpreters | sed 's|\(.*\)\.hs|import Wire.MockInterpreters.\1 as MockInterpreters|' + +import Wire.MockInterpreters.EmailSubsystem as MockInterpreters +import Wire.MockInterpreters.Error as MockInterpreters +import Wire.MockInterpreters.GalleyAPIAccess as MockInterpreters +import Wire.MockInterpreters.HashPassword as MockInterpreters +import Wire.MockInterpreters.Now as MockInterpreters +import Wire.MockInterpreters.PasswordResetCodeStore as MockInterpreters +import Wire.MockInterpreters.PasswordStore as MockInterpreters +import Wire.MockInterpreters.Random as MockInterpreters +import Wire.MockInterpreters.SessionStore as MockInterpreters +import Wire.MockInterpreters.UserEvents as MockInterpreters +import Wire.MockInterpreters.UserKeyStore as MockInterpreters +import Wire.MockInterpreters.UserStore as MockInterpreters +import Wire.MockInterpreters.UserSubsystem as MockInterpreters +import Wire.MockInterpreters.VerificationCodeStore as MockInterpreters diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EmailSubsystem.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EmailSubsystem.hs new file mode 100644 index 00000000000..57c9fac0c9e --- /dev/null +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EmailSubsystem.hs @@ -0,0 +1,25 @@ +module Wire.MockInterpreters.EmailSubsystem where + +import Data.Map qualified as Map +import Imports +import Polysemy +import Polysemy.State +import Wire.API.User +import Wire.EmailSubsystem + +data SentMail = SentMail + { locale :: Maybe Locale, + content :: SentMailContent + } + deriving (Show, Eq) + +data SentMailContent = PasswordResetMail PasswordResetPair + deriving (Show, Eq) + +emailSubsystemInterpreter :: (Member (State (Map Email [SentMail])) r) => InterpreterFor EmailSubsystem r +emailSubsystemInterpreter = interpret \case + SendPasswordResetMail email keyCodePair mLocale -> modify $ Map.insertWith (<>) email [SentMail mLocale $ PasswordResetMail keyCodePair] + _ -> error "emailSubsystemInterpreter: implement on demand" + +getEmailsSentTo :: (Member (State (Map Email [SentMail])) r) => Email -> Sem r [SentMail] +getEmailsSentTo email = gets $ Map.findWithDefault [] email diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/Error.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/Error.hs new file mode 100644 index 00000000000..09ed07d043d --- /dev/null +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/Error.hs @@ -0,0 +1,15 @@ +module Wire.MockInterpreters.Error where + +import Imports +import Polysemy +import Polysemy.Error + +runErrorUnsafe :: (HasCallStack, Exception e) => InterpreterFor (Error e) r +runErrorUnsafe action = do + res <- runError action + case res of + Left e -> error $ "Unexpected error: " <> displayException e + Right x -> pure x + +catchExpectedError :: (Member (Error e) r) => Sem r a -> Sem r (Maybe e) +catchExpectedError action = (Nothing <$ action) `catch` (pure . Just) diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/GalleyAPIAccess.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/GalleyAPIAccess.hs new file mode 100644 index 00000000000..1e8a81e9f51 --- /dev/null +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/GalleyAPIAccess.hs @@ -0,0 +1,19 @@ +module Wire.MockInterpreters.GalleyAPIAccess where + +import Imports +import Polysemy +import Wire.API.Team.Feature +import Wire.API.Team.Member +import Wire.GalleyAPIAccess + +-- | interprets galley by statically returning the values passed +miniGalleyAPIAccess :: + -- | what to return when calling GetTeamMember + Maybe TeamMember -> + -- | what to return when calling GetAllFeatureConfigsForUser + AllFeatureConfigs -> + InterpreterFor GalleyAPIAccess r +miniGalleyAPIAccess member configs = interpret $ \case + GetTeamMember _ _ -> pure member + GetAllFeatureConfigsForUser _ -> pure configs + _ -> error "uninterpreted effect: GalleyAPIAccess" diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/HashPassword.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/HashPassword.hs new file mode 100644 index 00000000000..05c15259bec --- /dev/null +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/HashPassword.hs @@ -0,0 +1,28 @@ +module Wire.MockInterpreters.HashPassword where + +import Crypto.KDF.Argon2 as Argon2 +import Data.Misc +import Data.Text.Encoding qualified as Text +import Imports +import Polysemy +import Wire.API.Password +import Wire.HashPassword + +staticHashPasswordInterpreter :: InterpreterFor HashPassword r +staticHashPasswordInterpreter = interpret $ \case + HashPassword password -> go (hashPasswordArgon2idWithOptions fastArgon2IdOptions) "9bytesalt" password + where + go alg salt password = do + let passwordBS = Text.encodeUtf8 (fromPlainTextPassword password) + pure $ unsafeMkPassword $ alg salt passwordBS + +fastArgon2IdOptions :: Argon2.Options +fastArgon2IdOptions = + let hashParallelism = 4 + in defaultOptions + { iterations = 1, + parallelism = hashParallelism, + -- This needs to be min 8 * hashParallelism, otherewise we get an + -- unsafe error + memory = 8 * hashParallelism + } diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/Now.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/Now.hs new file mode 100644 index 00000000000..826638a4042 --- /dev/null +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/Now.hs @@ -0,0 +1,25 @@ +module Wire.MockInterpreters.Now where + +import Data.Time +import Imports +import Polysemy +import Polysemy.State +import Wire.Sem.Now + +interpretNowConst :: + UTCTime -> + Sem (Now : r) a -> + Sem r a +interpretNowConst time = interpret \case + Wire.Sem.Now.Get -> pure time + +interpretNowAsState :: (Member (State UTCTime) r) => InterpreterFor Now r +interpretNowAsState = + interpret $ \case + Wire.Sem.Now.Get -> Polysemy.State.get + +defaultTime :: UTCTime +defaultTime = UTCTime (ModifiedJulianDay 0) 0 + +passTime :: (Member (State UTCTime) r) => NominalDiffTime -> Sem r () +passTime t = modify (addUTCTime t) diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/PasswordResetCodeStore.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/PasswordResetCodeStore.hs new file mode 100644 index 00000000000..25d6ab11d89 --- /dev/null +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/PasswordResetCodeStore.hs @@ -0,0 +1,28 @@ +module Wire.MockInterpreters.PasswordResetCodeStore where + +import Data.Map qualified as Map +import Data.Text.Ascii +import Imports +import Polysemy +import Polysemy.State +import Wire.API.User.Password +import Wire.PasswordResetCodeStore + +inMemoryPasswordResetCodeStore :: + forall r. + (Member (State (Map PasswordResetKey (PRQueryData Identity))) r) => + InterpreterFor PasswordResetCodeStore r +inMemoryPasswordResetCodeStore = + interpret + \case + GenerateEmailCode -> + pure . PasswordResetCode . encodeBase64Url $ "email-code" + GeneratePhoneCode -> (error "deprecated") + CodeSelect resetKey -> do + gets $ + fmap (mapPRQueryData (Just . runIdentity)) + . Map.lookup resetKey + CodeInsert resetKey queryData _ttl -> do + modify $ Map.insert resetKey queryData + CodeDelete resetKey -> do + modify $ Map.delete resetKey diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/PasswordStore.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/PasswordStore.hs new file mode 100644 index 00000000000..be4f1a140d3 --- /dev/null +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/PasswordStore.hs @@ -0,0 +1,14 @@ +module Wire.MockInterpreters.PasswordStore where + +import Data.Id +import Data.Map qualified as Map +import Imports +import Polysemy +import Polysemy.State +import Wire.API.Password +import Wire.PasswordStore + +inMemoryPasswordStoreInterpreter :: (Member (State (Map UserId Password)) r) => InterpreterFor PasswordStore r +inMemoryPasswordStoreInterpreter = interpret $ \case + UpsertHashedPassword uid password -> modify $ Map.insert uid password + LookupHashedPassword uid -> gets $ Map.lookup uid diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/Random.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/Random.hs new file mode 100644 index 00000000000..f6c0e77371c --- /dev/null +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/Random.hs @@ -0,0 +1,37 @@ +module Wire.MockInterpreters.Random where + +import Crypto.Random +import Data.ByteString.Short (fromShort) +import Data.Id +import Imports +import Polysemy +import Polysemy.State +import System.Random hiding (Random) +import Wire.Sem.Random + +randomToStatefulStdGen :: (Member (State StdGen) r) => InterpreterFor Random r +randomToStatefulStdGen = interpret $ \case + Bytes n -> do + fromShort <$> withStatefulGen (genShortByteString n) + Uuid -> withStatefulGen random + ScimTokenId -> Id <$> withStatefulGen random + LiftRandom m -> do + seedInt <- withStatefulGen (random @Int) + let seed = seedFromInteger $ toInteger seedInt + drg = drgNewSeed seed + (x, _) = withDRG drg m + pure x + NDigitNumber n -> withStatefulGen $ randomR (0, 10 ^ n - 1) + +runRandomPure :: InterpreterFor Random r +runRandomPure = evalState defaulGen . randomToStatefulStdGen . raiseUnder + +defaulGen :: StdGen +defaulGen = mkStdGen 0xBAD + +withStatefulGen :: (Member (State StdGen) r) => (StdGen -> (a, StdGen)) -> Sem r a +withStatefulGen f = do + g <- get + let (x, g') = f g + put g' + pure x diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/SessionStore.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/SessionStore.hs new file mode 100644 index 00000000000..43e2736ba2e --- /dev/null +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/SessionStore.hs @@ -0,0 +1,17 @@ +module Wire.MockInterpreters.SessionStore where + +import Data.Id +import Data.Map qualified as Map +import Imports +import Polysemy +import Polysemy.State +import Wire.API.User.Auth +import Wire.SessionStore + +inMemorySessionStoreInterpreter :: (Member (State (Map UserId [Cookie ()])) r) => InterpreterFor SessionStore r +inMemorySessionStoreInterpreter = interpret $ \case + InsertCookie uid cookie _ttl -> modify $ Map.insertWith (<>) uid [cookie] + ListCookies uid -> gets (Map.findWithDefault [] uid) + DeleteAllCookies uid -> modify $ Map.delete uid + DeleteCookies uid cc -> (error "implement on demand") uid cc + LookupCookie uid time cid -> (error "implement on demand") uid time cid diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserEvents.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserEvents.hs new file mode 100644 index 00000000000..4bcd7319418 --- /dev/null +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserEvents.hs @@ -0,0 +1,20 @@ +module Wire.MockInterpreters.UserEvents where + +import Data.Id +import Imports +import Polysemy +import Polysemy.State +import Wire.API.UserEvent +import Wire.UserEvents + +data MiniEvent = MkMiniEvent + { userId :: UserId, + event :: UserEvent + } + deriving stock (Eq, Show) + +miniEventInterpreter :: + (Member (State [MiniEvent]) r) => + InterpreterFor UserEvents r +miniEventInterpreter = interpret \case + GenerateUserEvent uid _mconn e -> modify (MkMiniEvent uid e :) diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserKeyStore.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserKeyStore.hs new file mode 100644 index 00000000000..b03108f83f2 --- /dev/null +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserKeyStore.hs @@ -0,0 +1,31 @@ +module Wire.MockInterpreters.UserKeyStore where + +import Data.Id +import Data.Map qualified as M +import Imports +import Polysemy +import Polysemy.State +import Wire.UserKeyStore + +inMemoryUserKeyStoreInterpreter :: + (Member (State (Map EmailKey UserId)) r) => + InterpreterFor UserKeyStore r +inMemoryUserKeyStoreInterpreter = interpret $ \case + LookupKey key -> do + gets (M.lookup key) + InsertKey uid key -> + modify $ M.insert key uid + DeleteKey key -> + modify $ M.delete key + DeleteKeyForUser uid key -> + modify $ M.filterWithKey (\k u -> k /= key && u /= uid) + ClaimKey key uid -> do + keys <- get + let free = M.notMember key keys || M.lookup key keys == (Just uid) + when free $ + modify $ + M.insert key uid + pure free + KeyAvailable key uid -> do + keys <- get + pure $ M.notMember key keys || M.lookup key keys == uid diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs new file mode 100644 index 00000000000..563b91f4bd1 --- /dev/null +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs @@ -0,0 +1,85 @@ +module Wire.MockInterpreters.UserStore where + +import Data.Handle +import Data.Id +import Imports +import Polysemy +import Polysemy.Error +import Polysemy.State +import Wire.API.User hiding (DeleteUser) +import Wire.API.User qualified as User +import Wire.StoredUser +import Wire.UserStore + +inMemoryUserStoreInterpreter :: + forall r. + (Member (State [StoredUser]) r) => + InterpreterFor UserStore r +inMemoryUserStoreInterpreter = interpret $ \case + GetUser uid -> gets $ find (\user -> user.id == uid) + UpdateUser uid update -> modify (map doUpdate) + where + doUpdate :: StoredUser -> StoredUser + doUpdate u = + if u.id == uid + then + maybe Imports.id setStoredUserAccentId update.accentId + . maybe Imports.id setStoredUserAssets update.assets + . maybe Imports.id setStoredUserPict update.pict + . maybe Imports.id setStoredUserName update.name + . maybe Imports.id setStoredUserLocale update.locale + . maybe Imports.id setStoredUserSupportedProtocols update.supportedProtocols + $ u + else u + UpdateUserHandleEither uid hUpdate -> runError $ modifyLocalUsers (traverse doUpdate) + where + doUpdate :: StoredUser -> Sem (Error StoredUserUpdateError : r) StoredUser + doUpdate u + | u.id == uid = do + handles <- gets $ mapMaybe (.handle) + when + ( hUpdate.old + /= Just hUpdate.new + && elem hUpdate.new handles + ) + $ throw StoredUserUpdateHandleExists + pure $ setStoredUserHandle hUpdate.new u + doUpdate u = pure u + + modifyLocalUsers :: forall r1. (Member (State [StoredUser]) r1) => ([StoredUser] -> Sem r1 [StoredUser]) -> Sem r1 () + modifyLocalUsers f = do + us <- get + us' <- f us + put us' + DeleteUser user -> modify $ filter (\u -> u.id /= User.userId user) + LookupHandle h -> lookupHandleImpl h + GlimpseHandle h -> lookupHandleImpl h + LookupStatus uid -> lookupStatusImpl uid + IsActivated uid -> isActivatedImpl uid + LookupLocale uid -> lookupLocaleImpl uid + +lookupLocaleImpl :: (Member (State [StoredUser]) r) => UserId -> Sem r (Maybe ((Maybe Language, Maybe Country))) +lookupLocaleImpl uid = do + users <- get + let mUser = find ((== uid) . (.id)) users + pure $ (\u -> (u.language, u.country)) <$> mUser + +isActivatedImpl :: (Member (State [StoredUser]) r) => UserId -> Sem r Bool +isActivatedImpl uid = do + gets $ + maybe False (.activated) + . find ((== uid) . (.id)) + +lookupStatusImpl :: (Member (State [StoredUser]) r) => UserId -> Sem r (Maybe AccountStatus) +lookupStatusImpl uid = do + users <- get + pure $ (.status) =<< (find ((== uid) . (.id)) users) + +lookupHandleImpl :: + (Member (State [StoredUser]) r) => + Handle -> + Sem r (Maybe UserId) +lookupHandleImpl h = do + gets $ + fmap (.id) + . find ((== Just h) . (.handle)) diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserSubsystem.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserSubsystem.hs new file mode 100644 index 00000000000..b47bfbd7d25 --- /dev/null +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserSubsystem.hs @@ -0,0 +1,15 @@ +module Wire.MockInterpreters.UserSubsystem where + +import Data.Qualified +import Imports +import Polysemy +import Wire.API.User +import Wire.UserKeyStore +import Wire.UserSubsystem + +userSubsystemTestInterpreter :: [UserAccount] -> InterpreterFor UserSubsystem r +userSubsystemTestInterpreter initialUsers = + interpret \case + GetLocalUserAccountByUserKey localUserKey -> case (tUnqualified localUserKey) of + EmailKey _ email -> pure $ find (\u -> userEmail u.accountUser == Just email) initialUsers + _ -> error $ "userSubsystemTestInterpreter: implement on demand" diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/VerificationCodeStore.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/VerificationCodeStore.hs new file mode 100644 index 00000000000..73b732e5679 --- /dev/null +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/VerificationCodeStore.hs @@ -0,0 +1,62 @@ +module Wire.MockInterpreters.VerificationCodeStore where + +import Control.Error +import Data.Map qualified as Map +import Data.RetryAfter +import Data.Time +import Imports +import Polysemy +import Polysemy.State +import Wire.Sem.Now as Now +import Wire.VerificationCode +import Wire.VerificationCodeStore + +type ExpiresAt = UTCTime + +type CodeState = Map (Key, Scope) (Code, UTCTime) + +type ThrottleState = Map (Key, Scope) (Word, UTCTime) + +inMemoryVerificationCodeStore :: + forall r. + ( Member Now r, + Member (State CodeState) r, + Member (State ThrottleState) r + ) => + InterpreterFor VerificationCodeStore r +inMemoryVerificationCodeStore = + interpret + \case + InsertCode code -> do + expiresAt <- (addUTCTime code.codeTTL.timeoutDiffTime) <$> Now.get + modify $ Map.insert (code.codeKey, code.codeScope) (code, expiresAt) + LookupCode key scope -> lookupWithExpiry (key, scope) + DeleteCode key scope -> modify @CodeState $ Map.delete (key, scope) + InsertThrottle key scope ttl -> do + expiresAt <- (addUTCTime (fromIntegral ttl)) <$> Now.get + modify $ Map.insert (key, scope) (ttl, expiresAt) + LookupThrottle key scope -> RetryAfter . fromIntegral <$$> lookupWithExpiry (key, scope) + +runInMemoryVerificationCodeStore :: (Member Now r) => InterpreterFor VerificationCodeStore r +runInMemoryVerificationCodeStore = + evalState mempty + . evalState mempty + . inMemoryVerificationCodeStore + . raiseUnder @(State CodeState) + . raiseUnder @(State ThrottleState) + +lookupWithExpiry :: + ( Member Now r, + Member (State (Map k (v, UTCTime))) r, + Ord k + ) => + k -> + Sem r (Maybe v) +lookupWithExpiry k = runMaybeT $ do + (v, expiresAt) <- MaybeT $ gets $ Map.lookup k + now <- lift $ Now.get + if now <= expiresAt + then pure v + else MaybeT $ do + modify $ Map.delete k + pure Nothing diff --git a/libs/wire-subsystems/test/unit/Wire/NotificationSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/NotificationSubsystem/InterpreterSpec.hs index 38bebcabb28..1c633c201ab 100644 --- a/libs/wire-subsystems/test/unit/Wire/NotificationSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/NotificationSubsystem/InterpreterSpec.hs @@ -308,7 +308,7 @@ runMiniStackWithControlledDelay mockConfig delayControl actualPushesRef = do . runControlledDelay delayControl . runInputConst mockConfig -runGundeckAPIAccessFailure :: Member (Embed IO) r => IORef [[V2.Push]] -> Sem (GundeckAPIAccess : r) a -> Sem r a +runGundeckAPIAccessFailure :: (Member (Embed IO) r) => IORef [[V2.Push]] -> Sem (GundeckAPIAccess : r) a -> Sem r a runGundeckAPIAccessFailure pushesRef = interpret $ \action -> do case action of @@ -328,7 +328,7 @@ data TestException = TestException instance Exception TestException -runGundeckAPIAccessIORef :: Member (Embed IO) r => IORef [[V2.Push]] -> Sem (GundeckAPIAccess : r) a -> Sem r a +runGundeckAPIAccessIORef :: (Member (Embed IO) r) => IORef [[V2.Push]] -> Sem (GundeckAPIAccess : r) a -> Sem r a runGundeckAPIAccessIORef pushesRef = interpret \case PushV2 pushes -> modifyIORef pushesRef (<> [pushes]) diff --git a/libs/wire-subsystems/test/unit/Wire/UserStoreSpec.hs b/libs/wire-subsystems/test/unit/Wire/UserStoreSpec.hs index 7a4ca034831..b1cbf972f98 100644 --- a/libs/wire-subsystems/test/unit/Wire/UserStoreSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/UserStoreSpec.hs @@ -16,7 +16,6 @@ spec = do then user.userIdentity === Nothing else (emailIdentity =<< user.userIdentity) === storedUser.email - .&&. (phoneIdentity =<< user.userIdentity) === storedUser.phone .&&. (ssoIdentity =<< user.userIdentity) === storedUser.ssoId prop "user deleted" $ \domain defaultLocale storedUser -> diff --git a/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs index 1e2f399b658..4abd27efd0f 100644 --- a/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs @@ -1,27 +1,40 @@ {-# LANGUAGE OverloadedLists #-} +{-# OPTIONS_GHC -Wno-ambiguous-fields -Wno-incomplete-uni-patterns #-} module Wire.UserSubsystem.InterpreterSpec (spec) where +import Control.Lens.At () import Data.Bifunctor (first) import Data.Coerce import Data.Default (Default (def)) import Data.Domain +import Data.Handle import Data.Id import Data.LegalHold (defUserLegalHoldStatus) +import Data.Map qualified as Map import Data.Qualified import Data.Set qualified as S import Imports +import Polysemy +import Polysemy.Error +import Polysemy.Internal +import Polysemy.State import Test.Hspec import Test.Hspec.QuickCheck import Test.QuickCheck import Wire.API.Federation.Error +import Wire.API.Team.Feature import Wire.API.Team.Member import Wire.API.Team.Permission import Wire.API.User hiding (DeleteUser) +import Wire.API.UserEvent import Wire.MiniBackend import Wire.StoredUser +import Wire.UserKeyStore import Wire.UserSubsystem -import Wire.UserSubsystem.Interpreter +import Wire.UserSubsystem.Error +import Wire.UserSubsystem.HandleBlacklist +import Wire.UserSubsystem.Interpreter (UserSubsystemConfig (..)) spec :: Spec spec = describe "UserSubsystem.Interpreter" do @@ -34,16 +47,15 @@ spec = describe "UserSubsystem.Interpreter" do viewer = viewerTeam {teamId = Nothing} -- Having teams adds complications in email visibility, -- all that stuff is tested in [without federation] tests - localTargetUsers = - S.fromList $ - map (\user -> (coerce user) {teamId = Nothing}) localTargetUsersNotPending + localTargetUsers = map (\user -> (coerce user) {teamId = Nothing}) localTargetUsersNotPending federation = [(remoteDomain1, remoteBackend1), (remoteDomain2, remoteBackend2)] - mkUserIds domain = map (flip Qualified domain . (.id)) . S.toList + mkUserIds domain = map (flip Qualified domain . (.id)) localTargets = mkUserIds localDomain localTargetUsers target1 = mkUserIds remoteDomain1 targetUsers1 target2 = mkUserIds remoteDomain2 targetUsers2 + localBackend = def {users = [viewer] <> localTargetUsers} retrievedProfiles = - runFederationStack ([viewer] <> S.toList localTargetUsers) federation Nothing (UserSubsystemConfig visibility miniLocale) $ + runFederationStack localBackend federation Nothing (UserSubsystemConfig visibility miniLocale) $ getUserProfiles (toLocalUnsafe localDomain viewer.id) (localTargets <> target1 <> target2) @@ -52,7 +64,7 @@ spec = describe "UserSubsystem.Interpreter" do Nothing (mkUserFromStored domain miniLocale targetUser) defUserLegalHoldStatus - | targetUser <- S.toList users + | targetUser <- users ] expectedLocalProfiles = mkExpectedProfiles localDomain localTargetUsers expectedProfiles1 = mkExpectedProfiles remoteDomain1 targetUsers1 @@ -63,23 +75,27 @@ spec = describe "UserSubsystem.Interpreter" do === sortOn (.profileQualifiedId) expectedProfiles prop "fails when a backend is offline or returns an error" $ - \viewer onlineTargetUsers (offlineTargetUsers :: Set StoredUser) visibility localDomain onlineDomain (offlineDomain :: Domain) -> do + \viewer onlineTargetUsers (offlineTargetUsers :: [StoredUser]) visibility localDomain onlineDomain (offlineDomain :: Domain) -> do let onlineRemoteBackend = def {users = onlineTargetUsers} online = [(onlineDomain, onlineRemoteBackend)] - mkUserIds domain users = map (flip Qualified domain . (.id)) (S.toList users) + mkUserIds domain users = map (flip Qualified domain . (.id)) users onlineUsers = mkUserIds onlineDomain onlineTargetUsers offlineUsers = mkUserIds offlineDomain offlineTargetUsers config = UserSubsystemConfig visibility miniLocale - + localBackend = def {users = [viewer]} result = - runFederationStackEither [viewer] online Nothing config $ - getUserProfiles + run + . runErrorUnsafe @UserSubsystemError + . runError @FederationError + . interpretFederationStack localBackend online Nothing config + $ getUserProfiles (toLocalUnsafe localDomain viewer.id) (onlineUsers <> offlineUsers) - localDomain /= offlineDomain && offlineTargetUsers /= [] ==> + + localDomain /= offlineDomain && not (null offlineTargetUsers) ==> -- The FederationError doesn't have an instance -- for Eq because of dependency on HTTP2Error - first (displayException) result + first displayException result === Left (displayException (FederationUnexpectedError "RunFederatedEither")) describe "[without federation]" do @@ -87,7 +103,7 @@ spec = describe "UserSubsystem.Interpreter" do \viewer targetUserIds visibility domain locale -> let config = UserSubsystemConfig visibility locale retrievedProfiles = - runNoFederationStack [] Nothing config $ + runNoFederationStack def Nothing config $ getUserProfiles (toLocalUnsafe domain viewer) (map (`Qualified` domain) targetUserIds) in retrievedProfiles === [] @@ -96,8 +112,9 @@ spec = describe "UserSubsystem.Interpreter" do let teamMember = mkTeamMember viewer.id fullPermissions Nothing defUserLegalHoldStatus targetUser = if sameTeam then targetUserNoTeam {teamId = viewer.teamId} else targetUserNoTeam config = UserSubsystemConfig visibility locale + localBackend = def {users = [targetUser, viewer]} retrievedProfiles = - runNoFederationStack [targetUser, viewer] (Just teamMember) config $ + runNoFederationStack localBackend (Just teamMember) config $ getUserProfiles (toLocalUnsafe domain viewer.id) [Qualified targetUser.id domain] in retrievedProfiles === [ mkUserProfile @@ -111,8 +128,9 @@ spec = describe "UserSubsystem.Interpreter" do let teamMember = mkTeamMember viewer.id fullPermissions Nothing defUserLegalHoldStatus targetUser = if sameTeam then targetUserNoTeam {teamId = viewer.teamId} else targetUserNoTeam config = UserSubsystemConfig visibility locale + localBackend = def {users = [targetUser, viewer]} retrievedProfile = - runNoFederationStack [targetUser, viewer] (Just teamMember) config $ + runNoFederationStack localBackend (Just teamMember) config $ getUserProfiles (toLocalUnsafe domain viewer.id) [Qualified targetUser.id domain] in retrievedProfile === [ mkUserProfile @@ -125,8 +143,9 @@ spec = describe "UserSubsystem.Interpreter" do \viewer (PendingStoredUser targetUser) visibility domain locale -> let teamMember = mkTeamMember viewer.id fullPermissions Nothing defUserLegalHoldStatus config = UserSubsystemConfig visibility locale + localBackend = def {users = [targetUser, viewer]} retrievedProfile = - runNoFederationStack [targetUser, viewer] (Just teamMember) config $ + runNoFederationStack localBackend (Just teamMember) config $ getLocalUserProfiles (toLocalUnsafe domain [targetUser.id]) in retrievedProfile === [] @@ -136,20 +155,17 @@ spec = describe "UserSubsystem.Interpreter" do let remoteBackend = def {users = targetUsers} federation = [(remoteDomain, remoteBackend)] config = UserSubsystemConfig visibility miniLocale + localBackend = def {users = [viewer]} retrievedProfilesWithErrors :: ([(Qualified UserId, FederationError)], [UserProfile]) = - runFederationStack [viewer] federation Nothing config $ + runFederationStack localBackend federation Nothing config $ getUserProfilesWithErrors (toLocalUnsafe domain viewer.id) - ( map (flip Qualified remoteDomain . (.id)) $ - S.toList targetUsers - ) + (map (flip Qualified remoteDomain . (.id)) targetUsers) retrievedProfiles :: [UserProfile] = - runFederationStack [viewer] federation Nothing config $ + runFederationStack localBackend federation Nothing config $ getUserProfiles (toLocalUnsafe domain viewer.id) - ( map (flip Qualified remoteDomain . (.id)) $ - S.toList targetUsers - ) + (map (flip Qualified remoteDomain . (.id)) targetUsers) remoteDomain /= domain ==> counterexample ("Retrieved profiles with errors: " <> show retrievedProfilesWithErrors) do length (fst retrievedProfilesWithErrors) === 0 @@ -160,8 +176,9 @@ spec = describe "UserSubsystem.Interpreter" do \viewer (targetUsers :: Set StoredUser) visibility domain remoteDomain -> do let online = mempty config = UserSubsystemConfig visibility miniLocale + localBackend = def {users = [viewer]} retrievedProfilesWithErrors :: ([(Qualified UserId, FederationError)], [UserProfile]) = - runFederationStack [viewer] online Nothing config $ + runFederationStack localBackend online Nothing config $ getUserProfilesWithErrors (toLocalUnsafe domain viewer.id) ( map (flip Qualified remoteDomain . (.id)) $ @@ -176,14 +193,308 @@ spec = describe "UserSubsystem.Interpreter" do let remoteBackendA = def {users = targetUsers} online = [(remoteDomainA, remoteBackendA)] allDomains = [domain, remoteDomainA, remoteDomainB] - remoteAUsers = map (flip Qualified remoteDomainA . (.id)) (S.toList targetUsers) - remoteBUsers = map (flip Qualified remoteDomainB . (.id)) (S.toList targetUsers) + remoteAUsers = map (flip Qualified remoteDomainA . (.id)) targetUsers + remoteBUsers = map (flip Qualified remoteDomainB . (.id)) targetUsers config = UserSubsystemConfig visibility miniLocale + localBackend = def {users = [viewer]} retrievedProfilesWithErrors :: ([(Qualified UserId, FederationError)], [UserProfile]) = - runFederationStack [viewer] online Nothing config $ + runFederationStack localBackend online Nothing config $ getUserProfilesWithErrors (toLocalUnsafe domain viewer.id) (remoteAUsers <> remoteBUsers) nub allDomains == allDomains ==> length (fst retrievedProfilesWithErrors) === length remoteBUsers .&&. length (snd retrievedProfilesWithErrors) === length remoteAUsers + + describe "getSelfProfile" $ do + prop "should retrieve a user which exists in the DB" \storedSelf otherStoredUsers domain config -> + let localBackend = def {users = storedSelf : filter (\u -> u.id /= storedSelf.id) otherStoredUsers} + retrievedProfile = + runNoFederationStack localBackend Nothing config $ + getSelfProfile (toLocalUnsafe domain storedSelf.id) + in retrievedProfile === Just (SelfProfile $ mkUserFromStored domain config.defaultLocale storedSelf) + + prop "should fail when the user does not exist in the DB" \selfId otherStoredUsers domain config -> + let localBackend = def {users = filter (\u -> u.id /= selfId) otherStoredUsers} + retrievedProfile = + runNoFederationStack localBackend Nothing config $ + getSelfProfile (toLocalUnsafe domain selfId) + in retrievedProfile === Nothing + + prop "should mark user as managed by scim if E2EId is enabled for the user and they have a handle" \storedSelf domain susbsystemConfig mlsE2EIdConfig -> + let localBackend = def {users = [storedSelf]} + allFeatureConfigs = def {afcMlsE2EId = withStatus FeatureStatusEnabled LockStatusUnlocked mlsE2EIdConfig FeatureTTLUnlimited} + SelfProfile retrievedUser = + fromJust + . runAllErrorsUnsafe + . interpretNoFederationStack localBackend Nothing allFeatureConfigs susbsystemConfig + $ getSelfProfile (toLocalUnsafe domain storedSelf.id) + expectedManagedBy = case storedSelf.handle of + Nothing -> fromMaybe ManagedByWire storedSelf.managedBy + Just _ -> ManagedByScim + in retrievedUser.userManagedBy === expectedManagedBy + + describe "updateUserProfile" $ do + prop "Update user" $ + \(NotPendingStoredUser alice) localDomain update config -> do + let lusr = toLocalUnsafe localDomain alice.id + localBackend = def {users = [alice {managedBy = Just ManagedByWire}]} + userBeforeUpdate = mkUserFromStored localDomain config.defaultLocale alice + (SelfProfile userAfterUpdate) = fromJust $ runNoFederationStack localBackend Nothing config do + updateUserProfile lusr Nothing UpdateOriginScim update + getSelfProfile lusr + in userAfterUpdate.userQualifiedId === tUntagged lusr + .&&. userAfterUpdate.userDisplayName === fromMaybe userBeforeUpdate.userDisplayName update.name + .&&. userAfterUpdate.userPict === fromMaybe userBeforeUpdate.userPict update.pict + .&&. userAfterUpdate.userAssets === fromMaybe userBeforeUpdate.userAssets update.assets + .&&. userAfterUpdate.userAccentId === fromMaybe userBeforeUpdate.userAccentId update.accentId + .&&. userAfterUpdate.userLocale === fromMaybe userBeforeUpdate.userLocale update.locale + + prop "Update user events" $ + \(NotPendingStoredUser alice) localDomain update config -> do + let lusr = toLocalUnsafe localDomain alice.id + localBackend = def {users = [alice {managedBy = Just ManagedByWire}]} + events = runNoFederationStack localBackend Nothing config do + updateUserProfile lusr Nothing UpdateOriginScim update + get @[MiniEvent] + in events + === [ MkMiniEvent + alice.id + ( UserUpdated $ + (emptyUserUpdatedData alice.id) + { eupName = update.name, + eupPict = update.pict, + eupAccentId = update.accentId, + eupAssets = update.assets, + eupLocale = update.locale, + eupSupportedProtocols = update.supportedProtocols + } + ) + ] + + describe "user managed by scim doesn't allow certain update operations, but allows others" $ do + prop "happy" $ + \(NotPendingStoredUser alice) localDomain update config -> + let lusr = toLocalUnsafe localDomain alice.id + localBackend = def {users = [alice {managedBy = Just ManagedByScim}]} + profileErr :: Either UserSubsystemError (Maybe UserProfile) = + run + . runErrorUnsafe + . runError + $ interpretNoFederationStack localBackend Nothing def config do + updateUserProfile lusr Nothing UpdateOriginWireClient update {name = Nothing, locale = Nothing} + getUserProfile lusr (tUntagged lusr) + in counterexample (show profileErr) $ isRight profileErr === True + + prop "name" $ + \(NotPendingStoredUser alice) localDomain name config -> + alice.name /= name ==> + let lusr = toLocalUnsafe localDomain alice.id + localBackend = def {users = [alice {managedBy = Just ManagedByScim}]} + profileErr :: Either UserSubsystemError (Maybe UserProfile) = + run + . runErrorUnsafe + . runError + $ interpretNoFederationStack localBackend Nothing def config do + updateUserProfile lusr Nothing UpdateOriginWireClient def {name = Just name} + getUserProfile lusr (tUntagged lusr) + in profileErr === Left UserSubsystemDisplayNameManagedByScim + + prop "locale" $ + \(NotPendingStoredUser alice) localDomain locale config -> + alice.locale /= Just locale ==> + let lusr = toLocalUnsafe localDomain alice.id + localBackend = def {users = [alice {managedBy = Just ManagedByScim}]} + profileErr :: Either UserSubsystemError (Maybe UserProfile) = + run + . runErrorUnsafe + . runError + $ interpretNoFederationStack localBackend Nothing def config do + updateUserProfile lusr Nothing UpdateOriginWireClient def {locale = Just locale} + getUserProfile lusr (tUntagged lusr) + in profileErr === Left UserSubsystemLocaleManagedByScim + + prop + "if e2e identity is activated, the user name cannot be updated" + \(NotPendingStoredUser alice) localDomain (newName :: Name) config -> + (alice.name /= newName) ==> + let lusr = toLocalUnsafe localDomain alice.id + localBackend = def {users = [alice]} + profileErr :: Either UserSubsystemError (Maybe UserProfile) = + run + . runErrorUnsafe + . runError + $ interpretNoFederationStack localBackend Nothing def {afcMlsE2EId = setStatus FeatureStatusEnabled defFeatureStatus} config do + updateUserProfile lusr Nothing UpdateOriginScim (def {name = Just newName}) + getUserProfile lusr (tUntagged lusr) + in profileErr === Left UserSubsystemDisplayNameManagedByScim + + prop + "CheckHandle succeeds if there is a user with that handle" + \((NotPendingStoredUser alice, handle :: Handle), config) -> + not (isBlacklistedHandle handle) ==> + let localBackend = def {users = [alice {managedBy = Just ManagedByWire, handle = Just handle}]} + checkHandleResp = + runNoFederationStack localBackend Nothing config $ checkHandle (fromHandle handle) + in checkHandleResp === CheckHandleFound + + prop + "CheckHandle fails if there is no user with that handle" + \(handle :: Handle, config) -> + not (isBlacklistedHandle handle) ==> + let localBackend = def {users = []} + checkHandleResp = + runNoFederationStack localBackend Nothing config $ checkHandle (fromHandle handle) + in checkHandleResp === CheckHandleNotFound + + prop + "CheckHandles returns available handles from a list of handles, up to X" + \((storedUsersAndHandles :: [(StoredUser, Handle)], randomHandles :: Set Handle), maxCount :: Word, config) -> + not (any isBlacklistedHandle ((snd <$> storedUsersAndHandles) <> (S.toList randomHandles))) ==> + let users = (\(u, h) -> u {handle = Just h, managedBy = Just ManagedByWire}) <$> storedUsersAndHandles + localBackend = def {users = users} + + runCheckHandles :: [Handle] -> [Handle] + runCheckHandles handles = runNoFederationStack localBackend Nothing config do + checkHandles handles maxCount + + takenHandles = snd <$> storedUsersAndHandles + freeHandles = runCheckHandles (S.toList randomHandles) + in runCheckHandles takenHandles === [] + .&&. freeHandles `intersect` takenHandles === mempty + .&&. counterexample (show (freeHandles, maxCount)) (length freeHandles <= fromIntegral maxCount) + .&&. counterexample (show (freeHandles, randomHandles)) ((S.fromList freeHandles) `S.isSubsetOf` randomHandles) + + describe "Scim+UpdateProfileUpdate" do + prop + "Updating handles fails when UpdateOriginWireClient" + \(alice, newHandle :: Handle, domain, config) -> + not (isBlacklistedHandle newHandle) ==> + let res :: Either UserSubsystemError () + res = run + . runErrorUnsafe + . runError + $ interpretNoFederationStack localBackend Nothing def config do + updateHandle (toLocalUnsafe domain alice.id) Nothing UpdateOriginWireClient (fromHandle newHandle) + + localBackend = def {users = [alice {managedBy = Just ManagedByScim}]} + in res === Left UserSubsystemHandleManagedByScim + + prop + "Updating handles succeeds when UpdateOriginScim" + \(alice, ssoId, email :: Maybe Email, fromHandle -> newHandle, domain, config) -> + not (isBlacklistedHandle (fromJust (parseHandle newHandle))) ==> + let res :: Either UserSubsystemError () = run + . runErrorUnsafe + . runError + $ interpretNoFederationStack localBackend Nothing def config do + updateHandle (toLocalUnsafe domain alice.id) Nothing UpdateOriginScim newHandle + localBackend = + def + { users = + [ alice + { managedBy = Just ManagedByScim, + email = email, + ssoId = Just ssoId, + activated = True + } + ] + } + in res === Right () + + prop + "update valid handles succeeds" + \(storedUser :: StoredUser, newHandle@(fromHandle -> rawNewHandle), config) -> + (isJust storedUser.identity && not (isBlacklistedHandle newHandle)) ==> + let updateResult :: Either UserSubsystemError () = run + . runErrorUnsafe + . runError + $ interpretNoFederationStack (def {users = [storedUser]}) Nothing def config do + let luid = toLocalUnsafe dom storedUser.id + dom = Domain "localdomain" + updateHandle luid Nothing UpdateOriginScim rawNewHandle + in updateResult === Right () + + prop + "update invalid handles fails" + \(storedUser :: StoredUser, BadHandle badHandle, config) -> + isJust storedUser.identity ==> + let updateResult :: Either UserSubsystemError () = run + . runErrorUnsafe + . runError + $ interpretNoFederationStack localBackend Nothing def config do + let luid = toLocalUnsafe dom storedUser.id + dom = Domain "localdomain" + updateHandle luid Nothing UpdateOriginScim badHandle + localBackend = def {users = [storedUser]} + in updateResult === Left UserSubsystemInvalidHandle + + prop "update / read supported-protocols" \(storedUser, config, newSupportedProtocols) -> + not (hasPendingInvitation storedUser) ==> + let luid :: Local UserId + luid = toLocalUnsafe dom storedUser.id + where + dom = Domain "localdomain" + + operation :: (Monad m) => Sem (MiniBackendEffects `Append` AllErrors) a -> m a + operation op = result `seq` pure result + where + result = runNoFederationStack localBackend Nothing config op + localBackend = def {users = [storedUser]} + + actualSupportedProtocols = runIdentity $ operation do + () <- updateUserProfile luid Nothing UpdateOriginWireClient (def {supportedProtocols = Just newSupportedProtocols}) + profileSupportedProtocols . fromJust <$> getUserProfile luid (tUntagged luid) + + expectedSupportedProtocols = + if S.null newSupportedProtocols + then defSupportedProtocols + else newSupportedProtocols + in actualSupportedProtocols === expectedSupportedProtocols + + describe "getLocalUserAccountByUserKey" $ do + prop "gets users iff they are indexed by the UserKeyStore" $ + \(config :: UserSubsystemConfig) (localDomain :: Domain) (storedUser :: StoredUser) (userKey :: EmailKey) -> + let localBackend = + def + { users = [storedUser], + userKeys = Map.singleton userKey storedUser.id + } + retrievedUser = + run + . runErrorUnsafe + . runErrorUnsafe @UserSubsystemError + . interpretNoFederationStack localBackend Nothing def config + $ getLocalUserAccountByUserKey (toLocalUnsafe localDomain userKey) + in retrievedUser === Just (mkAccountFromStored localDomain config.defaultLocale storedUser) + + prop "doesn't get users if they are not indexed by the UserKeyStore" $ + \(config :: UserSubsystemConfig) (localDomain :: Domain) (storedUserNoEmail :: StoredUser) (email :: Email) -> + let localBackend = + def + { users = [storedUser], + userKeys = mempty + } + storedUser = storedUserNoEmail {email = Just email} + retrievedUser = + run + . runErrorUnsafe + . runErrorUnsafe @UserSubsystemError + . interpretNoFederationStack localBackend Nothing def config + $ getLocalUserAccountByUserKey (toLocalUnsafe localDomain (mkEmailKey email)) + in retrievedUser === Nothing + + prop "doesn't get users if they are not present in the UserStore but somehow are still indexed in UserKeyStore" $ + \(config :: UserSubsystemConfig) (localDomain :: Domain) (nonExistentUserId :: UserId) (userKey :: EmailKey) -> + let localBackend = + def + { users = [], + userKeys = Map.singleton userKey nonExistentUserId + } + retrievedUser = + run + . runErrorUnsafe + . runErrorUnsafe @UserSubsystemError + . interpretNoFederationStack localBackend Nothing def config + $ getLocalUserAccountByUserKey (toLocalUnsafe localDomain userKey) + in retrievedUser === Nothing diff --git a/libs/wire-subsystems/test/unit/Wire/VerificationCodeSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/VerificationCodeSubsystem/InterpreterSpec.hs new file mode 100644 index 00000000000..20ffabf6270 --- /dev/null +++ b/libs/wire-subsystems/test/unit/Wire/VerificationCodeSubsystem/InterpreterSpec.hs @@ -0,0 +1,200 @@ +module Wire.VerificationCodeSubsystem.InterpreterSpec where + +import Data.Time +import Imports +import Polysemy +import Polysemy.Error +import Polysemy.Input +import Polysemy.State +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck +import Wire.MockInterpreters +import Wire.Sem.Now +import Wire.Sem.Random +import Wire.VerificationCode +import Wire.VerificationCodeGen +import Wire.VerificationCodeStore +import Wire.VerificationCodeSubsystem as Subsystem +import Wire.VerificationCodeSubsystem.Interpreter + +spec :: Spec +spec = describe "Wire.VerificationCodeSubsystem.Interpreter" $ do + describe "createCode/verifyCode" $ do + prop "should be able to create and verify codes" $ + \gen scope retries (abs -> timeout) mId throttle -> + let eitherProp = + runDependencies throttle + . interpretVerificationCodeSubsystem + $ do + c <- createCode gen scope retries timeout mId + case c of + Left (CodeAlreadyExists code) -> pure $ unexpectedCodeAlreadyExists code + Right code -> do + mCode <- verifyCode gen.genKey scope code.codeValue + pure $ retries > 0 ==> mCode === Just code + in assertRightProp eitherProp + + prop "should only allow verification with the same scope" $ + \gen scope retries (abs -> timeout) mId throttle arbitraryScope -> + let eitherProp = + runDependencies throttle + . interpretVerificationCodeSubsystem + $ do + c <- createCode gen scope retries timeout mId + case c of + Left (CodeAlreadyExists code) -> pure $ unexpectedCodeAlreadyExists code + Right code -> do + mCode <- verifyCode gen.genKey arbitraryScope code.codeValue + pure $ retries > 0 && arbitraryScope /= scope ==> mCode === Nothing + in assertRightProp eitherProp + + prop "should only allow verification with correct value" $ + \gen scope retries (abs -> timeout) mId throttle arbitraryVal -> + let eitherProp = + runDependencies throttle + . interpretVerificationCodeSubsystem + $ do + c <- createCode gen scope retries timeout mId + case c of + Left (CodeAlreadyExists code) -> pure $ unexpectedCodeAlreadyExists code + Right code -> do + mCode <- verifyCode gen.genKey scope arbitraryVal + pure $ retries > 0 && arbitraryVal /= code.codeValue ==> mCode === Nothing + in assertRightProp eitherProp + + prop "should allow retries" $ + \gen scope retries (abs -> timeout) mId throttle arbitraryVal -> + let eitherProp = + runDependencies throttle + . interpretVerificationCodeSubsystem + $ do + c <- createCode gen scope retries timeout mId + case c of + Left (CodeAlreadyExists code) -> pure $ unexpectedCodeAlreadyExists code + Right code -> do + codesWithArbitraryVal <- + catMaybes + <$> replicateM + (fromIntegral retries - 1) + (verifyCode gen.genKey scope arbitraryVal) + mCodeWithCorrectVal <- verifyCode gen.genKey scope code.codeValue + pure $ + retries > 1 && arbitraryVal /= code.codeValue ==> + codesWithArbitraryVal === [] + .&&. mCodeWithCorrectVal === Just (code {codeRetries = 1}) + in assertRightProp eitherProp + + prop "should only allow given number of retries" $ + \gen scope retries (abs -> timeout) mId throttle arbitraryVal -> + let eitherProp = + runDependencies throttle + . interpretVerificationCodeSubsystem + $ do + c <- createCode gen scope retries timeout mId + case c of + Left (CodeAlreadyExists code) -> pure $ unexpectedCodeAlreadyExists code + Right code -> do + codesWithArbitraryVal <- + catMaybes + <$> replicateM + (fromIntegral retries) + (verifyCode gen.genKey scope arbitraryVal) + mCodeWithCorrectVal <- verifyCode gen.genKey scope code.codeValue + pure $ + retries > 0 && arbitraryVal /= code.codeValue ==> + codesWithArbitraryVal === [] + .&&. mCodeWithCorrectVal === Nothing + in assertRightProp eitherProp + + describe "createCode" $ do + prop "should only allow one code at a time per (key, scope)" $ do + \gen scope retries (abs -> timeout) mId throttle -> + let eitherProp = + runDependencies throttle + . interpretVerificationCodeSubsystem + $ do + c1 <- createCode gen scope retries timeout mId + case c1 of + Left (CodeAlreadyExists code) -> pure $ unexpectedCodeAlreadyExists code + Right code -> do + c2 <- createCode gen scope retries timeout mId + pure $ c2 === Left (CodeAlreadyExists code) + in assertRightProp eitherProp + + describe "createCode/deleteCode/verifyCode" $ do + prop "should not allow verification using a deleted code" $ do + \gen scope retries (abs -> timeout) mId throttle -> + let eitherProp = + runDependencies throttle + . interpretVerificationCodeSubsystem + $ do + c <- createCode gen scope retries timeout mId + case c of + Left (CodeAlreadyExists code) -> pure $ unexpectedCodeAlreadyExists code + Right code -> do + Subsystem.deleteCode gen.genKey scope + mCode <- verifyCode gen.genKey scope code.codeValue + pure $ mCode === Nothing + in assertRightProp eitherProp + + describe "createCodeOverwritePrevious/verifyCode" $ do + prop "should allow creating code for the same scope and key, making previous code invalid" $ do + \gen scope retries (abs -> timeout) mId throttle -> + let eitherProp = + runDependencies throttle + . interpretVerificationCodeSubsystem + $ do + code1 <- createCodeOverwritePrevious gen scope retries timeout mId + passTime (fromIntegral throttle + 1) + code2 <- createCodeOverwritePrevious gen scope retries timeout mId + mCode1 <- verifyCode gen.genKey scope code1.codeValue + mCode2 <- verifyCode gen.genKey scope code2.codeValue + pure $ retries > 1 ==> mCode1 === Nothing .&&. mCode2 === Just (code2 {codeRetries = retries - 1}) + in assertRightProp eitherProp + + prop "should throttle creating codes " $ do + \gen scope retries (abs -> timeout) mId ((+ 1) -> throttle) -> + let eitherProp = + runDependencies throttle + . interpretVerificationCodeSubsystem + $ do + code <- createCodeOverwritePrevious gen scope retries timeout mId + mErrThrottled1 <- catchExpectedError $ createCodeOverwritePrevious gen scope retries timeout mId + mCode1 <- verifyCode gen.genKey scope code.codeValue + Subsystem.deleteCode gen.genKey scope + mErrThrottled2 <- catchExpectedError $ createCodeOverwritePrevious gen scope retries timeout mId + let expectedErr = Just $ VerificationCodeThrottled $ fromIntegral throttle + pure $ + mErrThrottled1 === expectedErr + .&&. mErrThrottled2 === expectedErr + .&&. (retries > 1 ==> mCode1 === Just code) + in assertRightProp eitherProp + + describe "internalLookupCode" $ do + prop "should allow looking up code by scope and key" $ do + \gen scope retries (abs -> timeout) mId throttle -> + let eitherProp = + runDependencies throttle + . interpretVerificationCodeSubsystem + $ do + code1 <- createCodeOverwritePrevious gen scope retries timeout mId + lookedUpCode <- internalLookupCode gen.genKey scope + pure $ lookedUpCode === Just code1 + in assertRightProp eitherProp + +runDependencies :: VerificationCodeThrottleTTL -> Sem '[Input VerificationCodeThrottleTTL, VerificationCodeStore, Now, State UTCTime, Random, Error e] a -> Either e a +runDependencies throttle = + run + . runError + . runRandomPure + . evalState defaultTime + . interpretNowAsState + . runInMemoryVerificationCodeStore + . runInputConst throttle + +assertRightProp :: (Show e) => Either e Property -> Property +assertRightProp = either (\e -> counterexample ("unexpected error: " <> show e) False) id + +unexpectedCodeAlreadyExists :: Code -> Property +unexpectedCodeAlreadyExists code = counterexample ("code shouldn't already exist, but exists: " <> show code) False diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index c959beac511..a603df5d43f 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -69,31 +69,60 @@ library -- cabal-fmt: expand src exposed-modules: + Wire.AuthenticationSubsystem + Wire.AuthenticationSubsystem.Error + Wire.AuthenticationSubsystem.Interpreter + Wire.AWS Wire.DeleteQueue Wire.DeleteQueue.InMemory + Wire.EmailSending + Wire.EmailSending.SES + Wire.EmailSending.SMTP + Wire.EmailSubsystem + Wire.EmailSubsystem.Interpreter + Wire.EmailSubsystem.Template + Wire.Error Wire.FederationAPIAccess Wire.FederationAPIAccess.Interpreter Wire.GalleyAPIAccess Wire.GalleyAPIAccess.Rpc Wire.GundeckAPIAccess + Wire.HashPassword Wire.InternalEvent - Wire.MiniBackend Wire.NotificationSubsystem Wire.NotificationSubsystem.Interpreter Wire.ParseException + Wire.PasswordResetCodeStore + Wire.PasswordResetCodeStore.Cassandra + Wire.PasswordStore + Wire.PasswordStore.Cassandra Wire.Rpc + Wire.SessionStore + Wire.SessionStore.Cassandra Wire.StoredUser + Wire.UserEvents + Wire.UserKeyStore + Wire.UserKeyStore.Cassandra Wire.UserStore Wire.UserStore.Cassandra + Wire.UserStore.Unique Wire.UserSubsystem + Wire.UserSubsystem.Error + Wire.UserSubsystem.HandleBlacklist Wire.UserSubsystem.Interpreter + Wire.VerificationCode + Wire.VerificationCodeGen + Wire.VerificationCodeStore + Wire.VerificationCodeStore.Cassandra + Wire.VerificationCodeSubsystem + Wire.VerificationCodeSubsystem.Interpreter hs-source-dirs: src build-depends: , aeson , amazonka , amazonka-core - , amazonka-sqs + , amazonka-ses , async , base , base16-bytestring @@ -103,41 +132,53 @@ library , cassandra-util , containers , cql + , crypton , currency-codes , data-default + , data-timeout , errors , exceptions , extended , extra , gundeck-types + , HaskellNet + , HaskellNet-SSL , HsOpenSSL , hspec + , html-entities , http-client , http-types , http2-manager , imports , iso639 , lens + , memory , mime , mime-mail + , network , network-conduit-tls , polysemy , polysemy-plugin , polysemy-time , polysemy-wire-zoo , QuickCheck + , resource-pool , resourcet , retry , servant , servant-client-core , stomp-queue + , template , text , time + , time-out + , time-units , tinylog , transformers , transitive-anns , types-common , unliftio + , unordered-containers , uuid , wai-utilities , wire-api @@ -156,9 +197,27 @@ test-suite wire-subsystems-tests -- cabal-fmt: expand test/unit other-modules: Spec + Wire.AuthenticationSubsystem.InterpreterSpec + Wire.MiniBackend + Wire.MockInterpreters + Wire.MockInterpreters.EmailSubsystem + Wire.MockInterpreters.Error + Wire.MockInterpreters.GalleyAPIAccess + Wire.MockInterpreters.HashPassword + Wire.MockInterpreters.Now + Wire.MockInterpreters.PasswordResetCodeStore + Wire.MockInterpreters.PasswordStore + Wire.MockInterpreters.Random + Wire.MockInterpreters.SessionStore + Wire.MockInterpreters.UserEvents + Wire.MockInterpreters.UserKeyStore + Wire.MockInterpreters.UserStore + Wire.MockInterpreters.UserSubsystem + Wire.MockInterpreters.VerificationCodeStore Wire.NotificationSubsystem.InterpreterSpec Wire.UserStoreSpec Wire.UserSubsystem.InterpreterSpec + Wire.VerificationCodeSubsystem.InterpreterSpec build-tool-depends: hspec-discover:hspec-discover build-depends: @@ -168,21 +227,32 @@ test-suite wire-subsystems-tests , bilge , bytestring , containers + , crypton , data-default + , errors , extended , gundeck-types , hspec , imports , iso639 + , lens + , mime-mail + , network + , pipes , polysemy , polysemy-plugin , polysemy-time , polysemy-wire-zoo + , postie , QuickCheck , quickcheck-instances + , random , servant-client-core + , streaming-commons , string-conversions + , text , time + , tinylog , transformers , types-common , wire-api diff --git a/libs/zauth/main/Main.hs b/libs/zauth/main/Main.hs index 16aacc4b56f..90ddb9a0a0d 100644 --- a/libs/zauth/main/Main.hs +++ b/libs/zauth/main/Main.hs @@ -123,7 +123,7 @@ tkn xs f = fromMaybe (error "Failed to read token") . f $ headDef "missing token uuid :: ByteString -> UUID uuid s = fromMaybe (error $ "Invalid UUID: " ++ show s) $ fromASCIIBytes s -check' :: ToByteString a => ByteString -> Token a -> IO () +check' :: (ToByteString a) => ByteString -> Token a -> IO () check' k t = exceptT (\e -> putStrLn e >> exitFailure) (const $ pure ()) $ do p <- hoistEither $ PublicKey <$> decode k e <- liftIO $ runValidate (V.mkEnv p (replicate (t ^. header . key) p)) (check t) diff --git a/libs/zauth/src/Data/ZAuth/Creation.hs b/libs/zauth/src/Data/ZAuth/Creation.hs index 7a63a68e4a7..f7dfda93d17 100644 --- a/libs/zauth/src/Data/ZAuth/Creation.hs +++ b/libs/zauth/src/Data/ZAuth/Creation.hs @@ -155,12 +155,12 @@ providerToken dur pid = do d <- expiry dur newToken d P Nothing (mkProvider pid) -renewToken :: ToByteString a => Integer -> Header -> a -> Create (Token a) +renewToken :: (ToByteString a) => Integer -> Header -> a -> Create (Token a) renewToken dur hdr bdy = do d <- expiry dur newToken d (hdr ^. typ) (hdr ^. tag) bdy -newToken :: ToByteString a => POSIXTime -> Type -> Maybe Tag -> a -> Create (Token a) +newToken :: (ToByteString a) => POSIXTime -> Type -> Maybe Tag -> a -> Create (Token a) newToken ti ty ta a = do k <- Create $ asks keyIdx let h = mkHeader tokenVersion k (floor ti) ty ta @@ -170,10 +170,10 @@ newToken ti ty ta a = do ----------------------------------------------------------------------------- -- Internal -signToken :: ToByteString a => Header -> a -> Create Signature +signToken :: (ToByteString a) => Header -> a -> Create Signature signToken h a = Create $ do f <- (! (h ^. key - 1)) <$> asks zSign liftIO . f . toStrict . toLazyByteString $ writeData h a -expiry :: MonadIO m => Integer -> m POSIXTime +expiry :: (MonadIO m) => Integer -> m POSIXTime expiry d = (fromInteger d +) <$> liftIO getPOSIXTime diff --git a/libs/zauth/src/Data/ZAuth/Token.hs b/libs/zauth/src/Data/ZAuth/Token.hs index 561878ce0bb..f87a314a6d0 100644 --- a/libs/zauth/src/Data/ZAuth/Token.hs +++ b/libs/zauth/src/Data/ZAuth/Token.hs @@ -233,7 +233,7 @@ instance FromByteString (Token LegalHoldUser) where Nothing -> fail "Invalid user token" Just t -> pure t -instance ToByteString a => ToByteString (Token a) where +instance (ToByteString a) => ToByteString (Token a) where builder = writeToken ----------------------------------------------------------------------------- @@ -331,13 +331,13 @@ readLegalHoldUserBody t = LegalHoldUser <$> readUserBody t ----------------------------------------------------------------------------- -- Writing -writeToken :: ToByteString a => Token a -> Builder +writeToken :: (ToByteString a) => Token a -> Builder writeToken t = byteString (encode (sigBytes (t ^. signature))) <> dot <> writeData (t ^. header) (t ^. body) -writeData :: ToByteString a => Header -> a -> Builder +writeData :: (ToByteString a) => Header -> a -> Builder writeData h a = writeHeader h <> dot <> builder a writeHeader :: Header -> Builder @@ -402,7 +402,7 @@ instance ToByteString Type where instance ToByteString Tag where builder S = char8 's' -field :: ToByteString a => LByteString -> a -> Builder +field :: (ToByteString a) => LByteString -> a -> Builder field k v = builder k <> eq <> builder v dot, eq :: Builder diff --git a/libs/zauth/src/Data/ZAuth/Validation.hs b/libs/zauth/src/Data/ZAuth/Validation.hs index f6289c4b67d..ca0283e642e 100644 --- a/libs/zauth/src/Data/ZAuth/Validation.hs +++ b/libs/zauth/src/Data/ZAuth/Validation.hs @@ -73,7 +73,7 @@ newtype Validate a = Validate mkEnv :: PublicKey -> [PublicKey] -> Env mkEnv k kk = Env $ Vec.fromList (map verifyWith (k : kk)) -runValidate :: MonadIO m => Env -> Validate a -> m (Either Failure a) +runValidate :: (MonadIO m) => Env -> Validate a -> m (Either Failure a) runValidate v m = liftIO $ runReaderT (runExceptT (valid m)) v validateUser :: ByteString -> Validate (Token User) @@ -112,7 +112,7 @@ validate (Just c) (Just t) = do throwError Invalid pure a -check :: ToByteString a => Token a -> Validate (Token a) +check :: (ToByteString a) => Token a -> Validate (Token a) check t = do ff <- Validate $ lift $ asks verifyFns let dat = toByteString' $ writeData (t ^. header) (t ^. body) @@ -130,5 +130,5 @@ check t = do throwError Expired pure t -now :: MonadIO m => m Integer +now :: (MonadIO m) => m Integer now = floor <$> liftIO getPOSIXTime diff --git a/nix/haskell-pins.nix b/nix/haskell-pins.nix index 1b3c0b97ae5..3cc68c3effc 100644 --- a/nix/haskell-pins.nix +++ b/nix/haskell-pins.nix @@ -36,7 +36,7 @@ # and update the 'rev' field of the pin under 'gitPins'. # # 2. Update 'sha256' field under `fetchgit` to be an empty string. (This step is optional: -# since the hash has changed, the error will be the same if you remove it or if you leave the +# since the sha256 has changed, the error will be the same if you remove it or if you leave the # old value in place.) # # 3. Run step 3. from how to add a git pin. @@ -66,8 +66,8 @@ let transitive-anns = { src = fetchgit { url = "https://github.com/wireapp/transitive-anns"; - rev = "95ee8b5f9c47fe04f8f0d1321f0ade261ab9af54"; - sha256 = "sha256-8NEAHkCBlGO6xnG2K3Lllb2xiCHSYf/dSV1YrmBkOW8="; + rev = "5e0cad1f411a0c92e6445404c205ddd4a0229c4d"; + hash = "sha256-/P4KJ4yZgqhZhzmg1GcE+Ti4kdsWUQX8q++RhgCUDKI="; }; }; @@ -75,15 +75,16 @@ let src = fetchgit { url = "https://github.com/wireapp/cryptobox-haskell"; rev = "7546a1a25635ef65183e3d44c1052285e8401608"; - sha256 = "0dgizj1kc135yzzqdf5l7f5ax0qpvrr8mxvg7s1dbm01cf11aqzn"; + hash = "sha256-9mMVgmMB1NWCPm/3inLeF4Ouiju0uIb/92UENoP88TU="; }; }; + # FIXME(mangoiv): should be merged https://github.com/wireapp/saml2-web-sso/pull/86 saml2-web-sso = { src = fetchgit { url = "https://github.com/wireapp/saml2-web-sso"; - rev = "0cf23a87b140ba5b960a848ecad3976e6fdaac88"; - sha256 = "sha256-Gm58Yjt5ZGh74cfEjcZSx6jvwkpFC324xTPLhLS29r0="; + rev = "9474485e6ed45930b75524f97633f7e036fc0273"; + hash = "sha256-TkULURVk7lDHXpbXREwowxFoiUp2VSVZWjr9KF48170="; }; }; @@ -95,7 +96,19 @@ let src = fetchgit { url = "https://github.com/wireapp/bloodhound"; rev = "abf819a4a6ec7601f1e58cb8da13b2fdad377d9e"; - sha256 = "sha256-m1O+F/mOJN5z5WNChmeyHP4dtmLRkl2YnLlTuwzRelk="; + hash = "sha256-m1O+F/mOJN5z5WNChmeyHP4dtmLRkl2YnLlTuwzRelk="; + }; + }; + + # PR: https://github.com/kazu-yamamoto/crypton-certificate/pull/8 + crypton-certificates = { + src = fetchgit { + url = "https://github.com/akshaymankar/hs-certificate"; + rev = "9e293695d8ca5efc513ee0082ae955ff9b32eb6b"; + hash = "sha256-mD5Dvuzol3K9CNNSfa2L9ir9AbrQ8HJc0QNmkK3qBWk="; + }; + packages = { + "crypton-x509-validation" = "x509-validation"; }; }; @@ -104,24 +117,27 @@ let src = fetchgit { url = "https://github.com/wireapp/HaskellNet-SSL"; rev = "c2844b63a39f458ffbfe62f2ac824017f1f84453"; - sha256 = "sha256-1mu/yEAWr3POY4MHRomum0DDvs5Qty1JvP3v5GS2u64="; + hash = "sha256-1mu/yEAWr3POY4MHRomum0DDvs5Qty1JvP3v5GS2u64="; }; }; + # PR https://github.com/dylex/hsaml2/pull/20 hsaml2 = { src = fetchgit { - url = "https://github.com/dylex/hsaml2"; - rev = "95d9dc7502c2533f7927de00cbc2bd20ad989ace"; - sha256 = "sha256-z3s/ZkkCd2ThVBsu72pS/+XygHImuffz/HVy3hkQ6eo="; + url = "https://github.com/mangoiv/hsaml2"; + rev = "d35f92a3253d146c92caf371b90eb4889841918a"; + hash = "sha256-gufEAC7fFqafG8dXkGIOSfAcVv+ZWkawmBgUV+Ics2s="; }; }; # PR: https://github.com/informatikr/hedis/pull/224 + # PR: https://github.com/informatikr/hedis/pull/226 + # PR: https://github.com/informatikr/hedis/pull/227 hedis = { src = fetchgit { url = "https://github.com/wireapp/hedis"; - rev = "81cdd8a2350b96168a06662c2601a41141a19f2d"; - sha256 = "sha256-0g6x9UOUq7s5ClnxMXvjYR2AsWNA6ymv1tYlQC44hGs="; + rev = "87f4a5ecfa572dfdc9ebe905485d0012ad2d1833"; + sha256 = "sha256-3evlUj/n39SYncJDUjN6hk12tn/DyCFy2TFvP0/6xdU="; }; }; @@ -130,7 +146,7 @@ let src = fetchgit { url = "https://github.com/wireapp/http-client"; rev = "37494bb9a89dd52f97a8dc582746c6ff52943934"; - sha256 = "sha256-z47GlT+tHsSlRX4ApSGQIpOpaZiBeqr72/tWuvzw8tc="; + hash = "sha256-z47GlT+tHsSlRX4ApSGQIpOpaZiBeqr72/tWuvzw8tc="; }; packages = { "http-client" = "http-client"; @@ -145,7 +161,7 @@ let src = fetchgit { url = "https://github.com/wireapp/hspec-wai"; rev = "08176f07fa893922e2e78dcaf996c33d79d23ce2"; - sha256 = "sha256-Nc5POjA+mJt7Vi3drczEivGsv9PXeVOCSwp21lLmz58="; + hash = "sha256-Nc5POjA+mJt7Vi3drczEivGsv9PXeVOCSwp21lLmz58="; }; }; @@ -154,7 +170,7 @@ let src = fetchgit { url = "https://github.com/wireapp/cql"; rev = "abbd2739969d17a909800f282d10d42a254c4e3b"; - sha256 = "sha256-2MYwZKiTdwgjJdLNvECi7gtcIo+3H4z1nYzen5x0lgU="; + hash = "sha256-2MYwZKiTdwgjJdLNvECi7gtcIo+3H4z1nYzen5x0lgU="; }; }; @@ -163,7 +179,7 @@ let src = fetchgit { url = "https://github.com/wireapp/cql-io"; rev = "c2b6aa995b5817ed7c78c53f72d5aa586ef87c36"; - sha256 = "sha256-DMRWUq4yorG5QFw2ZyF/DWnRjfnzGupx0njTiOyLzPI="; + hash = "sha256-DMRWUq4yorG5QFw2ZyF/DWnRjfnzGupx0njTiOyLzPI="; }; }; @@ -173,7 +189,7 @@ let src = fetchgit { url = "https://github.com/wireapp/wai-predicates"; rev = "ff95282a982ab45cced70656475eaf2cefaa26ea"; - sha256 = "sha256-x2XSv2+/+DG9FXN8hfUWGNIO7V4iBhlzYz19WWKaLKQ="; + hash = "sha256-x2XSv2+/+DG9FXN8hfUWGNIO7V4iBhlzYz19WWKaLKQ="; }; }; @@ -182,7 +198,7 @@ let src = fetchgit { url = "https://github.com/wireapp/wai-routing"; rev = "7e996a93fec5901767f845a50316b3c18e51a61d"; - sha256 = "18icwks9jc6sy42vcvj2ysaip2s0dsrpvm9sy608b6nq6kk1ahlk"; + hash = "sha256-k0IV5jTYmoWA8TrVfbNuQIsblfZCbrYF8dowmfTkLKI="; }; }; @@ -191,7 +207,7 @@ let src = fetchgit { url = "https://github.com/wireapp/tasty"; rev = "97df5c1db305b626ffa0b80055361b7b28e69cec"; - sha256 = "sha256-oACehxazeKgRr993gASRbQMf74heh5g0B+70ceAg17I="; + hash = "sha256-oACehxazeKgRr993gASRbQMf74heh5g0B+70ceAg17I="; }; packages = { tasty-hunit = "hunit"; @@ -203,16 +219,17 @@ let servant-openapi3 = { src = fetchgit { url = "https://github.com/wireapp/servant-openapi3"; - rev = "5cdb2783f15058f753c41b800415d4ba1149a78b"; - sha256 = "sha256-8FM3IAA3ewCuv9Mar8aWmzbyfKK9eLXIJPMHzmYb1zE="; + rev = "0db0095040df2c469a48f5b8724595f82afbad0c"; + hash = "sha256-iKMWd+qm8hHhKepa13VWXDPCpTMXxoOwWyoCk4lLlIY="; }; }; + # we need HEAD, the latest release is too old postie = { src = fetchgit { url = "https://github.com/alexbiehl/postie"; rev = "7321b977a2b427e0be782b7239901e4edfbb027f"; - sha256 = "sha256-DKugy4EpRsSgaGvybdh2tLa7HCtoxId+7RAAAw43llA="; + hash = "sha256-DKugy4EpRsSgaGvybdh2tLa7HCtoxId+7RAAAw43llA="; }; }; @@ -220,7 +237,7 @@ let src = fetchgit { url = "https://github.com/wireapp/tinylog.git"; rev = "9609104263e8cd2a631417c1c3ef23e090de0d09"; - sha256 = "sha256-htEIJY+LmIMACVZrflU60+X42/g14NxUyFM7VJs4E6w="; + hash = "sha256-htEIJY+LmIMACVZrflU60+X42/g14NxUyFM7VJs4E6w="; }; }; @@ -229,7 +246,7 @@ let src = fetchgit { url = "https://github.com/wireapp/tasty-ant-xml"; rev = "34ff294d805e62e73678dccc0be9d3da13540fbe"; - sha256 = "sha256-+rHcS+BwEFsXqPAHX/KZDIgv9zfk1dZl0LlZJ57Com4="; + hash = "sha256-+rHcS+BwEFsXqPAHX/KZDIgv9zfk1dZl0LlZJ57Com4="; }; }; @@ -241,18 +258,20 @@ let hash = "sha256-E35PVxi/4iJFfWts3td52KKZKQt4dj9KFP3SvWG77Cc="; }; }; - # PR: https://github.com/yesodweb/wai/pull/958 + + # open PR https://github.com/yesodweb/wai/pull/958 for sending connection: close when closing connection warp = { - src = fetchgit { - url = "https://github.com/wireapp/wai"; - rev = "bedd6a835f6d98128880465c30e8115fa986e3f6"; - sha256 = "sha256-0r/d9YwcKZIZd10EhL2TP+W14Wjk0/S8Q4pVvZuZLaY="; - }; - packages = { - "warp" = "warp"; + packages.warp = "warp"; + src = pkgs.fetchFromGitHub { + owner = "yesodweb"; + repo = "wai"; + rev = "8b20c9db265a202a2c7ba2a9ec8786a1ee59957b"; + hash = "sha256-fKUSiRl38FKY1gFSmbksktoqoLfQrDxRRWEh4k+RRW4="; }; }; + }; + hackagePins = { # Major re-write upstream, we should get rid of this dependency rather than # adapt to upstream, this will go away when completing servantification. @@ -261,20 +280,52 @@ let sha256 = "sha256-DSMckKIeVE/buSMg8Mq+mUm1bYPYB7veA11Ns7vTBbc="; }; - # these are not yet in nixpkgs - ghc-source-gen = { - version = "0.4.4.0"; - sha256 = "sha256-ZSJGF4sdr7tOCv6IUCjIiTrFYL+5gF4W3U6adjBODrE="; + # start pinned dependencies for http2 + + # this contains an important fix to the initialization of the window size + # and should be switched to upstream as soon as we can + http2 = { + version = "5.2.5"; + sha256 = "sha256-FCd4lPydwWqm2lrhgYtPW+BuXGqmmA8KFrB87SYEowY="; + }; + + http-semantics = { + version = "0.1.2"; + sha256 = "sha256-S4rGBCIKVPpLPumLcVzrPONrbWm8VBizqxI3dXNIfr0="; + }; + + network-run = { + version = "0.3.0"; + sha256 = "sha256-FP2GZKwacC+TLLwEIVgKBtnKplYPf5xOIjDfvlbQV0o="; + }; + time-manager = { + version = "0.1.0"; + sha256 = "sha256-WRe9LZrOIPJVBFk0vMN2IMoxgP0a0psQCiCiOFWJc74="; }; - hoogle = { - version = "5.0.18.4"; - sha256 = "sha256-gIc4hpdUfTS33rZPfzwLfVcXkQaglmsljqViyYdihdk="; + auto-update = { + version = "0.2.0"; + sha256 = "sha256-d/0IDjaaCLz8tlx88z8Ew8ol9PrSRPVWaUwTbim70yE="; }; - # dependency of hoogle - safe = { - version = "0.3.20"; - sha256 = "sha256-PGwjhrRnkH8cLhd7fHTZFd6ts9abp0w5sLlV8ke1yXU="; + + network-control = { + version = "0.1.0"; + sha256 = "sha256-D6pKb6+0Pr08FnObGbXBVMv04ys3N731p7U+GYH1oEg="; + }; + # end pinned dependencies for http2 + + # pinned for warp + warp-tls = { + version = "3.4.5"; + sha256 = "sha256-3cDi/+n7wHfcWT/iFWAsGdLYXtKYXmvzolDt+ACJnaM="; }; + # end pinned for warp + + # PR: https://github.com/wireapp/wire-server/pull/4027 + HsOpenSSL = { + version = "0.11.7.7"; + sha256 = "sha256-45qWTqfY4fwCjTQsQg/f0EPkC5KZ8CFZYH4cwcw3Y18="; + }; + }; # Name -> Source -> Maybe Subpath -> Drv mkGitDrv = name: src: subpath: @@ -285,7 +336,7 @@ let else "--subpath='${subpath}'"; in hself.callCabal2nixWithOptions name src "${subpathArg}" { }; - # [[AtrrSet]] + # [[AttrSet]] gitPackages = lib.attrsets.mapAttrsToList (name: pin: let @@ -303,11 +354,12 @@ let gitPins; # AttrSet hackagePackages = lib.attrsets.mapAttrs - (pkg: { version, sha256 }: + (pkg: args: hself.callHackageDirect { - ver = version; - inherit pkg sha256; + ver = args.version; + sha256 = args.sha256 or ""; + inherit pkg; } { } ) diff --git a/nix/local-haskell-packages.nix b/nix/local-haskell-packages.nix index 89527deeb19..133fcd9afae 100644 --- a/nix/local-haskell-packages.nix +++ b/nix/local-haskell-packages.nix @@ -20,7 +20,6 @@ metrics-core = hself.callPackage ../libs/metrics-core/default.nix { inherit gitignoreSource; }; metrics-wai = hself.callPackage ../libs/metrics-wai/default.nix { inherit gitignoreSource; }; polysemy-wire-zoo = hself.callPackage ../libs/polysemy-wire-zoo/default.nix { inherit gitignoreSource; }; - ropes = hself.callPackage ../libs/ropes/default.nix { inherit gitignoreSource; }; schema-profunctor = hself.callPackage ../libs/schema-profunctor/default.nix { inherit gitignoreSource; }; sodium-crypto-sign = hself.callPackage ../libs/sodium-crypto-sign/default.nix { inherit gitignoreSource; }; ssl-util = hself.callPackage ../libs/ssl-util/default.nix { inherit gitignoreSource; }; diff --git a/nix/manual-overrides.nix b/nix/manual-overrides.nix index 2a70e83728d..d2d6a1baef8 100644 --- a/nix/manual-overrides.nix +++ b/nix/manual-overrides.nix @@ -1,4 +1,4 @@ -{ libsodium, protobuf, hlib, mls-test-cli, ... }: +{ libsodium, protobuf, hlib, mls-test-cli, fetchurl, curl, fetchpatch, ... }: # FUTUREWORK: Figure out a way to detect if some of these packages are not # actually marked broken, so we can cleanup this file on every nixpkgs bump. hself: hsuper: { @@ -7,7 +7,10 @@ hself: hsuper: { # (these are in general not fine they need to be investigated) # FUTUREWORK: investigate whether all of these tests need to fail # ---------------- - amqp = hlib.dontCheck hsuper.amqp_0_22_2; + + # tests don't compile because `replicateM` isn't in scope. this dependency should be dropped asap + wai-route = hlib.dontCheck hsuper.wai-route; + # test suite doesn't compile and needs network access bloodhound = hlib.dontCheck hsuper.bloodhound; # tests need network access, cabal2nix disables haddocks @@ -15,13 +18,13 @@ hself: hsuper: { # PR with fix: https://github.com/freckle/hspec-junit-formatter/pull/23 # the PR has been merged, but has not arrived in nixpkgs hspec-junit-formatter = hlib.markUnbroken (hlib.dontCheck hsuper.hspec-junit-formatter); - markov-chain-usage-model = hlib.markUnbroken (hlib.dontCheck hsuper.markov-chain-usage-model); - openapi3 = hlib.markUnbroken (hlib.dontCheck hsuper.openapi3); - quickcheck-state-machine = hlib.dontCheck hsuper.quickcheck-state-machine; + quickcheck-state-machine = hlib.markUnbroken (hlib.dontCheck hsuper.quickcheck-state-machine); saml2-web-sso = hlib.dontCheck hsuper.saml2-web-sso; + # these are okay, the only issue is that the compiler underlines + # errors differently than before + singletons-base = hlib.markUnbroken (hlib.dontCheck hsuper.singletons-base); # one of the tests is flaky transitive-anns = hlib.dontCheck hsuper.transitive-anns; - warp = hlib.dontCheck hsuper.warp; # Tests require a running redis hedis = hlib.dontCheck hsuper.hedis; @@ -34,35 +37,48 @@ hself: hsuper: { binary-parsers = hlib.markUnbroken (hlib.doJailbreak hsuper.binary-parsers); bytestring-arbitrary = hlib.markUnbroken (hlib.doJailbreak hsuper.bytestring-arbitrary); lens-datetime = hlib.markUnbroken (hlib.doJailbreak hsuper.lens-datetime); - network-arbitrary = hlib.markUnbroken (hlib.doJailbreak hsuper.network-arbitrary); - proto-lens-protoc = hlib.doJailbreak hsuper.proto-lens-protoc; - proto-lens-setup = hlib.doJailbreak hsuper.proto-lens-setup; - th-desugar = hlib.doJailbreak hsuper.th-desugar; + + # the libsodium haskell library is incompatible with the new version of the libsodium c library + # that nixpkgs has - this downgrades libsodium from 1.0.19 to 1.0.18 + libsodium = hlib.markUnbroken (hlib.addPkgconfigDepend hsuper.libsodium ( + libsodium.overrideAttrs (old: + rec { + # we don't care for the patches for mingw and for 1.0.19 + patches = [ ]; + version = "1.0.18"; + src = fetchurl { + url = "https://download.libsodium.org/libsodium/releases/${old.pname}-${version}.tar.gz"; + hash = "sha256-b1BEkLNCpPikxKAvybhmy++GItXfTlRStGvhIeRmNsE="; + }; + } + ))); + + # depend on an old version of hedgehog + polysemy-test = hlib.markUnbroken (hlib.doJailbreak hsuper.polysemy-test); + polysemy-conc = hlib.markUnbroken (hlib.doJailbreak hsuper.polysemy-conc); # ------------------------------------ # okay but marked broken (nixpkgs bug) # (we can unfortunately not do anything here but update nixpkgs) # ------------------------------------ - bytestring-conversion = hlib.markUnbroken hsuper.bytestring-conversion; template = hlib.markUnbroken hsuper.template; - polysemy-test = hlib.markUnbroken hsuper.polysemy-test; # ----------------- # version overrides # (these are fine but will probably need to be adjusted in a future nixpkgs update) # ----------------- - hpack = hsuper.hpack_0_36_0; - linear-generics = hsuper.linear-generics_0_2_2; - network-conduit-tls = hsuper.network-conduit-tls_1_4_0; - optparse-generic = hsuper.optparse-generic_1_5_2; - th-abstraction = hsuper.th-abstraction_0_5_0_0; - tls = hsuper.tls_1_9_0; - warp-tls = hsuper.warp-tls_3_4_3; + tls = hsuper.tls_2_0_5; + tls-session-manager = hsuper.tls-session-manager_0_0_5; + + # warp requires curl in its testsuite + warp = hlib.addTestToolDepends hsuper.warp [ curl ]; # ----------------- # flags and patches # (these are fine) # ----------------- + cryptostore = hlib.addBuildDepends (hlib.dontCheck (hlib.appendConfigureFlags hsuper.cryptostore [ "-fuse_crypton" ])) + [ hself.crypton hself.crypton-x509 hself.crypton-x509-validation ]; # Make hoogle static to reduce size of the hoogle image hoogle = hlib.justStaticExecutables hsuper.hoogle; http2-manager = hlib.enableCabalFlag hsuper.http2-manager "-f-test-trailing-dot"; diff --git a/nix/overlay-docs.nix b/nix/overlay-docs.nix index 5c1a233bb5f..c97cbe66e6a 100644 --- a/nix/overlay-docs.nix +++ b/nix/overlay-docs.nix @@ -9,7 +9,5 @@ self: super: rec { }; }; - mls-test-cli = self.callPackage ./pkgs/mls-test-cli { }; - python3Packages = python3.pkgs; } diff --git a/nix/overlay.nix b/nix/overlay.nix index 0d846cb52b0..fe5263e55b9 100644 --- a/nix/overlay.nix +++ b/nix/overlay.nix @@ -50,7 +50,6 @@ let }; sources = import ./sources.nix; - pkgsCargo = import sources.nixpkgs-cargo { }; in self: super: { @@ -60,9 +59,7 @@ self: super: { mls-test-cli = self.callPackage ./pkgs/mls-test-cli { }; # Named like this so cabal2nix can find it - rusty_jwt_tools_ffi = self.callPackage ./pkgs/rusty_jwt_tools_ffi { - inherit (pkgsCargo) rustPlatform; - }; + rusty_jwt_tools_ffi = self.callPackage ./pkgs/rusty_jwt_tools_ffi { }; nginxModules = super.nginxModules // { zauth = { @@ -89,6 +86,13 @@ self: super: { ]; }; + haskellPackages = super.haskellPackages.override { + overrides = hself: hsuper: { + # https://github.com/ocharles/weeder/pull/165 + weeder = self.haskell.lib.dontCheck (hself.callPackage ./pkgs/weeder { }); + }; + }; + stack = staticBinaryInTarball rec { pname = "stack"; version = "2.7.3"; diff --git a/nix/pkgs/python-docs/sphinxcontrib-kroki.nix b/nix/pkgs/python-docs/sphinxcontrib-kroki.nix index 179c6cad862..53ef1ee3f35 100644 --- a/nix/pkgs/python-docs/sphinxcontrib-kroki.nix +++ b/nix/pkgs/python-docs/sphinxcontrib-kroki.nix @@ -2,6 +2,7 @@ , buildPythonPackage , sphinx , requests +, setuptools , pyyaml }: buildPythonPackage rec { @@ -17,6 +18,6 @@ buildPythonPackage rec { sphinx requests pyyaml + setuptools ]; - } diff --git a/nix/pkgs/weeder/default.nix b/nix/pkgs/weeder/default.nix new file mode 100644 index 00000000000..718f820242f --- /dev/null +++ b/nix/pkgs/weeder/default.nix @@ -0,0 +1,84 @@ +{ mkDerivation +, aeson +, algebraic-graphs +, async +, base +, bytestring +, containers +, directory +, fetchgit +, filepath +, generic-lens +, ghc +, Glob +, hspec-discover +, hspec-expectations +, lens +, lib +, mtl +, optparse-applicative +, parallel +, process +, regex-tdfa +, tasty +, tasty-golden +, tasty-hunit-compat +, text +, toml-reader +, transformers +}: +mkDerivation { + pname = "weeder"; + version = "2.8.0"; + src = fetchgit { + url = "https://github.com/fisx/weeder"; + sha256 = "sha256-Cv1H4m5X1iM26svGFdfCVfMO6E/ueaKxCRjrfwsoV7M="; + rev = "0dae376b4a41d67bdaa4ec55e902df0b3cc58fba"; # https://github.com/ocharles/weeder/pull/165 + fetchSubmodules = true; + }; + isLibrary = true; + isExecutable = true; + libraryHaskellDepends = [ + algebraic-graphs + async + base + bytestring + containers + directory + filepath + generic-lens + ghc + Glob + lens + mtl + optparse-applicative + parallel + regex-tdfa + text + toml-reader + transformers + ]; + executableHaskellDepends = [ base ]; + testHaskellDepends = [ + aeson + algebraic-graphs + base + bytestring + containers + directory + filepath + ghc + hspec-expectations + process + tasty + tasty-golden + tasty-hunit-compat + text + toml-reader + ]; + testToolDepends = [ hspec-discover ]; + homepage = "https://github.com/ocharles/weeder#readme"; + description = "Detect dead code"; + license = lib.licenses.bsd3; + mainProgram = "weeder"; +} diff --git a/nix/sources.json b/nix/sources.json index 207225e566b..0abe53ae006 100644 --- a/nix/sources.json +++ b/nix/sources.json @@ -1,38 +1,14 @@ { - "bombon": { - "branch": "main", - "description": "Nix CycloneDX Software Bills of Materials (SBOMs)", - "homepage": "", - "owner": "nikstur", - "repo": "bombon", - "rev": "09dce0377beb87c24822f79501d6c76166105788", - "sha256": "1z80waaimga03m4b0nhc3djaca4y2bh0dq8mc1r8s59hqngc22ch", - "type": "tarball", - "url": "https://github.com/nikstur/bombon/archive/09dce0377beb87c24822f79501d6c76166105788.tar.gz", - "url_template": "https://github.com///archive/.tar.gz" - }, "nixpkgs": { "branch": "nixpkgs-unstable", "description": "Nix Packages collection", "homepage": "https://github.com/NixOS/nixpkgs", "owner": "NixOS", "repo": "nixpkgs", - "rev": "e97b3e4186bcadf0ef1b6be22b8558eab1cdeb5d", - "sha256": "114ggf0xbwq16djg4qql3jljknk9xr8h7dw18ccalwqg9k1cgv0g", - "type": "tarball", - "url": "https://github.com/NixOS/nixpkgs/archive/e97b3e4186bcadf0ef1b6be22b8558eab1cdeb5d.tar.gz", - "url_template": "https://github.com///archive/.tar.gz" - }, - "nixpkgs-cargo": { - "branch": "master", - "description": "Nix Packages collection", - "homepage": "https://github.com/NixOS/nixpkgs", - "owner": "NixOS", - "repo": "nixpkgs", - "rev": "e236b838c71d2aff275356ade8104bbdef422117", - "sha256": "0zjf6b9pz3ljinwb2qxhmpix1mgiv4vakcqci7bcy5a6sv1sj1xs", + "rev": "4a3fc4cf736b7d2d288d7a8bf775ac8d4c0920b4", + "sha256": "1ibmc6iijim53bpi1wc1b295l579wzxgs8ynmsi0ldgjrxhgli1a", "type": "tarball", - "url": "https://github.com/NixOS/nixpkgs/archive/e236b838c71d2aff275356ade8104bbdef422117.tar.gz", + "url": "https://github.com/NixOS/nixpkgs/archive/4a3fc4cf736b7d2d288d7a8bf775ac8d4c0920b4.tar.gz", "url_template": "https://github.com///archive/.tar.gz" } } diff --git a/nix/sources.nix b/nix/sources.nix index 9a01c8acfc0..fe3dadf7ebb 100644 --- a/nix/sources.nix +++ b/nix/sources.nix @@ -10,33 +10,34 @@ let let name' = sanitizeName name + "-src"; in - if spec.builtin or true then - builtins_fetchurl { inherit (spec) url sha256; name = name'; } - else - pkgs.fetchurl { inherit (spec) url sha256; name = name'; }; + if spec.builtin or true then + builtins_fetchurl { inherit (spec) url sha256; name = name'; } + else + pkgs.fetchurl { inherit (spec) url sha256; name = name'; }; fetch_tarball = pkgs: name: spec: let name' = sanitizeName name + "-src"; in - if spec.builtin or true then - builtins_fetchTarball { name = name'; inherit (spec) url sha256; } - else - pkgs.fetchzip { name = name'; inherit (spec) url sha256; }; + if spec.builtin or true then + builtins_fetchTarball { name = name'; inherit (spec) url sha256; } + else + pkgs.fetchzip { name = name'; inherit (spec) url sha256; }; fetch_git = name: spec: let ref = - if spec ? ref then spec.ref else + spec.ref or ( if spec ? branch then "refs/heads/${spec.branch}" else - if spec ? tag then "refs/tags/${spec.tag}" else - abort "In git source '${name}': Please specify `ref`, `tag` or `branch`!"; - submodules = if spec ? submodules then spec.submodules else false; + if spec ? tag then "refs/tags/${spec.tag}" else + abort "In git source '${name}': Please specify `ref`, `tag` or `branch`!" + ); + submodules = spec.submodules or false; submoduleArg = let nixSupportsSubmodules = builtins.compareVersions builtins.nixVersion "2.4" >= 0; emptyArgWithWarning = - if submodules == true + if submodules then builtins.trace ( @@ -44,15 +45,15 @@ let + "but your nix's (${builtins.nixVersion}) builtins.fetchGit " + "does not support them" ) - {} - else {}; + { } + else { }; in - if nixSupportsSubmodules - then { inherit submodules; } - else emptyArgWithWarning; + if nixSupportsSubmodules + then { inherit submodules; } + else emptyArgWithWarning; in - builtins.fetchGit - ({ url = spec.repo; inherit (spec) rev; inherit ref; } // submoduleArg); + builtins.fetchGit + ({ url = spec.repo; inherit (spec) rev; inherit ref; } // submoduleArg); fetch_local = spec: spec.path; @@ -86,16 +87,16 @@ let hasNixpkgsPath = builtins.any (x: x.prefix == "nixpkgs") builtins.nixPath; hasThisAsNixpkgsPath = == ./.; in - if builtins.hasAttr "nixpkgs" sources - then sourcesNixpkgs - else if hasNixpkgsPath && ! hasThisAsNixpkgsPath then - import {} - else - abort - '' - Please specify either (through -I or NIX_PATH=nixpkgs=...) or - add a package called "nixpkgs" to your sources.json. - ''; + if builtins.hasAttr "nixpkgs" sources + then sourcesNixpkgs + else if hasNixpkgsPath && ! hasThisAsNixpkgsPath then + import { } + else + abort + '' + Please specify either (through -I or NIX_PATH=nixpkgs=...) or + add a package called "nixpkgs" to your sources.json. + ''; # The actual fetching function. fetch = pkgs: name: spec: @@ -115,13 +116,13 @@ let # the path directly as opposed to the fetched source. replace = name: drv: let - saneName = stringAsChars (c: if isNull (builtins.match "[a-zA-Z0-9]" c) then "_" else c) name; + saneName = stringAsChars (c: if (builtins.match "[a-zA-Z0-9]" c) == null then "_" else c) name; ersatz = builtins.getEnv "NIV_OVERRIDE_${saneName}"; in - if ersatz == "" then drv else - # this turns the string into an actual Nix path (for both absolute and - # relative paths) - if builtins.substring 0 1 ersatz == "/" then /. + ersatz else /. + builtins.getEnv "PWD" + "/${ersatz}"; + if ersatz == "" then drv else + # this turns the string into an actual Nix path (for both absolute and + # relative paths) + if builtins.substring 0 1 ersatz == "/" then /. + ersatz else /. + builtins.getEnv "PWD" + "/${ersatz}"; # Ports of functions for older nix versions @@ -132,7 +133,7 @@ let ); # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/lists.nix#L295 - range = first: last: if first > last then [] else builtins.genList (n: first + n) (last - first + 1); + range = first: last: if first > last then [ ] else builtins.genList (n: first + n) (last - first + 1); # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L257 stringToCharacters = s: map (p: builtins.substring p 1 s) (range 0 (builtins.stringLength s - 1)); @@ -143,43 +144,46 @@ let concatStrings = builtins.concatStringsSep ""; # https://github.com/NixOS/nixpkgs/blob/8a9f58a375c401b96da862d969f66429def1d118/lib/attrsets.nix#L331 - optionalAttrs = cond: as: if cond then as else {}; + optionalAttrs = cond: as: if cond then as else { }; # fetchTarball version that is compatible between all the versions of Nix builtins_fetchTarball = { url, name ? null, sha256 }@attrs: let inherit (builtins) lessThan nixVersion fetchTarball; in - if lessThan nixVersion "1.12" then - fetchTarball ({ inherit url; } // (optionalAttrs (!isNull name) { inherit name; })) - else - fetchTarball attrs; + if lessThan nixVersion "1.12" then + fetchTarball ({ inherit url; } // (optionalAttrs (name != null) { inherit name; })) + else + fetchTarball attrs; # fetchurl version that is compatible between all the versions of Nix builtins_fetchurl = { url, name ? null, sha256 }@attrs: let inherit (builtins) lessThan nixVersion fetchurl; in - if lessThan nixVersion "1.12" then - fetchurl ({ inherit url; } // (optionalAttrs (!isNull name) { inherit name; })) - else - fetchurl attrs; + if lessThan nixVersion "1.12" then + fetchurl ({ inherit url; } // (optionalAttrs (name != null) { inherit name; })) + else + fetchurl attrs; # Create the final "sources" from the config mkSources = config: - mapAttrs ( - name: spec: - if builtins.hasAttr "outPath" spec - then abort - "The values in sources.json should not have an 'outPath' attribute" - else - spec // { outPath = replace name (fetch config.pkgs name spec); } - ) config.sources; + mapAttrs + ( + name: spec: + if builtins.hasAttr "outPath" spec + then + abort + "The values in sources.json should not have an 'outPath' attribute" + else + spec // { outPath = replace name (fetch config.pkgs name spec); } + ) + config.sources; # The "config" used by the fetchers mkConfig = { sourcesFile ? if builtins.pathExists ./sources.json then ./sources.json else null - , sources ? if isNull sourcesFile then {} else builtins.fromJSON (builtins.readFile sourcesFile) + , sources ? if sourcesFile == null then { } else builtins.fromJSON (builtins.readFile sourcesFile) , system ? builtins.currentSystem , pkgs ? mkPkgs sources system }: rec { @@ -191,4 +195,4 @@ let }; in -mkSources (mkConfig {}) // { __functor = _: settings: mkSources (mkConfig settings); } +mkSources (mkConfig { }) // { __functor = _: settings: mkSources (mkConfig settings); } diff --git a/nix/wire-server.nix b/nix/wire-server.nix index eca106680b7..6fafadb5efa 100644 --- a/nix/wire-server.nix +++ b/nix/wire-server.nix @@ -32,14 +32,14 @@ # giving us the latest version. # # 3.3: External dependencies: cabal2nix sometimes fails to provide the external -# dependencies like adding protobuf and mls-test-cli as a buld tools. So, we +# dependencies like adding protobuf and mls-test-cli as buld tools. We # need to write overrides to ensure these are present during build. # # 3.4: Other overrides: We may need to override haskell package derivations for # some other reasons, like ensuring hoogle derivation produces just the # executable. We can use nix/manual-overrides.nix for this. # -# Using thse tweaks we can get a haskell package set which has wire-server +# Using these tweaks we can get a haskell package set which has wire-server # components and the required dependencies. We then use this package set along # with nixpkgs' dockerTools to make derivations for docker images that we need. pkgs: @@ -88,7 +88,7 @@ let test-stats = [ "test-stats" ]; }; - attrsets = lib.attrsets; + inherit (lib) attrsets; pinnedPackages = import ./haskell-pins.nix { inherit pkgs; @@ -101,9 +101,7 @@ let # on. let defaultPkgs = import ./local-haskell-packages.nix - { - inherit gitignoreSource; - } + { inherit gitignoreSource; } hsuper hself; @@ -130,18 +128,35 @@ let bench = _: drv: hlib.doBenchmark drv; + maintainer = _: drv: + drv.overrideAttrs (old: { + + meta = old.meta or { } // { + homepage = "https://github.com/wireapp"; + maintainers = [{ + name = "wireapp"; + email = "backend@wire.com"; + github = "wireapp"; + githubId = 16047324; + }]; + }; + }); + overrideAll = fn: overrides: - attrsets.mapAttrs fn (overrides); + attrsets.mapAttrs fn overrides; in lib.lists.foldr overrideAll defaultPkgs [ + maintainer werror opt docs tests bench ]; + manualOverrides = import ./manual-overrides.nix (with pkgs; { - inherit hlib libsodium protobuf mls-test-cli fetchpatch pkgs; + inherit (pkgs) libsodium protobuf fetchpatch fetchurl curl; + inherit hlib mls-test-cli; }); executables = hself: hsuper: @@ -154,7 +169,7 @@ let ) executablesMap; - hPkgs = localMods@{ enableOptimization, enableDocs, enableTests }: pkgs.haskell.packages.ghc94.override { + hPkgs = localMods@{ enableOptimization, enableDocs, enableTests }: pkgs.haskellPackages.override { overrides = lib.composeManyExtensions [ pinnedPackages (localPackages localMods) @@ -382,8 +397,6 @@ let }; }; - ormolu = pkgs.haskell.packages.ghc94.ormolu_0_5_2_0; - # Tools common between CI and developers commonTools = [ pkgs.cabal2nix @@ -399,13 +412,14 @@ let pkgs.kubelogin-oidc pkgs.nixpkgs-fmt pkgs.openssl - (hlib.justStaticExecutables ormolu) + pkgs.ormolu pkgs.shellcheck pkgs.treefmt pkgs.gawk pkgs.cfssl pkgs.awscli2 (hlib.justStaticExecutables pkgs.haskellPackages.cabal-fmt) + (hlib.justStaticExecutables pkgs.haskellPackages.weeder) ] ++ pkgs.lib.optionals pkgs.stdenv.isLinux [ pkgs.skopeo ]; @@ -434,14 +448,6 @@ let }; ghcWithPackages = shell.nativeBuildInputs ++ shell.buildInputs; - inherit (pkgs.haskellPackages.override { - overrides = _hfinal: hprev: { - base-compat = hprev.base-compat_0_13_1; - base-compat-batteries = hprev.base-compat-batteries_0_13_1; - cabal-plan = hlib.markUnbroken (hlib.doJailbreak hprev.cabal-plan); - }; - }) cabal-plan; - profileEnv = pkgs.writeTextFile { name = "profile-env"; destination = "/.profile"; @@ -458,11 +464,6 @@ let allImages = pkgs.linkFarm "all-images" (images localModsEnableAll); - # BOM is an acronym for bill of materials - allLocalPackagesBom = lib.buildBom allLocalPackages { - includeBuildtimeDependencies = true; - }; - haskellPackages = hPkgs localModsEnableAll; haskellPackagesUnoptimizedNoDocs = hPkgs localModsOnlyTests; @@ -491,7 +492,7 @@ let pkgs.writeText "all-toplevel.jsonl" (builtins.concatStringsSep "\n" out); in { - inherit ciImage hoogleImage allImages allLocalPackages allLocalPackagesBom + inherit ciImage hoogleImage allImages allLocalPackages toplevel-derivations haskellPackages haskellPackagesUnoptimizedNoDocs imagesList; images = images localModsEnableAll; @@ -511,7 +512,7 @@ in pkgs.bash pkgs.crate2nix pkgs.dash - (pkgs.haskell-language-server.override { supportedGhcVersions = [ "94" ]; }) + (pkgs.haskell-language-server.override { supportedGhcVersions = [ "96" ]; }) pkgs.ghcid pkgs.kind pkgs.netcat @@ -539,7 +540,7 @@ in pkgs.cabal-install pkgs.nix-prefetch-git - cabal-plan + pkgs.haskellPackages.cabal-plan profileEnv ] ++ ghcWithPackages diff --git a/services/background-worker/background-worker.cabal b/services/background-worker/background-worker.cabal index 31657b00ca5..387971a5fc0 100644 --- a/services/background-worker/background-worker.cabal +++ b/services/background-worker/background-worker.cabal @@ -37,7 +37,6 @@ library , http-client , http2-manager , imports - , metrics-core , metrics-wai , monad-control , prometheus-client @@ -111,7 +110,7 @@ executable background-worker -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -funbox-strict-fields -Wredundant-constraints -Wunused-packages - -threaded -with-rtsopts=-N -with-rtsopts=-T -rtsopts + -threaded "-with-rtsopts=-N -T" -rtsopts default-extensions: AllowAmbiguousTypes diff --git a/services/background-worker/background-worker.integration.yaml b/services/background-worker/background-worker.integration.yaml index 32ff94e37ef..c23798e63ed 100644 --- a/services/background-worker/background-worker.integration.yaml +++ b/services/background-worker/background-worker.integration.yaml @@ -10,11 +10,14 @@ federatorInternal: rabbitmq: host: 127.0.0.1 - port: 5672 + port: 5671 vHost: / - adminPort: 15672 + adminPort: 15671 + enableTls: true + caCert: test/resources/rabbitmq-ca.pem + insecureSkipVerifyTls: false backendNotificationPusher: pushBackoffMinWait: 1000 # 1ms pushBackoffMaxWait: 1000000 # 1s - remotesRefreshInterval: 10000 # 10ms \ No newline at end of file + remotesRefreshInterval: 10000 # 10ms diff --git a/services/background-worker/default.nix b/services/background-worker/default.nix index 3698011087d..6ccf66f8ac7 100644 --- a/services/background-worker/default.nix +++ b/services/background-worker/default.nix @@ -21,7 +21,6 @@ , http2-manager , imports , lib -, metrics-core , metrics-wai , monad-control , prometheus-client @@ -60,7 +59,6 @@ mkDerivation { http-client http2-manager imports - metrics-core metrics-wai monad-control prometheus-client diff --git a/services/background-worker/src/Wire/BackendNotificationPusher.hs b/services/background-worker/src/Wire/BackendNotificationPusher.hs index 7dfad1390f1..f7cfe209ad6 100644 --- a/services/background-worker/src/Wire/BackendNotificationPusher.hs +++ b/services/background-worker/src/Wire/BackendNotificationPusher.hs @@ -40,7 +40,7 @@ startPushingNotifications runningFlag chan domain = do lift $ ensureQueue chan domain._domainText QL.consumeMsgs chan (routingKey domain._domainText) Q.Ack (void . pushNotification runningFlag domain) -pushNotification :: RabbitMQEnvelope e => MVar () -> Domain -> (Q.Message, e) -> AppT IO (Async ()) +pushNotification :: (RabbitMQEnvelope e) => MVar () -> Domain -> (Q.Message, e) -> AppT IO (Async ()) pushNotification runningFlag targetDomain (msg, envelope) = do cfg <- asks (.backendNotificationsConfig) -- Jittered exponential backoff with 10ms as starting delay and 300s as max @@ -191,7 +191,7 @@ sendNotificationIgnoringVersionMismatch env comp path body = Right () -> pure () -- | Find the pair that maximises b. -pairedMaximumOn :: Ord b => (a -> b) -> [a] -> (a, b) +pairedMaximumOn :: (Ord b) => (a -> b) -> [a] -> (a, b) pairedMaximumOn f = maximumBy (compare `on` snd) . map (id &&& f) -- FUTUREWORK: Recosider using 1 channel for many consumers. It shouldn't matter @@ -268,7 +268,7 @@ getRemoteDomains = do let policy = limitRetriesByCumulativeDelay 60_000_000 $ fullJitterBackoff 10000 logErrr willRetry (SomeException e) rs = Log.err $ - Log.msg (Log.val "Exception occurred while refreshig domains") + Log.msg (Log.val "Exception occurred while refreshing domains") . Log.field "error" (displayException e) . Log.field "willRetry" willRetry . Log.field "retryCount" rs.rsIterNumber diff --git a/services/background-worker/src/Wire/BackgroundWorker.hs b/services/background-worker/src/Wire/BackgroundWorker.hs index b5e745d6558..3a9bc8e298a 100644 --- a/services/background-worker/src/Wire/BackgroundWorker.hs +++ b/services/background-worker/src/Wire/BackgroundWorker.hs @@ -48,7 +48,7 @@ run opts = do -- Close the channel. `extended` will then close the connection, flushing messages to the server. Log.info l $ Log.msg $ Log.val "Closing RabbitMQ channel" Q.closeChannel chan - let server = defaultServer (T.unpack $ opts.backgroundWorker._host) opts.backgroundWorker._port env.logger env.metrics + let server = defaultServer (T.unpack $ opts.backgroundWorker._host) opts.backgroundWorker._port env.logger settings <- newSettings server -- Additional cleanup when shutting down via signals. runSettingsWithCleanup cleanup settings (servantApp env) Nothing diff --git a/services/background-worker/src/Wire/BackgroundWorker/Env.hs b/services/background-worker/src/Wire/BackgroundWorker/Env.hs index 0d3080595f6..db968315947 100644 --- a/services/background-worker/src/Wire/BackgroundWorker/Env.hs +++ b/services/background-worker/src/Wire/BackgroundWorker/Env.hs @@ -7,7 +7,6 @@ import Control.Monad.Base import Control.Monad.Catch import Control.Monad.Trans.Control import Data.Map.Strict qualified as Map -import Data.Metrics qualified as Metrics import HTTP2.Client.Manager import Imports import Network.AMQP.Extended @@ -35,7 +34,6 @@ data Env = Env rabbitmqAdminClient :: RabbitMqAdmin.AdminAPI (Servant.AsClientT IO), rabbitmqVHost :: Text, logger :: Logger, - metrics :: Metrics.Metrics, federatorInternal :: Endpoint, httpManager :: Manager, defederationTimeout :: ResponseTimeout, @@ -75,7 +73,6 @@ mkEnv opts = do Map.fromList [ (BackendNotificationPusher, False) ] - metrics <- Metrics.metrics backendNotificationMetrics <- mkBackendNotificationMetrics let backendNotificationsConfig = opts.backendNotificationPusher pure Env {..} @@ -111,7 +108,7 @@ deriving newtype instance (MonadBase b m) => MonadBase b (AppT m) deriving newtype instance (MonadBaseControl b m) => MonadBaseControl b (AppT m) -- Coppied from Federator. -instance MonadUnliftIO m => MonadUnliftIO (AppT m) where +instance (MonadUnliftIO m) => MonadUnliftIO (AppT m) where withRunInIO inner = AppT . ReaderT $ \r -> withRunInIO $ \runner -> diff --git a/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs b/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs index 472f02d1f2e..6b53ed6e9e3 100644 --- a/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs +++ b/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs @@ -270,7 +270,6 @@ spec = do let federatorInternal = Endpoint "localhost" 8097 http2Manager = undefined statuses = undefined - metrics = undefined rabbitmqAdminClient = mockRabbitMqAdminClient mockAdmin rabbitmqVHost = "test-vhost" defederationTimeout = responseTimeoutNone @@ -288,7 +287,6 @@ spec = do let federatorInternal = Endpoint "localhost" 8097 http2Manager = undefined statuses = undefined - metrics = undefined rabbitmqAdminClient = mockRabbitMqAdminClient mockAdmin rabbitmqVHost = "test-vhost" defederationTimeout = responseTimeoutNone diff --git a/services/background-worker/test/Test/Wire/Util.hs b/services/background-worker/test/Test/Wire/Util.hs index ba698cccc2b..7c6fbf48aab 100644 --- a/services/background-worker/test/Test/Wire/Util.hs +++ b/services/background-worker/test/Test/Wire/Util.hs @@ -21,7 +21,6 @@ testEnv = do let federatorInternal = Endpoint "localhost" 0 rabbitmqAdminClient = undefined rabbitmqVHost = undefined - metrics = undefined defederationTimeout = responseTimeoutNone backendNotificationsConfig = BackendNotificationsConfig 1000 500000 1000 pure Env {..} diff --git a/services/background-worker/test/resources/rabbitmq-ca.pem b/services/background-worker/test/resources/rabbitmq-ca.pem new file mode 120000 index 00000000000..ca91c2c31bd --- /dev/null +++ b/services/background-worker/test/resources/rabbitmq-ca.pem @@ -0,0 +1 @@ +../../../../deploy/dockerephemeral/rabbitmq-config/certificates/ca.pem \ No newline at end of file diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal index 29d5d17791a..49d45527d52 100644 --- a/services/brig/brig.cabal +++ b/services/brig/brig.cabal @@ -76,7 +76,6 @@ library -- cabal-fmt: expand src exposed-modules: - Brig.Allowlists Brig.API.Auth Brig.API.Client Brig.API.Connection @@ -106,7 +105,6 @@ library Brig.Calling.API Brig.Calling.Internal Brig.CanonicalInterpreter - Brig.Code Brig.Data.Activation Brig.Data.Client Brig.Data.Connection @@ -116,26 +114,18 @@ library Brig.Data.Properties Brig.Data.Types Brig.Data.User - Brig.Data.UserKey Brig.DeleteQueue.Interpreter - Brig.Effects.BlacklistPhonePrefixStore - Brig.Effects.BlacklistPhonePrefixStore.Cassandra Brig.Effects.BlacklistStore Brig.Effects.BlacklistStore.Cassandra - Brig.Effects.CodeStore - Brig.Effects.CodeStore.Cassandra Brig.Effects.ConnectionStore Brig.Effects.ConnectionStore.Cassandra Brig.Effects.FederationConfigStore Brig.Effects.FederationConfigStore.Cassandra Brig.Effects.JwtTools - Brig.Effects.PasswordResetStore - Brig.Effects.PasswordResetStore.CodeStore Brig.Effects.PublicKeyBundle Brig.Effects.SFT Brig.Effects.UserPendingActivationStore Brig.Effects.UserPendingActivationStore.Cassandra - Brig.Email Brig.Federation.Client Brig.Index.Eval Brig.Index.Migrations @@ -147,9 +137,7 @@ library Brig.IO.Intra Brig.IO.Journal Brig.IO.Logging - Brig.Locale Brig.Options - Brig.Phone Brig.Provider.API Brig.Provider.DB Brig.Provider.Email @@ -201,26 +189,18 @@ library Brig.Schema.V80_KeyPackageCiphersuite Brig.Schema.V81_AddFederationRemoteTeams Brig.Schema.V_FUTUREWORK - Brig.SMTP Brig.Team.API Brig.Team.DB Brig.Team.Email Brig.Team.Template Brig.Team.Util Brig.Template - Brig.Unique Brig.User.API.Handle Brig.User.API.Search Brig.User.Auth Brig.User.Auth.Cookie Brig.User.Auth.Cookie.Limit - Brig.User.Auth.DB.Cookie - Brig.User.Auth.DB.Instances Brig.User.EJPD - Brig.User.Email - Brig.User.Handle - Brig.User.Handle.Blacklist - Brig.User.Phone Brig.User.Search.Index Brig.User.Search.Index.Types Brig.User.Search.SearchIndex @@ -264,7 +244,7 @@ library , cql , cryptobox-haskell >=0.1.1 , currency-codes >=2.0 - , data-timeout >=0.3 + , data-default , dns , dns-util , enclosed-exceptions >=1.0 @@ -279,10 +259,7 @@ library , galley-types >=0.75.3 , gundeck-types >=1.32.1 , hashable >=1.2 - , HaskellNet >=0.3 - , HaskellNet-SSL , HsOpenSSL >=0.10 - , html-entities >=1.1 , http-client >=0.7 , http-client-openssl >=0.2 , http-media @@ -313,13 +290,12 @@ library , polysemy-plugin , polysemy-time , polysemy-wire-zoo + , prometheus-client , proto-lens >=0.1 , random-shuffle >=0.0.3 , raw-strings-qq - , resource-pool >=0.2 , resourcet >=1.1 , retry >=0.7 - , ropes >=0.4.20 , safe-exceptions >=0.1 , saml2-web-sso , schema-profunctor @@ -367,8 +343,8 @@ executable brig main-is: exec/Main.hs other-modules: Paths_brig ghc-options: - -funbox-strict-fields -threaded -with-rtsopts=-N -with-rtsopts=-T - -rtsopts -Wredundant-constraints -Wunused-packages + -funbox-strict-fields -threaded "-with-rtsopts=-N -T" -rtsopts + -Wredundant-constraints -Wunused-packages build-depends: , base @@ -522,6 +498,7 @@ executable brig-integration , warp-tls >=3.2 , wire-api , wire-api-federation + , wire-subsystems , yaml , zauth diff --git a/services/brig/brig.integration.yaml b/services/brig/brig.integration.yaml index 1723ec9f1e5..e0c76b082ca 100644 --- a/services/brig/brig.integration.yaml +++ b/services/brig/brig.integration.yaml @@ -21,8 +21,11 @@ elasticsearch: rabbitmq: host: 127.0.0.1 - port: 5672 + port: 5671 vHost: / + enableTls: true + caCert: test/resources/rabbitmq-ca.pem + insecureSkipVerifyTls: false cargohold: host: 127.0.0.1 @@ -155,8 +158,6 @@ optSettings: setVerificationTimeout: 10 setTeamInvitationTimeout: 10 setExpiredUserCleanupTimeout: 1 - setTwilio: test/resources/twilio-credentials.yaml - setNexmo: test/resources/nexmo-credentials.yaml # setStomp: test/resources/stomp-credentials.yaml setUserMaxConnections: 16 setCookieInsecure: true @@ -214,9 +215,6 @@ optSettings: # To only allow specific email address domains to register, uncomment and update the setting below # setAllowlistEmailDomains: # - wire.com - # To only allow specific phone number prefixes to register uncomment and update the settings below - # setAllowlistPhonePrefixes: - # - "+1555555" # needs to be kept in sync with services/nginz/integration-test/resources/oauth/ed25519_public.jwk setOAuthJwkKeyPair: test/resources/oauth/ed25519.jwk setOAuthAuthCodeExpirationTimeSecs: 3 # 3 secs diff --git a/services/brig/deb/opt/brig/template-version b/services/brig/deb/opt/brig/template-version index 4af04f0f334..fea60e70c1a 100644 --- a/services/brig/deb/opt/brig/template-version +++ b/services/brig/deb/opt/brig/template-version @@ -1 +1 @@ -v1.0.102 +v1.0.121 diff --git a/services/brig/deb/opt/brig/templates/de/provider/email/activation.html b/services/brig/deb/opt/brig/templates/de/provider/email/activation.html index b612ef7f8a2..e0f5f48f6a9 100644 --- a/services/brig/deb/opt/brig/templates/de/provider/email/activation.html +++ b/services/brig/deb/opt/brig/templates/de/provider/email/activation.html @@ -1 +1 @@ -Ihr ${brand_service}-Benutzerkonto

${brand_label_url}

Bestätigen Sie Ihre E-Mail-Adresse

Ihre E-Mail-Adresse ${email} wurde verwendet, um sich als ${brand_service} zu registrieren.

Um die Registrierung abzuschließen, bestätigen Sie bitte Ihre E-Mail-Adresse, indem Sie auf den unteren Button klicken.

Bitte beachten Sie, dass das Service-Provider-Konto nach der Bestätigung der E-Mail-Adresse noch durch uns freigeschaltet werden muss. Dies geschieht üblicherweise innerhalb von 24 Stunden. Sie werden in einer separaten E-Mail über die Freischaltung informiert.

 
Bestätigen
 

Falls Sie nicht auf den Button klicken können, kopieren Sie diesen Link und fügen Sie ihn in Ihren Browser ein:

${url}

Wenn Sie sich nicht mit dieser E-Mail-Adresse für ein ${brand}-Benutzerkonto registriert haben, können Sie diese Nachricht ignorieren. Wenn Sie den Missbrauch Ihrer E-Mail-Adresse melden möchten, kontaktiere Sie uns bitte.

Bitte antworten Sie nicht auf diese Nachricht.

Datenschutzrichtlinien und Nutzungsbedingungen · Missbrauch melden
${copyright}. ALLE RECHTE VORBEHALTEN.

                                                           
\ No newline at end of file +Ihr ${brand_service}-Benutzerkonto

${brand_label_url}

Bestätigen Sie Ihre E-Mail-Adresse

Ihre E-Mail-Adresse ${email} wurde verwendet, um sich als ${brand_service} zu registrieren.

Um die Registrierung abzuschließen, bestätigen Sie bitte Ihre E-Mail-Adresse, indem Sie auf den unteren Button klicken.

Bitte beachten Sie, dass das Service-Provider-Konto nach der Bestätigung der E-Mail-Adresse noch durch uns freigeschaltet werden muss. Dies geschieht üblicherweise innerhalb von 24 Stunden. Sie werden in einer separaten E-Mail über die Freischaltung informiert.

 
Bestätigen
 

Falls Sie nicht auf den Button klicken können, kopieren Sie diesen Link und fügen Sie ihn in Ihren Browser ein:

${url}

Wenn Sie sich nicht mit dieser E-Mail-Adresse für ein ${brand}-Benutzerkonto registriert haben, können Sie diese Nachricht ignorieren. Wenn Sie den Missbrauch Ihrer E-Mail-Adresse melden möchten, kontaktiere Sie uns bitte.

Bitte antworten Sie nicht auf diese Nachricht.

Datenschutzrichtlinien und Nutzungsbedingungen · Missbrauch melden
${copyright}. ALLE RECHTE VORBEHALTEN.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/de/provider/email/approval-confirm.html b/services/brig/deb/opt/brig/templates/de/provider/email/approval-confirm.html index 5ddabbceeed..dba2f45a57b 100644 --- a/services/brig/deb/opt/brig/templates/de/provider/email/approval-confirm.html +++ b/services/brig/deb/opt/brig/templates/de/provider/email/approval-confirm.html @@ -1 +1 @@ -Ihr ${brand_service}-Benutzerkonto

${brand_label_url}

Guten Tag,

Wir freuen uns, Ihnen mitteilen zu können, dass Sie jetzt ein anerkannter ${brand_service} sind.

Bitte antworten Sie nicht auf diese Nachricht.

Wenn Sie sich nicht mit dieser E-Mail-Adresse für ein ${brand_service}-Konto registriert haben, kontaktieren Sie uns bitte.

Datenschutzrichtlinien und Nutzungsbedingungen · Missbrauch melden
${copyright}. ALLE RECHTE VORBEHALTEN.

                                                           
\ No newline at end of file +Ihr ${brand_service}-Benutzerkonto

${brand_label_url}

Guten Tag,

Wir freuen uns, Ihnen mitteilen zu können, dass Sie jetzt ein anerkannter ${brand_service} sind.

Bitte antworten Sie nicht auf diese Nachricht.

Wenn Sie sich nicht mit dieser E-Mail-Adresse für ein ${brand_service}-Konto registriert haben, kontaktieren Sie uns bitte.

Datenschutzrichtlinien und Nutzungsbedingungen · Missbrauch melden
${copyright}. ALLE RECHTE VORBEHALTEN.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/de/provider/email/approval-request-subject.txt b/services/brig/deb/opt/brig/templates/de/provider/email/approval-request-subject.txt index e69de29bb2d..c443f0f727c 100644 --- a/services/brig/deb/opt/brig/templates/de/provider/email/approval-request-subject.txt +++ b/services/brig/deb/opt/brig/templates/de/provider/email/approval-request-subject.txt @@ -0,0 +1 @@ +Genehmigungsanfrage: ${brand_service} \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/de/provider/email/approval-request.html b/services/brig/deb/opt/brig/templates/de/provider/email/approval-request.html index 4d25202c0a6..c15511e2223 100644 --- a/services/brig/deb/opt/brig/templates/de/provider/email/approval-request.html +++ b/services/brig/deb/opt/brig/templates/de/provider/email/approval-request.html @@ -1 +1 @@ -

${brand_label_url}

Genehmigungsanfrage

Ein neuer ${brand_service} ist registriert und wartet auf die Genehmigung. Bitte lesen Sie die unten angegebenen Informationen.

Name: ${name}

E-Mail: ${email}

Website: ${url}

Beschreibung: ${description}

Wenn die Anfrage echt scheint, können Sie den Anbieter genehmigen, indem Sie auf den unteren Button klicken. Sobald genehmigt, kann sich der Anbieter anmelden und mit der Registrierung von Diensten beginnen, die ${brand}-Nutzer ihren Unterhaltungen hinzufügen können.

Falls die Anfrage zweifelhaft scheint, wenden Sie sich bitte an den Anbieter zur Klärung, bevor Sie fortfahren.

 
Genehmigen
 

Falls Sie nicht auf den Button klicken können, kopieren Sie diesen Link und fügen Sie ihn in Ihren Browser ein:

${url}

Bitte antworten Sie nicht auf diese Nachricht.

Datenschutzrichtlinien und Nutzungsbedingungen · Missbrauch melden
${copyright}. ALLE RECHTE VORBEHALTEN.

                                                           
\ No newline at end of file +Genehmigungsanfrage: ${brand_service}

${brand_label_url}

Genehmigungsanfrage

Ein neuer ${brand_service} ist registriert und wartet auf die Genehmigung. Bitte lesen Sie die unten angegebenen Informationen.

Name: ${name}

E-Mail: ${email}

Website: ${url}

Beschreibung: ${description}

Wenn die Anfrage echt scheint, können Sie den Anbieter genehmigen, indem Sie auf den unteren Button klicken. Sobald genehmigt, kann sich der Anbieter anmelden und mit der Registrierung von Diensten beginnen, die ${brand}-Nutzer ihren Unterhaltungen hinzufügen können.

Falls die Anfrage zweifelhaft scheint, wenden Sie sich bitte an den Anbieter zur Klärung, bevor Sie fortfahren.

 
Genehmigen
 

Falls Sie nicht auf den Button klicken können, kopieren Sie diesen Link und fügen Sie ihn in Ihren Browser ein:

${url}

Bitte antworten Sie nicht auf diese Nachricht.

Datenschutzrichtlinien und Nutzungsbedingungen · Missbrauch melden
${copyright}. ALLE RECHTE VORBEHALTEN.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/de/team/email/invitation.html b/services/brig/deb/opt/brig/templates/de/team/email/invitation.html index a5e5763d5ed..7abcafc58aa 100644 --- a/services/brig/deb/opt/brig/templates/de/team/email/invitation.html +++ b/services/brig/deb/opt/brig/templates/de/team/email/invitation.html @@ -1 +1 @@ -Sie wurden eingeladen, einem ${brand}-Team beizutreten

${brand_label_url}

Einladung zum Team

${inviter} hat Sie auf ${brand} zu einem Team eingeladen. Klicken Sie bitte auf den unteren Button, um die Einladung anzunehmen.

 
Team beitreten
 

Falls Sie nicht auf den Button klicken können, kopieren Sie diesen Link und fügen Sie ihn in Ihren Browser ein:

${url}

Wenn Sie Fragen haben, dann kontaktieren Sie uns bitte.

Was ist Wire?
Wire ist die sicherste Plattform für Ihre Kommunikation. Wo auch immer Sie sind, arbeiten Sie mit Ihrem Team und externen Partnern zusammen – mittels Nachrichten, Videokonferenzen und Dateiaustausch, alles mit Ende-zu-Ende-Verschlüsselung. Mehr erfahren.

Datenschutzrichtlinien und Nutzungsbedingungen · Missbrauch melden
${copyright}. ALLE RECHTE VORBEHALTEN.

                                                           
\ No newline at end of file +Sie wurden eingeladen, einem ${brand}-Team beizutreten

${brand_label_url}

Einladung zum Team

${inviter} hat Sie auf ${brand} zu einem Team eingeladen. Klicken Sie bitte auf den unteren Button, um die Einladung anzunehmen.

 
Team beitreten
 

Falls Sie nicht auf den Button klicken können, kopieren Sie diesen Link und fügen Sie ihn in Ihren Browser ein:

${url}

Wenn Sie Fragen haben, dann kontaktieren Sie uns bitte.

Was ist Wire?
Wire ist die sicherste Plattform für Ihre Kommunikation. Wo auch immer Sie sind, arbeiten Sie mit Ihrem Team und externen Partnern zusammen – mittels Nachrichten, Videokonferenzen und Dateiaustausch, alles mit Ende-zu-Ende-Verschlüsselung. Mehr erfahren.

Datenschutzrichtlinien und Nutzungsbedingungen · Missbrauch melden
${copyright}. ALLE RECHTE VORBEHALTEN.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/de/team/email/new-member-welcome.html b/services/brig/deb/opt/brig/templates/de/team/email/new-member-welcome.html index 420ebc845ab..03c007c723f 100644 --- a/services/brig/deb/opt/brig/templates/de/team/email/new-member-welcome.html +++ b/services/brig/deb/opt/brig/templates/de/team/email/new-member-welcome.html @@ -1 +1 @@ -Sie sind einem Team auf ${brand} beigetreten

${brand_label_url}

Willkommen bei ${team_name}.

Sie sind soeben mit ${email} einem Team namens ${team_name} auf ${brand} beigetreten.

 

${brand} vereint sichere Verschlüsselung mit reichhaltigem Funktionsumfang und einfacher Bedienung in einer einzigen App. Unterstützt alle gängigen Plattformen.

 
${brand} herunterladen
 

Falls Sie nicht auf den Button klicken können, kopieren Sie diesen Link und fügen Sie ihn in Ihren Browser ein:

${url}

Wenn Sie Fragen haben, dann kontaktieren Sie uns bitte.

Team ID: ${team_id}

Datenschutzrichtlinien und Nutzungsbedingungen · Missbrauch melden
${copyright}. ALLE RECHTE VORBEHALTEN.

                                                           
\ No newline at end of file +Sie sind einem Team auf ${brand} beigetreten

${brand_label_url}

Willkommen bei ${team_name}.

Sie sind soeben mit ${email} einem Team namens ${team_name} auf ${brand} beigetreten.

 

${brand} vereint sichere Verschlüsselung mit reichhaltigem Funktionsumfang und einfacher Bedienung in einer einzigen App. Unterstützt alle gängigen Plattformen.

 
${brand} herunterladen
 

Falls Sie nicht auf den Button klicken können, kopieren Sie diesen Link und fügen Sie ihn in Ihren Browser ein:

${url}

Wenn Sie Fragen haben, dann kontaktieren Sie uns bitte.

Team ID: ${team_id}

Datenschutzrichtlinien und Nutzungsbedingungen · Missbrauch melden
${copyright}. ALLE RECHTE VORBEHALTEN.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/de/user/email/activation.html b/services/brig/deb/opt/brig/templates/de/user/email/activation.html index be729533ed6..ec58a8e1a32 100644 --- a/services/brig/deb/opt/brig/templates/de/user/email/activation.html +++ b/services/brig/deb/opt/brig/templates/de/user/email/activation.html @@ -1 +1 @@ -Ihr ${brand}-Benutzerkonto

${brand_label_url}

Bestätigen Sie Ihre E-Mail-Adresse

${email} wurde verwendet, um ein Benutzerkonto auf ${brand} zu erstellen.
Klicken Sie auf den folgenden Button, um Ihre E-Mail-Adresse zu bestätigen.

 
Bestätigen
 

Falls Sie nicht auf den Button klicken können, kopieren Sie diesen Link und fügen Sie ihn in Ihren Browser ein:

${url}

Wenn Sie Fragen haben, dann kontaktieren Sie uns bitte.

Datenschutzrichtlinien und Nutzungsbedingungen · Missbrauch melden
${copyright}. ALLE RECHTE VORBEHALTEN.

                                                           
\ No newline at end of file +Ihr ${brand}-Benutzerkonto

${brand_label_url}

Bestätigen Sie Ihre E-Mail-Adresse

${email} wurde verwendet, um ein Benutzerkonto auf ${brand} zu erstellen.
Klicken Sie auf den folgenden Button, um Ihre E-Mail-Adresse zu bestätigen.

 
Bestätigen
 

Falls Sie nicht auf den Button klicken können, kopieren Sie diesen Link und fügen Sie ihn in Ihren Browser ein:

${url}

Wenn Sie Fragen haben, dann kontaktieren Sie uns bitte.

Datenschutzrichtlinien und Nutzungsbedingungen · Missbrauch melden
${copyright}. ALLE RECHTE VORBEHALTEN.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/de/user/email/deletion.html b/services/brig/deb/opt/brig/templates/de/user/email/deletion.html index 7febba8ad1c..7c6ba323943 100644 --- a/services/brig/deb/opt/brig/templates/de/user/email/deletion.html +++ b/services/brig/deb/opt/brig/templates/de/user/email/deletion.html @@ -1 +1 @@ -Benutzerkonto löschen?

${brand_label_url}

Ihr Benutzerkonto löschen

Wir haben eine Anfrage zur Löschung Ihrer ${brand}-Benutzerkontos erhalten. Klicken Sie innerhalb der nächsten 10 Minuten auf den folgenden Link, um alle Ihre Unterhaltungen, Nachrichten und Kontakte zu löschen.

 
Benutzerkonto löschen
 

Falls Sie nicht auf den Button klicken können, kopieren Sie diesen Link und fügen Sie ihn in Ihren Browser ein:

${url}

Falls Sie dies nicht angefordert haben, setzen Sie Ihr Passwort zurück.

Wenn Sie Fragen haben, dann kontaktieren Sie uns bitte.

Datenschutzrichtlinien und Nutzungsbedingungen · Missbrauch melden
${copyright}. ALLE RECHTE VORBEHALTEN.

                                                           
\ No newline at end of file +Benutzerkonto löschen?

${brand_label_url}

Ihr Benutzerkonto löschen

Wir haben eine Anfrage zur Löschung Ihrer ${brand}-Benutzerkontos erhalten. Klicken Sie innerhalb der nächsten 10 Minuten auf den folgenden Link, um alle Ihre Unterhaltungen, Nachrichten und Kontakte zu löschen.

 
Benutzerkonto löschen
 

Falls Sie nicht auf den Button klicken können, kopieren Sie diesen Link und fügen Sie ihn in Ihren Browser ein:

${url}

Falls Sie dies nicht angefordert haben, setzen Sie Ihr Passwort zurück.

Wenn Sie Fragen haben, dann kontaktieren Sie uns bitte.

Datenschutzrichtlinien und Nutzungsbedingungen · Missbrauch melden
${copyright}. ALLE RECHTE VORBEHALTEN.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/de/user/email/new-client.html b/services/brig/deb/opt/brig/templates/de/user/email/new-client.html index a499050c1d5..5db2fe516cb 100644 --- a/services/brig/deb/opt/brig/templates/de/user/email/new-client.html +++ b/services/brig/deb/opt/brig/templates/de/user/email/new-client.html @@ -1 +1 @@ -Neues Gerät

${brand_label_url}

Neues Gerät

Ein neues Gerät wurde zu Ihrem ${brand}-Benutzerkonto hinzugefügt:

${date}

${model}

Sie haben ${brand} vermutlich auf einem neuen Gerät installiert oder sich auf einem bestehenden Gerät erneut eingeloggt. Falls dies nicht der Fall ist, gehen Sie in Ihre ${brand} Einstellungen, entfernen Sie das Gerät und setzen Sie Ihr Passwort zurück.

Wenn Sie Fragen haben, dann kontaktieren Sie uns bitte.

Datenschutzrichtlinien und Nutzungsbedingungen · Missbrauch melden
${copyright}. ALLE RECHTE VORBEHALTEN.

                                                           
\ No newline at end of file +Neues Gerät

${brand_label_url}

Neues Gerät

Ein neues Gerät wurde zu Ihrem ${brand}-Benutzerkonto hinzugefügt:

${date}

${model}

Sie haben ${brand} vermutlich auf einem neuen Gerät installiert oder sich auf einem bestehenden Gerät erneut eingeloggt. Falls dies nicht der Fall ist, gehen Sie in Ihre ${brand} Einstellungen, entfernen Sie das Gerät und setzen Sie Ihr Passwort zurück.

Wenn Sie Fragen haben, dann kontaktieren Sie uns bitte.

Datenschutzrichtlinien und Nutzungsbedingungen · Missbrauch melden
${copyright}. ALLE RECHTE VORBEHALTEN.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/de/user/email/password-reset.html b/services/brig/deb/opt/brig/templates/de/user/email/password-reset.html index 3f52cef6d49..de528deb585 100644 --- a/services/brig/deb/opt/brig/templates/de/user/email/password-reset.html +++ b/services/brig/deb/opt/brig/templates/de/user/email/password-reset.html @@ -1 +1 @@ -Änderung des Passworts auf ${brand}

${brand_label_url}

Passwort zurücksetzen

Wir haben eine Anfrage zum Zurücksetzen des Passworts für Ihr ${brand}-Benutzerkonto erhalten. Klicken Sie auf den folgenden Button, um ein neues Passwort zu erstellen.

 
Passwort zurücksetzen
 

Falls Sie nicht auf den Button klicken können, kopieren Sie diesen Link und fügen Sie ihn in Ihren Browser ein:

${url}

Wenn Sie Fragen haben, dann kontaktieren Sie uns bitte.

Datenschutzrichtlinien und Nutzungsbedingungen · Missbrauch melden
${copyright}. ALLE RECHTE VORBEHALTEN.

                                                           
\ No newline at end of file +Änderung des Passworts auf ${brand}

${brand_label_url}

Passwort zurücksetzen

Wir haben eine Anfrage zum Zurücksetzen des Passworts für Ihr ${brand}-Benutzerkonto erhalten. Klicken Sie auf den folgenden Button, um ein neues Passwort zu erstellen.

 
Passwort zurücksetzen
 

Falls Sie nicht auf den Button klicken können, kopieren Sie diesen Link und fügen Sie ihn in Ihren Browser ein:

${url}

Wenn Sie Fragen haben, dann kontaktieren Sie uns bitte.

Datenschutzrichtlinien und Nutzungsbedingungen · Missbrauch melden
${copyright}. ALLE RECHTE VORBEHALTEN.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/de/user/email/team-activation.html b/services/brig/deb/opt/brig/templates/de/user/email/team-activation.html index 157a676fe8a..6818d31b724 100644 --- a/services/brig/deb/opt/brig/templates/de/user/email/team-activation.html +++ b/services/brig/deb/opt/brig/templates/de/user/email/team-activation.html @@ -1 +1 @@ -${brand} Benutzerkonto

${brand_label_url}

Ihr neues ${brand}-Benutzerkonto

Ein neues ${brand} Team wurde mit ${email} erstellt. Bitte bestätigen Sie Ihre E-Mail-Adresse.

 
Bestätigen
 

Falls Sie nicht auf den Button klicken können, kopieren Sie diesen Link und fügen Sie ihn in Ihren Browser ein:

${url}

Wenn Sie Fragen haben, dann kontaktieren Sie uns bitte.

Datenschutzrichtlinien und Nutzungsbedingungen · Missbrauch melden
${copyright}. ALLE RECHTE VORBEHALTEN.

                                                           
\ No newline at end of file +${brand} Benutzerkonto

${brand_label_url}

Ihr neues ${brand}-Benutzerkonto

Ein neues ${brand} Team wurde mit ${email} erstellt. Bitte bestätigen Sie Ihre E-Mail-Adresse.

 
Bestätigen
 

Falls Sie nicht auf den Button klicken können, kopieren Sie diesen Link und fügen Sie ihn in Ihren Browser ein:

${url}

Wenn Sie Fragen haben, dann kontaktieren Sie uns bitte.

Datenschutzrichtlinien und Nutzungsbedingungen · Missbrauch melden
${copyright}. ALLE RECHTE VORBEHALTEN.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/de/user/email/update.html b/services/brig/deb/opt/brig/templates/de/user/email/update.html index bbf507c7b65..61148ef262b 100644 --- a/services/brig/deb/opt/brig/templates/de/user/email/update.html +++ b/services/brig/deb/opt/brig/templates/de/user/email/update.html @@ -1 +1 @@ -Ihre neue E-Mail-Adresse auf ${brand}

${brand_label_url}

Bestätigen Sie Ihre E-Mail-Adresse

${email} wurde als Ihre neue E-Mail-Adresse auf ${brand} registriert. Klicken Sie auf den folgenden Button, um Ihre neue Adresse zu bestätigen.

 
Bestätigen
 

Falls Sie nicht auf den Button klicken können, kopieren Sie diesen Link und fügen Sie ihn in Ihren Browser ein:

${url}

Wenn Sie Fragen haben, dann kontaktieren Sie uns bitte.

Datenschutzrichtlinien und Nutzungsbedingungen · Missbrauch melden
${copyright}. ALLE RECHTE VORBEHALTEN.

                                                           
\ No newline at end of file +Ihre neue E-Mail-Adresse auf ${brand}

${brand_label_url}

Bestätigen Sie Ihre E-Mail-Adresse

${email} wurde als Ihre neue E-Mail-Adresse auf ${brand} registriert. Klicken Sie auf den folgenden Button, um Ihre neue Adresse zu bestätigen.

 
Bestätigen
 

Falls Sie nicht auf den Button klicken können, kopieren Sie diesen Link und fügen Sie ihn in Ihren Browser ein:

${url}

Wenn Sie Fragen haben, dann kontaktieren Sie uns bitte.

Datenschutzrichtlinien und Nutzungsbedingungen · Missbrauch melden
${copyright}. ALLE RECHTE VORBEHALTEN.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/de/user/email/verification-delete-team-subject.txt b/services/brig/deb/opt/brig/templates/de/user/email/verification-delete-team-subject.txt index e69de29bb2d..5a8e6a53fe2 100644 --- a/services/brig/deb/opt/brig/templates/de/user/email/verification-delete-team-subject.txt +++ b/services/brig/deb/opt/brig/templates/de/user/email/verification-delete-team-subject.txt @@ -0,0 +1 @@ +Ihr ${brand}-Bestätigungscode lautet ${code} \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/de/user/email/verification-delete-team.html b/services/brig/deb/opt/brig/templates/de/user/email/verification-delete-team.html index cf8d6856feb..3b8852f6dad 100644 --- a/services/brig/deb/opt/brig/templates/de/user/email/verification-delete-team.html +++ b/services/brig/deb/opt/brig/templates/de/user/email/verification-delete-team.html @@ -1 +1 @@ -

${brand_label_url}

Bestätigen Sie die Kündigung

${email} wurde verwendet, um Ihr ${brand}-Team zu löschen. Geben Sie diesen Code ein, um Ihre E-Mail-Adresse zu bestätigen und das Team zu löschen.

 

${code}

 

Wenn Sie Fragen haben, dann kontaktieren Sie uns bitte.

Datenschutzrichtlinien und Nutzungsbedingungen · Missbrauch melden
${copyright}. ALLE RECHTE VORBEHALTEN.

                                                           
\ No newline at end of file +Ihr ${brand}-Bestätigungscode lautet ${code}

${brand_label_url}

Bestätigen Sie die Kündigung

${email} wurde verwendet, um Ihr ${brand}-Team zu löschen. Geben Sie diesen Code ein, um Ihre E-Mail-Adresse zu bestätigen und das Team zu löschen.

 

${code}

 

Wenn Sie Fragen haben, dann kontaktieren Sie uns bitte.

Datenschutzrichtlinien und Nutzungsbedingungen · Missbrauch melden
${copyright}. ALLE RECHTE VORBEHALTEN.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/de/user/email/verification-login-subject.txt b/services/brig/deb/opt/brig/templates/de/user/email/verification-login-subject.txt index e69de29bb2d..5a8e6a53fe2 100644 --- a/services/brig/deb/opt/brig/templates/de/user/email/verification-login-subject.txt +++ b/services/brig/deb/opt/brig/templates/de/user/email/verification-login-subject.txt @@ -0,0 +1 @@ +Ihr ${brand}-Bestätigungscode lautet ${code} \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/de/user/email/verification-login.html b/services/brig/deb/opt/brig/templates/de/user/email/verification-login.html index 77c2a061ecd..9237c11e73d 100644 --- a/services/brig/deb/opt/brig/templates/de/user/email/verification-login.html +++ b/services/brig/deb/opt/brig/templates/de/user/email/verification-login.html @@ -1 +1 @@ -

${brand_label_url}

Bestätigen Sie Ihre Anmeldung

${email} wurde verwendet, um sich bei Ihrem ${brand}-Benutzerkonto anzumelden. Geben Sie diesen Code ein, um Ihre E-Mail-Adresse zu bestätigen und sich anzumelden.

 

${code}

 

Wenn Sie Fragen haben, dann kontaktieren Sie uns bitte.

Datenschutzrichtlinien und Nutzungsbedingungen · Missbrauch melden
${copyright}. ALLE RECHTE VORBEHALTEN.

                                                           
\ No newline at end of file +Ihr ${brand}-Bestätigungscode lautet ${code}

${brand_label_url}

Bestätigen Sie Ihre Anmeldung

${email} wurde verwendet, um sich bei Ihrem ${brand}-Benutzerkonto anzumelden. Geben Sie diesen Code ein, um Ihre E-Mail-Adresse zu bestätigen und sich anzumelden.

 

${code}

 

Wenn Sie Fragen haben, dann kontaktieren Sie uns bitte.

Datenschutzrichtlinien und Nutzungsbedingungen · Missbrauch melden
${copyright}. ALLE RECHTE VORBEHALTEN.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/de/user/email/verification-scim-token-subject.txt b/services/brig/deb/opt/brig/templates/de/user/email/verification-scim-token-subject.txt index e69de29bb2d..5a8e6a53fe2 100644 --- a/services/brig/deb/opt/brig/templates/de/user/email/verification-scim-token-subject.txt +++ b/services/brig/deb/opt/brig/templates/de/user/email/verification-scim-token-subject.txt @@ -0,0 +1 @@ +Ihr ${brand}-Bestätigungscode lautet ${code} \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/de/user/email/verification-scim-token.html b/services/brig/deb/opt/brig/templates/de/user/email/verification-scim-token.html index 00ed3439996..5936fd050ec 100644 --- a/services/brig/deb/opt/brig/templates/de/user/email/verification-scim-token.html +++ b/services/brig/deb/opt/brig/templates/de/user/email/verification-scim-token.html @@ -1 +1 @@ -

${brand_label_url}

Bestätigen Sie die Erstellung eines SCIM-Token

${email} wurde verwendet, um ein SCIM-Token zu generieren. Geben Sie diesen Code ein, um Ihre E-Mail-Adresse zu bestätigen und den Token zu erstellen.

 

${code}

 

Wenn Sie Fragen haben, dann kontaktieren Sie uns bitte.

Datenschutzrichtlinien und Nutzungsbedingungen · Missbrauch melden
${copyright}. ALLE RECHTE VORBEHALTEN.

                                                           
\ No newline at end of file +Ihr ${brand}-Bestätigungscode lautet ${code}

${brand_label_url}

Bestätigen Sie die Erstellung eines SCIM-Token

${email} wurde verwendet, um ein SCIM-Token zu generieren. Geben Sie diesen Code ein, um Ihre E-Mail-Adresse zu bestätigen und den Token zu erstellen.

 

${code}

 

Wenn Sie Fragen haben, dann kontaktieren Sie uns bitte.

Datenschutzrichtlinien und Nutzungsbedingungen · Missbrauch melden
${copyright}. ALLE RECHTE VORBEHALTEN.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/de/user/email/verification.html b/services/brig/deb/opt/brig/templates/de/user/email/verification.html index 2e80eafea70..5c27fc2d57a 100644 --- a/services/brig/deb/opt/brig/templates/de/user/email/verification.html +++ b/services/brig/deb/opt/brig/templates/de/user/email/verification.html @@ -1 +1 @@ -${code} ist Ihr ${brand}-Bestätigungscode

${brand_label_url}

Bestätigen Sie Ihre E-Mail-Adresse

${email} wurde verwendet, um ein Benutzerkonto auf ${brand} zu erstellen. Geben Sie diesen Code ein, um Ihre E-Mail-Adresse zu bestätigen und Ihr Benutzerkonto zu erstellen.

 

${code}

 

Wenn Sie Fragen haben, dann kontaktieren Sie uns bitte.

Datenschutzrichtlinien und Nutzungsbedingungen · Missbrauch melden
${copyright}. ALLE RECHTE VORBEHALTEN.

                                                           
\ No newline at end of file +${code} ist Ihr ${brand}-Bestätigungscode

${brand_label_url}

Bestätigen Sie Ihre E-Mail-Adresse

${email} wurde verwendet, um ein Benutzerkonto auf ${brand} zu erstellen. Geben Sie diesen Code ein, um Ihre E-Mail-Adresse zu bestätigen und Ihr Benutzerkonto zu erstellen.

 

${code}

 

Wenn Sie Fragen haben, dann kontaktieren Sie uns bitte.

Datenschutzrichtlinien und Nutzungsbedingungen · Missbrauch melden
${copyright}. ALLE RECHTE VORBEHALTEN.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/en/provider/email/activation.html b/services/brig/deb/opt/brig/templates/en/provider/email/activation.html index 489b5fd0be0..fce3dd2e80b 100644 --- a/services/brig/deb/opt/brig/templates/en/provider/email/activation.html +++ b/services/brig/deb/opt/brig/templates/en/provider/email/activation.html @@ -1 +1 @@ -Your ${brand_service} Account

${brand_label_url}

Verify your email

Your email address ${email} was used to register as a ${brand_service}.

To complete the registration, it is necessary that you verify your e-mail address by clicking on the button below.

Please note that upon successful verification of your e-mail, your ${brand_service} account is still subject to approval through our staff, which usually happens within 24 hours. You will be informed of the approval via a separate e-mail.

 
Verify
 

If you can’t click the button, copy and paste this link to your browser:

${url}

If you didn’t register for a ${brand} service provider account using this e-mail address, you can safely ignore this message. If you want to report abuse of your e-mail address, please contact us.

Please don’t reply to this message.

Privacy policy and terms of use · Report Misuse
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file +Your ${brand_service} Account

${brand_label_url}

Verify your email

Your email address ${email} was used to register as a ${brand_service}.

To complete the registration, it is necessary that you verify your e-mail address by clicking on the button below.

Please note that upon successful verification of your e-mail, your ${brand_service} account is still subject to approval through our staff, which usually happens within 24 hours. You will be informed of the approval via a separate e-mail.

 
Verify
 

If you can’t click the button, copy and paste this link to your browser:

${url}

If you didn’t register for a ${brand} service provider account using this e-mail address, you can safely ignore this message. If you want to report abuse of your e-mail address, please contact us.

Please don’t reply to this message.

Privacy policy and terms of use · Report Misuse
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/en/provider/email/approval-confirm.html b/services/brig/deb/opt/brig/templates/en/provider/email/approval-confirm.html index 96d8422307d..9ab7127a0a1 100644 --- a/services/brig/deb/opt/brig/templates/en/provider/email/approval-confirm.html +++ b/services/brig/deb/opt/brig/templates/en/provider/email/approval-confirm.html @@ -1 +1 @@ -Your ${brand_service} Account

${brand_label_url}

Hello,

We are happy to inform you that you are now an approved ${brand_service}.

Please don’t reply to this message.

If you didn’t register for a ${brand_service} account using this e-mail address, please contact us.

Privacy policy and terms of use · Report Misuse
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file +Your ${brand_service} Account

${brand_label_url}

Hello,

We are happy to inform you that you are now an approved ${brand_service}.

Please don’t reply to this message.

If you didn’t register for a ${brand_service} account using this e-mail address, please contact us.

Privacy policy and terms of use · Report Misuse
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/en/provider/email/approval-request.html b/services/brig/deb/opt/brig/templates/en/provider/email/approval-request.html index 5fa64b5de5d..d2900b45d9a 100644 --- a/services/brig/deb/opt/brig/templates/en/provider/email/approval-request.html +++ b/services/brig/deb/opt/brig/templates/en/provider/email/approval-request.html @@ -1 +1 @@ -Approval Request: ${brand_service}

${brand_label_url}

Approval request

A new ${brand_service} has registered and is awaiting approval. Please review the information provided below.

Name: ${name}

E-mail: ${email}

Website: ${url}

Description: ${description}

If the request seems genuine, you can approve the provider by clicking on the button below. Once approved, the provider will be able to sign in and start registering services that ${brand} users can add to their conversations.

If the request seems dubious, please contact the provider for clarifications before proceeding.

 
Approve
 

If you can’t click the button, copy and paste this link to your browser:

${url}

Please don’t reply to this message.

Privacy policy and terms of use · Report Misuse
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file +Approval Request: ${brand_service}

${brand_label_url}

Approval request

A new ${brand_service} has registered and is awaiting approval. Please review the information provided below.

Name: ${name}

E-mail: ${email}

Website: ${url}

Description: ${description}

If the request seems genuine, you can approve the provider by clicking on the button below. Once approved, the provider will be able to sign in and start registering services that ${brand} users can add to their conversations.

If the request seems dubious, please contact the provider for clarifications before proceeding.

 
Approve
 

If you can’t click the button, copy and paste this link to your browser:

${url}

Please don’t reply to this message.

Privacy policy and terms of use · Report Misuse
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/en/team/email/invitation.html b/services/brig/deb/opt/brig/templates/en/team/email/invitation.html index 4581a262ee4..1643844f28e 100644 --- a/services/brig/deb/opt/brig/templates/en/team/email/invitation.html +++ b/services/brig/deb/opt/brig/templates/en/team/email/invitation.html @@ -1 +1 @@ -You have been invited to join a team on ${brand}

${brand_label_url}

Team invitation

${inviter} has invited you to join a team on ${brand}. Click the button below to accept the invitation.

 
Join team
 

If you can’t click the button, copy and paste this link to your browser:

${url}

If you have any questions, please contact us.

What is Wire?
Wire is the most secure collaboration platform. Work with your team and external partners wherever you are through messages, video conferencing and file sharing – always secured with end-to-end-encryption. Learn more.

Privacy policy and terms of use · Report Misuse
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file +You have been invited to join a team on ${brand}

${brand_label_url}

Team invitation

${inviter} has invited you to join a team on ${brand}. Click the button below to accept the invitation.

 
Join team
 

If you can’t click the button, copy and paste this link to your browser:

${url}

If you have any questions, please contact us.

What is Wire?
Wire is the most secure collaboration platform. Work with your team and external partners wherever you are through messages, video conferencing and file sharing – always secured with end-to-end-encryption. Learn more.

Privacy policy and terms of use · Report Misuse
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/en/team/email/new-member-welcome.html b/services/brig/deb/opt/brig/templates/en/team/email/new-member-welcome.html index df0a884e71e..a63b3a1d9c6 100644 --- a/services/brig/deb/opt/brig/templates/en/team/email/new-member-welcome.html +++ b/services/brig/deb/opt/brig/templates/en/team/email/new-member-welcome.html @@ -1 +1 @@ -You joined a team on ${brand}

${brand_label_url}

Welcome to ${team_name}.

You have just joined a team called ${team_name} on ${brand} with ${email}.

 

${brand} combines strong encryption, a rich feature set and ease-of-use in one app like never before. Works on all popular platforms.

 
Download ${brand}
 

If you can’t click the button, copy and paste this link to your browser:

${url}

If you have any questions, please contact us.

Team ID: ${team_id}

Privacy policy and terms of use · Report Misuse
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file +You joined a team on ${brand}

${brand_label_url}

Welcome to ${team_name}.

You have just joined a team called ${team_name} on ${brand} with ${email}.

 

${brand} combines strong encryption, a rich feature set and ease-of-use in one app like never before. Works on all popular platforms.

 
Download ${brand}
 

If you can’t click the button, copy and paste this link to your browser:

${url}

If you have any questions, please contact us.

Team ID: ${team_id}

Privacy policy and terms of use · Report Misuse
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/en/user/email/activation.html b/services/brig/deb/opt/brig/templates/en/user/email/activation.html index 46848555fe1..c67376c606b 100644 --- a/services/brig/deb/opt/brig/templates/en/user/email/activation.html +++ b/services/brig/deb/opt/brig/templates/en/user/email/activation.html @@ -1 +1 @@ -Your ${brand} Account

${brand_label_url}

Verify your email

${email} was used to register on ${brand}.
Click the button to verify your address.

 
Verify
 

If you can’t click the button, copy and paste this link to your browser:

${url}

If you have any questions, please contact us.

Privacy policy and terms of use · Report Misuse
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file +Your ${brand} Account

${brand_label_url}

Verify your email

${email} was used to register on ${brand}.
Click the button to verify your address.

 
Verify
 

If you can’t click the button, copy and paste this link to your browser:

${url}

If you have any questions, please contact us.

Privacy policy and terms of use · Report Misuse
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/en/user/email/deletion.html b/services/brig/deb/opt/brig/templates/en/user/email/deletion.html index 3746238c1cb..690b0104fdd 100644 --- a/services/brig/deb/opt/brig/templates/en/user/email/deletion.html +++ b/services/brig/deb/opt/brig/templates/en/user/email/deletion.html @@ -1 +1 @@ -Delete account?

${brand_label_url}

Delete your account

We’ve received a request to delete your ${brand} account. Click the button below within 10 minutes to delete all your conversations, content and connections.

 
Delete account
 

If you can’t click the button, copy and paste this link to your browser:

${url}

If you didn’t request this, reset your password.

If you have any questions, please contact us.

Privacy policy and terms of use · Report Misuse
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file +Delete account?

${brand_label_url}

Delete your account

We’ve received a request to delete your ${brand} account. Click the button below within 10 minutes to delete all your conversations, content and connections.

 
Delete account
 

If you can’t click the button, copy and paste this link to your browser:

${url}

If you didn’t request this, reset your password.

If you have any questions, please contact us.

Privacy policy and terms of use · Report Misuse
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/en/user/email/new-client.html b/services/brig/deb/opt/brig/templates/en/user/email/new-client.html index b923eeb4ca5..81371023e58 100644 --- a/services/brig/deb/opt/brig/templates/en/user/email/new-client.html +++ b/services/brig/deb/opt/brig/templates/en/user/email/new-client.html @@ -1 +1 @@ -New device

${brand_label_url}

New device

Your ${brand} account was used on:

${date}

${model}

You may have installed ${brand} on a new device or installed it again on an existing one. If that was not the case, go to ${brand} Settings, remove the device and reset your password.

If you have any questions, please contact us.

Privacy policy and terms of use · Report Misuse
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file +New device

${brand_label_url}

New device

Your ${brand} account was used on:

${date}

${model}

You may have installed ${brand} on a new device or installed it again on an existing one. If that was not the case, go to ${brand} Settings, remove the device and reset your password.

If you have any questions, please contact us.

Privacy policy and terms of use · Report Misuse
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/en/user/email/password-reset.html b/services/brig/deb/opt/brig/templates/en/user/email/password-reset.html index 18071d996fe..53ffea05fde 100644 --- a/services/brig/deb/opt/brig/templates/en/user/email/password-reset.html +++ b/services/brig/deb/opt/brig/templates/en/user/email/password-reset.html @@ -1 +1 @@ -Password Change at ${brand}

${brand_label_url}

Reset your password

We’ve received a request to reset the password for your ${brand} account. To create a new password, click the button below.

 
Reset password
 

If you can’t click the button, copy and paste this link to your browser:

${url}

If you have any questions, please contact us.

Privacy policy and terms of use · Report Misuse
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file +Password Change at ${brand}

${brand_label_url}

Reset your password

We’ve received a request to reset the password for your ${brand} account. To create a new password, click the button below.

 
Reset password
 

If you can’t click the button, copy and paste this link to your browser:

${url}

If you have any questions, please contact us.

Privacy policy and terms of use · Report Misuse
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/en/user/email/team-activation.html b/services/brig/deb/opt/brig/templates/en/user/email/team-activation.html index de3833956be..e34ca5f3894 100644 --- a/services/brig/deb/opt/brig/templates/en/user/email/team-activation.html +++ b/services/brig/deb/opt/brig/templates/en/user/email/team-activation.html @@ -1 +1 @@ -${brand} Account

${brand_label_url}

Your new account on ${brand}

A new ${brand} team was created with ${email}. Please verify your email.

 
Verify
 

If you can’t click the button, copy and paste this link to your browser:

${url}

If you have any questions, please contact us.

Privacy policy and terms of use · Report Misuse
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file +${brand} Account

${brand_label_url}

Your new account on ${brand}

A new ${brand} team was created with ${email}. Please verify your email.

 
Verify
 

If you can’t click the button, copy and paste this link to your browser:

${url}

If you have any questions, please contact us.

Privacy policy and terms of use · Report Misuse
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/en/user/email/update.html b/services/brig/deb/opt/brig/templates/en/user/email/update.html index be3a81b8644..339aad5dea7 100644 --- a/services/brig/deb/opt/brig/templates/en/user/email/update.html +++ b/services/brig/deb/opt/brig/templates/en/user/email/update.html @@ -1 +1 @@ -Your new email address on ${brand}

${brand_label_url}

Verify your email

${email} was registered as your new email address on ${brand}. Click the button below to verify your address.

 
Verify
 

If you can’t click the button, copy and paste this link to your browser:

${url}

If you have any questions, please contact us.

Privacy policy and terms of use · Report Misuse
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file +Your new email address on ${brand}

${brand_label_url}

Verify your email

${email} was registered as your new email address on ${brand}. Click the button below to verify your address.

 
Verify
 

If you can’t click the button, copy and paste this link to your browser:

${url}

If you have any questions, please contact us.

Privacy policy and terms of use · Report Misuse
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/en/user/email/verification-delete-team.html b/services/brig/deb/opt/brig/templates/en/user/email/verification-delete-team.html index a957cc75b85..7f0bd94bc56 100644 --- a/services/brig/deb/opt/brig/templates/en/user/email/verification-delete-team.html +++ b/services/brig/deb/opt/brig/templates/en/user/email/verification-delete-team.html @@ -1 +1 @@ -your ${brand} verification code is ${code}

${brand_label_url}

Verify team deletion

${email} was used to delete your ${brand} team. Enter this code to verify your email and delete the team.

 

${code}

 

If you have any questions, please contact us.

Privacy policy and terms of use · Report Misuse
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file +your ${brand} verification code is ${code}

${brand_label_url}

Verify team deletion

${email} was used to delete your ${brand} team. Enter this code to verify your email and delete the team.

 

${code}

 

If you have any questions, please contact us.

Privacy policy and terms of use · Report Misuse
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/en/user/email/verification-login.html b/services/brig/deb/opt/brig/templates/en/user/email/verification-login.html index 78c0bf1a2ee..96783ebe654 100644 --- a/services/brig/deb/opt/brig/templates/en/user/email/verification-login.html +++ b/services/brig/deb/opt/brig/templates/en/user/email/verification-login.html @@ -1 +1 @@ -your ${brand} verification code is ${code}

${brand_label_url}

Verify login

${email} was used to log in to your ${brand} account. Enter this code to verify your email and log in.

 

${code}

 

If you have any questions, please contact us.

Privacy policy and terms of use · Report Misuse
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file +your ${brand} verification code is ${code}

${brand_label_url}

Verify login

${email} was used to log in to your ${brand} account. Enter this code to verify your email and log in.

 

${code}

 

If you have any questions, please contact us.

Privacy policy and terms of use · Report Misuse
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/en/user/email/verification-scim-token.html b/services/brig/deb/opt/brig/templates/en/user/email/verification-scim-token.html index abf8c05d4d1..35c8525e298 100644 --- a/services/brig/deb/opt/brig/templates/en/user/email/verification-scim-token.html +++ b/services/brig/deb/opt/brig/templates/en/user/email/verification-scim-token.html @@ -1 +1 @@ -your ${brand} verification code is ${code}

${brand_label_url}

Verify SCIM token creation

${email} was used to generate a SCIM token. Enter this code to verify your email and create the token.

 

${code}

 

If you have any questions, please contact us.

Privacy policy and terms of use · Report Misuse
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file +your ${brand} verification code is ${code}

${brand_label_url}

Verify SCIM token creation

${email} was used to generate a SCIM token. Enter this code to verify your email and create the token.

 

${code}

 

If you have any questions, please contact us.

Privacy policy and terms of use · Report Misuse
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/en/user/email/verification.html b/services/brig/deb/opt/brig/templates/en/user/email/verification.html index d59229ac555..ad903d3607c 100644 --- a/services/brig/deb/opt/brig/templates/en/user/email/verification.html +++ b/services/brig/deb/opt/brig/templates/en/user/email/verification.html @@ -1 +1 @@ -${code} is your ${brand} verification code

${brand_label_url}

Verify your email

${email} was used to register on ${brand}. Enter this code to verify your email and create your account.

 

${code}

 

If you have any questions, please contact us.

Privacy policy and terms of use · Report Misuse
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file +${code} is your ${brand} verification code

${brand_label_url}

Verify your email

${email} was used to register on ${brand}. Enter this code to verify your email and create your account.

 

${code}

 

If you have any questions, please contact us.

Privacy policy and terms of use · Report Misuse
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/et/user/email/activation.html b/services/brig/deb/opt/brig/templates/et/user/email/activation.html index 537e333f6a9..bd77e33958a 100644 --- a/services/brig/deb/opt/brig/templates/et/user/email/activation.html +++ b/services/brig/deb/opt/brig/templates/et/user/email/activation.html @@ -1 +1 @@ -Your ${brand} Account

${brand_label_url}

Kinnita oma e-posti aadress

${email} was used to register on ${brand}.
Click the button to verify your address.

 
Kinnita
 

Kui sul pole võimalik nuppu klikkida, siis kopeeri allolev aadress veebibrauserisse:

${url}

If you have any questions, please contact us.

Privacy policy and terms of use · Report Misuse
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file +Your ${brand} Account

${brand_label_url}

Kinnita oma e-posti aadress

${email} was used to register on ${brand}.
Click the button to verify your address.

 
Kinnita
 

Kui sul pole võimalik nuppu klikkida, siis kopeeri allolev aadress veebibrauserisse:

${url}

If you have any questions, please contact us.

Privacy policy and terms of use · Report Misuse
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/et/user/email/deletion.html b/services/brig/deb/opt/brig/templates/et/user/email/deletion.html index 7a2265f982b..36eb10cdf00 100644 --- a/services/brig/deb/opt/brig/templates/et/user/email/deletion.html +++ b/services/brig/deb/opt/brig/templates/et/user/email/deletion.html @@ -1 +1 @@ -Kustuta konto?

${brand_label_url}

Kustuta konto

We’ve received a request to delete your ${brand} account. Kogu kontoga seotud info kustutamise kinnitamiseks kliki kümne minuti jooksul alloleval lingil.

 
Kustuta konto
 

Kui sul pole võimalik nuppu klikkida, siis kopeeri allolev aadress veebibrauserisse:

${url}

If you didn’t request this, reset your password.

If you have any questions, please contact us.

Privacy policy and terms of use · Report Misuse
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file +Kustuta konto?

${brand_label_url}

Kustuta konto

We’ve received a request to delete your ${brand} account. Kogu kontoga seotud info kustutamise kinnitamiseks kliki kümne minuti jooksul alloleval lingil.

 
Kustuta konto
 

Kui sul pole võimalik nuppu klikkida, siis kopeeri allolev aadress veebibrauserisse:

${url}

If you didn’t request this, reset your password.

If you have any questions, please contact us.

Privacy policy and terms of use · Report Misuse
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/et/user/email/new-client.html b/services/brig/deb/opt/brig/templates/et/user/email/new-client.html index 71fcf3a4397..622ea916c83 100644 --- a/services/brig/deb/opt/brig/templates/et/user/email/new-client.html +++ b/services/brig/deb/opt/brig/templates/et/user/email/new-client.html @@ -1 +1 @@ -Sisselogimine uuelt seadmelt

${brand_label_url}

Wire uuel seadmel

Your ${brand} account was used on:

${date}

${model}

You may have installed ${brand} on a new device or installed it again on an existing one. If that was not the case, go to ${brand} Settings, remove the device and reset your password.

If you have any questions, please contact us.

Privacy policy and terms of use · Report Misuse
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file +Sisselogimine uuelt seadmelt

${brand_label_url}

Wire uuel seadmel

Your ${brand} account was used on:

${date}

${model}

You may have installed ${brand} on a new device or installed it again on an existing one. If that was not the case, go to ${brand} Settings, remove the device and reset your password.

If you have any questions, please contact us.

Privacy policy and terms of use · Report Misuse
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/et/user/email/password-reset.html b/services/brig/deb/opt/brig/templates/et/user/email/password-reset.html index 6ec235c3b89..2055ca88695 100644 --- a/services/brig/deb/opt/brig/templates/et/user/email/password-reset.html +++ b/services/brig/deb/opt/brig/templates/et/user/email/password-reset.html @@ -1 +1 @@ -Password Change at ${brand}

${brand_label_url}

Lähtesta oma parool

We’ve received a request to reset the password for your ${brand} account. Uue salasõna loomiseks vajutage järgmisele lingile:

 
Lähesta parool
 

Kui sul pole võimalik nuppu klikkida, siis kopeeri allolev aadress veebibrauserisse:

${url}

If you have any questions, please contact us.

Privacy policy and terms of use · Report Misuse
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file +Password Change at ${brand}

${brand_label_url}

Lähtesta oma parool

We’ve received a request to reset the password for your ${brand} account. Uue salasõna loomiseks vajutage järgmisele lingile:

 
Lähesta parool
 

Kui sul pole võimalik nuppu klikkida, siis kopeeri allolev aadress veebibrauserisse:

${url}

If you have any questions, please contact us.

Privacy policy and terms of use · Report Misuse
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/et/user/email/team-activation.html b/services/brig/deb/opt/brig/templates/et/user/email/team-activation.html index 980a3abf701..d042ee19056 100644 --- a/services/brig/deb/opt/brig/templates/et/user/email/team-activation.html +++ b/services/brig/deb/opt/brig/templates/et/user/email/team-activation.html @@ -1 +1 @@ -${brand} Account

${brand_label_url}

Your new account on ${brand}

A new ${brand} team was created with ${email}. Palun kinnita oma meiliaadress.

 
Kinnita
 

Kui sul pole võimalik nuppu klikkida, siis kopeeri allolev aadress veebibrauserisse:

${url}

If you have any questions, please contact us.

Privacy policy and terms of use · Report Misuse
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file +${brand} Account

${brand_label_url}

Your new account on ${brand}

A new ${brand} team was created with ${email}. Palun kinnita oma meiliaadress.

 
Kinnita
 

Kui sul pole võimalik nuppu klikkida, siis kopeeri allolev aadress veebibrauserisse:

${url}

If you have any questions, please contact us.

Privacy policy and terms of use · Report Misuse
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/et/user/email/update.html b/services/brig/deb/opt/brig/templates/et/user/email/update.html index 1d2a00961bb..92c86559af6 100644 --- a/services/brig/deb/opt/brig/templates/et/user/email/update.html +++ b/services/brig/deb/opt/brig/templates/et/user/email/update.html @@ -1 +1 @@ -Your new email address on ${brand}

${brand_label_url}

Kinnita oma e-posti aadress

${email} was registered as your new email address on ${brand}. Aadressi kinnitamiseks kliki alloleval lingil.

 
Kinnita
 

Kui sul pole võimalik nuppu klikkida, siis kopeeri allolev aadress veebibrauserisse:

${url}

If you have any questions, please contact us.

Privacy policy and terms of use · Report Misuse
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file +Your new email address on ${brand}

${brand_label_url}

Kinnita oma e-posti aadress

${email} was registered as your new email address on ${brand}. Aadressi kinnitamiseks kliki alloleval lingil.

 
Kinnita
 

Kui sul pole võimalik nuppu klikkida, siis kopeeri allolev aadress veebibrauserisse:

${url}

If you have any questions, please contact us.

Privacy policy and terms of use · Report Misuse
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/et/user/email/verification-delete-team.html b/services/brig/deb/opt/brig/templates/et/user/email/verification-delete-team.html index a957cc75b85..7f0bd94bc56 100644 --- a/services/brig/deb/opt/brig/templates/et/user/email/verification-delete-team.html +++ b/services/brig/deb/opt/brig/templates/et/user/email/verification-delete-team.html @@ -1 +1 @@ -your ${brand} verification code is ${code}

${brand_label_url}

Verify team deletion

${email} was used to delete your ${brand} team. Enter this code to verify your email and delete the team.

 

${code}

 

If you have any questions, please contact us.

Privacy policy and terms of use · Report Misuse
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file +your ${brand} verification code is ${code}

${brand_label_url}

Verify team deletion

${email} was used to delete your ${brand} team. Enter this code to verify your email and delete the team.

 

${code}

 

If you have any questions, please contact us.

Privacy policy and terms of use · Report Misuse
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/et/user/email/verification-login.html b/services/brig/deb/opt/brig/templates/et/user/email/verification-login.html index 78c0bf1a2ee..96783ebe654 100644 --- a/services/brig/deb/opt/brig/templates/et/user/email/verification-login.html +++ b/services/brig/deb/opt/brig/templates/et/user/email/verification-login.html @@ -1 +1 @@ -your ${brand} verification code is ${code}

${brand_label_url}

Verify login

${email} was used to log in to your ${brand} account. Enter this code to verify your email and log in.

 

${code}

 

If you have any questions, please contact us.

Privacy policy and terms of use · Report Misuse
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file +your ${brand} verification code is ${code}

${brand_label_url}

Verify login

${email} was used to log in to your ${brand} account. Enter this code to verify your email and log in.

 

${code}

 

If you have any questions, please contact us.

Privacy policy and terms of use · Report Misuse
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/et/user/email/verification-scim-token.html b/services/brig/deb/opt/brig/templates/et/user/email/verification-scim-token.html index abf8c05d4d1..35c8525e298 100644 --- a/services/brig/deb/opt/brig/templates/et/user/email/verification-scim-token.html +++ b/services/brig/deb/opt/brig/templates/et/user/email/verification-scim-token.html @@ -1 +1 @@ -your ${brand} verification code is ${code}

${brand_label_url}

Verify SCIM token creation

${email} was used to generate a SCIM token. Enter this code to verify your email and create the token.

 

${code}

 

If you have any questions, please contact us.

Privacy policy and terms of use · Report Misuse
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file +your ${brand} verification code is ${code}

${brand_label_url}

Verify SCIM token creation

${email} was used to generate a SCIM token. Enter this code to verify your email and create the token.

 

${code}

 

If you have any questions, please contact us.

Privacy policy and terms of use · Report Misuse
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/et/user/email/verification.html b/services/brig/deb/opt/brig/templates/et/user/email/verification.html index a198747ba3e..e15dfcd7a48 100644 --- a/services/brig/deb/opt/brig/templates/et/user/email/verification.html +++ b/services/brig/deb/opt/brig/templates/et/user/email/verification.html @@ -1 +1 @@ -${code} is your ${brand} verification code

${brand_label_url}

Kinnita oma e-posti aadress

${email} was used to register on ${brand}. Konto loomiseks sisestage see kood brauseriaknas.

 

${code}

 

If you have any questions, please contact us.

Privacy policy and terms of use · Report Misuse
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file +${code} is your ${brand} verification code

${brand_label_url}

Kinnita oma e-posti aadress

${email} was used to register on ${brand}. Konto loomiseks sisestage see kood brauseriaknas.

 

${code}

 

If you have any questions, please contact us.

Privacy policy and terms of use · Report Misuse
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/fr/user/email/activation.html b/services/brig/deb/opt/brig/templates/fr/user/email/activation.html index d2fb45305ed..8435bf74e19 100644 --- a/services/brig/deb/opt/brig/templates/fr/user/email/activation.html +++ b/services/brig/deb/opt/brig/templates/fr/user/email/activation.html @@ -1 +1 @@ -Votre Compte ${brand}

${brand_label_url}

Vérification de votre adresse email

${email} a été utilisé pour s'enregistrer sur ${brand}.
Cliquez sur le bouton ci-dessous pour vérifier votre adresse.

 
Vérifier
 

Si vous ne pouvez pas cliquer sur le bouton, copiez et collez ce lien dans votre navigateur :

${url}

Si vous avez des questions, veuillez nous contacter.

Règles de confidentialité et conditions d'utilisation · Signaler un abus
${copyright}. TOUS DROITS RÉSERVÉS.

                                                           
\ No newline at end of file +Votre Compte ${brand}

${brand_label_url}

Vérification de votre adresse email

${email} a été utilisé pour s'enregistrer sur ${brand}.
Cliquez sur le bouton ci-dessous pour vérifier votre adresse.

 
Vérifier
 

Si vous ne pouvez pas cliquer sur le bouton, copiez et collez ce lien dans votre navigateur :

${url}

Si vous avez des questions, veuillez nous contacter.

Règles de confidentialité et conditions d'utilisation · Signaler un abus
${copyright}. TOUS DROITS RÉSERVÉS.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/fr/user/email/deletion.html b/services/brig/deb/opt/brig/templates/fr/user/email/deletion.html index 03721e20ac2..331a6b0cbcf 100644 --- a/services/brig/deb/opt/brig/templates/fr/user/email/deletion.html +++ b/services/brig/deb/opt/brig/templates/fr/user/email/deletion.html @@ -1 +1 @@ -Supprimer votre compte ?

${brand_label_url}

Supprimer votre compte

Nous avons reçu une demande de suppression de votre compte ${brand}. Cliquez sur le lien ci-dessous dans les 10 minutes pour supprimer toutes vos conversations, contenus et connexions.

 
Supprimer le compte
 

Si vous ne pouvez pas cliquer sur le bouton, copiez et collez ce lien dans votre navigateur :

${url}

Si vous n'êtes pas à l'origine de cette demande, réinitialisez votre mot de passe.

Si vous avez des questions, veuillez nous contacter.

Règles de confidentialité et conditions d'utilisation · Signaler un abus
${copyright}. TOUS DROITS RÉSERVÉS.

                                                           
\ No newline at end of file +Supprimer votre compte ?

${brand_label_url}

Supprimer votre compte

Nous avons reçu une demande de suppression de votre compte ${brand}. Cliquez sur le lien ci-dessous dans les 10 minutes pour supprimer toutes vos conversations, contenus et connexions.

 
Supprimer le compte
 

Si vous ne pouvez pas cliquer sur le bouton, copiez et collez ce lien dans votre navigateur :

${url}

Si vous n'êtes pas à l'origine de cette demande, réinitialisez votre mot de passe.

Si vous avez des questions, veuillez nous contacter.

Règles de confidentialité et conditions d'utilisation · Signaler un abus
${copyright}. TOUS DROITS RÉSERVÉS.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/fr/user/email/new-client.html b/services/brig/deb/opt/brig/templates/fr/user/email/new-client.html index f971057e648..6c3a77b13e8 100644 --- a/services/brig/deb/opt/brig/templates/fr/user/email/new-client.html +++ b/services/brig/deb/opt/brig/templates/fr/user/email/new-client.html @@ -1 +1 @@ -Nouvel appareil

${brand_label_url}

Nouvel appareil

Votre compte ${brand} a été utilisé sur :

${date}

${model}

Il se peut que vous ayez installé ${brand} sur un nouvel appareil ou réinstallé sur le même. Si ce n'était pas le cas, allez dans les paramètres de ${brand}, retirez cet appareil et réinitialisez votre mot de passe.

Si vous avez des questions, veuillez nous contacter.

Règles de confidentialité et conditions d'utilisation · Signaler un abus
${copyright}. TOUS DROITS RÉSERVÉS.

                                                           
\ No newline at end of file +Nouvel appareil

${brand_label_url}

Nouvel appareil

Votre compte ${brand} a été utilisé sur :

${date}

${model}

Il se peut que vous ayez installé ${brand} sur un nouvel appareil ou réinstallé sur le même. Si ce n'était pas le cas, allez dans les paramètres de ${brand}, retirez cet appareil et réinitialisez votre mot de passe.

Si vous avez des questions, veuillez nous contacter.

Règles de confidentialité et conditions d'utilisation · Signaler un abus
${copyright}. TOUS DROITS RÉSERVÉS.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/fr/user/email/password-reset.html b/services/brig/deb/opt/brig/templates/fr/user/email/password-reset.html index c95987ccc7d..02cc9de42e7 100644 --- a/services/brig/deb/opt/brig/templates/fr/user/email/password-reset.html +++ b/services/brig/deb/opt/brig/templates/fr/user/email/password-reset.html @@ -1 +1 @@ -Réinitialisation du mot de passe ${brand}

${brand_label_url}

Réinitialiser votre mot de passe

Nous avons reçu une demande pour réinitialiser le mot de passe de votre compte ${brand}. Pour créer un nouveau mot de passe, cliquez sur le bouton ci-dessous.

 
Réinitialiser le mot de passe
 

Si vous ne pouvez pas cliquer sur le bouton, copiez et collez ce lien dans votre navigateur :

${url}

Si vous avez des questions, veuillez nous contacter.

Règles de confidentialité et conditions d'utilisation · Signaler un abus
${copyright}. TOUS DROITS RÉSERVÉS.

                                                           
\ No newline at end of file +Réinitialisation du mot de passe ${brand}

${brand_label_url}

Réinitialiser votre mot de passe

Nous avons reçu une demande pour réinitialiser le mot de passe de votre compte ${brand}. Pour créer un nouveau mot de passe, cliquez sur le bouton ci-dessous.

 
Réinitialiser le mot de passe
 

Si vous ne pouvez pas cliquer sur le bouton, copiez et collez ce lien dans votre navigateur :

${url}

Si vous avez des questions, veuillez nous contacter.

Règles de confidentialité et conditions d'utilisation · Signaler un abus
${copyright}. TOUS DROITS RÉSERVÉS.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/fr/user/email/team-activation.html b/services/brig/deb/opt/brig/templates/fr/user/email/team-activation.html index c1a3c2eb890..d4450a20a3d 100644 --- a/services/brig/deb/opt/brig/templates/fr/user/email/team-activation.html +++ b/services/brig/deb/opt/brig/templates/fr/user/email/team-activation.html @@ -1 +1 @@ -Compte ${brand}

${brand_label_url}

Votre nouveau compte ${brand}

Une nouvelle équipé a été créée sur ${brand} avec ${email}. Veuillez vérifier votre adresse email s’il vous plaît.

 
Vérifier
 

Si vous ne pouvez pas cliquer sur le bouton, copiez et collez ce lien dans votre navigateur :

${url}

Si vous avez des questions, veuillez nous contacter.

Règles de confidentialité et conditions d'utilisation · Signaler un abus
${copyright}. TOUS DROITS RÉSERVÉS.

                                                           
\ No newline at end of file +Compte ${brand}

${brand_label_url}

Votre nouveau compte ${brand}

Une nouvelle équipé a été créée sur ${brand} avec ${email}. Veuillez vérifier votre adresse email s’il vous plaît.

 
Vérifier
 

Si vous ne pouvez pas cliquer sur le bouton, copiez et collez ce lien dans votre navigateur :

${url}

Si vous avez des questions, veuillez nous contacter.

Règles de confidentialité et conditions d'utilisation · Signaler un abus
${copyright}. TOUS DROITS RÉSERVÉS.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/fr/user/email/update.html b/services/brig/deb/opt/brig/templates/fr/user/email/update.html index eba1972a7b3..5aeb1430126 100644 --- a/services/brig/deb/opt/brig/templates/fr/user/email/update.html +++ b/services/brig/deb/opt/brig/templates/fr/user/email/update.html @@ -1 +1 @@ -Votre nouvelle adresse e-mail sur ${brand}

${brand_label_url}

Vérification de votre adresse email

${email} a été enregistré comme votre nouvelle adresse email sur ${brand}. Veuillez vérifier votre email s’il vous plaît. Cliquez sur le bouton ci-dessous pour vérifier votre adresse email.

 
Vérifier
 

Si vous ne pouvez pas cliquer sur le bouton, copiez et collez ce lien dans votre navigateur :

${url}

Si vous avez des questions, veuillez nous contacter.

Règles de confidentialité et conditions d'utilisation · Signaler un abus
${copyright}. TOUS DROITS RÉSERVÉS.

                                                           
\ No newline at end of file +Votre nouvelle adresse e-mail sur ${brand}

${brand_label_url}

Vérification de votre adresse email

${email} a été enregistré comme votre nouvelle adresse email sur ${brand}. Veuillez vérifier votre email s’il vous plaît. Cliquez sur le bouton ci-dessous pour vérifier votre adresse email.

 
Vérifier
 

Si vous ne pouvez pas cliquer sur le bouton, copiez et collez ce lien dans votre navigateur :

${url}

Si vous avez des questions, veuillez nous contacter.

Règles de confidentialité et conditions d'utilisation · Signaler un abus
${copyright}. TOUS DROITS RÉSERVÉS.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/fr/user/email/verification-delete-team-subject.txt b/services/brig/deb/opt/brig/templates/fr/user/email/verification-delete-team-subject.txt index e69de29bb2d..2498475de38 100644 --- a/services/brig/deb/opt/brig/templates/fr/user/email/verification-delete-team-subject.txt +++ b/services/brig/deb/opt/brig/templates/fr/user/email/verification-delete-team-subject.txt @@ -0,0 +1 @@ +« votre code de vérification ${brand} est ${code} » \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/fr/user/email/verification-delete-team.html b/services/brig/deb/opt/brig/templates/fr/user/email/verification-delete-team.html index 3f6dfbd6a81..cd176964978 100644 --- a/services/brig/deb/opt/brig/templates/fr/user/email/verification-delete-team.html +++ b/services/brig/deb/opt/brig/templates/fr/user/email/verification-delete-team.html @@ -1 +1 @@ -

${brand_label_url}

Vérifier la suppression de l'équipe

${email} a été utilisé pour supprimer votre équipe ${brand}. Entrez ce code pour vérifier votre adresse courriel et supprimer l'équipe.

 

${code}

 

Si vous avez des questions, veuillez nous contacter.

Règles de confidentialité et conditions d'utilisation · Signaler un abus
${copyright}. TOUS DROITS RÉSERVÉS.

                                                           
\ No newline at end of file +« votre code de vérification ${brand} est ${code} »

${brand_label_url}

Vérifier la suppression de l'équipe

${email} a été utilisé pour supprimer votre équipe ${brand}. Entrez ce code pour vérifier votre adresse courriel et supprimer l'équipe.

 

${code}

 

Si vous avez des questions, veuillez nous contacter.

Règles de confidentialité et conditions d'utilisation · Signaler un abus
${copyright}. TOUS DROITS RÉSERVÉS.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/fr/user/email/verification-login.html b/services/brig/deb/opt/brig/templates/fr/user/email/verification-login.html index 8e9d0b12908..e7706bd69fd 100644 --- a/services/brig/deb/opt/brig/templates/fr/user/email/verification-login.html +++ b/services/brig/deb/opt/brig/templates/fr/user/email/verification-login.html @@ -1 +1 @@ -« votre code de vérification ${brand} est ${code} »

${brand_label_url}

Vérifier la connexion

${email} a été utilisé pour se connecter à votre compte ${brand}. Entrez ce code pour vérifier votre adresse courriel et connectez-vous.

 

${code}

 

Si vous avez des questions, veuillez nous contacter.

Règles de confidentialité et conditions d'utilisation · Signaler un abus
${copyright}. TOUS DROITS RÉSERVÉS.

                                                           
\ No newline at end of file +« votre code de vérification ${brand} est ${code} »

${brand_label_url}

Vérifier la connexion

${email} a été utilisé pour se connecter à votre compte ${brand}. Entrez ce code pour vérifier votre adresse courriel et connectez-vous.

 

${code}

 

Si vous avez des questions, veuillez nous contacter.

Règles de confidentialité et conditions d'utilisation · Signaler un abus
${copyright}. TOUS DROITS RÉSERVÉS.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/fr/user/email/verification-scim-token-subject.txt b/services/brig/deb/opt/brig/templates/fr/user/email/verification-scim-token-subject.txt index e69de29bb2d..2498475de38 100644 --- a/services/brig/deb/opt/brig/templates/fr/user/email/verification-scim-token-subject.txt +++ b/services/brig/deb/opt/brig/templates/fr/user/email/verification-scim-token-subject.txt @@ -0,0 +1 @@ +« votre code de vérification ${brand} est ${code} » \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/fr/user/email/verification-scim-token.html b/services/brig/deb/opt/brig/templates/fr/user/email/verification-scim-token.html index cc6237b38ce..ebee6e06170 100644 --- a/services/brig/deb/opt/brig/templates/fr/user/email/verification-scim-token.html +++ b/services/brig/deb/opt/brig/templates/fr/user/email/verification-scim-token.html @@ -1 +1 @@ -

${brand_label_url}

Vérifier la création du jeton SCIM

${email} a été utilisé pour générer un jeton SCIM. Entrez ce code pour vérifier votre adresse courriel et créer le jeton.

 

${code}

 

Si vous avez des questions, veuillez nous contacter.

Règles de confidentialité et conditions d'utilisation · Signaler un abus
${copyright}. TOUS DROITS RÉSERVÉS.

                                                           
\ No newline at end of file +« votre code de vérification ${brand} est ${code} »

${brand_label_url}

Vérifier la création du jeton SCIM

${email} a été utilisé pour générer un jeton SCIM. Entrez ce code pour vérifier votre adresse courriel et créer le jeton.

 

${code}

 

Si vous avez des questions, veuillez nous contacter.

Règles de confidentialité et conditions d'utilisation · Signaler un abus
${copyright}. TOUS DROITS RÉSERVÉS.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/fr/user/email/verification.html b/services/brig/deb/opt/brig/templates/fr/user/email/verification.html index 0209a72d2d7..a3ab5aa79f1 100644 --- a/services/brig/deb/opt/brig/templates/fr/user/email/verification.html +++ b/services/brig/deb/opt/brig/templates/fr/user/email/verification.html @@ -1 +1 @@ -${code} est votre code de vérification pour ${brand}

${brand_label_url}

Vérification de votre adresse email

L'adresse ${email} a été utilisée pour créer un compte sur ${brand}. Entrez ce code afin de vérifier votre adresse email et créer votre compte.

 

${code}

 

Si vous avez des questions, veuillez nous contacter.

Règles de confidentialité et conditions d'utilisation · Signaler un abus
${copyright}. TOUS DROITS RÉSERVÉS.

                                                           
\ No newline at end of file +${code} est votre code de vérification pour ${brand}

${brand_label_url}

Vérification de votre adresse email

L'adresse ${email} a été utilisée pour créer un compte sur ${brand}. Entrez ce code afin de vérifier votre adresse email et créer votre compte.

 

${code}

 

Si vous avez des questions, veuillez nous contacter.

Règles de confidentialité et conditions d'utilisation · Signaler un abus
${copyright}. TOUS DROITS RÉSERVÉS.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/index.html b/services/brig/deb/opt/brig/templates/index.html index 7c4de7c2040..f0d4029dc3a 100644 --- a/services/brig/deb/opt/brig/templates/index.html +++ b/services/brig/deb/opt/brig/templates/index.html @@ -4,4 +4,4 @@ link.rel = 'stylesheet'; link.href = '//cdnjs.cloudflare.com/ajax/libs/flag-icon-css/2.9.0/css/flag-icon.min.css'; document.head.appendChild(link); - }
 

Wire Email Templates Preview

Click the links below to display the content of each message:

Provider
  1. Activation — txt
  2. Approval confirm — txt
  3. Approval request — txt
Team
  1. Invitation — txt
  2. New member welcome — txt
User
  1. Activation — txt
  2. Deletion — txt
  3. New client — txt
  4. Password reset — txt
  5. Update — txt
  6. Verification — txt
  7. Team activation — txt
  8. Second factor verification for login — txt
  9. Second factor verification create SCIM token — txt
  10. Second factor verification delete team — txt
Billing
  1. Suspension — txt

For source and instructions, see github.com/wireapp/wire-emails or visit the Crowdin project to help with translations.

                                                           
\ No newline at end of file + }
 

Wire Email Templates Preview

Click the links below to display the content of each message:

Provider
  1. Activation — txt
  2. Approval confirm — txt
  3. Approval request — txt
Team
  1. Invitation — txt
  2. New member welcome — txt
User
  1. Activation — txt
  2. Deletion — txt
  3. New client — txt
  4. Password reset — txt
  5. Update — txt
  6. Verification — txt
  7. Team activation — txt
  8. Second factor verification for login — txt
  9. Second factor verification create SCIM token — txt
  10. Second factor verification delete team — txt
Billing
  1. Suspension — txt

For source and instructions, see github.com/wireapp/wire-emails or visit the Crowdin project to help with translations.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/it/user/call/activation.txt b/services/brig/deb/opt/brig/templates/it/user/call/activation.txt index fa1e320db39..c1b51fc95b8 100644 --- a/services/brig/deb/opt/brig/templates/it/user/call/activation.txt +++ b/services/brig/deb/opt/brig/templates/it/user/call/activation.txt @@ -1 +1 @@ -Ciao, il tuo codice di verifica di Wire è: ${code}. Ripeto, il codice è: ${code} \ No newline at end of file +Ciao, il tuo codice verifica di Wire è: ${code}. Ancora una volta, il codice è: ${code} \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/it/user/call/login.txt b/services/brig/deb/opt/brig/templates/it/user/call/login.txt index e51ef3c5a68..fd6cfc78e6a 100644 --- a/services/brig/deb/opt/brig/templates/it/user/call/login.txt +++ b/services/brig/deb/opt/brig/templates/it/user/call/login.txt @@ -1 +1 @@ -Ciao, il tuo codice di accesso Wire è: ${code}. Ripeto, il codice è: ${code} +Ciao, il tuo codice di accesso di Wire è: ${code}. Ancora una volta, il codice è: ${code} \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/it/user/email/activation-subject.txt b/services/brig/deb/opt/brig/templates/it/user/email/activation-subject.txt index 4934020198c..ee3b847edfb 100644 --- a/services/brig/deb/opt/brig/templates/it/user/email/activation-subject.txt +++ b/services/brig/deb/opt/brig/templates/it/user/email/activation-subject.txt @@ -1 +1 @@ -Il tuo account su Wire \ No newline at end of file +Il tuo account ${brand} \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/it/user/email/activation.html b/services/brig/deb/opt/brig/templates/it/user/email/activation.html index b6c7a766375..0812e96af31 100644 --- a/services/brig/deb/opt/brig/templates/it/user/email/activation.html +++ b/services/brig/deb/opt/brig/templates/it/user/email/activation.html @@ -1,124 +1 @@ - - - - - - - -
- - - - - - - - - - - - - - - - - -
- - - wire.com -
-

- Ciao, -

- -

- L'indirizzo ${email} è stato usato per create un account su Wire. Ti preghiamo di confermare l'indirizzoo email. -

-

- - CONFERMA - -

-

- Clicca sul pulsante qui sopra per verificare il tuo indirizzo. Non puoi utilizzare Wire fino a che non premi il pulsante. -

-

- Se non è possibile fare clic sul pulsante, usa questo link:
-

-

- ${url} -

-

- Se non hai richiesto tu questa modifica, puoi ignorare questa email o - - contattaci - . -

-
- Informativa sulla privacy · Segnala uso improprio
© Wire Swiss GmbH. Tutti i diritti riservati. -
- - +Il tuo account ${brand}

${brand_label_url}

Verifica il tuo indirizzo e-mail

${email} è stato utilizzata per registrarsi su ${brand}.
Clicca il pulsante per verificare il tuo indirizzo.

 
Verifica
 

Se non puoi fare clic sul pulsante, copia e incolla questo link nel tuo browser:

${url}

Se hai domande, per favore contattaci.

Politica della privacy e termini d'uso · Segnala Uso Scorretto
${copyright}. TUTTI I DIRITTI RISERVATI.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/it/user/email/activation.txt b/services/brig/deb/opt/brig/templates/it/user/email/activation.txt index dd8fa3fe157..b655bab11cb 100644 --- a/services/brig/deb/opt/brig/templates/it/user/email/activation.txt +++ b/services/brig/deb/opt/brig/templates/it/user/email/activation.txt @@ -1,22 +1,21 @@ -Wire +[${brand_logo}] +${brand_label_url} [${brand_url}] -Ciao, - -Il tuo indirizzo e-mail ${email} è stato utilizzato per creare un account su Wire. Ti preghiamo di verificare l'indirizzo email. - -Apri il link qui sotto per confermare il tuo indirizzo. Non potrai usare Wire fino a che non avrai confermato. +VERIFICA IL TUO INDIRIZZO E-MAIL +${email} è stato utilizzata per registrarsi su ${brand}. +Clicca il pulsante per verificare il tuo indirizzo. +Verifica [${url}]Se non puoi fare clic sul pulsante, copia e incolla questo link +nel tuo browser: ${url} -Si prega di non rispondere a questo messaggio. - -Se non sei stato tu a create un account Wire con questa e-mail, si prega di visitare https://support.wire.com - - +Se hai domande, per favore contattaci [${support}]. -(c) Wire Swiss GmbH +-------------------------------------------------------------------------------- -Informativa sulla privacy | Riporta uso improprio +Politica della privacy e termini d'uso [${legal}] · Segnala Uso Scorretto +[${misuse}] +${copyright}. TUTTI I DIRITTI RISERVATI. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/it/user/email/deletion-subject.txt b/services/brig/deb/opt/brig/templates/it/user/email/deletion-subject.txt index c2b90f5c4cf..9e0674745cf 100644 --- a/services/brig/deb/opt/brig/templates/it/user/email/deletion-subject.txt +++ b/services/brig/deb/opt/brig/templates/it/user/email/deletion-subject.txt @@ -1 +1 @@ -Eliminare l'account? \ No newline at end of file +Eliminare account? \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/it/user/email/deletion.html b/services/brig/deb/opt/brig/templates/it/user/email/deletion.html index cebdc7ae191..10d09fa2521 100644 --- a/services/brig/deb/opt/brig/templates/it/user/email/deletion.html +++ b/services/brig/deb/opt/brig/templates/it/user/email/deletion.html @@ -1,123 +1 @@ - - - - - - - -
- - - - - - - - - - - - - - - - - -
- - - wire.com -
-

- Ciao ${name}, -

- -

- Abbiamo ricevuto una richiesta per eliminare il tuo account su Wire. Clicca sul pulsante sotto entro 10 minuti per eliminare tutte le tue conversazioni, contenuti e collegamenti -

-

- - ELIMINA ACCOUNT - -

-

- Se non è possibile fare clic sul pulsante, usa questo link:
-

-

- ${url} -

-

- Se non sei stato tu a richiederlo, reimposta la tua password. -

-

- Il team di Wire -

-
- Informativa sulla privacy · Segnala uso improprio
© Wire Swiss GmbH. Tutti i diritti riservati. -
- - +Eliminare account?

${brand_label_url}

Elimina il tuo account

Abbiamo ricevuto una richiesta per eliminare il tuo account ${brand}. Clicca sul pulsante qui sotto entro 10 minuti per eliminare tutte le conversazioni, i contenuti e le connessioni.

 
Elimina account
 

Se non puoi fare clic sul pulsante, copia e incolla questo link nel tuo browser:

${url}

Se non lo hai richiesto, reimposta la password.

Se hai domande, per favore contattaci.

Politica della privacy e termini d'uso · Segnala Uso Scorretto
${copyright}. TUTTI I DIRITTI RISERVATI.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/it/user/email/deletion.txt b/services/brig/deb/opt/brig/templates/it/user/email/deletion.txt index 4333b54d64d..376449de73c 100644 --- a/services/brig/deb/opt/brig/templates/it/user/email/deletion.txt +++ b/services/brig/deb/opt/brig/templates/it/user/email/deletion.txt @@ -1,17 +1,24 @@ -Wire +[${brand_logo}] +${brand_label_url} [${brand_url}] -Ciao ${name}, +ELIMINA IL TUO ACCOUNT +Abbiamo ricevuto una richiesta per eliminare il tuo account ${brand}. Clicca sul +pulsante qui sotto entro 10 minuti per eliminare tutte le conversazioni, i +contenuti e le connessioni. -Abbiamo ricevuto una richiesta per eliminare il tuo account su Wire. Visita il link qui sotto entro 10 minuti per eliminare tutte le tue conversazioni, contenuti e collegamenti +Elimina account [${url}]Se non puoi fare clic sul pulsante, copia e incolla +questo link nel tuo browser: ${url} -Se non sei stato tu a richiedere l'eliminazione, reimposta la password. +Se non lo hai richiesto, reimposta la password [${forgot}]. -Il team di Wire +Se hai domande, per favore contattaci [${support}]. -(c) Wire Swiss GmbH +-------------------------------------------------------------------------------- -Informativa sulla privacy | Riporta uso improprio +Politica della privacy e termini d'uso [${legal}] · Segnala Uso Scorretto +[${misuse}] +${copyright}. TUTTI I DIRITTI RISERVATI. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/it/user/email/new-client.html b/services/brig/deb/opt/brig/templates/it/user/email/new-client.html index 100a746e2dd..dc4dbaccb0e 100644 --- a/services/brig/deb/opt/brig/templates/it/user/email/new-client.html +++ b/services/brig/deb/opt/brig/templates/it/user/email/new-client.html @@ -1,99 +1 @@ - - - - - - - -
- - - - - - - - - - - - - - - - - -
- - - wire.com -
-

- Ciao ${name}, -

- -

- Il tuo account di Wire è stato utilizzato in data: -

- -

- ${date} -

-

- ${model} -

- -

- Potresti avere installato Wire su un nuovo dispositivo o averlo installato di nuovo su uno utilizzato precedentemente. Se non fosse così, vai alle impostazioni di Wire, rimuovi il dispositivo e reimposta la password. -

- -

- Il team di Wire -

-
- Informativa sulla privacy · Segnala uso improprio
© Wire Swiss GmbH. Tutti i diritti riservati. -
- - +Nuovo dispositivo

${brand_label_url}

Nuovo dispositivo

Il tuo account ${brand} è stato utilizzato in data:

${date}

${model}

Potresti avere installato ${brand} su un nuovo dispositivo o averlo installato di nuovo su uno utilizzato precedentemente. Se questo non è il caso, vai nelle impostazioni di ${brand} rimuovi quel dispositivo e reimposta la tua password.

Se hai domande, per favore contattaci.

Politica della privacy e termini d'uso · Segnala Uso Scorretto
${copyright}. TUTTI I DIRITTI RISERVATI.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/it/user/email/new-client.txt b/services/brig/deb/opt/brig/templates/it/user/email/new-client.txt index 1193c2cf489..ae7cc169b84 100644 --- a/services/brig/deb/opt/brig/templates/it/user/email/new-client.txt +++ b/services/brig/deb/opt/brig/templates/it/user/email/new-client.txt @@ -1,18 +1,24 @@ -Wire +[${brand_logo}] +${brand_label_url} [${brand_url}] -Ciao ${name}, +NUOVO DISPOSITIVO +Il tuo account ${brand} è stato utilizzato in data: -Il tuo account di Wire è stato utilizzato in data: +${date} - ${date} - ${model} +${model} -Potresti avere installato Wire su un nuovo dispositivo o averlo installato di nuovo su uno utilizzato precedentemente. Se questo non è il caso, vai nelle impostazioni di Wire, rimuovi quel dispositivo e reimposta la tua password. +Potresti avere installato ${brand} su un nuovo dispositivo o averlo installato +di nuovo su uno utilizzato precedentemente. Se questo non è il caso, vai nelle +impostazioni di ${brand} rimuovi quel dispositivo e reimposta la tua password +[${forgot}]. -Il team di Wire +Se hai domande, per favore contattaci [${support}]. -(c) Wire Swiss GmbH +-------------------------------------------------------------------------------- -Informativa sulla privacy | Riporta uso improprio +Politica della privacy e termini d'uso [${legal}] · Segnala Uso Scorretto +[${misuse}] +${copyright}. TUTTI I DIRITTI RISERVATI. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/it/user/email/password-reset-subject.txt b/services/brig/deb/opt/brig/templates/it/user/email/password-reset-subject.txt index f4f06b6f47e..e052e20d512 100644 --- a/services/brig/deb/opt/brig/templates/it/user/email/password-reset-subject.txt +++ b/services/brig/deb/opt/brig/templates/it/user/email/password-reset-subject.txt @@ -1 +1 @@ -Modifica della password di Wire \ No newline at end of file +Cambio di password di ${brand} \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/it/user/email/password-reset.html b/services/brig/deb/opt/brig/templates/it/user/email/password-reset.html index e3b992d6813..475f1d82b97 100644 --- a/services/brig/deb/opt/brig/templates/it/user/email/password-reset.html +++ b/services/brig/deb/opt/brig/templates/it/user/email/password-reset.html @@ -1,115 +1 @@ - - - - - - - -
- - - - - - - - - - - - - - - - - -
- - - wire.com -
-

- Ciao, -

-

- Abbiamo ricevuto una richiesta per modificare la password per l'account di Wire. Per modificare Per modificare la password, fai clic sul pulsante qui sotto. -

-

- - CAMBIA PASSWORD - -

-

- Se non è possibile fare clic sul pulsante, usa questo link:
-

-

- ${url} -

-

- Questo è un messaggio automatico e nessuno potrà leggere la tua risposta. -

-
- Informativa sulla privacy · Segnala uso improprio
© Wire Swiss GmbH. Tutti i diritti riservati. -
- - +Cambio di password di ${brand}

${brand_label_url}

Reimposta la tua password

Abbiamo ricevuto una richiesta di reimpostazione della password del tuo account ${brand}. Per creare una nuova password, fai clic sul pulsante qui sotto.

 
Reimposta password
 

Se non puoi fare clic sul pulsante, copia e incolla questo link nel tuo browser:

${url}

Se hai domande, per favore contattaci.

Politica della privacy e termini d'uso · Segnala Uso Scorretto
${copyright}. TUTTI I DIRITTI RISERVATI.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/it/user/email/password-reset.txt b/services/brig/deb/opt/brig/templates/it/user/email/password-reset.txt index 1c2e63ccb1e..3aa152a0db3 100644 --- a/services/brig/deb/opt/brig/templates/it/user/email/password-reset.txt +++ b/services/brig/deb/opt/brig/templates/it/user/email/password-reset.txt @@ -1,21 +1,21 @@ -Wire +[${brand_logo}] +${brand_label_url} [${brand_url}] -Ciao, +REIMPOSTA LA TUA PASSWORD +Abbiamo ricevuto una richiesta di reimpostazione della password del tuo account +${brand}. Per creare una nuova password, fai clic sul pulsante qui sotto. -Abbiamo ricevuto una richiesta per modificare la password per l'account di Wire. - -Per modificare la password, fai clic sul link qui sotto. +Reimposta password [${url}]Se non puoi fare clic sul pulsante, copia e incolla +questo link nel tuo browser: ${url} -Si prega di non rispondere a questo messaggio. - -Questo è un messaggio automatico e nessuno potrà leggere la tua risposta. -Se hai bisogno di aiuto, si prega di visitare https://support.wire.com - +Se hai domande, per favore contattaci [${support}]. -(c) Wire Swiss GmbH +-------------------------------------------------------------------------------- -Informativa sulla privacy | Riporta uso improprio +Politica della privacy e termini d'uso [${legal}] · Segnala Uso Scorretto +[${misuse}] +${copyright}. TUTTI I DIRITTI RISERVATI. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/it/user/email/team-activation-subject.txt b/services/brig/deb/opt/brig/templates/it/user/email/team-activation-subject.txt index 4934020198c..e1d8c21b701 100644 --- a/services/brig/deb/opt/brig/templates/it/user/email/team-activation-subject.txt +++ b/services/brig/deb/opt/brig/templates/it/user/email/team-activation-subject.txt @@ -1 +1 @@ -Il tuo account su Wire \ No newline at end of file +Profilo di ${brand} \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/it/user/email/team-activation.html b/services/brig/deb/opt/brig/templates/it/user/email/team-activation.html index eb02eb099c2..0f6eeadb38b 100644 --- a/services/brig/deb/opt/brig/templates/it/user/email/team-activation.html +++ b/services/brig/deb/opt/brig/templates/it/user/email/team-activation.html @@ -1,121 +1 @@ - - - - - - - -
- - - - -
-
- - - - - - - - - - - - - - - - - -
- Wire - - wire.com -
-

- Il tuo nuovo account Wire -

-
-

- Un nuovo team su Wire è stato creato con l'indirizzo email ${email}. Ti preghiamo di verificare l'indirizzo email. -

-

- - VERIFICA - -

-

- Clicca sul pulsante qui sopra per verificare il tuo indirizzo. Non puoi utilizzare Wire fino a che non premi il pulsante. -

-

- Se non è possibile fare clic sul pulsante, usa questo link:
-

-

- ${url} -

-

- Se non hai richiesto tu questa modifica, puoi ignorare questa email o - - contattaci - . -

-
- Privacy· - Segnala abuso
Wire Swiss GmbH. Tutti i diritti riservati. -
-
-
- - +Profilo di ${brand}

${brand_label_url}

Il tuo nuovo profilo su ${brand}

Un nuovo team di ${brand} è stato creato con ${email}. Sei pregato di verificare la tua email.

 
Verifica
 

Se non puoi fare clic sul pulsante, copia e incolla questo link nel tuo browser:

${url}

Se hai domande, per favore contattaci.

Politica della privacy e termini d'uso · Segnala Uso Scorretto
${copyright}. TUTTI I DIRITTI RISERVATI.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/it/user/email/team-activation.txt b/services/brig/deb/opt/brig/templates/it/user/email/team-activation.txt index 437ad4e0bb8..83096c121e5 100644 --- a/services/brig/deb/opt/brig/templates/it/user/email/team-activation.txt +++ b/services/brig/deb/opt/brig/templates/it/user/email/team-activation.txt @@ -1,22 +1,21 @@ -Wire +[${brand_logo}] +${brand_label_url} [${brand_url}] -Ciao, - -Un nuovo team su Wire è stato creato con l'indirizzo email ${email}. Ti preghiamo di verificare l'indirizzo email. - -Apri il link qui sotto per confermare il tuo indirizzo. Non potrai usare Wire fino a che non avrai confermato. +IL TUO NUOVO PROFILO SU ${brand} +Un nuovo team di ${brand} è stato creato con ${email}. Sei pregato di verificare +la tua email. +Verifica [${url}]Se non puoi fare clic sul pulsante, copia e incolla questo link +nel tuo browser: ${url} -Si prega di non rispondere a questo messaggio. - -Se non sei stato tu a create un account Wire con questa e-mail, si prega di visitare https://support.wire.com - - +Se hai domande, per favore contattaci [${support}]. -(c) Wire Swiss GmbH +-------------------------------------------------------------------------------- -Informativa sulla privacy | Riporta uso improprio +Politica della privacy e termini d'uso [${legal}] · Segnala Uso Scorretto +[${misuse}] +${copyright}. TUTTI I DIRITTI RISERVATI. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/it/user/email/update-subject.txt b/services/brig/deb/opt/brig/templates/it/user/email/update-subject.txt index 362aa22a1f4..153308448f5 100644 --- a/services/brig/deb/opt/brig/templates/it/user/email/update-subject.txt +++ b/services/brig/deb/opt/brig/templates/it/user/email/update-subject.txt @@ -1 +1 @@ -Il tuo nuovo indirizzo email su Wire \ No newline at end of file +Il tuo nuovo indirizzo email su ${brand} \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/it/user/email/update.html b/services/brig/deb/opt/brig/templates/it/user/email/update.html index 932dc544631..0685328ddb6 100644 --- a/services/brig/deb/opt/brig/templates/it/user/email/update.html +++ b/services/brig/deb/opt/brig/templates/it/user/email/update.html @@ -1,123 +1 @@ - - - - - - - -
- - - - - - - - - - - - - - - - - -
- - - wire.com -
-

- Ciao, -

- -

- ${email} è stato impostato come il tuo nuovo indirizzo email su Wire. Ti preghiamo di verificare l'indirizzo. -

-

- - CONFERMA - -

-

- Clicca sul pulsante qui sopra per verificare il tuo nuovo indirizzo email. -

-

- Se non è possibile fare clic sul pulsante, usa questo link:
-

-

- ${url} -

-

- Se non hai richiesto tu questa modifica, puoi ignorare questa email o - - contattaci - . -

-
- Informativa sulla privacy · Segnala uso improprio
© Wire Swiss GmbH. Tutti i diritti riservati. -
- - +Il tuo nuovo indirizzo email su ${brand}

${brand_label_url}

Verifica il tuo indirizzo e-mail

${email} è stato registrato come tuo nuovo indirizzo email su ${brand}. Clicca il pulsante sotto per verificare il tuo indirizzo.

 
Verifica
 

Se non puoi fare clic sul pulsante, copia e incolla questo link nel tuo browser:

${url}

Se hai domande, per favore contattaci.

Politica della privacy e termini d'uso · Segnala Uso Scorretto
${copyright}. TUTTI I DIRITTI RISERVATI.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/it/user/email/update.txt b/services/brig/deb/opt/brig/templates/it/user/email/update.txt index 92b8b8cb3fc..881ea68a8b0 100644 --- a/services/brig/deb/opt/brig/templates/it/user/email/update.txt +++ b/services/brig/deb/opt/brig/templates/it/user/email/update.txt @@ -1,22 +1,21 @@ -Wire +[${brand_logo}] +${brand_label_url} [${brand_url}] -Ciao, - -${email} è stato registrato come il tuo nuovo indirizzo email su Wire. Ti preghiamo di verificare l'indirizzo email. - -Apri il link qui sotto per confermare il tuo nuovo indirizzo. +VERIFICA IL TUO INDIRIZZO E-MAIL +${email} è stato registrato come tuo nuovo indirizzo email su ${brand}. Clicca +il pulsante sotto per verificare il tuo indirizzo. +Verifica [${url}]Se non puoi fare clic sul pulsante, copia e incolla questo link +nel tuo browser: ${url} -Si prega di non rispondere a questo messaggio. - -Se non hai richiesto questa modifica, puoi ignorare questa email o visita https://support.wire.com - - +Se hai domande, per favore contattaci [${support}]. -(c) Wire Swiss GmbH +-------------------------------------------------------------------------------- -Informativa sulla privacy | Riporta uso improprio +Politica della privacy e termini d'uso [${legal}] · Segnala Uso Scorretto +[${misuse}] +${copyright}. TUTTI I DIRITTI RISERVATI. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/it/user/email/verification-delete-team-subject.txt b/services/brig/deb/opt/brig/templates/it/user/email/verification-delete-team-subject.txt new file mode 100644 index 00000000000..5687c98820a --- /dev/null +++ b/services/brig/deb/opt/brig/templates/it/user/email/verification-delete-team-subject.txt @@ -0,0 +1 @@ +your ${brand} verification code is ${code} \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/it/user/email/verification-delete-team.html b/services/brig/deb/opt/brig/templates/it/user/email/verification-delete-team.html new file mode 100644 index 00000000000..9d099da8265 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/it/user/email/verification-delete-team.html @@ -0,0 +1 @@ +your ${brand} verification code is ${code}

${brand_label_url}

Verify team deletion

${email} was used to delete your ${brand} team. Enter this code to verify your email and delete the team.

 

${code}

 

Se hai domande, per favore contattaci.

Politica della privacy e termini d'uso · Segnala Uso Scorretto
${copyright}. TUTTI I DIRITTI RISERVATI.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/it/user/email/verification-delete-team.txt b/services/brig/deb/opt/brig/templates/it/user/email/verification-delete-team.txt new file mode 100644 index 00000000000..5293c564913 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/it/user/email/verification-delete-team.txt @@ -0,0 +1,18 @@ +[${brand_logo}] + +${brand_label_url} [${brand_url}] + +VERIFY TEAM DELETION +${email} was used to delete your ${brand} team. Enter this code to verify your +email and delete the team. + +${code} + +Se hai domande, per favore contattaci [${support}]. + + +-------------------------------------------------------------------------------- + +Politica della privacy e termini d'uso [${legal}] · Segnala Uso Scorretto +[${misuse}] +${copyright}. TUTTI I DIRITTI RISERVATI. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/it/user/email/verification-login-subject.txt b/services/brig/deb/opt/brig/templates/it/user/email/verification-login-subject.txt new file mode 100644 index 00000000000..5687c98820a --- /dev/null +++ b/services/brig/deb/opt/brig/templates/it/user/email/verification-login-subject.txt @@ -0,0 +1 @@ +your ${brand} verification code is ${code} \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/it/user/email/verification-login.html b/services/brig/deb/opt/brig/templates/it/user/email/verification-login.html new file mode 100644 index 00000000000..014585c62a7 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/it/user/email/verification-login.html @@ -0,0 +1 @@ +your ${brand} verification code is ${code}

${brand_label_url}

Verify login

${email} was used to log in to your ${brand} account. Enter this code to verify your email and log in.

 

${code}

 

Se hai domande, per favore contattaci.

Politica della privacy e termini d'uso · Segnala Uso Scorretto
${copyright}. TUTTI I DIRITTI RISERVATI.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/it/user/email/verification-login.txt b/services/brig/deb/opt/brig/templates/it/user/email/verification-login.txt new file mode 100644 index 00000000000..2d7e2ec5b76 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/it/user/email/verification-login.txt @@ -0,0 +1,18 @@ +[${brand_logo}] + +${brand_label_url} [${brand_url}] + +VERIFY LOGIN +${email} was used to log in to your ${brand} account. Enter this code to verify +your email and log in. + +${code} + +Se hai domande, per favore contattaci [${support}]. + + +-------------------------------------------------------------------------------- + +Politica della privacy e termini d'uso [${legal}] · Segnala Uso Scorretto +[${misuse}] +${copyright}. TUTTI I DIRITTI RISERVATI. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/it/user/email/verification-scim-token-subject.txt b/services/brig/deb/opt/brig/templates/it/user/email/verification-scim-token-subject.txt new file mode 100644 index 00000000000..5687c98820a --- /dev/null +++ b/services/brig/deb/opt/brig/templates/it/user/email/verification-scim-token-subject.txt @@ -0,0 +1 @@ +your ${brand} verification code is ${code} \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/it/user/email/verification-scim-token.html b/services/brig/deb/opt/brig/templates/it/user/email/verification-scim-token.html new file mode 100644 index 00000000000..b2d7b090237 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/it/user/email/verification-scim-token.html @@ -0,0 +1 @@ +your ${brand} verification code is ${code}

${brand_label_url}

Verify SCIM token creation

${email} was used to generate a SCIM token. Enter this code to verify your email and create the token.

 

${code}

 

Se hai domande, per favore contattaci.

Politica della privacy e termini d'uso · Segnala Uso Scorretto
${copyright}. TUTTI I DIRITTI RISERVATI.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/it/user/email/verification-scim-token.txt b/services/brig/deb/opt/brig/templates/it/user/email/verification-scim-token.txt new file mode 100644 index 00000000000..cf612bd7469 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/it/user/email/verification-scim-token.txt @@ -0,0 +1,18 @@ +[${brand_logo}] + +${brand_label_url} [${brand_url}] + +VERIFY SCIM TOKEN CREATION +${email} was used to generate a SCIM token. Enter this code to verify your email +and create the token. + +${code} + +Se hai domande, per favore contattaci [${support}]. + + +-------------------------------------------------------------------------------- + +Politica della privacy e termini d'uso [${legal}] · Segnala Uso Scorretto +[${misuse}] +${copyright}. TUTTI I DIRITTI RISERVATI. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/it/user/email/verification-subject.txt b/services/brig/deb/opt/brig/templates/it/user/email/verification-subject.txt new file mode 100644 index 00000000000..5a3fa40b37d --- /dev/null +++ b/services/brig/deb/opt/brig/templates/it/user/email/verification-subject.txt @@ -0,0 +1 @@ +${code} è il tuo codice di verifica di ${brand} \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/it/user/email/verification.html b/services/brig/deb/opt/brig/templates/it/user/email/verification.html index de0cfba18bb..3d3cbb53001 100644 --- a/services/brig/deb/opt/brig/templates/it/user/email/verification.html +++ b/services/brig/deb/opt/brig/templates/it/user/email/verification.html @@ -1,82 +1 @@ - - - - - - - -
- - - - -
-
- - - - - - - - - - - - - - - - - -
- Wire - - wire.com -
-

- Verifica il tuo indirizzo e-mail -

-
-

- ${email} è stato registrato su Wire. Inserisci questo codice per verificare il tuo indirizzo email e creare il tuo account. -

-

- ${code} -

-

- Se non hai richiesto tu questa modifica, puoi ignorare questa email o - - contattaci - . -

-
- Privacy· - Segnala abuso
Wire Swiss GmbH. Tutti i diritti riservati. -
-
-
- - +${code} è il tuo codice di verifica di ${brand}

${brand_label_url}

Verifica la tua email

${email} è stato usato per registrare su ${brand}. Inserisci questo codice per verificare la tua email e creare il tuo profilo.

 

${code}

 

Se hai domande, per favore contattaci.

Politica della privacy e termini d'uso · Segnala Uso Scorretto
${copyright}. TUTTI I DIRITTI RISERVATI.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/it/user/email/verification.txt b/services/brig/deb/opt/brig/templates/it/user/email/verification.txt index c99da10a394..11178f64c65 100644 --- a/services/brig/deb/opt/brig/templates/it/user/email/verification.txt +++ b/services/brig/deb/opt/brig/templates/it/user/email/verification.txt @@ -1,18 +1,18 @@ -Wire +[${brand_logo}] +${brand_label_url} [${brand_url}] -Ciao, - -${email} è stato registrato su Wire. Inserisci questo codice per verificare il tuo indirizzo email e creare il tuo account. +VERIFICA LA TUA EMAIL +${email} è stato usato per registrare su ${brand}. Inserisci questo codice per +verificare la tua email e creare il tuo profilo. ${code} -Si prega di non rispondere a questo messaggio. - -Se non sei stato tu a create un account Wire con questa e-mail, si prega di visitare https://support.wire.com - +Se hai domande, per favore contattaci [${support}]. -(c) Wire Swiss GmbH +-------------------------------------------------------------------------------- -Informativa sulla privacy | Riporta uso improprio +Politica della privacy e termini d'uso [${legal}] · Segnala Uso Scorretto +[${misuse}] +${copyright}. TUTTI I DIRITTI RISERVATI. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/it/user/sms/activation.txt b/services/brig/deb/opt/brig/templates/it/user/sms/activation.txt index 0c31f4db1a6..2f831a186d0 100644 --- a/services/brig/deb/opt/brig/templates/it/user/sms/activation.txt +++ b/services/brig/deb/opt/brig/templates/it/user/sms/activation.txt @@ -1,3 +1,3 @@ -Il tuo codice per Wire è ${code}. +Il codice del tuo ${brand} è ${code}. -Apri ${url} per verificare il tuo numero o inserisci manualmente il codice in Wire. +Apri ${url} per verificare il tuo numero. diff --git a/services/brig/deb/opt/brig/templates/it/user/sms/deletion.txt b/services/brig/deb/opt/brig/templates/it/user/sms/deletion.txt index 3af6fc6283c..954020d32c8 100644 --- a/services/brig/deb/opt/brig/templates/it/user/sms/deletion.txt +++ b/services/brig/deb/opt/brig/templates/it/user/sms/deletion.txt @@ -1,2 +1,2 @@ -Toccare per eliminare il tuo account di Wire. -${url} +Tocca per eliminare il tuo profilo di ${brand}. +${url} diff --git a/services/brig/deb/opt/brig/templates/it/user/sms/login.txt b/services/brig/deb/opt/brig/templates/it/user/sms/login.txt index 7813739db76..84a0b9861d0 100644 --- a/services/brig/deb/opt/brig/templates/it/user/sms/login.txt +++ b/services/brig/deb/opt/brig/templates/it/user/sms/login.txt @@ -1,3 +1,3 @@ -Il tuo codice di accesso Wire è ${code}. +Il tuo codice di accesso di ${brand} è ${code}. -Apri ${url} per effettuare l'accesso, oppure inserisci questo codice nell'applicazione Wire: ${code}. +Apri ${url} per accedere. diff --git a/services/brig/deb/opt/brig/templates/it/user/sms/password-reset.txt b/services/brig/deb/opt/brig/templates/it/user/sms/password-reset.txt index a9377271184..b9aa4d7a945 100644 --- a/services/brig/deb/opt/brig/templates/it/user/sms/password-reset.txt +++ b/services/brig/deb/opt/brig/templates/it/user/sms/password-reset.txt @@ -1,3 +1,3 @@ -Il codice di recupero password per Wire è ${code}. +Il tuo codice di recupero di ${brand} è ${code}. -Apri Wire e utilizza questo codice per reimpostare la password. \ No newline at end of file +Usa questo codice per completare il ripristino della password. diff --git a/services/brig/deb/opt/brig/templates/ja/user/call/activation.txt b/services/brig/deb/opt/brig/templates/ja/user/call/activation.txt new file mode 100644 index 00000000000..d62a4fa1c53 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/ja/user/call/activation.txt @@ -0,0 +1 @@ +こんにちは、あなたのWire確認コードは、${code} です。 もう一度、あなたのコードは${code} です。 \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/ja/user/call/login.txt b/services/brig/deb/opt/brig/templates/ja/user/call/login.txt new file mode 100644 index 00000000000..443ac057de1 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/ja/user/call/login.txt @@ -0,0 +1 @@ +こんにちは、あなたのWire確認コードは、${code} です。 もう一度、あなたのコードは ${code} です。 \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/ja/user/email/activation-subject.txt b/services/brig/deb/opt/brig/templates/ja/user/email/activation-subject.txt new file mode 100644 index 00000000000..fcd089dbc75 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/ja/user/email/activation-subject.txt @@ -0,0 +1 @@ +あなたの ${brand} アカウント \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/ja/user/email/activation.html b/services/brig/deb/opt/brig/templates/ja/user/email/activation.html new file mode 100644 index 00000000000..5628de34d87 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/ja/user/email/activation.html @@ -0,0 +1 @@ +あなたの ${brand} アカウント

${brand_label_url}

メールアドレス認証

${email} は、${brand} への登録に使用されました。
ボタンをクリックしてメールアドレスの認証を行ってください。

 
認証
 

ボタンをクリックできない場合は、以下のリンクをブラウザにコピー＆ペーストして下さい。

${url}

ご不明な点がございましたら、 こちら から私たちにご連絡ください。

プライバシーポリシーと利用規約 · 不具合を報告する
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/ja/user/email/activation.txt b/services/brig/deb/opt/brig/templates/ja/user/email/activation.txt new file mode 100644 index 00000000000..9b1e2f77f15 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/ja/user/email/activation.txt @@ -0,0 +1,19 @@ +[${brand_logo}] + +${brand_label_url} [${brand_url}] + +メールアドレス認証 +${email} は、${brand} への登録に使用されました。 +ボタンをクリックしてメールアドレスの認証を行ってください。 + +認証 [${url}]ボタンをクリックできない場合は、以下のリンクをブラウザにコピー＆ペーストして下さい。 + +${url} + +ご不明な点がございましたら、 こちら [${support}] から私たちにご連絡ください。 + + +-------------------------------------------------------------------------------- + +プライバシーポリシーと利用規約 [${legal}] · 不具合を報告する [${misuse}] +${copyright}. ALL RIGHTS RESERVED. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/ja/user/email/deletion-subject.txt b/services/brig/deb/opt/brig/templates/ja/user/email/deletion-subject.txt new file mode 100644 index 00000000000..e030ffada01 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/ja/user/email/deletion-subject.txt @@ -0,0 +1 @@ +アカウントを削除しますか？ \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/ja/user/email/deletion.html b/services/brig/deb/opt/brig/templates/ja/user/email/deletion.html new file mode 100644 index 00000000000..72e2c8d9330 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/ja/user/email/deletion.html @@ -0,0 +1 @@ +アカウントを削除しますか？

${brand_label_url}

アカウントを削除

あなたの ${brand} アカウントの削除リクエストを受け付けました。 あなたのすべての会話、コンテンツ、友人を削除するには10分以内に下記のリンクをクリックしてください。

 
アカウント削除
 

ボタンをクリックできない場合は、以下のリンクをブラウザにコピー＆ペーストして下さい。

${url}

あなたがこのリクエスト行っていない場合は、パスワードをリセットしてください。

ご不明な点がございましたら、 こちら から私たちにご連絡ください。

プライバシーポリシーと利用規約 · 不具合を報告する
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/ja/user/email/deletion.txt b/services/brig/deb/opt/brig/templates/ja/user/email/deletion.txt new file mode 100644 index 00000000000..d11c0c14f8c --- /dev/null +++ b/services/brig/deb/opt/brig/templates/ja/user/email/deletion.txt @@ -0,0 +1,21 @@ +[${brand_logo}] + +${brand_label_url} [${brand_url}] + +アカウントを削除 +あなたの ${brand} アカウントの削除リクエストを受け付けました。 +あなたのすべての会話、コンテンツ、友人を削除するには10分以内に下記のリンクをクリックしてください。 + +アカウント削除 [${url}]ボタンをクリックできない場合は、以下のリンクをブラウザにコピー＆ペーストして下さい。 + +${url} + +あなたがこのリクエスト行っていない場合は、パスワードをリセット [${forgot}]してください。 + +ご不明な点がございましたら、 こちら [${support}] から私たちにご連絡ください。 + + +-------------------------------------------------------------------------------- + +プライバシーポリシーと利用規約 [${legal}] · 不具合を報告する [${misuse}] +${copyright}. ALL RIGHTS RESERVED. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/ja/user/email/new-client-subject.txt b/services/brig/deb/opt/brig/templates/ja/user/email/new-client-subject.txt new file mode 100644 index 00000000000..da91008b882 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/ja/user/email/new-client-subject.txt @@ -0,0 +1 @@ +新しいデバイス \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/ja/user/email/new-client.html b/services/brig/deb/opt/brig/templates/ja/user/email/new-client.html new file mode 100644 index 00000000000..24128ee1a17 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/ja/user/email/new-client.html @@ -0,0 +1 @@ +新しいデバイス

${brand_label_url}

新しいデバイス

あなたの ${brand} アカウントが使用されました:

${date}

${model}

新しいデバイスに ${brand} がインストールされたか、既存のデバイスに再インストールされました。 この操作をあなたが行っていない場合は、 ${brand} の設定に移動し、デバイスを削除し、パスワードをリセットしてください。

ご不明な点がございましたら、 こちら から私たちにご連絡ください。

プライバシーポリシーと利用規約 · 不具合を報告する
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/ja/user/email/new-client.txt b/services/brig/deb/opt/brig/templates/ja/user/email/new-client.txt new file mode 100644 index 00000000000..b2f1534c245 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/ja/user/email/new-client.txt @@ -0,0 +1,21 @@ +[${brand_logo}] + +${brand_label_url} [${brand_url}] + +新しいデバイス +あなたの ${brand} アカウントが使用されました: + +${date} + +${model} + +新しいデバイスに ${brand} がインストールされたか、既存のデバイスに再インストールされました。 この操作をあなたが行っていない場合は、 ${brand} +の設定に移動し、デバイスを削除し、パスワードをリセット [${forgot}]してください。 + +ご不明な点がございましたら、 こちら [${support}] から私たちにご連絡ください。 + + +-------------------------------------------------------------------------------- + +プライバシーポリシーと利用規約 [${legal}] · 不具合を報告する [${misuse}] +${copyright}. ALL RIGHTS RESERVED. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/ja/user/email/password-reset-subject.txt b/services/brig/deb/opt/brig/templates/ja/user/email/password-reset-subject.txt new file mode 100644 index 00000000000..bf4a5a46ae3 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/ja/user/email/password-reset-subject.txt @@ -0,0 +1 @@ +${brand} でのパスワードリセット \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/ja/user/email/password-reset.html b/services/brig/deb/opt/brig/templates/ja/user/email/password-reset.html new file mode 100644 index 00000000000..eb0d59f2aa7 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/ja/user/email/password-reset.html @@ -0,0 +1 @@ +${brand} でのパスワードリセット

${brand_label_url}

パスワードリセット

${brand} アカウントのパスワードをリセット要求を受け取りました。 新しいパスワードを作成するには、以下のボタンをクリックしてください。

 
パスワードリセット
 

ボタンをクリックできない場合は、以下のリンクをブラウザにコピー＆ペーストして下さい。

${url}

ご不明な点がございましたら、 こちら から私たちにご連絡ください。

プライバシーポリシーと利用規約 · 不具合を報告する
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/ja/user/email/password-reset.txt b/services/brig/deb/opt/brig/templates/ja/user/email/password-reset.txt new file mode 100644 index 00000000000..0ffdc49b479 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/ja/user/email/password-reset.txt @@ -0,0 +1,18 @@ +[${brand_logo}] + +${brand_label_url} [${brand_url}] + +パスワードリセット +${brand} アカウントのパスワードをリセット要求を受け取りました。 新しいパスワードを作成するには、以下のボタンをクリックしてください。 + +パスワードリセット [${url}]ボタンをクリックできない場合は、以下のリンクをブラウザにコピー＆ペーストして下さい。 + +${url} + +ご不明な点がございましたら、 こちら [${support}] から私たちにご連絡ください。 + + +-------------------------------------------------------------------------------- + +プライバシーポリシーと利用規約 [${legal}] · 不具合を報告する [${misuse}] +${copyright}. ALL RIGHTS RESERVED. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/ja/user/email/team-activation-subject.txt b/services/brig/deb/opt/brig/templates/ja/user/email/team-activation-subject.txt new file mode 100644 index 00000000000..a63d219cb43 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/ja/user/email/team-activation-subject.txt @@ -0,0 +1 @@ +${brand} アカウント \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/ja/user/email/team-activation.html b/services/brig/deb/opt/brig/templates/ja/user/email/team-activation.html new file mode 100644 index 00000000000..63c73884208 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/ja/user/email/team-activation.html @@ -0,0 +1 @@ +${brand} アカウント

${brand_label_url}

あなたの新しい ${brand} アカウント

新しい ${brand} チーム が、 ${email} によって作成されました。 メールアドレスの認証をお願いします。

 
認証
 

ボタンをクリックできない場合は、以下のリンクをブラウザにコピー＆ペーストして下さい。

${url}

ご不明な点がございましたら、 こちら から私たちにご連絡ください。

プライバシーポリシーと利用規約 · 不具合を報告する
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/ja/user/email/team-activation.txt b/services/brig/deb/opt/brig/templates/ja/user/email/team-activation.txt new file mode 100644 index 00000000000..89248d20a57 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/ja/user/email/team-activation.txt @@ -0,0 +1,18 @@ +[${brand_logo}] + +${brand_label_url} [${brand_url}] + +あなたの新しい ${brand} アカウント +新しい ${brand} チーム が、 ${email} によって作成されました。 メールアドレスの認証をお願いします。 + +認証 [${url}]ボタンをクリックできない場合は、以下のリンクをブラウザにコピー＆ペーストして下さい。 + +${url} + +ご不明な点がございましたら、 こちら [${support}] から私たちにご連絡ください。 + + +-------------------------------------------------------------------------------- + +プライバシーポリシーと利用規約 [${legal}] · 不具合を報告する [${misuse}] +${copyright}. ALL RIGHTS RESERVED. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/ja/user/email/update-subject.txt b/services/brig/deb/opt/brig/templates/ja/user/email/update-subject.txt new file mode 100644 index 00000000000..24791817316 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/ja/user/email/update-subject.txt @@ -0,0 +1 @@ +${brand} での新しいメールアドレス \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/ja/user/email/update.html b/services/brig/deb/opt/brig/templates/ja/user/email/update.html new file mode 100644 index 00000000000..8a0b25f9a3f --- /dev/null +++ b/services/brig/deb/opt/brig/templates/ja/user/email/update.html @@ -0,0 +1 @@ +${brand} での新しいメールアドレス

${brand_label_url}

メールアドレス認証

${email} は、 ${brand} で新しいメールアドレスとして登録されました。 新しいメールアドレスを認証するために下のボタンをクリックしてください。

 
認証
 

ボタンをクリックできない場合は、以下のリンクをブラウザにコピー＆ペーストして下さい。

${url}

ご不明な点がございましたら、 こちら から私たちにご連絡ください。

プライバシーポリシーと利用規約 · 不具合を報告する
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/ja/user/email/update.txt b/services/brig/deb/opt/brig/templates/ja/user/email/update.txt new file mode 100644 index 00000000000..bb5992939f7 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/ja/user/email/update.txt @@ -0,0 +1,18 @@ +[${brand_logo}] + +${brand_label_url} [${brand_url}] + +メールアドレス認証 +${email} は、 ${brand} で新しいメールアドレスとして登録されました。 新しいメールアドレスを認証するために下のボタンをクリックしてください。 + +認証 [${url}]ボタンをクリックできない場合は、以下のリンクをブラウザにコピー＆ペーストして下さい。 + +${url} + +ご不明な点がございましたら、 こちら [${support}] から私たちにご連絡ください。 + + +-------------------------------------------------------------------------------- + +プライバシーポリシーと利用規約 [${legal}] · 不具合を報告する [${misuse}] +${copyright}. ALL RIGHTS RESERVED. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/ja/user/email/verification-delete-team-subject.txt b/services/brig/deb/opt/brig/templates/ja/user/email/verification-delete-team-subject.txt new file mode 100644 index 00000000000..5687c98820a --- /dev/null +++ b/services/brig/deb/opt/brig/templates/ja/user/email/verification-delete-team-subject.txt @@ -0,0 +1 @@ +your ${brand} verification code is ${code} \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/ja/user/email/verification-delete-team.html b/services/brig/deb/opt/brig/templates/ja/user/email/verification-delete-team.html new file mode 100644 index 00000000000..9a9c81ac516 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/ja/user/email/verification-delete-team.html @@ -0,0 +1 @@ +your ${brand} verification code is ${code}

${brand_label_url}

Verify team deletion

${email} was used to delete your ${brand} team. Enter this code to verify your email and delete the team.

 

${code}

 

ご不明な点がございましたら、 こちら から私たちにご連絡ください。

プライバシーポリシーと利用規約 · 不具合を報告する
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/ja/user/email/verification-delete-team.txt b/services/brig/deb/opt/brig/templates/ja/user/email/verification-delete-team.txt new file mode 100644 index 00000000000..6f673d386d8 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/ja/user/email/verification-delete-team.txt @@ -0,0 +1,17 @@ +[${brand_logo}] + +${brand_label_url} [${brand_url}] + +VERIFY TEAM DELETION +${email} was used to delete your ${brand} team. Enter this code to verify your +email and delete the team. + +${code} + +ご不明な点がございましたら、 こちら [${support}] から私たちにご連絡ください。 + + +-------------------------------------------------------------------------------- + +プライバシーポリシーと利用規約 [${legal}] · 不具合を報告する [${misuse}] +${copyright}. ALL RIGHTS RESERVED. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/ja/user/email/verification-login-subject.txt b/services/brig/deb/opt/brig/templates/ja/user/email/verification-login-subject.txt new file mode 100644 index 00000000000..5687c98820a --- /dev/null +++ b/services/brig/deb/opt/brig/templates/ja/user/email/verification-login-subject.txt @@ -0,0 +1 @@ +your ${brand} verification code is ${code} \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/ja/user/email/verification-login.html b/services/brig/deb/opt/brig/templates/ja/user/email/verification-login.html new file mode 100644 index 00000000000..48333dcccb1 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/ja/user/email/verification-login.html @@ -0,0 +1 @@ +your ${brand} verification code is ${code}

${brand_label_url}

Verify login

${email} was used to log in to your ${brand} account. Enter this code to verify your email and log in.

 

${code}

 

ご不明な点がございましたら、 こちら から私たちにご連絡ください。

プライバシーポリシーと利用規約 · 不具合を報告する
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/ja/user/email/verification-login.txt b/services/brig/deb/opt/brig/templates/ja/user/email/verification-login.txt new file mode 100644 index 00000000000..7ae51ead2c9 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/ja/user/email/verification-login.txt @@ -0,0 +1,17 @@ +[${brand_logo}] + +${brand_label_url} [${brand_url}] + +VERIFY LOGIN +${email} was used to log in to your ${brand} account. Enter this code to verify +your email and log in. + +${code} + +ご不明な点がございましたら、 こちら [${support}] から私たちにご連絡ください。 + + +-------------------------------------------------------------------------------- + +プライバシーポリシーと利用規約 [${legal}] · 不具合を報告する [${misuse}] +${copyright}. ALL RIGHTS RESERVED. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/ja/user/email/verification-scim-token-subject.txt b/services/brig/deb/opt/brig/templates/ja/user/email/verification-scim-token-subject.txt new file mode 100644 index 00000000000..5687c98820a --- /dev/null +++ b/services/brig/deb/opt/brig/templates/ja/user/email/verification-scim-token-subject.txt @@ -0,0 +1 @@ +your ${brand} verification code is ${code} \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/ja/user/email/verification-scim-token.html b/services/brig/deb/opt/brig/templates/ja/user/email/verification-scim-token.html new file mode 100644 index 00000000000..25b1ba5e8a2 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/ja/user/email/verification-scim-token.html @@ -0,0 +1 @@ +your ${brand} verification code is ${code}

${brand_label_url}

Verify SCIM token creation

${email} was used to generate a SCIM token. Enter this code to verify your email and create the token.

 

${code}

 

ご不明な点がございましたら、 こちら から私たちにご連絡ください。

プライバシーポリシーと利用規約 · 不具合を報告する
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/ja/user/email/verification-scim-token.txt b/services/brig/deb/opt/brig/templates/ja/user/email/verification-scim-token.txt new file mode 100644 index 00000000000..4dca3b84b5e --- /dev/null +++ b/services/brig/deb/opt/brig/templates/ja/user/email/verification-scim-token.txt @@ -0,0 +1,17 @@ +[${brand_logo}] + +${brand_label_url} [${brand_url}] + +VERIFY SCIM TOKEN CREATION +${email} was used to generate a SCIM token. Enter this code to verify your email +and create the token. + +${code} + +ご不明な点がございましたら、 こちら [${support}] から私たちにご連絡ください。 + + +-------------------------------------------------------------------------------- + +プライバシーポリシーと利用規約 [${legal}] · 不具合を報告する [${misuse}] +${copyright}. ALL RIGHTS RESERVED. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/ja/user/email/verification-subject.txt b/services/brig/deb/opt/brig/templates/ja/user/email/verification-subject.txt new file mode 100644 index 00000000000..5120622e6d1 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/ja/user/email/verification-subject.txt @@ -0,0 +1 @@ +あなたの ${brand} の認証コードは ${code} です \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/ja/user/email/verification.html b/services/brig/deb/opt/brig/templates/ja/user/email/verification.html new file mode 100644 index 00000000000..5e1a1781025 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/ja/user/email/verification.html @@ -0,0 +1 @@ +あなたの ${brand} の認証コードは ${code} です

${brand_label_url}

メールアドレス認証

${email} が ${brand} に登録するために使用されました。 下記コードを入力することでメールアドレスを認証し、アカウントを作成します。

 

${code}

 

ご不明な点がございましたら、 こちら から私たちにご連絡ください。

プライバシーポリシーと利用規約 · 不具合を報告する
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/ja/user/email/verification.txt b/services/brig/deb/opt/brig/templates/ja/user/email/verification.txt new file mode 100644 index 00000000000..9758e4a82c4 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/ja/user/email/verification.txt @@ -0,0 +1,16 @@ +[${brand_logo}] + +${brand_label_url} [${brand_url}] + +メールアドレス認証 +${email} が ${brand} に登録するために使用されました。 下記コードを入力することでメールアドレスを認証し、アカウントを作成します。 + +${code} + +ご不明な点がございましたら、 こちら [${support}] から私たちにご連絡ください。 + + +-------------------------------------------------------------------------------- + +プライバシーポリシーと利用規約 [${legal}] · 不具合を報告する [${misuse}] +${copyright}. ALL RIGHTS RESERVED. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/ja/user/sms/activation.txt b/services/brig/deb/opt/brig/templates/ja/user/sms/activation.txt new file mode 100644 index 00000000000..5b27432624a --- /dev/null +++ b/services/brig/deb/opt/brig/templates/ja/user/sms/activation.txt @@ -0,0 +1,3 @@ +あなたの ${brand} の ログインコードは ${code} です + +${url} を開いて、あなたの番号を認証してください。 diff --git a/services/brig/deb/opt/brig/templates/ja/user/sms/deletion.txt b/services/brig/deb/opt/brig/templates/ja/user/sms/deletion.txt new file mode 100644 index 00000000000..f552addbd5c --- /dev/null +++ b/services/brig/deb/opt/brig/templates/ja/user/sms/deletion.txt @@ -0,0 +1,2 @@ +タップして、あなたの ${brand} のアカウントを削除します +${url} diff --git a/services/brig/deb/opt/brig/templates/ja/user/sms/login.txt b/services/brig/deb/opt/brig/templates/ja/user/sms/login.txt new file mode 100644 index 00000000000..ac0ec8b47d1 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/ja/user/sms/login.txt @@ -0,0 +1,3 @@ +あなたの ${brand} ログインコードは ${code} です + +${url} を開いて、ログインしてください。 diff --git a/services/brig/deb/opt/brig/templates/ja/user/sms/password-reset.txt b/services/brig/deb/opt/brig/templates/ja/user/sms/password-reset.txt new file mode 100644 index 00000000000..9476d182cb1 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/ja/user/sms/password-reset.txt @@ -0,0 +1,3 @@ +あなたの ${brand} の リカバリーコードは ${code} です。 + +このコードを使ってパスワードのリセットを完了してください。 diff --git a/services/brig/deb/opt/brig/templates/lt/user/email/activation.html b/services/brig/deb/opt/brig/templates/lt/user/email/activation.html index 59e25e0789b..1fb608768bc 100644 --- a/services/brig/deb/opt/brig/templates/lt/user/email/activation.html +++ b/services/brig/deb/opt/brig/templates/lt/user/email/activation.html @@ -1 +1 @@ -Jūsų „${brand}“ paskyra

${brand_label_url}

Patvirtinkite savo el. paštą

${email} buvo panaudotas, registruojantis „${brand}“.
Norėdami patvirtinti savo adresą, spustelėkite mygtuką.

 
Patvirtinti
 

Jeigu negalite spustelėti ant mygtuko, nukopijuokite ir įdėkite šią nuorodą į savo naršyklę:

${url}

Jei turite klausimų, susisiekite su mumis.

Privatumo politika ir naudojimosi sąlygos · Pranešti apie piktnaudžiavimą
${copyright}. VISOS TEISĖS SAUGOMOS.

                                                           
\ No newline at end of file +Jūsų „${brand}“ paskyra

${brand_label_url}

Patvirtinkite savo el. paštą

${email} buvo panaudotas, registruojantis „${brand}“.
Norėdami patvirtinti savo adresą, spustelėkite mygtuką.

 
Patvirtinti
 

Jeigu negalite spustelėti ant mygtuko, nukopijuokite ir įdėkite šią nuorodą į savo naršyklę:

${url}

Jei turite klausimų, susisiekite su mumis.

Privatumo politika ir naudojimosi sąlygos · Pranešti apie piktnaudžiavimą
${copyright}. VISOS TEISĖS SAUGOMOS.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/lt/user/email/deletion.html b/services/brig/deb/opt/brig/templates/lt/user/email/deletion.html index 44e0623b218..21df982477e 100644 --- a/services/brig/deb/opt/brig/templates/lt/user/email/deletion.html +++ b/services/brig/deb/opt/brig/templates/lt/user/email/deletion.html @@ -1 +1 @@ -Ištrinti paskyrą?

${brand_label_url}

Ištrinti jūsų paskyrą

Mes gavome užklausą ištrinti jūsų ${brand} paskyrą. Norėdami ištrinti visus savo pokalbius, visą turinį ir ryšius, 10 minučių bėgyje spustelėkite žemiau esantį mygtuką.

 
Ištrinti paskyrą
 

Jeigu negalite spustelėti ant mygtuko, nukopijuokite ir įdėkite šią nuorodą į savo naršyklę:

${url}

Jeigu jūs nebuvote to užklausę, atstatykite savo slaptažodį.

Jei turite klausimų, susisiekite su mumis.

Privatumo politika ir naudojimosi sąlygos · Pranešti apie piktnaudžiavimą
${copyright}. VISOS TEISĖS SAUGOMOS.

                                                           
\ No newline at end of file +Ištrinti paskyrą?

${brand_label_url}

Ištrinti jūsų paskyrą

Mes gavome užklausą ištrinti jūsų ${brand} paskyrą. Norėdami ištrinti visus savo pokalbius, visą turinį ir ryšius, 10 minučių bėgyje spustelėkite žemiau esantį mygtuką.

 
Ištrinti paskyrą
 

Jeigu negalite spustelėti ant mygtuko, nukopijuokite ir įdėkite šią nuorodą į savo naršyklę:

${url}

Jeigu jūs nebuvote to užklausę, atstatykite savo slaptažodį.

Jei turite klausimų, susisiekite su mumis.

Privatumo politika ir naudojimosi sąlygos · Pranešti apie piktnaudžiavimą
${copyright}. VISOS TEISĖS SAUGOMOS.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/lt/user/email/new-client.html b/services/brig/deb/opt/brig/templates/lt/user/email/new-client.html index ba553e5075a..ca0b70954a3 100644 --- a/services/brig/deb/opt/brig/templates/lt/user/email/new-client.html +++ b/services/brig/deb/opt/brig/templates/lt/user/email/new-client.html @@ -1 +1 @@ -Naujas įrenginys

${brand_label_url}

Naujas įrenginys

Jūsų „${brand}“ paskyra buvo naudota:

${date}

${model}

Tikriausiai įdiegėte „${brand}“ naujame įrenginyje arba įdiegėte iš naujo esančiame įrenginyje. Jei to nedarėte, eikit į „${brand}“ nustatymus, pašalinkite įrenginį ir pakeiskite savo slaptažodį.

Jei turite klausimų, susisiekite su mumis.

Privatumo politika ir naudojimosi sąlygos · Pranešti apie piktnaudžiavimą
${copyright}. VISOS TEISĖS SAUGOMOS.

                                                           
\ No newline at end of file +Naujas įrenginys

${brand_label_url}

Naujas įrenginys

Jūsų „${brand}“ paskyra buvo naudota:

${date}

${model}

Tikriausiai įdiegėte „${brand}“ naujame įrenginyje arba įdiegėte iš naujo esančiame įrenginyje. Jei to nedarėte, eikit į „${brand}“ nustatymus, pašalinkite įrenginį ir pakeiskite savo slaptažodį.

Jei turite klausimų, susisiekite su mumis.

Privatumo politika ir naudojimosi sąlygos · Pranešti apie piktnaudžiavimą
${copyright}. VISOS TEISĖS SAUGOMOS.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/lt/user/email/password-reset.html b/services/brig/deb/opt/brig/templates/lt/user/email/password-reset.html index a0d060b3307..1345946ca57 100644 --- a/services/brig/deb/opt/brig/templates/lt/user/email/password-reset.html +++ b/services/brig/deb/opt/brig/templates/lt/user/email/password-reset.html @@ -1 +1 @@ -„${brand}“ slaptažodžio pakeitimas

${brand_label_url}

Atstatyti jūsų slaptažodį

Gavome užklausą atstatyti jūsų ${brand} paskyros slaptažodį. Norėdami susikurti naują slaptažodį, spustelėkite mygtuką žemiau.

 
Atstatyti slaptažodį
 

Jeigu negalite spustelėti ant mygtuko, nukopijuokite ir įdėkite šią nuorodą į savo naršyklę:

${url}

Jei turite klausimų, susisiekite su mumis.

Privatumo politika ir naudojimosi sąlygos · Pranešti apie piktnaudžiavimą
${copyright}. VISOS TEISĖS SAUGOMOS.

                                                           
\ No newline at end of file +„${brand}“ slaptažodžio pakeitimas

${brand_label_url}

Atstatyti jūsų slaptažodį

Gavome užklausą atstatyti jūsų ${brand} paskyros slaptažodį. Norėdami susikurti naują slaptažodį, spustelėkite mygtuką žemiau.

 
Atstatyti slaptažodį
 

Jeigu negalite spustelėti ant mygtuko, nukopijuokite ir įdėkite šią nuorodą į savo naršyklę:

${url}

Jei turite klausimų, susisiekite su mumis.

Privatumo politika ir naudojimosi sąlygos · Pranešti apie piktnaudžiavimą
${copyright}. VISOS TEISĖS SAUGOMOS.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/lt/user/email/team-activation.html b/services/brig/deb/opt/brig/templates/lt/user/email/team-activation.html index d4b08309330..66def145ce8 100644 --- a/services/brig/deb/opt/brig/templates/lt/user/email/team-activation.html +++ b/services/brig/deb/opt/brig/templates/lt/user/email/team-activation.html @@ -1 +1 @@ -„${brand}“ paskyra

${brand_label_url}

Jūsų nauja „${brand}“ paskyra

Naudojant ${email}, buvo sukurta nauja „${brand}“ komanda. Patvirtinkite savo el. paštą.

 
Patvirtinti
 

Jeigu negalite spustelėti ant mygtuko, nukopijuokite ir įdėkite šią nuorodą į savo naršyklę:

${url}

Jei turite klausimų, susisiekite su mumis.

Privatumo politika ir naudojimosi sąlygos · Pranešti apie piktnaudžiavimą
${copyright}. VISOS TEISĖS SAUGOMOS.

                                                           
\ No newline at end of file +„${brand}“ paskyra

${brand_label_url}

Jūsų nauja „${brand}“ paskyra

Naudojant ${email}, buvo sukurta nauja „${brand}“ komanda. Patvirtinkite savo el. paštą.

 
Patvirtinti
 

Jeigu negalite spustelėti ant mygtuko, nukopijuokite ir įdėkite šią nuorodą į savo naršyklę:

${url}

Jei turite klausimų, susisiekite su mumis.

Privatumo politika ir naudojimosi sąlygos · Pranešti apie piktnaudžiavimą
${copyright}. VISOS TEISĖS SAUGOMOS.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/lt/user/email/update.html b/services/brig/deb/opt/brig/templates/lt/user/email/update.html index 481a59e184c..e7bc8d4a286 100644 --- a/services/brig/deb/opt/brig/templates/lt/user/email/update.html +++ b/services/brig/deb/opt/brig/templates/lt/user/email/update.html @@ -1 +1 @@ -Jūsų naujas „${brand}“ el. pašto adresas

${brand_label_url}

Patvirtinkite savo el. paštą

${email} buvo užregistruotas kaip naujas „${brand}“ el. pašto adresas. Norėdami patvirtinti savo adresą, spustelėkite mygtuką žemiau.

 
Patvirtinti
 

Jeigu negalite spustelėti ant mygtuko, nukopijuokite ir įdėkite šią nuorodą į savo naršyklę:

${url}

Jei turite klausimų, susisiekite su mumis.

Privatumo politika ir naudojimosi sąlygos · Pranešti apie piktnaudžiavimą
${copyright}. VISOS TEISĖS SAUGOMOS.

                                                           
\ No newline at end of file +Jūsų naujas „${brand}“ el. pašto adresas

${brand_label_url}

Patvirtinkite savo el. paštą

${email} buvo užregistruotas kaip naujas „${brand}“ el. pašto adresas. Norėdami patvirtinti savo adresą, spustelėkite mygtuką žemiau.

 
Patvirtinti
 

Jeigu negalite spustelėti ant mygtuko, nukopijuokite ir įdėkite šią nuorodą į savo naršyklę:

${url}

Jei turite klausimų, susisiekite su mumis.

Privatumo politika ir naudojimosi sąlygos · Pranešti apie piktnaudžiavimą
${copyright}. VISOS TEISĖS SAUGOMOS.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/lt/user/email/verification-delete-team.html b/services/brig/deb/opt/brig/templates/lt/user/email/verification-delete-team.html index 8ea472834af..981cb4403ad 100644 --- a/services/brig/deb/opt/brig/templates/lt/user/email/verification-delete-team.html +++ b/services/brig/deb/opt/brig/templates/lt/user/email/verification-delete-team.html @@ -1 +1 @@ -your ${brand} verification code is ${code}

${brand_label_url}

Verify team deletion

${email} was used to delete your ${brand} team. Enter this code to verify your email and delete the team.

 

${code}

 

Jei turite klausimų, susisiekite su mumis.

Privatumo politika ir naudojimosi sąlygos · Pranešti apie piktnaudžiavimą
${copyright}. VISOS TEISĖS SAUGOMOS.

                                                           
\ No newline at end of file +your ${brand} verification code is ${code}

${brand_label_url}

Verify team deletion

${email} was used to delete your ${brand} team. Enter this code to verify your email and delete the team.

 

${code}

 

Jei turite klausimų, susisiekite su mumis.

Privatumo politika ir naudojimosi sąlygos · Pranešti apie piktnaudžiavimą
${copyright}. VISOS TEISĖS SAUGOMOS.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/lt/user/email/verification-login.html b/services/brig/deb/opt/brig/templates/lt/user/email/verification-login.html index 53861c0b635..d43700a8b30 100644 --- a/services/brig/deb/opt/brig/templates/lt/user/email/verification-login.html +++ b/services/brig/deb/opt/brig/templates/lt/user/email/verification-login.html @@ -1 +1 @@ -your ${brand} verification code is ${code}

${brand_label_url}

Verify login

${email} was used to log in to your ${brand} account. Enter this code to verify your email and log in.

 

${code}

 

Jei turite klausimų, susisiekite su mumis.

Privatumo politika ir naudojimosi sąlygos · Pranešti apie piktnaudžiavimą
${copyright}. VISOS TEISĖS SAUGOMOS.

                                                           
\ No newline at end of file +your ${brand} verification code is ${code}

${brand_label_url}

Verify login

${email} was used to log in to your ${brand} account. Enter this code to verify your email and log in.

 

${code}

 

Jei turite klausimų, susisiekite su mumis.

Privatumo politika ir naudojimosi sąlygos · Pranešti apie piktnaudžiavimą
${copyright}. VISOS TEISĖS SAUGOMOS.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/lt/user/email/verification-scim-token.html b/services/brig/deb/opt/brig/templates/lt/user/email/verification-scim-token.html index d3efac395db..69397437f15 100644 --- a/services/brig/deb/opt/brig/templates/lt/user/email/verification-scim-token.html +++ b/services/brig/deb/opt/brig/templates/lt/user/email/verification-scim-token.html @@ -1 +1 @@ -your ${brand} verification code is ${code}

${brand_label_url}

Verify SCIM token creation

${email} was used to generate a SCIM token. Enter this code to verify your email and create the token.

 

${code}

 

Jei turite klausimų, susisiekite su mumis.

Privatumo politika ir naudojimosi sąlygos · Pranešti apie piktnaudžiavimą
${copyright}. VISOS TEISĖS SAUGOMOS.

                                                           
\ No newline at end of file +your ${brand} verification code is ${code}

${brand_label_url}

Verify SCIM token creation

${email} was used to generate a SCIM token. Enter this code to verify your email and create the token.

 

${code}

 

Jei turite klausimų, susisiekite su mumis.

Privatumo politika ir naudojimosi sąlygos · Pranešti apie piktnaudžiavimą
${copyright}. VISOS TEISĖS SAUGOMOS.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/lt/user/email/verification.html b/services/brig/deb/opt/brig/templates/lt/user/email/verification.html index 06ed33b5c3b..4a934004504 100644 --- a/services/brig/deb/opt/brig/templates/lt/user/email/verification.html +++ b/services/brig/deb/opt/brig/templates/lt/user/email/verification.html @@ -1 +1 @@ -${code} is your ${brand} verification code

${brand_label_url}

Patvirtinkite savo el. paštą

${email} buvo užregistruotas „${brand}“ sistemoje. Norėdami patvirtinti savo el. paštą ir susikurti paskyrą, įveskite šį kodą.

 

${code}

 

Jei turite klausimų, susisiekite su mumis.

Privatumo politika ir naudojimosi sąlygos · Pranešti apie piktnaudžiavimą
${copyright}. VISOS TEISĖS SAUGOMOS.

                                                           
\ No newline at end of file +${code} is your ${brand} verification code

${brand_label_url}

Patvirtinkite savo el. paštą

${email} buvo užregistruotas „${brand}“ sistemoje. Norėdami patvirtinti savo el. paštą ir susikurti paskyrą, įveskite šį kodą.

 

${code}

 

Jei turite klausimų, susisiekite su mumis.

Privatumo politika ir naudojimosi sąlygos · Pranešti apie piktnaudžiavimą
${copyright}. VISOS TEISĖS SAUGOMOS.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/pl/user/call/activation.txt b/services/brig/deb/opt/brig/templates/pl/user/call/activation.txt new file mode 100644 index 00000000000..8b52566e1ed --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pl/user/call/activation.txt @@ -0,0 +1 @@ +Witaj, Twój kod weryfikacyjny Wire to: ${code}. Jeszcze raz twój kod to: ${code} \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/pl/user/call/login.txt b/services/brig/deb/opt/brig/templates/pl/user/call/login.txt new file mode 100644 index 00000000000..b2d8c07e3b3 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pl/user/call/login.txt @@ -0,0 +1 @@ +Witaj, Twój kod logowania Wire to: ${code}. Jeszcze raz twój kod to: ${code} \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/pl/user/email/activation-subject.txt b/services/brig/deb/opt/brig/templates/pl/user/email/activation-subject.txt new file mode 100644 index 00000000000..4bc57a10ed6 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pl/user/email/activation-subject.txt @@ -0,0 +1 @@ +Twoje konto ${brand} \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/pl/user/email/activation.html b/services/brig/deb/opt/brig/templates/pl/user/email/activation.html new file mode 100644 index 00000000000..d264b4c23f5 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pl/user/email/activation.html @@ -0,0 +1 @@ +Twoje konto ${brand}

${brand_label_url}

Potwierdź swój adres email

${email} został użyty do rejestracji ${brand}.
Kliknij przycisk, aby zweryfikować swój adres.

 
Zweryfikuj
 

Jeśli nie możesz kliknąć przycisku, skopiuj i wklej ten link do swojej przeglądarki:

${url}

Jeśli masz jakieś pytania, prosimy skontaktuj się z nami.

Polityka prywatności i warunki użytkowania · Zgłoś niewłaściwe użycie
${copyright}. WSZELKIE PRAWA ZASTRZEŻONE.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/pl/user/email/activation.txt b/services/brig/deb/opt/brig/templates/pl/user/email/activation.txt new file mode 100644 index 00000000000..3921797a145 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pl/user/email/activation.txt @@ -0,0 +1,21 @@ +[${brand_logo}] + +${brand_label_url} [${brand_url}] + +POTWIERDŹ SWÓJ ADRES EMAIL +${email} został użyty do rejestracji ${brand}. +Kliknij przycisk, aby zweryfikować swój adres. + +Zweryfikuj [${url}]Jeśli nie możesz kliknąć przycisku, skopiuj i wklej ten link +do swojej przeglądarki: + +${url} + +Jeśli masz jakieś pytania, prosimy skontaktuj się z nami [${support}]. + + +-------------------------------------------------------------------------------- + +Polityka prywatności i warunki użytkowania [${legal}] · Zgłoś niewłaściwe użycie +[${misuse}] +${copyright}. WSZELKIE PRAWA ZASTRZEŻONE. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/pl/user/email/deletion-subject.txt b/services/brig/deb/opt/brig/templates/pl/user/email/deletion-subject.txt new file mode 100644 index 00000000000..104d8881c50 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pl/user/email/deletion-subject.txt @@ -0,0 +1 @@ +Usunąć konto? \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/pl/user/email/deletion.html b/services/brig/deb/opt/brig/templates/pl/user/email/deletion.html new file mode 100644 index 00000000000..76459d62cb6 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pl/user/email/deletion.html @@ -0,0 +1 @@ +Usunąć konto?

${brand_label_url}

Usuń swoje konto

Otrzymaliśmy prośbę o usunięcie konta ${brand}. Kliknij przycisk poniżej w ciągu 10 minut, aby usunąć wszystkie konwersacje, treści i połączenia.

 
Usuń konto
 

Jeśli nie możesz kliknąć przycisku, skopiuj i wklej ten link do swojej przeglądarki:

${url}

Jeśli nie poprosiłeś o to, zresetuj swoje hasło.

Jeśli masz jakieś pytania, prosimy skontaktuj się z nami.

Polityka prywatności i warunki użytkowania · Zgłoś niewłaściwe użycie
${copyright}. WSZELKIE PRAWA ZASTRZEŻONE.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/pl/user/email/deletion.txt b/services/brig/deb/opt/brig/templates/pl/user/email/deletion.txt new file mode 100644 index 00000000000..33a4f532af8 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pl/user/email/deletion.txt @@ -0,0 +1,23 @@ +[${brand_logo}] + +${brand_label_url} [${brand_url}] + +USUŃ SWOJE KONTO +Otrzymaliśmy prośbę o usunięcie konta ${brand}. Kliknij przycisk poniżej w ciągu +10 minut, aby usunąć wszystkie konwersacje, treści i połączenia. + +Usuń konto [${url}]Jeśli nie możesz kliknąć przycisku, skopiuj i wklej ten link +do swojej przeglądarki: + +${url} + +Jeśli nie poprosiłeś o to, zresetuj swoje hasło [${forgot}]. + +Jeśli masz jakieś pytania, prosimy skontaktuj się z nami [${support}]. + + +-------------------------------------------------------------------------------- + +Polityka prywatności i warunki użytkowania [${legal}] · Zgłoś niewłaściwe użycie +[${misuse}] +${copyright}. WSZELKIE PRAWA ZASTRZEŻONE. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/pl/user/email/new-client-subject.txt b/services/brig/deb/opt/brig/templates/pl/user/email/new-client-subject.txt new file mode 100644 index 00000000000..01f2fc441ad --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pl/user/email/new-client-subject.txt @@ -0,0 +1 @@ +Nowe urządzenie \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/pl/user/email/new-client.html b/services/brig/deb/opt/brig/templates/pl/user/email/new-client.html new file mode 100644 index 00000000000..f0064d61ba6 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pl/user/email/new-client.html @@ -0,0 +1 @@ +Nowe urządzenie

${brand_label_url}

Nowe urządzenie

Twoje konto ${brand} zostało użyte dnia:

${date}

${model}

Możesz zainstalować ${brand} na nowym urządzeniu lub zainstalować go ponownie na istniejącym. Jeśli tak nie było, przejdź do Ustawień ${brand}, usuń urządzenie i zresetuj hasło.

Jeśli masz jakieś pytania, prosimy skontaktuj się z nami.

Polityka prywatności i warunki użytkowania · Zgłoś niewłaściwe użycie
${copyright}. WSZELKIE PRAWA ZASTRZEŻONE.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/pl/user/email/new-client.txt b/services/brig/deb/opt/brig/templates/pl/user/email/new-client.txt new file mode 100644 index 00000000000..1d7bd177e11 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pl/user/email/new-client.txt @@ -0,0 +1,23 @@ +[${brand_logo}] + +${brand_label_url} [${brand_url}] + +NOWE URZĄDZENIE +Twoje konto ${brand} zostało użyte dnia: + +${date} + +${model} + +Możesz zainstalować ${brand} na nowym urządzeniu lub zainstalować go ponownie na +istniejącym. Jeśli tak nie było, przejdź do Ustawień ${brand}, usuń urządzenie i +zresetuj hasło [${forgot}]. + +Jeśli masz jakieś pytania, prosimy skontaktuj się z nami [${support}]. + + +-------------------------------------------------------------------------------- + +Polityka prywatności i warunki użytkowania [${legal}] · Zgłoś niewłaściwe użycie +[${misuse}] +${copyright}. WSZELKIE PRAWA ZASTRZEŻONE. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/pl/user/email/password-reset-subject.txt b/services/brig/deb/opt/brig/templates/pl/user/email/password-reset-subject.txt new file mode 100644 index 00000000000..98ef3d18238 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pl/user/email/password-reset-subject.txt @@ -0,0 +1 @@ +Zmiana hasła w ${brand} \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/pl/user/email/password-reset.html b/services/brig/deb/opt/brig/templates/pl/user/email/password-reset.html new file mode 100644 index 00000000000..139c47eb9ea --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pl/user/email/password-reset.html @@ -0,0 +1 @@ +Zmiana hasła w ${brand}

${brand_label_url}

Zresetuj hasło

Otrzymaliśmy prośbę o zresetowanie hasła do Twojego konta ${brand}. Aby utworzyć nowe hasło, kliknij poniższy przycisk.

 
Zresetuj hasło
 

Jeśli nie możesz kliknąć przycisku, skopiuj i wklej ten link do swojej przeglądarki:

${url}

Jeśli masz jakieś pytania, prosimy skontaktuj się z nami.

Polityka prywatności i warunki użytkowania · Zgłoś niewłaściwe użycie
${copyright}. WSZELKIE PRAWA ZASTRZEŻONE.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/pl/user/email/password-reset.txt b/services/brig/deb/opt/brig/templates/pl/user/email/password-reset.txt new file mode 100644 index 00000000000..780fb104cc0 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pl/user/email/password-reset.txt @@ -0,0 +1,21 @@ +[${brand_logo}] + +${brand_label_url} [${brand_url}] + +ZRESETUJ HASŁO +Otrzymaliśmy prośbę o zresetowanie hasła do Twojego konta ${brand}. Aby utworzyć +nowe hasło, kliknij poniższy przycisk. + +Zresetuj hasło [${url}]Jeśli nie możesz kliknąć przycisku, skopiuj i wklej ten +link do swojej przeglądarki: + +${url} + +Jeśli masz jakieś pytania, prosimy skontaktuj się z nami [${support}]. + + +-------------------------------------------------------------------------------- + +Polityka prywatności i warunki użytkowania [${legal}] · Zgłoś niewłaściwe użycie +[${misuse}] +${copyright}. WSZELKIE PRAWA ZASTRZEŻONE. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/pl/user/email/team-activation-subject.txt b/services/brig/deb/opt/brig/templates/pl/user/email/team-activation-subject.txt new file mode 100644 index 00000000000..79fabd2adb9 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pl/user/email/team-activation-subject.txt @@ -0,0 +1 @@ +Konto ${brand} \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/pl/user/email/team-activation.html b/services/brig/deb/opt/brig/templates/pl/user/email/team-activation.html new file mode 100644 index 00000000000..067c12da167 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pl/user/email/team-activation.html @@ -0,0 +1 @@ +Konto ${brand}

${brand_label_url}

Twoje nowe konto na ${brand}

Nowy zespół ${brand} został utworzony z ${email}. Prosimy, zweryfikuj swój adres email.

 
Zweryfikuj
 

Jeśli nie możesz kliknąć przycisku, skopiuj i wklej ten link do swojej przeglądarki:

${url}

Jeśli masz jakieś pytania, prosimy skontaktuj się z nami.

Polityka prywatności i warunki użytkowania · Zgłoś niewłaściwe użycie
${copyright}. WSZELKIE PRAWA ZASTRZEŻONE.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/pl/user/email/team-activation.txt b/services/brig/deb/opt/brig/templates/pl/user/email/team-activation.txt new file mode 100644 index 00000000000..f1054d62cfa --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pl/user/email/team-activation.txt @@ -0,0 +1,21 @@ +[${brand_logo}] + +${brand_label_url} [${brand_url}] + +TWOJE NOWE KONTO NA ${BRAND} +Nowy zespół ${brand} został utworzony z ${email}. Prosimy, zweryfikuj swój adres +email. + +Zweryfikuj [${url}]Jeśli nie możesz kliknąć przycisku, skopiuj i wklej ten link +do swojej przeglądarki: + +${url} + +Jeśli masz jakieś pytania, prosimy skontaktuj się z nami [${support}]. + + +-------------------------------------------------------------------------------- + +Polityka prywatności i warunki użytkowania [${legal}] · Zgłoś niewłaściwe użycie +[${misuse}] +${copyright}. WSZELKIE PRAWA ZASTRZEŻONE. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/pl/user/email/update-subject.txt b/services/brig/deb/opt/brig/templates/pl/user/email/update-subject.txt new file mode 100644 index 00000000000..719299d9623 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pl/user/email/update-subject.txt @@ -0,0 +1 @@ +Twój nowy adres e-mail na ${brand} \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/pl/user/email/update.html b/services/brig/deb/opt/brig/templates/pl/user/email/update.html new file mode 100644 index 00000000000..8a0a1d35d99 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pl/user/email/update.html @@ -0,0 +1 @@ +Twój nowy adres e-mail na ${brand}

${brand_label_url}

Potwierdź swój adres email

${email} został zarejestrowany jako Twój nowy adres e-mail na ${brand}. Kliknij poniższy przycisk, aby zweryfikować swój adres.

 
Zweryfikuj
 

Jeśli nie możesz kliknąć przycisku, skopiuj i wklej ten link do swojej przeglądarki:

${url}

Jeśli masz jakieś pytania, prosimy skontaktuj się z nami.

Polityka prywatności i warunki użytkowania · Zgłoś niewłaściwe użycie
${copyright}. WSZELKIE PRAWA ZASTRZEŻONE.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/pl/user/email/update.txt b/services/brig/deb/opt/brig/templates/pl/user/email/update.txt new file mode 100644 index 00000000000..63e46b58a26 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pl/user/email/update.txt @@ -0,0 +1,21 @@ +[${brand_logo}] + +${brand_label_url} [${brand_url}] + +POTWIERDŹ SWÓJ ADRES EMAIL +${email} został zarejestrowany jako Twój nowy adres e-mail na ${brand}. Kliknij +poniższy przycisk, aby zweryfikować swój adres. + +Zweryfikuj [${url}]Jeśli nie możesz kliknąć przycisku, skopiuj i wklej ten link +do swojej przeglądarki: + +${url} + +Jeśli masz jakieś pytania, prosimy skontaktuj się z nami [${support}]. + + +-------------------------------------------------------------------------------- + +Polityka prywatności i warunki użytkowania [${legal}] · Zgłoś niewłaściwe użycie +[${misuse}] +${copyright}. WSZELKIE PRAWA ZASTRZEŻONE. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/pl/user/email/verification-delete-team-subject.txt b/services/brig/deb/opt/brig/templates/pl/user/email/verification-delete-team-subject.txt new file mode 100644 index 00000000000..5687c98820a --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pl/user/email/verification-delete-team-subject.txt @@ -0,0 +1 @@ +your ${brand} verification code is ${code} \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/pl/user/email/verification-delete-team.html b/services/brig/deb/opt/brig/templates/pl/user/email/verification-delete-team.html new file mode 100644 index 00000000000..41249f6efb8 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pl/user/email/verification-delete-team.html @@ -0,0 +1 @@ +your ${brand} verification code is ${code}

${brand_label_url}

Verify team deletion

${email} was used to delete your ${brand} team. Enter this code to verify your email and delete the team.

 

${code}

 

Jeśli masz jakieś pytania, prosimy skontaktuj się z nami.

Polityka prywatności i warunki użytkowania · Zgłoś niewłaściwe użycie
${copyright}. WSZELKIE PRAWA ZASTRZEŻONE.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/pl/user/email/verification-delete-team.txt b/services/brig/deb/opt/brig/templates/pl/user/email/verification-delete-team.txt new file mode 100644 index 00000000000..5083b37be80 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pl/user/email/verification-delete-team.txt @@ -0,0 +1,18 @@ +[${brand_logo}] + +${brand_label_url} [${brand_url}] + +VERIFY TEAM DELETION +${email} was used to delete your ${brand} team. Enter this code to verify your +email and delete the team. + +${code} + +Jeśli masz jakieś pytania, prosimy skontaktuj się z nami [${support}]. + + +-------------------------------------------------------------------------------- + +Polityka prywatności i warunki użytkowania [${legal}] · Zgłoś niewłaściwe użycie +[${misuse}] +${copyright}. WSZELKIE PRAWA ZASTRZEŻONE. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/pl/user/email/verification-login-subject.txt b/services/brig/deb/opt/brig/templates/pl/user/email/verification-login-subject.txt new file mode 100644 index 00000000000..5687c98820a --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pl/user/email/verification-login-subject.txt @@ -0,0 +1 @@ +your ${brand} verification code is ${code} \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/pl/user/email/verification-login.html b/services/brig/deb/opt/brig/templates/pl/user/email/verification-login.html new file mode 100644 index 00000000000..f76ed3ab0e1 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pl/user/email/verification-login.html @@ -0,0 +1 @@ +your ${brand} verification code is ${code}

${brand_label_url}

Verify login

${email} was used to log in to your ${brand} account. Enter this code to verify your email and log in.

 

${code}

 

Jeśli masz jakieś pytania, prosimy skontaktuj się z nami.

Polityka prywatności i warunki użytkowania · Zgłoś niewłaściwe użycie
${copyright}. WSZELKIE PRAWA ZASTRZEŻONE.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/pl/user/email/verification-login.txt b/services/brig/deb/opt/brig/templates/pl/user/email/verification-login.txt new file mode 100644 index 00000000000..a3fb260d38e --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pl/user/email/verification-login.txt @@ -0,0 +1,18 @@ +[${brand_logo}] + +${brand_label_url} [${brand_url}] + +VERIFY LOGIN +${email} was used to log in to your ${brand} account. Enter this code to verify +your email and log in. + +${code} + +Jeśli masz jakieś pytania, prosimy skontaktuj się z nami [${support}]. + + +-------------------------------------------------------------------------------- + +Polityka prywatności i warunki użytkowania [${legal}] · Zgłoś niewłaściwe użycie +[${misuse}] +${copyright}. WSZELKIE PRAWA ZASTRZEŻONE. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/pl/user/email/verification-scim-token-subject.txt b/services/brig/deb/opt/brig/templates/pl/user/email/verification-scim-token-subject.txt new file mode 100644 index 00000000000..5687c98820a --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pl/user/email/verification-scim-token-subject.txt @@ -0,0 +1 @@ +your ${brand} verification code is ${code} \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/pl/user/email/verification-scim-token.html b/services/brig/deb/opt/brig/templates/pl/user/email/verification-scim-token.html new file mode 100644 index 00000000000..2692de19628 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pl/user/email/verification-scim-token.html @@ -0,0 +1 @@ +your ${brand} verification code is ${code}

${brand_label_url}

Verify SCIM token creation

${email} was used to generate a SCIM token. Enter this code to verify your email and create the token.

 

${code}

 

Jeśli masz jakieś pytania, prosimy skontaktuj się z nami.

Polityka prywatności i warunki użytkowania · Zgłoś niewłaściwe użycie
${copyright}. WSZELKIE PRAWA ZASTRZEŻONE.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/pl/user/email/verification-scim-token.txt b/services/brig/deb/opt/brig/templates/pl/user/email/verification-scim-token.txt new file mode 100644 index 00000000000..2e71ea22393 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pl/user/email/verification-scim-token.txt @@ -0,0 +1,18 @@ +[${brand_logo}] + +${brand_label_url} [${brand_url}] + +VERIFY SCIM TOKEN CREATION +${email} was used to generate a SCIM token. Enter this code to verify your email +and create the token. + +${code} + +Jeśli masz jakieś pytania, prosimy skontaktuj się z nami [${support}]. + + +-------------------------------------------------------------------------------- + +Polityka prywatności i warunki użytkowania [${legal}] · Zgłoś niewłaściwe użycie +[${misuse}] +${copyright}. WSZELKIE PRAWA ZASTRZEŻONE. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/pl/user/email/verification-subject.txt b/services/brig/deb/opt/brig/templates/pl/user/email/verification-subject.txt new file mode 100644 index 00000000000..0f7cfb2744c --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pl/user/email/verification-subject.txt @@ -0,0 +1 @@ +${code} to twój kod weryfikacyjny ${brand} \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/pl/user/email/verification.html b/services/brig/deb/opt/brig/templates/pl/user/email/verification.html new file mode 100644 index 00000000000..5e669a1b58d --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pl/user/email/verification.html @@ -0,0 +1 @@ +${code} to twój kod weryfikacyjny ${brand}

${brand_label_url}

Potwierdź swój adres email

${email} został użyty do rejestracji ${brand}. Wprowadź ten kod, aby zweryfikować swój adres e-mail i utworzyć konto.

 

${code}

 

Jeśli masz jakieś pytania, prosimy skontaktuj się z nami.

Polityka prywatności i warunki użytkowania · Zgłoś niewłaściwe użycie
${copyright}. WSZELKIE PRAWA ZASTRZEŻONE.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/pl/user/email/verification.txt b/services/brig/deb/opt/brig/templates/pl/user/email/verification.txt new file mode 100644 index 00000000000..3a229ff4e6d --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pl/user/email/verification.txt @@ -0,0 +1,18 @@ +[${brand_logo}] + +${brand_label_url} [${brand_url}] + +POTWIERDŹ SWÓJ ADRES EMAIL +${email} został użyty do rejestracji ${brand}. Wprowadź ten kod, aby +zweryfikować swój adres e-mail i utworzyć konto. + +${code} + +Jeśli masz jakieś pytania, prosimy skontaktuj się z nami [${support}]. + + +-------------------------------------------------------------------------------- + +Polityka prywatności i warunki użytkowania [${legal}] · Zgłoś niewłaściwe użycie +[${misuse}] +${copyright}. WSZELKIE PRAWA ZASTRZEŻONE. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/pl/user/sms/activation.txt b/services/brig/deb/opt/brig/templates/pl/user/sms/activation.txt new file mode 100644 index 00000000000..7fc97d25b1c --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pl/user/sms/activation.txt @@ -0,0 +1,3 @@ +Twój kod ${brand} to ${code}. + +Otwórz ${url} aby zweryfikować swój numer. diff --git a/services/brig/deb/opt/brig/templates/pl/user/sms/deletion.txt b/services/brig/deb/opt/brig/templates/pl/user/sms/deletion.txt new file mode 100644 index 00000000000..97abae34dde --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pl/user/sms/deletion.txt @@ -0,0 +1,2 @@ +Dotknij, aby usunąć swoje konto ${brand}. +${url} diff --git a/services/brig/deb/opt/brig/templates/pl/user/sms/login.txt b/services/brig/deb/opt/brig/templates/pl/user/sms/login.txt new file mode 100644 index 00000000000..f3b86d6a962 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pl/user/sms/login.txt @@ -0,0 +1,3 @@ +Twój kod logowania ${brand} to ${code}. + +Otwórz ${url} aby się zalogować. diff --git a/services/brig/deb/opt/brig/templates/pl/user/sms/password-reset.txt b/services/brig/deb/opt/brig/templates/pl/user/sms/password-reset.txt new file mode 100644 index 00000000000..046e6e86c5c --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pl/user/sms/password-reset.txt @@ -0,0 +1,3 @@ +Twój kod odzyskiwania ${brand} to ${code}. + +Użyj tego kodu, aby ukończyć resetowanie hasła. diff --git a/services/brig/deb/opt/brig/templates/pt/user/call/activation.txt b/services/brig/deb/opt/brig/templates/pt/user/call/activation.txt new file mode 100644 index 00000000000..9198dbdff87 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pt/user/call/activation.txt @@ -0,0 +1 @@ +Olá, seu código de verificação do Wire é: ${code}. Novamente, seu código é: ${code} \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/pt/user/call/login.txt b/services/brig/deb/opt/brig/templates/pt/user/call/login.txt new file mode 100644 index 00000000000..7da656975eb --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pt/user/call/login.txt @@ -0,0 +1 @@ +Olá, seu código de login do Wire é: ${code}. Novamente, seu código é: ${code} \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/pt/user/email/activation-subject.txt b/services/brig/deb/opt/brig/templates/pt/user/email/activation-subject.txt new file mode 100644 index 00000000000..1a7676c99fa --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pt/user/email/activation-subject.txt @@ -0,0 +1 @@ +Sua Conta ${brand} \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/pt/user/email/activation.html b/services/brig/deb/opt/brig/templates/pt/user/email/activation.html new file mode 100644 index 00000000000..ea3081ffced --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pt/user/email/activation.html @@ -0,0 +1 @@ +Sua Conta ${brand}

${brand_label_url}

Verifique seu e-mail

${email} foi usado para se registrar no ${brand}.
Clique no botão para verificar seu e-mail.

 
Verificar
 

Se você não conseguir clicar no botão, copie e cole este link no seu navegador:

${url}

Se você tiver alguma dúvida, por favor, entre em contato conosco.

Política de privacidade e termos de uso · Reportar uso indevido
${copyright}. TODOS OS DIREITOS RESERVADOS.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/pt/user/email/activation.txt b/services/brig/deb/opt/brig/templates/pt/user/email/activation.txt new file mode 100644 index 00000000000..ada1772adab --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pt/user/email/activation.txt @@ -0,0 +1,21 @@ +[${brand_logo}] + +${brand_label_url} [${brand_url}] + +VERIFIQUE SEU E-MAIL +${email} foi usado para se registrar no ${brand}. +Clique no botão para verificar seu e-mail. + +Verificar [${url}]Se você não conseguir clicar no botão, copie e cole este link +no seu navegador: + +${url} + +Se você tiver alguma dúvida, por favor, entre em contato conosco [${support}]. + + +-------------------------------------------------------------------------------- + +Política de privacidade e termos de uso [${legal}] · Reportar uso indevido +[${misuse}] +${copyright}. TODOS OS DIREITOS RESERVADOS. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/pt/user/email/deletion-subject.txt b/services/brig/deb/opt/brig/templates/pt/user/email/deletion-subject.txt new file mode 100644 index 00000000000..4fa7c98ccd1 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pt/user/email/deletion-subject.txt @@ -0,0 +1 @@ +Excluir conta? \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/pt/user/email/deletion.html b/services/brig/deb/opt/brig/templates/pt/user/email/deletion.html new file mode 100644 index 00000000000..a9fd902f42a --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pt/user/email/deletion.html @@ -0,0 +1 @@ +Excluir conta?

${brand_label_url}

Excluir sua conta

Nós recebemos uma solicitação para excluir sua conta ${brand}. Clique no botão abaixo em até 10 minutos para excluir todas as suas conversas, conteúdo e conexões.

 
Excluir conta
 

Se você não conseguir clicar no botão, copie e cole este link no seu navegador:

${url}

Se você não solicitou isso, redefina sua senha.

Se você tiver alguma dúvida, por favor, entre em contato conosco.

Política de privacidade e termos de uso · Reportar uso indevido
${copyright}. TODOS OS DIREITOS RESERVADOS.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/pt/user/email/deletion.txt b/services/brig/deb/opt/brig/templates/pt/user/email/deletion.txt new file mode 100644 index 00000000000..2b9dab30e3b --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pt/user/email/deletion.txt @@ -0,0 +1,24 @@ +[${brand_logo}] + +${brand_label_url} [${brand_url}] + +EXCLUIR SUA CONTA +Nós recebemos uma solicitação para excluir sua conta ${brand}. Clique no botão +abaixo em até 10 minutos para excluir todas as suas conversas, conteúdo e +conexões. + +Excluir conta [${url}]Se você não conseguir clicar no botão, copie e cole este +link no seu navegador: + +${url} + +Se você não solicitou isso, redefina sua senha [${forgot}]. + +Se você tiver alguma dúvida, por favor, entre em contato conosco [${support}]. + + +-------------------------------------------------------------------------------- + +Política de privacidade e termos de uso [${legal}] · Reportar uso indevido +[${misuse}] +${copyright}. TODOS OS DIREITOS RESERVADOS. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/pt/user/email/new-client-subject.txt b/services/brig/deb/opt/brig/templates/pt/user/email/new-client-subject.txt new file mode 100644 index 00000000000..3681f044050 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pt/user/email/new-client-subject.txt @@ -0,0 +1 @@ +Novo dispositivo \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/pt/user/email/new-client.html b/services/brig/deb/opt/brig/templates/pt/user/email/new-client.html new file mode 100644 index 00000000000..7d7308b7f3f --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pt/user/email/new-client.html @@ -0,0 +1 @@ +Novo dispositivo

${brand_label_url}

Novo dispositivo

Sua conta ${brand} foi usada em:

${date}

${model}

Você pode ter instalado o ${brand} em um dispositivo novo ou instalado novamente em um já existente. Se não foi esse o caso, vá nas Configurações de ${brand}, remova o dispositivo e redefina sua senha.

Se você tiver alguma dúvida, por favor, entre em contato conosco.

Política de privacidade e termos de uso · Reportar uso indevido
${copyright}. TODOS OS DIREITOS RESERVADOS.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/pt/user/email/new-client.txt b/services/brig/deb/opt/brig/templates/pt/user/email/new-client.txt new file mode 100644 index 00000000000..69670319527 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pt/user/email/new-client.txt @@ -0,0 +1,23 @@ +[${brand_logo}] + +${brand_label_url} [${brand_url}] + +NOVO DISPOSITIVO +Sua conta ${brand} foi usada em: + +${date} + +${model} + +Você pode ter instalado o ${brand} em um dispositivo novo ou instalado novamente +em um já existente. Se não foi esse o caso, vá nas Configurações de ${brand}, +remova o dispositivo e redefina sua senha [${forgot}]. + +Se você tiver alguma dúvida, por favor, entre em contato conosco [${support}]. + + +-------------------------------------------------------------------------------- + +Política de privacidade e termos de uso [${legal}] · Reportar uso indevido +[${misuse}] +${copyright}. TODOS OS DIREITOS RESERVADOS. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/pt/user/email/password-reset-subject.txt b/services/brig/deb/opt/brig/templates/pt/user/email/password-reset-subject.txt new file mode 100644 index 00000000000..6c6f2407ee6 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pt/user/email/password-reset-subject.txt @@ -0,0 +1 @@ +Mudança de Senha no ${brand} \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/pt/user/email/password-reset.html b/services/brig/deb/opt/brig/templates/pt/user/email/password-reset.html new file mode 100644 index 00000000000..1066973603f --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pt/user/email/password-reset.html @@ -0,0 +1 @@ +Mudança de Senha no ${brand}

${brand_label_url}

Redefinir sua senha

Recebemos uma solicitação para redefinir a senha de sua conta ${brand}. Para criar uma nova senha, clique no botão abaixo.

 
Redefinir senha
 

Se você não conseguir clicar no botão, copie e cole este link no seu navegador:

${url}

Se você tiver alguma dúvida, por favor, entre em contato conosco.

Política de privacidade e termos de uso · Reportar uso indevido
${copyright}. TODOS OS DIREITOS RESERVADOS.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/pt/user/email/password-reset.txt b/services/brig/deb/opt/brig/templates/pt/user/email/password-reset.txt new file mode 100644 index 00000000000..ce009cf1502 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pt/user/email/password-reset.txt @@ -0,0 +1,21 @@ +[${brand_logo}] + +${brand_label_url} [${brand_url}] + +REDEFINIR SUA SENHA +Recebemos uma solicitação para redefinir a senha de sua conta ${brand}. Para +criar uma nova senha, clique no botão abaixo. + +Redefinir senha [${url}]Se você não conseguir clicar no botão, copie e cole este +link no seu navegador: + +${url} + +Se você tiver alguma dúvida, por favor, entre em contato conosco [${support}]. + + +-------------------------------------------------------------------------------- + +Política de privacidade e termos de uso [${legal}] · Reportar uso indevido +[${misuse}] +${copyright}. TODOS OS DIREITOS RESERVADOS. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/pt/user/email/team-activation-subject.txt b/services/brig/deb/opt/brig/templates/pt/user/email/team-activation-subject.txt new file mode 100644 index 00000000000..464c16e3ac9 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pt/user/email/team-activation-subject.txt @@ -0,0 +1 @@ +Conta ${brand} \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/pt/user/email/team-activation.html b/services/brig/deb/opt/brig/templates/pt/user/email/team-activation.html new file mode 100644 index 00000000000..acc4378363a --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pt/user/email/team-activation.html @@ -0,0 +1 @@ +Conta ${brand}

${brand_label_url}

Sua nova conta em ${brand}

Um nova conta na equipe ${brand} foi criada com ${email}. Por favor, verifique seu e-mail.

 
Verificar
 

Se você não conseguir clicar no botão, copie e cole este link no seu navegador:

${url}

Se você tiver alguma dúvida, por favor, entre em contato conosco.

Política de privacidade e termos de uso · Reportar uso indevido
${copyright}. TODOS OS DIREITOS RESERVADOS.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/pt/user/email/team-activation.txt b/services/brig/deb/opt/brig/templates/pt/user/email/team-activation.txt new file mode 100644 index 00000000000..876e24f88b5 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pt/user/email/team-activation.txt @@ -0,0 +1,21 @@ +[${brand_logo}] + +${brand_label_url} [${brand_url}] + +SUA NOVA CONTA EM ${BRAND} +Um nova conta na equipe ${brand} foi criada com ${email}. Por favor, verifique +seu e-mail. + +Verificar [${url}]Se você não conseguir clicar no botão, copie e cole este link +no seu navegador: + +${url} + +Se você tiver alguma dúvida, por favor, entre em contato conosco [${support}]. + + +-------------------------------------------------------------------------------- + +Política de privacidade e termos de uso [${legal}] · Reportar uso indevido +[${misuse}] +${copyright}. TODOS OS DIREITOS RESERVADOS. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/pt/user/email/update-subject.txt b/services/brig/deb/opt/brig/templates/pt/user/email/update-subject.txt new file mode 100644 index 00000000000..104b19d1ed7 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pt/user/email/update-subject.txt @@ -0,0 +1 @@ +Seu novo endereço de email no ${brand} \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/pt/user/email/update.html b/services/brig/deb/opt/brig/templates/pt/user/email/update.html new file mode 100644 index 00000000000..60c2d425e94 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pt/user/email/update.html @@ -0,0 +1 @@ +Seu novo endereço de email no ${brand}

${brand_label_url}

Confirme o seu e-mail

${email} foi registrado como seu novo endereço de e-mail no ${brand}. Clique no botão para confirmar seu endereço de e-mail.

 
Verificar
 

Se você não conseguir clicar no botão, copie e cole este link no seu navegador:

${url}

Se você tiver alguma dúvida, por favor, entre em contato conosco.

Política de privacidade e termos de uso · Reportar uso indevido
${copyright}. TODOS OS DIREITOS RESERVADOS.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/pt/user/email/update.txt b/services/brig/deb/opt/brig/templates/pt/user/email/update.txt new file mode 100644 index 00000000000..ea858533a49 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pt/user/email/update.txt @@ -0,0 +1,21 @@ +[${brand_logo}] + +${brand_label_url} [${brand_url}] + +CONFIRME O SEU E-MAIL +${email} foi registrado como seu novo endereço de e-mail no ${brand}. Clique no +botão para confirmar seu endereço de e-mail. + +Verificar [${url}]Se você não conseguir clicar no botão, copie e cole este link +no seu navegador: + +${url} + +Se você tiver alguma dúvida, por favor, entre em contato conosco [${support}]. + + +-------------------------------------------------------------------------------- + +Política de privacidade e termos de uso [${legal}] · Reportar uso indevido +[${misuse}] +${copyright}. TODOS OS DIREITOS RESERVADOS. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/pt/user/email/verification-delete-team-subject.txt b/services/brig/deb/opt/brig/templates/pt/user/email/verification-delete-team-subject.txt new file mode 100644 index 00000000000..d40987b30b7 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pt/user/email/verification-delete-team-subject.txt @@ -0,0 +1 @@ +Seu código de verificação do ${brand} é ${code} \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/pt/user/email/verification-delete-team.html b/services/brig/deb/opt/brig/templates/pt/user/email/verification-delete-team.html new file mode 100644 index 00000000000..c7666c1f0d7 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pt/user/email/verification-delete-team.html @@ -0,0 +1 @@ +Seu código de verificação do ${brand} é ${code}

${brand_label_url}

Verificar exclusão da equipe

${email} foi usado para excluir sua equipe do ${brand}. Insira este código para verificar seu e-mail e excluir a equipe.

 

${code}

 

Se você tiver alguma dúvida, por favor, entre em contato conosco.

Política de privacidade e termos de uso · Reportar uso indevido
${copyright}. TODOS OS DIREITOS RESERVADOS.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/pt/user/email/verification-delete-team.txt b/services/brig/deb/opt/brig/templates/pt/user/email/verification-delete-team.txt new file mode 100644 index 00000000000..820aa9824d1 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pt/user/email/verification-delete-team.txt @@ -0,0 +1,18 @@ +[${brand_logo}] + +${brand_label_url} [${brand_url}] + +VERIFICAR EXCLUSÃO DA EQUIPE +${email} foi usado para excluir sua equipe do ${brand}. Insira este código para +verificar seu e-mail e excluir a equipe. + +${code} + +Se você tiver alguma dúvida, por favor, entre em contato conosco [${support}]. + + +-------------------------------------------------------------------------------- + +Política de privacidade e termos de uso [${legal}] · Reportar uso indevido +[${misuse}] +${copyright}. TODOS OS DIREITOS RESERVADOS. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/pt/user/email/verification-login-subject.txt b/services/brig/deb/opt/brig/templates/pt/user/email/verification-login-subject.txt new file mode 100644 index 00000000000..d40987b30b7 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pt/user/email/verification-login-subject.txt @@ -0,0 +1 @@ +Seu código de verificação do ${brand} é ${code} \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/pt/user/email/verification-login.html b/services/brig/deb/opt/brig/templates/pt/user/email/verification-login.html new file mode 100644 index 00000000000..c3f39e27cd5 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pt/user/email/verification-login.html @@ -0,0 +1 @@ +Seu código de verificação do ${brand} é ${code}

${brand_label_url}

Verificar login

${email} foi usado para iniciar sessão em sua conta do ${brand}. Insira este código para verificar seu e-mail e iniciar sessão.

 

${code}

 

Se você tiver alguma dúvida, por favor, entre em contato conosco.

Política de privacidade e termos de uso · Reportar uso indevido
${copyright}. TODOS OS DIREITOS RESERVADOS.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/pt/user/email/verification-login.txt b/services/brig/deb/opt/brig/templates/pt/user/email/verification-login.txt new file mode 100644 index 00000000000..6d78124dea2 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pt/user/email/verification-login.txt @@ -0,0 +1,18 @@ +[${brand_logo}] + +${brand_label_url} [${brand_url}] + +VERIFICAR LOGIN +${email} foi usado para iniciar sessão em sua conta do ${brand}. Insira este +código para verificar seu e-mail e iniciar sessão. + +${code} + +Se você tiver alguma dúvida, por favor, entre em contato conosco [${support}]. + + +-------------------------------------------------------------------------------- + +Política de privacidade e termos de uso [${legal}] · Reportar uso indevido +[${misuse}] +${copyright}. TODOS OS DIREITOS RESERVADOS. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/pt/user/email/verification-scim-token-subject.txt b/services/brig/deb/opt/brig/templates/pt/user/email/verification-scim-token-subject.txt new file mode 100644 index 00000000000..d40987b30b7 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pt/user/email/verification-scim-token-subject.txt @@ -0,0 +1 @@ +Seu código de verificação do ${brand} é ${code} \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/pt/user/email/verification-scim-token.html b/services/brig/deb/opt/brig/templates/pt/user/email/verification-scim-token.html new file mode 100644 index 00000000000..dc89990c0a6 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pt/user/email/verification-scim-token.html @@ -0,0 +1 @@ +Seu código de verificação do ${brand} é ${code}

${brand_label_url}

Verificar criação do token SCIM

${email} foi usado para gerar um token SCIM. Insira este código para verificar seu e-mail e criar o token.

 

${code}

 

Se você tiver alguma dúvida, por favor, entre em contato conosco.

Política de privacidade e termos de uso · Reportar uso indevido
${copyright}. TODOS OS DIREITOS RESERVADOS.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/pt/user/email/verification-scim-token.txt b/services/brig/deb/opt/brig/templates/pt/user/email/verification-scim-token.txt new file mode 100644 index 00000000000..e55147ef8b1 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pt/user/email/verification-scim-token.txt @@ -0,0 +1,18 @@ +[${brand_logo}] + +${brand_label_url} [${brand_url}] + +VERIFICAR CRIAÇÃO DO TOKEN SCIM +${email} foi usado para gerar um token SCIM. Insira este código para verificar +seu e-mail e criar o token. + +${code} + +Se você tiver alguma dúvida, por favor, entre em contato conosco [${support}]. + + +-------------------------------------------------------------------------------- + +Política de privacidade e termos de uso [${legal}] · Reportar uso indevido +[${misuse}] +${copyright}. TODOS OS DIREITOS RESERVADOS. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/pt/user/email/verification-subject.txt b/services/brig/deb/opt/brig/templates/pt/user/email/verification-subject.txt new file mode 100644 index 00000000000..3c1b6bbaade --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pt/user/email/verification-subject.txt @@ -0,0 +1 @@ +${code} é o seu código de verificação do ${brand} \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/pt/user/email/verification.html b/services/brig/deb/opt/brig/templates/pt/user/email/verification.html new file mode 100644 index 00000000000..103bbb41ea9 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pt/user/email/verification.html @@ -0,0 +1 @@ +${code} é o seu código de verificação do ${brand}

${brand_label_url}

Verifique seu e-mail

${email} foi usado para se registrar no ${brand}. Digite este código para verificar seu e-mail e criar sua conta.

 

${code}

 

Se você tiver alguma dúvida, por favor, entre em contato conosco.

Política de privacidade e termos de uso · Reportar uso indevido
${copyright}. TODOS OS DIREITOS RESERVADOS.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/pt/user/email/verification.txt b/services/brig/deb/opt/brig/templates/pt/user/email/verification.txt new file mode 100644 index 00000000000..c0b0003e06b --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pt/user/email/verification.txt @@ -0,0 +1,18 @@ +[${brand_logo}] + +${brand_label_url} [${brand_url}] + +VERIFIQUE SEU E-MAIL +${email} foi usado para se registrar no ${brand}. Digite este código para +verificar seu e-mail e criar sua conta. + +${code} + +Se você tiver alguma dúvida, por favor, entre em contato conosco [${support}]. + + +-------------------------------------------------------------------------------- + +Política de privacidade e termos de uso [${legal}] · Reportar uso indevido +[${misuse}] +${copyright}. TODOS OS DIREITOS RESERVADOS. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/pt/user/sms/activation.txt b/services/brig/deb/opt/brig/templates/pt/user/sms/activation.txt new file mode 100644 index 00000000000..520eb63c92d --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pt/user/sms/activation.txt @@ -0,0 +1,3 @@ +Seu código ${brand} é ${code}. + +Acesse ${url} para verificar seu número. diff --git a/services/brig/deb/opt/brig/templates/pt/user/sms/deletion.txt b/services/brig/deb/opt/brig/templates/pt/user/sms/deletion.txt new file mode 100644 index 00000000000..7faf69e6639 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pt/user/sms/deletion.txt @@ -0,0 +1,2 @@ +Toque para excluir sua conta no ${brand}. +${url} diff --git a/services/brig/deb/opt/brig/templates/pt/user/sms/login.txt b/services/brig/deb/opt/brig/templates/pt/user/sms/login.txt new file mode 100644 index 00000000000..ef5e8fd5d16 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pt/user/sms/login.txt @@ -0,0 +1,3 @@ +Seu código de login ${brand} é ${code}. + +Acesse ${url} para entrar. diff --git a/services/brig/deb/opt/brig/templates/pt/user/sms/password-reset.txt b/services/brig/deb/opt/brig/templates/pt/user/sms/password-reset.txt new file mode 100644 index 00000000000..3667edd333c --- /dev/null +++ b/services/brig/deb/opt/brig/templates/pt/user/sms/password-reset.txt @@ -0,0 +1,3 @@ +Seu código de recuperação ${brand} é ${code}. + +Use este código para concluir a redefinição de senha. diff --git a/services/brig/deb/opt/brig/templates/ru/user/email/activation.html b/services/brig/deb/opt/brig/templates/ru/user/email/activation.html index 01de6edfd88..8470a280639 100644 --- a/services/brig/deb/opt/brig/templates/ru/user/email/activation.html +++ b/services/brig/deb/opt/brig/templates/ru/user/email/activation.html @@ -1 +1 @@ -Ваша учетная запись ${brand}

${brand_label_url}

Подтвердите ваш email

${email} был использован для регистрации в ${brand}.
Нажмите на кнопку для подтверждения вашего email адреса.

 
Подтвердить
 

Если вы не можете нажать на кнопку, скопируйте и вставьте эту ссылку в свой браузер:

${url}

Если у вас возникли вопросы или нужна помощь, пожалуйста свяжитесь с нами.

Политика конфиденциальности и условия использования · Сообщить о злоупотреблении
${copyright}. ВСЕ ПРАВА РЕЗЕРВЕННЫ.

                                                           
\ No newline at end of file +Ваша учетная запись ${brand}

${brand_label_url}

Подтвердите ваш email

${email} был использован для регистрации в ${brand}.
Нажмите на кнопку для подтверждения вашего email адреса.

 
Подтвердить
 

Если вы не можете нажать на кнопку, скопируйте и вставьте эту ссылку в свой браузер:

${url}

Если у вас возникли вопросы или нужна помощь, пожалуйста свяжитесь с нами.

Политика конфиденциальности и условия использования · Сообщить о злоупотреблении
${copyright}. ВСЕ ПРАВА РЕЗЕРВЕННЫ.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/ru/user/email/deletion.html b/services/brig/deb/opt/brig/templates/ru/user/email/deletion.html index 2066c270ddb..cb4f186bde7 100644 --- a/services/brig/deb/opt/brig/templates/ru/user/email/deletion.html +++ b/services/brig/deb/opt/brig/templates/ru/user/email/deletion.html @@ -1 +1 @@ -Удалить учетную запись?

${brand_label_url}

Удалить учетную запись

Мы получили запрос на удаление вашего аккаунта ${brand}. Нажмите на кнопку ниже в течение 10 минут для удаления всех ваших разговоров, контента и контактов.

 
Удалить учетную запись
 

Если вы не можете нажать на кнопку, скопируйте и вставьте эту ссылку в свой браузер:

${url}

Если вы не запрашивали удаление вашего аккаунта, то сбросьте ваш пароль.

Если у вас возникли вопросы или нужна помощь, пожалуйста свяжитесь с нами.

Политика конфиденциальности и условия использования · Сообщить о злоупотреблении
${copyright}. ВСЕ ПРАВА РЕЗЕРВЕННЫ.

                                                           
\ No newline at end of file +Удалить учетную запись?

${brand_label_url}

Удалить учетную запись

Мы получили запрос на удаление вашего аккаунта ${brand}. Нажмите на кнопку ниже в течение 10 минут для удаления всех ваших разговоров, контента и контактов.

 
Удалить учетную запись
 

Если вы не можете нажать на кнопку, скопируйте и вставьте эту ссылку в свой браузер:

${url}

Если вы не запрашивали удаление вашего аккаунта, то сбросьте ваш пароль.

Если у вас возникли вопросы или нужна помощь, пожалуйста свяжитесь с нами.

Политика конфиденциальности и условия использования · Сообщить о злоупотреблении
${copyright}. ВСЕ ПРАВА РЕЗЕРВЕННЫ.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/ru/user/email/new-client.html b/services/brig/deb/opt/brig/templates/ru/user/email/new-client.html index b3f8669542d..6c111e2c508 100644 --- a/services/brig/deb/opt/brig/templates/ru/user/email/new-client.html +++ b/services/brig/deb/opt/brig/templates/ru/user/email/new-client.html @@ -1 +1 @@ -Новое устройство

${brand_label_url}

Новое устройство

Ваша учетная запись ${brand} использовалась на:

${date}

${model}

Возможно, вы установили ${brand} на новом устройстве или переустановили его на одном из уже используемых ранее. Если это не так, перейдите в настройки ${brand}, удалите это устройство из списка и сбросьте ваш пароль.

Если у вас возникли вопросы или нужна помощь, пожалуйста свяжитесь с нами.

Политика конфиденциальности и условия использования · Сообщить о злоупотреблении
${copyright}. ВСЕ ПРАВА РЕЗЕРВЕННЫ.

                                                           
\ No newline at end of file +Новое устройство

${brand_label_url}

Новое устройство

Ваша учетная запись ${brand} использовалась на:

${date}

${model}

Возможно, вы установили ${brand} на новое устройство или повторно установили его на существующее. Если это не так, перейдите в настройки ${brand}, удалите это устройство из списка и сбросьте пароль.

Если у вас возникли вопросы или нужна помощь, пожалуйста свяжитесь с нами.

Политика конфиденциальности и условия использования · Сообщить о злоупотреблении
${copyright}. ВСЕ ПРАВА РЕЗЕРВЕННЫ.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/ru/user/email/new-client.txt b/services/brig/deb/opt/brig/templates/ru/user/email/new-client.txt index fade67d1c4f..1bc94a85aca 100644 --- a/services/brig/deb/opt/brig/templates/ru/user/email/new-client.txt +++ b/services/brig/deb/opt/brig/templates/ru/user/email/new-client.txt @@ -9,9 +9,9 @@ ${date} ${model} -Возможно, вы установили ${brand} на новом устройстве или переустановили его на -одном из уже используемых ранее. Если это не так, перейдите в настройки -${brand}, удалите это устройство из списка и сбросьте ваш пароль [${forgot}]. +Возможно, вы установили ${brand} на новое устройство или повторно установили его +на существующее. Если это не так, перейдите в настройки ${brand}, удалите это +устройство из списка и сбросьте пароль [${forgot}]. Если у вас возникли вопросы или нужна помощь, пожалуйста свяжитесь с нами [${support}]. diff --git a/services/brig/deb/opt/brig/templates/ru/user/email/password-reset.html b/services/brig/deb/opt/brig/templates/ru/user/email/password-reset.html index 3ee9646f58c..fd2ea12f9ce 100644 --- a/services/brig/deb/opt/brig/templates/ru/user/email/password-reset.html +++ b/services/brig/deb/opt/brig/templates/ru/user/email/password-reset.html @@ -1 +1 @@ -Смена пароля в ${brand}

${brand_label_url}

Сбросить пароль

Мы получили запрос на сброс пароля для вашей учетной записи ${brand}. Чтобы создать новый пароль нажмите на кнопку ниже.

 
Сбросить пароль
 

Если вы не можете нажать на кнопку, скопируйте и вставьте эту ссылку в свой браузер:

${url}

Если у вас возникли вопросы или нужна помощь, пожалуйста свяжитесь с нами.

Политика конфиденциальности и условия использования · Сообщить о злоупотреблении
${copyright}. ВСЕ ПРАВА РЕЗЕРВЕННЫ.

                                                           
\ No newline at end of file +Смена пароля в ${brand}

${brand_label_url}

Сбросить пароль

Мы получили запрос на сброс пароля для вашей учетной записи ${brand}. Чтобы создать новый пароль нажмите на кнопку ниже.

 
Сбросить пароль
 

Если вы не можете нажать на кнопку, скопируйте и вставьте эту ссылку в свой браузер:

${url}

Если у вас возникли вопросы или нужна помощь, пожалуйста свяжитесь с нами.

Политика конфиденциальности и условия использования · Сообщить о злоупотреблении
${copyright}. ВСЕ ПРАВА РЕЗЕРВЕННЫ.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/ru/user/email/team-activation.html b/services/brig/deb/opt/brig/templates/ru/user/email/team-activation.html index 4543331120e..8302577b73e 100644 --- a/services/brig/deb/opt/brig/templates/ru/user/email/team-activation.html +++ b/services/brig/deb/opt/brig/templates/ru/user/email/team-activation.html @@ -1 +1 @@ -Ваша учетная запись ${brand}

${brand_label_url}

Ваша новая учетная запись ${brand}

В ${brand} была создана новая команда с использованием email адреса ${email}. Подтвердите ваш email адрес.

 
Подтвердить
 

Если вы не можете нажать на кнопку, скопируйте и вставьте эту ссылку в свой браузер:

${url}

Если у вас возникли вопросы или нужна помощь, пожалуйста свяжитесь с нами.

Политика конфиденциальности и условия использования · Сообщить о злоупотреблении
${copyright}. ВСЕ ПРАВА РЕЗЕРВЕННЫ.

                                                           
\ No newline at end of file +Ваша учетная запись ${brand}

${brand_label_url}

Ваша новая учетная запись ${brand}

В ${brand} была создана новая команда с использованием email адреса ${email}. Подтвердите ваш email адрес.

 
Подтвердить
 

Если вы не можете нажать на кнопку, скопируйте и вставьте эту ссылку в свой браузер:

${url}

Если у вас возникли вопросы или нужна помощь, пожалуйста свяжитесь с нами.

Политика конфиденциальности и условия использования · Сообщить о злоупотреблении
${copyright}. ВСЕ ПРАВА РЕЗЕРВЕННЫ.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/ru/user/email/team-activation.txt b/services/brig/deb/opt/brig/templates/ru/user/email/team-activation.txt index bde3eda6113..9ea2873c2f4 100644 --- a/services/brig/deb/opt/brig/templates/ru/user/email/team-activation.txt +++ b/services/brig/deb/opt/brig/templates/ru/user/email/team-activation.txt @@ -2,7 +2,7 @@ ${brand_label_url} [${brand_url}] -ВАША НОВАЯ УЧЕТНАЯ ЗАПИСЬ ${brand} +ВАША НОВАЯ УЧЕТНАЯ ЗАПИСЬ ${BRAND} В ${brand} была создана новая команда с использованием email адреса ${email}. Подтвердите ваш email адрес. diff --git a/services/brig/deb/opt/brig/templates/ru/user/email/update.html b/services/brig/deb/opt/brig/templates/ru/user/email/update.html index 64122ef00b6..36577320f83 100644 --- a/services/brig/deb/opt/brig/templates/ru/user/email/update.html +++ b/services/brig/deb/opt/brig/templates/ru/user/email/update.html @@ -1 +1 @@ -Ваш новый email адрес в ${brand}

${brand_label_url}

Подтвердите ваш email адрес

${email} был указан как ваш новый email адрес в ${brand}. Нажмите на кнопку ниже для подтверждения своего адреса.

 
Подтвердить
 

Если вы не можете нажать на кнопку, скопируйте и вставьте эту ссылку в свой браузер:

${url}

Если у вас возникли вопросы или нужна помощь, пожалуйста свяжитесь с нами.

Политика конфиденциальности и условия использования · Сообщить о злоупотреблении
${copyright}. ВСЕ ПРАВА РЕЗЕРВЕННЫ.

                                                           
\ No newline at end of file +Ваш новый email адрес в ${brand}

${brand_label_url}

Подтвердите ваш email адрес

${email} был указан как ваш новый email адрес в ${brand}. Нажмите на кнопку ниже для подтверждения своего адреса.

 
Подтвердить
 

Если вы не можете нажать на кнопку, скопируйте и вставьте эту ссылку в свой браузер:

${url}

Если у вас возникли вопросы или нужна помощь, пожалуйста свяжитесь с нами.

Политика конфиденциальности и условия использования · Сообщить о злоупотреблении
${copyright}. ВСЕ ПРАВА РЕЗЕРВЕННЫ.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/ru/user/email/verification-delete-team-subject.txt b/services/brig/deb/opt/brig/templates/ru/user/email/verification-delete-team-subject.txt index e69de29bb2d..1cb058df873 100644 --- a/services/brig/deb/opt/brig/templates/ru/user/email/verification-delete-team-subject.txt +++ b/services/brig/deb/opt/brig/templates/ru/user/email/verification-delete-team-subject.txt @@ -0,0 +1 @@ +ваш код подтверждения ${brand} - ${code} \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/ru/user/email/verification-delete-team.html b/services/brig/deb/opt/brig/templates/ru/user/email/verification-delete-team.html index 8023ee5b7b5..81d0a92e4b3 100644 --- a/services/brig/deb/opt/brig/templates/ru/user/email/verification-delete-team.html +++ b/services/brig/deb/opt/brig/templates/ru/user/email/verification-delete-team.html @@ -1 +1 @@ -

${brand_label_url}

Подтвердить удаление команды

${email} был использован для удаления вашей команды ${brand}. Введите этот код для подтверждения электронной почты и удаления команды.

 

${code}

 

Если у вас возникли вопросы или нужна помощь, пожалуйста свяжитесь с нами.

Политика конфиденциальности и условия использования · Сообщить о злоупотреблении
${copyright}. ВСЕ ПРАВА РЕЗЕРВЕННЫ.

                                                           
\ No newline at end of file +ваш код подтверждения ${brand} - ${code}

${brand_label_url}

Подтвердить удаление команды

${email} был использован для удаления вашей команды ${brand}. Введите этот код для подтверждения электронной почты и удаления команды.

 

${code}

 

Если у вас возникли вопросы или нужна помощь, пожалуйста свяжитесь с нами.

Политика конфиденциальности и условия использования · Сообщить о злоупотреблении
${copyright}. ВСЕ ПРАВА РЕЗЕРВЕННЫ.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/ru/user/email/verification-login-subject.txt b/services/brig/deb/opt/brig/templates/ru/user/email/verification-login-subject.txt index e69de29bb2d..1cb058df873 100644 --- a/services/brig/deb/opt/brig/templates/ru/user/email/verification-login-subject.txt +++ b/services/brig/deb/opt/brig/templates/ru/user/email/verification-login-subject.txt @@ -0,0 +1 @@ +ваш код подтверждения ${brand} - ${code} \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/ru/user/email/verification-login.html b/services/brig/deb/opt/brig/templates/ru/user/email/verification-login.html index 07664a34a3b..3124ff0691b 100644 --- a/services/brig/deb/opt/brig/templates/ru/user/email/verification-login.html +++ b/services/brig/deb/opt/brig/templates/ru/user/email/verification-login.html @@ -1 +1 @@ -

${brand_label_url}

Подтвердить вход

${email} был использован для входа в ${brand}. Введите этот код для подтверждения электронной почты и авторизации в вашем аккаунте.

 

${code}

 

Если у вас возникли вопросы или нужна помощь, пожалуйста свяжитесь с нами.

Политика конфиденциальности и условия использования · Сообщить о злоупотреблении
${copyright}. ВСЕ ПРАВА РЕЗЕРВЕННЫ.

                                                           
\ No newline at end of file +ваш код подтверждения ${brand} - ${code}

${brand_label_url}

Подтвердить вход

${email} был использован для входа в ${brand}. Введите этот код для подтверждения электронной почты и авторизации в вашем аккаунте.

 

${code}

 

Если у вас возникли вопросы или нужна помощь, пожалуйста свяжитесь с нами.

Политика конфиденциальности и условия использования · Сообщить о злоупотреблении
${copyright}. ВСЕ ПРАВА РЕЗЕРВЕННЫ.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/ru/user/email/verification-scim-token-subject.txt b/services/brig/deb/opt/brig/templates/ru/user/email/verification-scim-token-subject.txt index e69de29bb2d..1cb058df873 100644 --- a/services/brig/deb/opt/brig/templates/ru/user/email/verification-scim-token-subject.txt +++ b/services/brig/deb/opt/brig/templates/ru/user/email/verification-scim-token-subject.txt @@ -0,0 +1 @@ +ваш код подтверждения ${brand} - ${code} \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/ru/user/email/verification-scim-token.html b/services/brig/deb/opt/brig/templates/ru/user/email/verification-scim-token.html index 525d031dbe3..84348b41109 100644 --- a/services/brig/deb/opt/brig/templates/ru/user/email/verification-scim-token.html +++ b/services/brig/deb/opt/brig/templates/ru/user/email/verification-scim-token.html @@ -1 +1 @@ -

${brand_label_url}

Подтвердить создание токена SCIM

${email} был использован для создания токена SCIM. Введите этот код для подтверждения электронной почты и создания токена SCIM.

 

${code}

 

Если у вас возникли вопросы или нужна помощь, пожалуйста свяжитесь с нами.

Политика конфиденциальности и условия использования · Сообщить о злоупотреблении
${copyright}. ВСЕ ПРАВА РЕЗЕРВЕННЫ.

                                                           
\ No newline at end of file +ваш код подтверждения ${brand} - ${code}

${brand_label_url}

Подтвердить создание токена SCIM

${email} был использован для создания токена SCIM. Введите этот код для подтверждения электронной почты и создания токена SCIM.

 

${code}

 

Если у вас возникли вопросы или нужна помощь, пожалуйста свяжитесь с нами.

Политика конфиденциальности и условия использования · Сообщить о злоупотреблении
${copyright}. ВСЕ ПРАВА РЕЗЕРВЕННЫ.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/ru/user/email/verification.html b/services/brig/deb/opt/brig/templates/ru/user/email/verification.html index 8bd5beb8fbf..d8cbb110703 100644 --- a/services/brig/deb/opt/brig/templates/ru/user/email/verification.html +++ b/services/brig/deb/opt/brig/templates/ru/user/email/verification.html @@ -1 +1 @@ -${code} - это код подтверждения ${brand}

${brand_label_url}

Подтвердите ваш email

${email} был использован для регистрации в ${brand}. Введите этот код для подтверждения email и создания учетной записи.

 

${code}

 

Если у вас возникли вопросы или нужна помощь, пожалуйста свяжитесь с нами.

Политика конфиденциальности и условия использования · Сообщить о злоупотреблении
${copyright}. ВСЕ ПРАВА РЕЗЕРВЕННЫ.

                                                           
\ No newline at end of file +${code} - это код подтверждения ${brand}

${brand_label_url}

Подтвердите ваш email

${email} был использован для регистрации в ${brand}. Введите этот код для подтверждения email и создания учетной записи.

 

${code}

 

Если у вас возникли вопросы или нужна помощь, пожалуйста свяжитесь с нами.

Политика конфиденциальности и условия использования · Сообщить о злоупотреблении
${copyright}. ВСЕ ПРАВА РЕЗЕРВЕННЫ.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/si/user/call/activation.txt b/services/brig/deb/opt/brig/templates/si/user/call/activation.txt new file mode 100644 index 00000000000..c7754ab63c1 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/si/user/call/activation.txt @@ -0,0 +1 @@ +ආයුබෝවන්, ඔබගේ වයර් සත්‍යාපන කේතය: ${code}. නැවත වරක්, ඔබගේ කේතය: ${code} \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/si/user/call/login.txt b/services/brig/deb/opt/brig/templates/si/user/call/login.txt new file mode 100644 index 00000000000..ccb91205ee0 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/si/user/call/login.txt @@ -0,0 +1 @@ +ආයුබෝවන්, ඔබගේ වයර් කේතය: ${code}. නැවත වරක්, ඔබගේ කේතය: ${code} \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/si/user/email/activation-subject.txt b/services/brig/deb/opt/brig/templates/si/user/email/activation-subject.txt new file mode 100644 index 00000000000..f6c88ca3390 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/si/user/email/activation-subject.txt @@ -0,0 +1 @@ +ඔබගේ ${brand} ගිණුම \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/si/user/email/activation.html b/services/brig/deb/opt/brig/templates/si/user/email/activation.html new file mode 100644 index 00000000000..5469f094995 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/si/user/email/activation.html @@ -0,0 +1 @@ +ඔබගේ ${brand} ගිණුම

${brand_label_url}

ඔබගේ වි-තැපෑල සත්‍යාපනය කරන්න

${brand} හි ලියාපදිංචියට ${email} භාවිතා කර ඇත.
ඔබගේ ලිපිනය සත්‍යාපනයට පහත බොත්තම ඔබන්න.

 
සත්‍යාපනය
 

බොත්තම එබීමට නොහැකි නම් මෙම සබැඳිය පිටපත් කර ඔබගේ අතිරික්සුවෙහි අලවන්න:

${url}

ඔබට කිසියම් ප්‍රශ්නයක් ඇත්නම් කරුණාකර අප අමතන්න.

රහස්‍යතා ප්‍රතිපත්තිය සහ භාවිත නියම · අවභාවිතය වාර්තා කරන්න
${copyright}. සියළුම හිමිකම් ඇවිරිණි.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/si/user/email/activation.txt b/services/brig/deb/opt/brig/templates/si/user/email/activation.txt new file mode 100644 index 00000000000..bab1d042dc5 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/si/user/email/activation.txt @@ -0,0 +1,21 @@ +[${brand_logo}] + +${brand_label_url} [${brand_url}] + +ඔබගේ වි-තැපෑල සත්‍යාපනය කරන්න +${brand} හි ලියාපදිංචියට ${email} භාවිතා කර ඇත. +ඔබගේ ලිපිනය සත්‍යාපනයට පහත බොත්තම ඔබන්න. + +සත්‍යාපනය [${url}]බොත්තම එබීමට නොහැකි නම් මෙම සබැඳිය පිටපත් කර ඔබගේ +අතිරික්සුවෙහි අලවන්න: + +${url} + +ඔබට කිසියම් ප්‍රශ්නයක් ඇත්නම් කරුණාකර අප අමතන්න [${support}]. + + +-------------------------------------------------------------------------------- + +රහස්‍යතා ප්‍රතිපත්තිය සහ භාවිත නියම [${legal}] · අවභාවිතය වාර්තා කරන්න +[${misuse}] +${copyright}. සියළුම හිමිකම් ඇවිරිණි. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/si/user/email/deletion-subject.txt b/services/brig/deb/opt/brig/templates/si/user/email/deletion-subject.txt new file mode 100644 index 00000000000..4d3a96064c0 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/si/user/email/deletion-subject.txt @@ -0,0 +1 @@ +ගිණුම මකනවාද? \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/si/user/email/deletion.html b/services/brig/deb/opt/brig/templates/si/user/email/deletion.html new file mode 100644 index 00000000000..6852a1f7796 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/si/user/email/deletion.html @@ -0,0 +1 @@ +ගිණුම මකනවාද?

${brand_label_url}

ඔබගේ ගිණුම මකන්න

ඔබගේ ${brand} ගිණුම මැකීම සඳහා අපට ඉල්ලීමක් ලැබුණි. ඔබගේ සියළුම සංවාද, අන්තර්ගත සහ සම්බන්ධතා මැකීමට විනාඩි 10 ක් ඇතුළත පහත බොත්තම ඔබන්න.

 
ගිණුම මකන්න
 

බොත්තම එබීමට නොහැකි නම් මෙම සබැඳිය පිටපත් කර ඔබගේ අතිරික්සුවෙහි අලවන්න:

${url}

ඔබ මෙය ඉල්ලුවේ නැති නම්, මුරපදය යළි සකසන්න.

ඔබට කිසියම් ප්‍රශ්නයක් ඇත්නම් කරුණාකර අප අමතන්න.

රහස්‍යතා ප්‍රතිපත්තිය සහ භාවිත නියම · අවභාවිතය වාර්තා කරන්න
${copyright}. සියළුම හිමිකම් ඇවිරිණි.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/si/user/email/deletion.txt b/services/brig/deb/opt/brig/templates/si/user/email/deletion.txt new file mode 100644 index 00000000000..07207417957 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/si/user/email/deletion.txt @@ -0,0 +1,23 @@ +[${brand_logo}] + +${brand_label_url} [${brand_url}] + +ඔබගේ ගිණුම මකන්න +ඔබගේ ${brand} ගිණුම මැකීම සඳහා අපට ඉල්ලීමක් ලැබුණි. ඔබගේ සියළුම සංවාද, අන්තර්ගත +සහ සම්බන්ධතා මැකීමට විනාඩි 10 ක් ඇතුළත පහත බොත්තම ඔබන්න. + +ගිණුම මකන්න [${url}]බොත්තම එබීමට නොහැකි නම් මෙම සබැඳිය පිටපත් කර ඔබගේ +අතිරික්සුවෙහි අලවන්න: + +${url} + +ඔබ මෙය ඉල්ලුවේ නැති නම්, මුරපදය යළි සකසන්න [${forgot}]. + +ඔබට කිසියම් ප්‍රශ්නයක් ඇත්නම් කරුණාකර අප අමතන්න [${support}]. + + +-------------------------------------------------------------------------------- + +රහස්‍යතා ප්‍රතිපත්තිය සහ භාවිත නියම [${legal}] · අවභාවිතය වාර්තා කරන්න +[${misuse}] +${copyright}. සියළුම හිමිකම් ඇවිරිණි. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/si/user/email/new-client-subject.txt b/services/brig/deb/opt/brig/templates/si/user/email/new-client-subject.txt new file mode 100644 index 00000000000..342354069fa --- /dev/null +++ b/services/brig/deb/opt/brig/templates/si/user/email/new-client-subject.txt @@ -0,0 +1 @@ +නව උපාංගය \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/si/user/email/new-client.html b/services/brig/deb/opt/brig/templates/si/user/email/new-client.html new file mode 100644 index 00000000000..4147eaec097 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/si/user/email/new-client.html @@ -0,0 +1 @@ +නව උපාංගය

${brand_label_url}

නව උපාංගය

ඔබගේ ${brand} ගිණුම භාවිතා වී ඇත:

${date}

${model}

ඔබ නව උපාංගයක හෝ පැවති උපාංගයක නැවත ${brand} ස්ථාපනය කර ඇත. මෙය අනපේක්‍ෂිත නම්, ${brand} සැකසුම් වෙත ගොස්, උපාංගය ඉවත් කර මුරපදය යළි සකසන්න.

ඔබට කිසියම් ප්‍රශ්නයක් ඇත්නම් කරුණාකර අප අමතන්න.

රහස්‍යතා ප්‍රතිපත්තිය සහ භාවිත නියම · අවභාවිතය වාර්තා කරන්න
${copyright}. සියළුම හිමිකම් ඇවිරිණි.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/si/user/email/new-client.txt b/services/brig/deb/opt/brig/templates/si/user/email/new-client.txt new file mode 100644 index 00000000000..bd6267e1a37 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/si/user/email/new-client.txt @@ -0,0 +1,22 @@ +[${brand_logo}] + +${brand_label_url} [${brand_url}] + +නව උපාංගය +ඔබගේ ${brand} ගිණුම භාවිතා වී ඇත: + +${date} + +${model} + +ඔබ නව උපාංගයක හෝ පැවති උපාංගයක නැවත ${brand} ස්ථාපනය කර ඇත. මෙය අනපේක්‍ෂිත නම්, +${brand} සැකසුම් වෙත ගොස්, උපාංගය ඉවත් කර මුරපදය යළි සකසන්න [${forgot}]. + +ඔබට කිසියම් ප්‍රශ්නයක් ඇත්නම් කරුණාකර අප අමතන්න [${support}]. + + +-------------------------------------------------------------------------------- + +රහස්‍යතා ප්‍රතිපත්තිය සහ භාවිත නියම [${legal}] · අවභාවිතය වාර්තා කරන්න +[${misuse}] +${copyright}. සියළුම හිමිකම් ඇවිරිණි. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/si/user/email/password-reset-subject.txt b/services/brig/deb/opt/brig/templates/si/user/email/password-reset-subject.txt new file mode 100644 index 00000000000..08edd4bae53 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/si/user/email/password-reset-subject.txt @@ -0,0 +1 @@ +${brand} මුරපදය වෙනස් කිරීම \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/si/user/email/password-reset.html b/services/brig/deb/opt/brig/templates/si/user/email/password-reset.html new file mode 100644 index 00000000000..fd5fe0d1863 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/si/user/email/password-reset.html @@ -0,0 +1 @@ +${brand} මුරපදය වෙනස් කිරීම

${brand_label_url}

මුරපදය යළි සකසන්න

ඔබගේ ${brand} ගිණුමේ මුරපදය යළි සැකසීම සඳහා අපට ඉල්ලීමක් ලැබුණි. නව මුරපදයක් සෑදීමට පහත බොත්තම ඔබන්න.

 
මුරපදය යළි සකසන්න
 

බොත්තම එබීමට නොහැකි නම් මෙම සබැඳිය පිටපත් කර ඔබගේ අතිරික්සුවෙහි අලවන්න:

${url}

ඔබට කිසියම් ප්‍රශ්නයක් ඇත්නම් කරුණාකර අප අමතන්න.

රහස්‍යතා ප්‍රතිපත්තිය සහ භාවිත නියම · අවභාවිතය වාර්තා කරන්න
${copyright}. සියළුම හිමිකම් ඇවිරිණි.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/si/user/email/password-reset.txt b/services/brig/deb/opt/brig/templates/si/user/email/password-reset.txt new file mode 100644 index 00000000000..fddd05d4af4 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/si/user/email/password-reset.txt @@ -0,0 +1,21 @@ +[${brand_logo}] + +${brand_label_url} [${brand_url}] + +මුරපදය යළි සකසන්න +ඔබගේ ${brand} ගිණුමේ මුරපදය යළි සැකසීම සඳහා අපට ඉල්ලීමක් ලැබුණි. නව මුරපදයක් +සෑදීමට පහත බොත්තම ඔබන්න. + +මුරපදය යළි සකසන්න [${url}]බොත්තම එබීමට නොහැකි නම් මෙම සබැඳිය පිටපත් කර ඔබගේ +අතිරික්සුවෙහි අලවන්න: + +${url} + +ඔබට කිසියම් ප්‍රශ්නයක් ඇත්නම් කරුණාකර අප අමතන්න [${support}]. + + +-------------------------------------------------------------------------------- + +රහස්‍යතා ප්‍රතිපත්තිය සහ භාවිත නියම [${legal}] · අවභාවිතය වාර්තා කරන්න +[${misuse}] +${copyright}. සියළුම හිමිකම් ඇවිරිණි. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/si/user/email/team-activation-subject.txt b/services/brig/deb/opt/brig/templates/si/user/email/team-activation-subject.txt new file mode 100644 index 00000000000..c9eab6a756d --- /dev/null +++ b/services/brig/deb/opt/brig/templates/si/user/email/team-activation-subject.txt @@ -0,0 +1 @@ +${brand} ගිණුම \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/si/user/email/team-activation.html b/services/brig/deb/opt/brig/templates/si/user/email/team-activation.html new file mode 100644 index 00000000000..7017f3c8545 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/si/user/email/team-activation.html @@ -0,0 +1 @@ +${brand} ගිණුම

${brand_label_url}

ඔබගේ නව ${brand} ගිණුම

${email} සමඟ නව ${brand} කණ්ඩායමක් සාදා ඇත. ඔබගේ වි-තැපෑල සත්‍යාපනය කරන්න.

 
සත්‍යාපනය
 

බොත්තම එබීමට නොහැකි නම් මෙම සබැඳිය පිටපත් කර ඔබගේ අතිරික්සුවෙහි අලවන්න:

${url}

ඔබට කිසියම් ප්‍රශ්නයක් ඇත්නම් කරුණාකර අප අමතන්න.

රහස්‍යතා ප්‍රතිපත්තිය සහ භාවිත නියම · අවභාවිතය වාර්තා කරන්න
${copyright}. සියළුම හිමිකම් ඇවිරිණි.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/si/user/email/team-activation.txt b/services/brig/deb/opt/brig/templates/si/user/email/team-activation.txt new file mode 100644 index 00000000000..520e00970c2 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/si/user/email/team-activation.txt @@ -0,0 +1,20 @@ +[${brand_logo}] + +${brand_label_url} [${brand_url}] + +ඔබගේ නව ${BRAND} ගිණුම +${email} සමඟ නව ${brand} කණ්ඩායමක් සාදා ඇත. ඔබගේ වි-තැපෑල සත්‍යාපනය කරන්න. + +සත්‍යාපනය [${url}]බොත්තම එබීමට නොහැකි නම් මෙම සබැඳිය පිටපත් කර ඔබගේ +අතිරික්සුවෙහි අලවන්න: + +${url} + +ඔබට කිසියම් ප්‍රශ්නයක් ඇත්නම් කරුණාකර අප අමතන්න [${support}]. + + +-------------------------------------------------------------------------------- + +රහස්‍යතා ප්‍රතිපත්තිය සහ භාවිත නියම [${legal}] · අවභාවිතය වාර්තා කරන්න +[${misuse}] +${copyright}. සියළුම හිමිකම් ඇවිරිණි. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/si/user/email/update-subject.txt b/services/brig/deb/opt/brig/templates/si/user/email/update-subject.txt new file mode 100644 index 00000000000..9293ee6b3a0 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/si/user/email/update-subject.txt @@ -0,0 +1 @@ +${brand} සඳහා නව වි-තැපැල් ලිපිනය \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/si/user/email/update.html b/services/brig/deb/opt/brig/templates/si/user/email/update.html new file mode 100644 index 00000000000..a0ad8cff780 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/si/user/email/update.html @@ -0,0 +1 @@ +${brand} සඳහා නව වි-තැපැල් ලිපිනය

${brand_label_url}

වි-තැපෑල සත්‍යාපනය කරන්න

ඔබගේ නව ${brand} වි-තැපැල් ලිපිනය ලෙස ${email} ලියාපදිංචි කර ඇත. ඔබගේ ලිපිනය සත්‍යාපනයට පහත බොත්තම ඔබන්න.

 
සත්‍යාපනය
 

බොත්තම එබීමට නොහැකි නම් මෙම සබැඳිය පිටපත් කර ඔබගේ අතිරික්සුවෙහි අලවන්න:

${url}

ඔබට කිසියම් ප්‍රශ්නයක් ඇත්නම් කරුණාකර අප අමතන්න.

රහස්‍යතා ප්‍රතිපත්තිය සහ භාවිත නියම · අවභාවිතය වාර්තා කරන්න
${copyright}. සියළුම හිමිකම් ඇවිරිණි.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/si/user/email/update.txt b/services/brig/deb/opt/brig/templates/si/user/email/update.txt new file mode 100644 index 00000000000..326cfeb0d08 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/si/user/email/update.txt @@ -0,0 +1,21 @@ +[${brand_logo}] + +${brand_label_url} [${brand_url}] + +වි-තැපෑල සත්‍යාපනය කරන්න +ඔබගේ නව ${brand} වි-තැපැල් ලිපිනය ලෙස ${email} ලියාපදිංචි කර ඇත. ඔබගේ ලිපිනය +සත්‍යාපනයට පහත බොත්තම ඔබන්න. + +සත්‍යාපනය [${url}]බොත්තම එබීමට නොහැකි නම් මෙම සබැඳිය පිටපත් කර ඔබගේ +අතිරික්සුවෙහි අලවන්න: + +${url} + +ඔබට කිසියම් ප්‍රශ්නයක් ඇත්නම් කරුණාකර අප අමතන්න [${support}]. + + +-------------------------------------------------------------------------------- + +රහස්‍යතා ප්‍රතිපත්තිය සහ භාවිත නියම [${legal}] · අවභාවිතය වාර්තා කරන්න +[${misuse}] +${copyright}. සියළුම හිමිකම් ඇවිරිණි. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/si/user/email/verification-delete-team-subject.txt b/services/brig/deb/opt/brig/templates/si/user/email/verification-delete-team-subject.txt new file mode 100644 index 00000000000..d06bd22b906 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/si/user/email/verification-delete-team-subject.txt @@ -0,0 +1 @@ +ඔබගේ ${brand} සත්‍යාපන කේතය ${code} වේ \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/si/user/email/verification-delete-team.html b/services/brig/deb/opt/brig/templates/si/user/email/verification-delete-team.html new file mode 100644 index 00000000000..3c96f8daf21 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/si/user/email/verification-delete-team.html @@ -0,0 +1 @@ +ඔබගේ ${brand} සත්‍යාපන කේතය ${code} වේ

${brand_label_url}

කණ්ඩායම මැකීම සත්‍යාපනය

ඔබගේ ${brand} කණ්ඩායම මැකීමට ${email} භාවිතා කර ඇත. වි-තැපෑල සත්‍යාපනයට හා කණ්ඩායම මැකීමට මෙම කේතය ඇතුල් කරන්න.

 

${code}

 

ඔබට කිසියම් ප්‍රශ්නයක් ඇත්නම් කරුණාකර අප අමතන්න.

රහස්‍යතා ප්‍රතිපත්තිය සහ භාවිත නියම · අවභාවිතය වාර්තා කරන්න
${copyright}. සියළුම හිමිකම් ඇවිරිණි.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/si/user/email/verification-delete-team.txt b/services/brig/deb/opt/brig/templates/si/user/email/verification-delete-team.txt new file mode 100644 index 00000000000..3660c00571c --- /dev/null +++ b/services/brig/deb/opt/brig/templates/si/user/email/verification-delete-team.txt @@ -0,0 +1,18 @@ +[${brand_logo}] + +${brand_label_url} [${brand_url}] + +කණ්ඩායම මැකීම සත්‍යාපනය +ඔබගේ ${brand} කණ්ඩායම මැකීමට ${email} භාවිතා කර ඇත. වි-තැපෑල සත්‍යාපනයට හා +කණ්ඩායම මැකීමට මෙම කේතය ඇතුල් කරන්න. + +${code} + +ඔබට කිසියම් ප්‍රශ්නයක් ඇත්නම් කරුණාකර අප අමතන්න [${support}]. + + +-------------------------------------------------------------------------------- + +රහස්‍යතා ප්‍රතිපත්තිය සහ භාවිත නියම [${legal}] · අවභාවිතය වාර්තා කරන්න +[${misuse}] +${copyright}. සියළුම හිමිකම් ඇවිරිණි. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/si/user/email/verification-login-subject.txt b/services/brig/deb/opt/brig/templates/si/user/email/verification-login-subject.txt new file mode 100644 index 00000000000..d06bd22b906 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/si/user/email/verification-login-subject.txt @@ -0,0 +1 @@ +ඔබගේ ${brand} සත්‍යාපන කේතය ${code} වේ \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/si/user/email/verification-login.html b/services/brig/deb/opt/brig/templates/si/user/email/verification-login.html new file mode 100644 index 00000000000..e119b29c810 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/si/user/email/verification-login.html @@ -0,0 +1 @@ +ඔබගේ ${brand} සත්‍යාපන කේතය ${code} වේ

${brand_label_url}

පිවිසුම සත්‍යාපනය

ඔබගේ ${brand} ගිණුමට පිවිසීම සඳහා ${email} භාවිතා කර ඇත. ඔබගේ වි-තැපෑල සත්‍යාපනයට සහ පිවිසීමට මෙම කේතය ඇතුල් කරන්න.

 

${code}

 

ඔබට කිසියම් ප්‍රශ්නයක් ඇත්නම් කරුණාකර අප අමතන්න.

රහස්‍යතා ප්‍රතිපත්තිය සහ භාවිත නියම · අවභාවිතය වාර්තා කරන්න
${copyright}. සියළුම හිමිකම් ඇවිරිණි.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/si/user/email/verification-login.txt b/services/brig/deb/opt/brig/templates/si/user/email/verification-login.txt new file mode 100644 index 00000000000..dab9e9a5fe4 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/si/user/email/verification-login.txt @@ -0,0 +1,18 @@ +[${brand_logo}] + +${brand_label_url} [${brand_url}] + +පිවිසුම සත්‍යාපනය +ඔබගේ ${brand} ගිණුමට පිවිසීම සඳහා ${email} භාවිතා කර ඇත. ඔබගේ වි-තැපෑල +සත්‍යාපනයට සහ පිවිසීමට මෙම කේතය ඇතුල් කරන්න. + +${code} + +ඔබට කිසියම් ප්‍රශ්නයක් ඇත්නම් කරුණාකර අප අමතන්න [${support}]. + + +-------------------------------------------------------------------------------- + +රහස්‍යතා ප්‍රතිපත්තිය සහ භාවිත නියම [${legal}] · අවභාවිතය වාර්තා කරන්න +[${misuse}] +${copyright}. සියළුම හිමිකම් ඇවිරිණි. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/si/user/email/verification-scim-token-subject.txt b/services/brig/deb/opt/brig/templates/si/user/email/verification-scim-token-subject.txt new file mode 100644 index 00000000000..d06bd22b906 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/si/user/email/verification-scim-token-subject.txt @@ -0,0 +1 @@ +ඔබගේ ${brand} සත්‍යාපන කේතය ${code} වේ \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/si/user/email/verification-scim-token.html b/services/brig/deb/opt/brig/templates/si/user/email/verification-scim-token.html new file mode 100644 index 00000000000..fbb8d327a0f --- /dev/null +++ b/services/brig/deb/opt/brig/templates/si/user/email/verification-scim-token.html @@ -0,0 +1 @@ +ඔබගේ ${brand} සත්‍යාපන කේතය ${code} වේ

${brand_label_url}

SCIM නිමිත්ත සෑදීම සත්‍යාපනය

SCIM නිමිත්ත උත්පාදනයට ${email} භාවිතා කර ඇත. ඔබගේ වි-තැපැල් ලිපිනය සත්‍යාපනයට සහ නිමිත්ත සෑදීමට මෙම කේතය ඇතුල් කරන්න.

 

${code}

 

ඔබට කිසියම් ප්‍රශ්නයක් ඇත්නම් කරුණාකර අප අමතන්න.

රහස්‍යතා ප්‍රතිපත්තිය සහ භාවිත නියම · අවභාවිතය වාර්තා කරන්න
${copyright}. සියළුම හිමිකම් ඇවිරිණි.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/si/user/email/verification-scim-token.txt b/services/brig/deb/opt/brig/templates/si/user/email/verification-scim-token.txt new file mode 100644 index 00000000000..abb5f7c3b66 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/si/user/email/verification-scim-token.txt @@ -0,0 +1,18 @@ +[${brand_logo}] + +${brand_label_url} [${brand_url}] + +SCIM නිමිත්ත සෑදීම සත්‍යාපනය +SCIM නිමිත්ත උත්පාදනයට ${email} භාවිතා කර ඇත. ඔබගේ වි-තැපැල් ලිපිනය සත්‍යාපනයට +සහ නිමිත්ත සෑදීමට මෙම කේතය ඇතුල් කරන්න. + +${code} + +ඔබට කිසියම් ප්‍රශ්නයක් ඇත්නම් කරුණාකර අප අමතන්න [${support}]. + + +-------------------------------------------------------------------------------- + +රහස්‍යතා ප්‍රතිපත්තිය සහ භාවිත නියම [${legal}] · අවභාවිතය වාර්තා කරන්න +[${misuse}] +${copyright}. සියළුම හිමිකම් ඇවිරිණි. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/si/user/email/verification-subject.txt b/services/brig/deb/opt/brig/templates/si/user/email/verification-subject.txt new file mode 100644 index 00000000000..d06bd22b906 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/si/user/email/verification-subject.txt @@ -0,0 +1 @@ +ඔබගේ ${brand} සත්‍යාපන කේතය ${code} වේ \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/si/user/email/verification.html b/services/brig/deb/opt/brig/templates/si/user/email/verification.html new file mode 100644 index 00000000000..0ea0bec7a07 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/si/user/email/verification.html @@ -0,0 +1 @@ +ඔබගේ ${brand} සත්‍යාපන කේතය ${code} වේ

${brand_label_url}

ඔබගේ වි-තැපෑල සත්‍යාපනය කරන්න

${brand} හි ලියාපදිංචියට ${email} භාවිතා කර ඇත. ඔබගේ වි-තැපෑල සත්‍යාපනයට හා ගිණුම සෑදීමට මෙම කේතය ඇතුල් කරන්න.

 

${code}

 

ඔබට කිසියම් ප්‍රශ්නයක් ඇත්නම් කරුණාකර අප අමතන්න.

රහස්‍යතා ප්‍රතිපත්තිය සහ භාවිත නියම · අවභාවිතය වාර්තා කරන්න
${copyright}. සියළුම හිමිකම් ඇවිරිණි.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/si/user/email/verification.txt b/services/brig/deb/opt/brig/templates/si/user/email/verification.txt new file mode 100644 index 00000000000..6aad88b82ff --- /dev/null +++ b/services/brig/deb/opt/brig/templates/si/user/email/verification.txt @@ -0,0 +1,18 @@ +[${brand_logo}] + +${brand_label_url} [${brand_url}] + +ඔබගේ වි-තැපෑල සත්‍යාපනය කරන්න +${brand} හි ලියාපදිංචියට ${email} භාවිතා කර ඇත. ඔබගේ වි-තැපෑල සත්‍යාපනයට හා +ගිණුම සෑදීමට මෙම කේතය ඇතුල් කරන්න. + +${code} + +ඔබට කිසියම් ප්‍රශ්නයක් ඇත්නම් කරුණාකර අප අමතන්න [${support}]. + + +-------------------------------------------------------------------------------- + +රහස්‍යතා ප්‍රතිපත්තිය සහ භාවිත නියම [${legal}] · අවභාවිතය වාර්තා කරන්න +[${misuse}] +${copyright}. සියළුම හිමිකම් ඇවිරිණි. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/si/user/sms/activation.txt b/services/brig/deb/opt/brig/templates/si/user/sms/activation.txt new file mode 100644 index 00000000000..e029a030748 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/si/user/sms/activation.txt @@ -0,0 +1,3 @@ +ඔබගේ ${brand} කේතය ${code} වේ. + +ඔබගේ අංකය සත්‍යාපනයට ${url} අරින්න. diff --git a/services/brig/deb/opt/brig/templates/si/user/sms/deletion.txt b/services/brig/deb/opt/brig/templates/si/user/sms/deletion.txt new file mode 100644 index 00000000000..15b1622cad3 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/si/user/sms/deletion.txt @@ -0,0 +1,2 @@ +${brand} ගිණුම මැකීමට තට්ටු කරන්න. +${url} diff --git a/services/brig/deb/opt/brig/templates/si/user/sms/login.txt b/services/brig/deb/opt/brig/templates/si/user/sms/login.txt new file mode 100644 index 00000000000..5b0be13a59d --- /dev/null +++ b/services/brig/deb/opt/brig/templates/si/user/sms/login.txt @@ -0,0 +1,3 @@ +ඔබගේ ${brand} කේතය ${code} වේ. + +පිවිසීමට ${url} අරින්න. diff --git a/services/brig/deb/opt/brig/templates/si/user/sms/password-reset.txt b/services/brig/deb/opt/brig/templates/si/user/sms/password-reset.txt new file mode 100644 index 00000000000..d39d0227116 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/si/user/sms/password-reset.txt @@ -0,0 +1,3 @@ +ඔබගේ ${brand} ප්‍රතිසාධන කේතය ${code} වේ. + +මුරපදය යළි සැකසීම සඳහා මෙම කේතය භාවිතා කරන්න. diff --git a/services/brig/deb/opt/brig/templates/tr/user/call/activation.txt b/services/brig/deb/opt/brig/templates/tr/user/call/activation.txt index dfa77bd1174..d1208907366 100644 --- a/services/brig/deb/opt/brig/templates/tr/user/call/activation.txt +++ b/services/brig/deb/opt/brig/templates/tr/user/call/activation.txt @@ -1 +1 @@ -Selam, Wire doğrulama kodunuz: ${code}. Bir kez daha, kodunuz: ${code} \ No newline at end of file +Merhaba, Wire doğrulama kodunuz: ${code}. Bir kez daha, kodunuz: ${code} \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/tr/user/call/login.txt b/services/brig/deb/opt/brig/templates/tr/user/call/login.txt index c279d5cf311..0a7091f6d20 100644 --- a/services/brig/deb/opt/brig/templates/tr/user/call/login.txt +++ b/services/brig/deb/opt/brig/templates/tr/user/call/login.txt @@ -1 +1 @@ -Selam, Wire giriş kodunuz: ${code} Bir kez daha, kodunuz: ${code} +Merhaba, Wire giriş kodunuz: ${code}. Birkez daha, kodunuz şudur: ${code} \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/tr/user/email/activation-subject.txt b/services/brig/deb/opt/brig/templates/tr/user/email/activation-subject.txt new file mode 100644 index 00000000000..1b52783813f --- /dev/null +++ b/services/brig/deb/opt/brig/templates/tr/user/email/activation-subject.txt @@ -0,0 +1 @@ +${brand} Hesabınız \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/tr/user/email/activation.html b/services/brig/deb/opt/brig/templates/tr/user/email/activation.html new file mode 100644 index 00000000000..024f68bd64c --- /dev/null +++ b/services/brig/deb/opt/brig/templates/tr/user/email/activation.html @@ -0,0 +1 @@ +${brand} Hesabınız

${brand_label_url}

E-postanızı doğrulayın

${brand}} a kaydolmak için ${email} kullanıldı.
Adresinizi doğrulamak için düğmeyi tıklayın.

 
Doğrula
 

Düğmeyi tıklayamıyorsanız, bu bağlantıyı kopyalayıp tarayıcınıza yapıştırın:

${url}

Herhangi bir sorunuz veya yardıma ihtiyacınız varsa, lütfen bize ulaşın.

Privacy policy and terms of use · Report Misuse
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/tr/user/email/activation.txt b/services/brig/deb/opt/brig/templates/tr/user/email/activation.txt new file mode 100644 index 00000000000..17b7f8815c8 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/tr/user/email/activation.txt @@ -0,0 +1,21 @@ +[${brand_logo}] + +${brand_label_url} [${brand_url}] + +E-POSTANIZI DOĞRULAYIN +${brand}} a kaydolmak için ${email} kullanıldı. +Adresinizi doğrulamak için düğmeyi tıklayın. + +Doğrula [${url}]Düğmeyi tıklayamıyorsanız, bu bağlantıyı kopyalayıp tarayıcınıza +yapıştırın: + +${url} + +Herhangi bir sorunuz veya yardıma ihtiyacınız varsa, lütfen bize ulaşın +[${support}]. + + +-------------------------------------------------------------------------------- + +Privacy policy and terms of use [${legal}] · Report Misuse [${misuse}] +${copyright}. ALL RIGHTS RESERVED. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/tr/user/email/deletion-subject.txt b/services/brig/deb/opt/brig/templates/tr/user/email/deletion-subject.txt new file mode 100644 index 00000000000..eb6e4557b10 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/tr/user/email/deletion-subject.txt @@ -0,0 +1 @@ +Hesabı sil? \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/tr/user/email/deletion.html b/services/brig/deb/opt/brig/templates/tr/user/email/deletion.html new file mode 100644 index 00000000000..56e31fa36bd --- /dev/null +++ b/services/brig/deb/opt/brig/templates/tr/user/email/deletion.html @@ -0,0 +1 @@ +Hesabı sil?

${brand_label_url}

Hesabını Sil

${brand} hesabınızı silmek için bir istek aldık. Tüm konuşmalarınızı, içeriğinizi ve bağlantılarınızı silmek için 10 dakika içinde aşağıdaki düğmeyi tıklayın.

 
Hesabı Sil
 

Düğmeyi tıklayamıyorsanız, bu bağlantıyı kopyalayıp tarayıcınıza yapıştırın:

${url}

Bunu istemediyseniz, şifrenizi sıfırlayın.

Herhangi bir sorunuz veya yardıma ihtiyacınız varsa, lütfen bize ulaşın.

Privacy policy and terms of use · Report Misuse
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/tr/user/email/deletion.txt b/services/brig/deb/opt/brig/templates/tr/user/email/deletion.txt new file mode 100644 index 00000000000..4fa840086de --- /dev/null +++ b/services/brig/deb/opt/brig/templates/tr/user/email/deletion.txt @@ -0,0 +1,24 @@ +[${brand_logo}] + +${brand_label_url} [${brand_url}] + +HESABINI SIL +${brand} hesabınızı silmek için bir istek aldık. Tüm konuşmalarınızı, +içeriğinizi ve bağlantılarınızı silmek için 10 dakika içinde aşağıdaki düğmeyi +tıklayın. + +Hesabı Sil [${url}]Düğmeyi tıklayamıyorsanız, bu bağlantıyı kopyalayıp +tarayıcınıza yapıştırın: + +${url} + +Bunu istemediyseniz, şifrenizi sıfırlayın [${forgot}]. + +Herhangi bir sorunuz veya yardıma ihtiyacınız varsa, lütfen bize ulaşın +[${support}]. + + +-------------------------------------------------------------------------------- + +Privacy policy and terms of use [${legal}] · Report Misuse [${misuse}] +${copyright}. ALL RIGHTS RESERVED. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/tr/user/email/new-client-subject.txt b/services/brig/deb/opt/brig/templates/tr/user/email/new-client-subject.txt new file mode 100644 index 00000000000..7c56d398c91 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/tr/user/email/new-client-subject.txt @@ -0,0 +1 @@ +Yeni cihaz \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/tr/user/email/new-client.html b/services/brig/deb/opt/brig/templates/tr/user/email/new-client.html new file mode 100644 index 00000000000..0767e46de95 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/tr/user/email/new-client.html @@ -0,0 +1 @@ +Yeni cihaz

${brand_label_url}

Yeni cihaz

${brand} hesabınız şunun üzerinde kullanıldı:

${date}

${model}

${brand} cihazını yeni bir cihaza kurmuş veya tekrar mevcut bir cihaza kurmuş olabilirsiniz. Öyle değilse, ${brand} Ayarlar bölümüne gidin, cihazı kaldırın ve şifrenizi sıfırlayın.

Herhangi bir sorunuz veya yardıma ihtiyacınız varsa, lütfen bize ulaşın.

Privacy policy and terms of use · Report Misuse
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/tr/user/email/new-client.txt b/services/brig/deb/opt/brig/templates/tr/user/email/new-client.txt new file mode 100644 index 00000000000..893716b44c4 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/tr/user/email/new-client.txt @@ -0,0 +1,23 @@ +[${brand_logo}] + +${brand_label_url} [${brand_url}] + +YENI CIHAZ +${brand} hesabınız şunun üzerinde kullanıldı: + +${date} + +${model} + +${brand} cihazını yeni bir cihaza kurmuş veya tekrar mevcut bir cihaza kurmuş +olabilirsiniz. Öyle değilse, ${brand} Ayarlar bölümüne gidin, cihazı kaldırın ve +şifrenizi sıfırlayın [${forgot}]. + +Herhangi bir sorunuz veya yardıma ihtiyacınız varsa, lütfen bize ulaşın +[${support}]. + + +-------------------------------------------------------------------------------- + +Privacy policy and terms of use [${legal}] · Report Misuse [${misuse}] +${copyright}. ALL RIGHTS RESERVED. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/tr/user/email/password-reset-subject.txt b/services/brig/deb/opt/brig/templates/tr/user/email/password-reset-subject.txt new file mode 100644 index 00000000000..5559a82e123 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/tr/user/email/password-reset-subject.txt @@ -0,0 +1 @@ +${brand} 'da Şifre Değişikliği \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/tr/user/email/password-reset.html b/services/brig/deb/opt/brig/templates/tr/user/email/password-reset.html new file mode 100644 index 00000000000..bb1d0aa60a9 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/tr/user/email/password-reset.html @@ -0,0 +1 @@ +${brand} 'da Şifre Değişikliği

${brand_label_url}

Şifrenizi sıfırlayın

${brand} hesabınızın şifresini sıfırlama isteği aldık. Yeni bir şifre oluşturmak için aşağıdaki butona tıklayın.

 
Şifreni sıfırla
 

Düğmeyi tıklayamıyorsanız, bu bağlantıyı kopyalayıp tarayıcınıza yapıştırın:

${url}

Herhangi bir sorunuz veya yardıma ihtiyacınız varsa, lütfen bize ulaşın.

Privacy policy and terms of use · Report Misuse
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/tr/user/email/password-reset.txt b/services/brig/deb/opt/brig/templates/tr/user/email/password-reset.txt new file mode 100644 index 00000000000..7c9925c6ca7 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/tr/user/email/password-reset.txt @@ -0,0 +1,21 @@ +[${brand_logo}] + +${brand_label_url} [${brand_url}] + +ŞIFRENIZI SIFIRLAYIN +${brand} hesabınızın şifresini sıfırlama isteği aldık. Yeni bir şifre oluşturmak +için aşağıdaki butona tıklayın. + +Şifreni sıfırla [${url}]Düğmeyi tıklayamıyorsanız, bu bağlantıyı kopyalayıp +tarayıcınıza yapıştırın: + +${url} + +Herhangi bir sorunuz veya yardıma ihtiyacınız varsa, lütfen bize ulaşın +[${support}]. + + +-------------------------------------------------------------------------------- + +Privacy policy and terms of use [${legal}] · Report Misuse [${misuse}] +${copyright}. ALL RIGHTS RESERVED. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/tr/user/email/team-activation-subject.txt b/services/brig/deb/opt/brig/templates/tr/user/email/team-activation-subject.txt new file mode 100644 index 00000000000..c4323f2027d --- /dev/null +++ b/services/brig/deb/opt/brig/templates/tr/user/email/team-activation-subject.txt @@ -0,0 +1 @@ +${brand} Hesap \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/tr/user/email/team-activation.html b/services/brig/deb/opt/brig/templates/tr/user/email/team-activation.html new file mode 100644 index 00000000000..6e2a676f7e9 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/tr/user/email/team-activation.html @@ -0,0 +1 @@ +${brand} Hesap

${brand_label_url}

${brand}'da yeni hesabınız

${email} ile yeni bir ${brand} takımı oluşturuldu. Lütfen e-postanızı doğrulayın.

 
Doğrula
 

Düğmeyi tıklayamıyorsanız, bu bağlantıyı kopyalayıp tarayıcınıza yapıştırın:

${url}

Herhangi bir sorunuz veya yardıma ihtiyacınız varsa, lütfen bize ulaşın.

Privacy policy and terms of use · Report Misuse
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/tr/user/email/team-activation.txt b/services/brig/deb/opt/brig/templates/tr/user/email/team-activation.txt new file mode 100644 index 00000000000..8615ceb768e --- /dev/null +++ b/services/brig/deb/opt/brig/templates/tr/user/email/team-activation.txt @@ -0,0 +1,21 @@ +[${brand_logo}] + +${brand_label_url} [${brand_url}] + +${BRAND}'DA YENI HESABINIZ +${email} ile yeni bir ${brand} takımı oluşturuldu. Lütfen e-postanızı +doğrulayın. + +Doğrula [${url}]Düğmeyi tıklayamıyorsanız, bu bağlantıyı kopyalayıp tarayıcınıza +yapıştırın: + +${url} + +Herhangi bir sorunuz veya yardıma ihtiyacınız varsa, lütfen bize ulaşın +[${support}]. + + +-------------------------------------------------------------------------------- + +Privacy policy and terms of use [${legal}] · Report Misuse [${misuse}] +${copyright}. ALL RIGHTS RESERVED. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/tr/user/email/update-subject.txt b/services/brig/deb/opt/brig/templates/tr/user/email/update-subject.txt new file mode 100644 index 00000000000..33b5153931f --- /dev/null +++ b/services/brig/deb/opt/brig/templates/tr/user/email/update-subject.txt @@ -0,0 +1 @@ +${brand} üzerindeki yeni e-posta adresiniz \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/tr/user/email/update.html b/services/brig/deb/opt/brig/templates/tr/user/email/update.html new file mode 100644 index 00000000000..5b14f678898 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/tr/user/email/update.html @@ -0,0 +1 @@ +${brand} üzerindeki yeni e-posta adresiniz

${brand_label_url}

E-postanızı doğrulayın

${email}, ${brand}'daki yeni e-posta adresiniz olarak kaydedildi. Adresinizi doğrulamak için aşağıdaki düğmeye tıklayın.

 
Doğrula
 

Düğmeyi tıklayamıyorsanız, bu bağlantıyı kopyalayıp tarayıcınıza yapıştırın:

${url}

Herhangi bir sorunuz veya yardıma ihtiyacınız varsa, lütfen bize ulaşın.

Privacy policy and terms of use · Report Misuse
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/tr/user/email/update.txt b/services/brig/deb/opt/brig/templates/tr/user/email/update.txt new file mode 100644 index 00000000000..e8346877e6d --- /dev/null +++ b/services/brig/deb/opt/brig/templates/tr/user/email/update.txt @@ -0,0 +1,21 @@ +[${brand_logo}] + +${brand_label_url} [${brand_url}] + +E-POSTANIZI DOĞRULAYIN +${email}, ${brand}'daki yeni e-posta adresiniz olarak kaydedildi. Adresinizi +doğrulamak için aşağıdaki düğmeye tıklayın. + +Doğrula [${url}]Düğmeyi tıklayamıyorsanız, bu bağlantıyı kopyalayıp tarayıcınıza +yapıştırın: + +${url} + +Herhangi bir sorunuz veya yardıma ihtiyacınız varsa, lütfen bize ulaşın +[${support}]. + + +-------------------------------------------------------------------------------- + +Privacy policy and terms of use [${legal}] · Report Misuse [${misuse}] +${copyright}. ALL RIGHTS RESERVED. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/tr/user/email/verification-delete-team-subject.txt b/services/brig/deb/opt/brig/templates/tr/user/email/verification-delete-team-subject.txt new file mode 100644 index 00000000000..9a9c2a3d923 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/tr/user/email/verification-delete-team-subject.txt @@ -0,0 +1 @@ +${brand} doğrulama kodu ${code} \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/tr/user/email/verification-delete-team.html b/services/brig/deb/opt/brig/templates/tr/user/email/verification-delete-team.html new file mode 100644 index 00000000000..fc209c5eaeb --- /dev/null +++ b/services/brig/deb/opt/brig/templates/tr/user/email/verification-delete-team.html @@ -0,0 +1 @@ +${brand} doğrulama kodu ${code}

${brand_label_url}

Verify team deletion

${email} was used to delete your ${brand} team. Enter this code to verify your email and delete the team.

 

${code}

 

Herhangi bir sorunuz veya yardıma ihtiyacınız varsa, lütfen bize ulaşın.

Privacy policy and terms of use · Report Misuse
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/tr/user/email/verification-delete-team.txt b/services/brig/deb/opt/brig/templates/tr/user/email/verification-delete-team.txt new file mode 100644 index 00000000000..0f035370be9 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/tr/user/email/verification-delete-team.txt @@ -0,0 +1,18 @@ +[${brand_logo}] + +${brand_label_url} [${brand_url}] + +VERIFY TEAM DELETION +${email} was used to delete your ${brand} team. Enter this code to verify your +email and delete the team. + +${code} + +Herhangi bir sorunuz veya yardıma ihtiyacınız varsa, lütfen bize ulaşın +[${support}]. + + +-------------------------------------------------------------------------------- + +Privacy policy and terms of use [${legal}] · Report Misuse [${misuse}] +${copyright}. ALL RIGHTS RESERVED. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/tr/user/email/verification-login-subject.txt b/services/brig/deb/opt/brig/templates/tr/user/email/verification-login-subject.txt new file mode 100644 index 00000000000..9a9c2a3d923 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/tr/user/email/verification-login-subject.txt @@ -0,0 +1 @@ +${brand} doğrulama kodu ${code} \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/tr/user/email/verification-login.html b/services/brig/deb/opt/brig/templates/tr/user/email/verification-login.html new file mode 100644 index 00000000000..6a5f4cbc63d --- /dev/null +++ b/services/brig/deb/opt/brig/templates/tr/user/email/verification-login.html @@ -0,0 +1 @@ +${brand} doğrulama kodu ${code}

${brand_label_url}

Verify login

${email} was used to log in to your ${brand} account. Enter this code to verify your email and log in.

 

${code}

 

Herhangi bir sorunuz veya yardıma ihtiyacınız varsa, lütfen bize ulaşın.

Privacy policy and terms of use · Report Misuse
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/tr/user/email/verification-login.txt b/services/brig/deb/opt/brig/templates/tr/user/email/verification-login.txt new file mode 100644 index 00000000000..67bec69e125 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/tr/user/email/verification-login.txt @@ -0,0 +1,18 @@ +[${brand_logo}] + +${brand_label_url} [${brand_url}] + +VERIFY LOGIN +${email} was used to log in to your ${brand} account. Enter this code to verify +your email and log in. + +${code} + +Herhangi bir sorunuz veya yardıma ihtiyacınız varsa, lütfen bize ulaşın +[${support}]. + + +-------------------------------------------------------------------------------- + +Privacy policy and terms of use [${legal}] · Report Misuse [${misuse}] +${copyright}. ALL RIGHTS RESERVED. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/tr/user/email/verification-scim-token-subject.txt b/services/brig/deb/opt/brig/templates/tr/user/email/verification-scim-token-subject.txt new file mode 100644 index 00000000000..9a9c2a3d923 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/tr/user/email/verification-scim-token-subject.txt @@ -0,0 +1 @@ +${brand} doğrulama kodu ${code} \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/tr/user/email/verification-scim-token.html b/services/brig/deb/opt/brig/templates/tr/user/email/verification-scim-token.html new file mode 100644 index 00000000000..90c7885b171 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/tr/user/email/verification-scim-token.html @@ -0,0 +1 @@ +${brand} doğrulama kodu ${code}

${brand_label_url}

Verify SCIM token creation

${email} was used to generate a SCIM token. Enter this code to verify your email and create the token.

 

${code}

 

Herhangi bir sorunuz veya yardıma ihtiyacınız varsa, lütfen bize ulaşın.

Privacy policy and terms of use · Report Misuse
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/tr/user/email/verification-scim-token.txt b/services/brig/deb/opt/brig/templates/tr/user/email/verification-scim-token.txt new file mode 100644 index 00000000000..c5ed077177f --- /dev/null +++ b/services/brig/deb/opt/brig/templates/tr/user/email/verification-scim-token.txt @@ -0,0 +1,18 @@ +[${brand_logo}] + +${brand_label_url} [${brand_url}] + +VERIFY SCIM TOKEN CREATION +${email} was used to generate a SCIM token. Enter this code to verify your email +and create the token. + +${code} + +Herhangi bir sorunuz veya yardıma ihtiyacınız varsa, lütfen bize ulaşın +[${support}]. + + +-------------------------------------------------------------------------------- + +Privacy policy and terms of use [${legal}] · Report Misuse [${misuse}] +${copyright}. ALL RIGHTS RESERVED. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/tr/user/email/verification-subject.txt b/services/brig/deb/opt/brig/templates/tr/user/email/verification-subject.txt new file mode 100644 index 00000000000..5cb510f23f5 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/tr/user/email/verification-subject.txt @@ -0,0 +1 @@ +${code} is your ${brand} verification code \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/tr/user/email/verification.html b/services/brig/deb/opt/brig/templates/tr/user/email/verification.html new file mode 100644 index 00000000000..f8d2b9f963a --- /dev/null +++ b/services/brig/deb/opt/brig/templates/tr/user/email/verification.html @@ -0,0 +1 @@ +${code} is your ${brand} verification code

${brand_label_url}

E-postanızı doğrulayın

${brand} 'a kaydolmak için ${email} kullanıldı. E-postanızı doğrulayıp hesap oluşturmak için kodu girin.

 

${code}

 

Herhangi bir sorunuz veya yardıma ihtiyacınız varsa, lütfen bize ulaşın.

Privacy policy and terms of use · Report Misuse
${copyright}. ALL RIGHTS RESERVED.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/tr/user/email/verification.txt b/services/brig/deb/opt/brig/templates/tr/user/email/verification.txt new file mode 100644 index 00000000000..0c04a0ab6ce --- /dev/null +++ b/services/brig/deb/opt/brig/templates/tr/user/email/verification.txt @@ -0,0 +1,18 @@ +[${brand_logo}] + +${brand_label_url} [${brand_url}] + +E-POSTANIZI DOĞRULAYIN +${brand} 'a kaydolmak için ${email} kullanıldı. E-postanızı doğrulayıp hesap +oluşturmak için kodu girin. + +${code} + +Herhangi bir sorunuz veya yardıma ihtiyacınız varsa, lütfen bize ulaşın +[${support}]. + + +-------------------------------------------------------------------------------- + +Privacy policy and terms of use [${legal}] · Report Misuse [${misuse}] +${copyright}. ALL RIGHTS RESERVED. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/tr/user/sms/activation.txt b/services/brig/deb/opt/brig/templates/tr/user/sms/activation.txt index 85848c0dc29..0f297cd946d 100644 --- a/services/brig/deb/opt/brig/templates/tr/user/sms/activation.txt +++ b/services/brig/deb/opt/brig/templates/tr/user/sms/activation.txt @@ -1,3 +1,3 @@ -Wire kodunuz ${code}. +${brand} kodunuz ${code}. -${url} adresine açarak numaranızı doğrulayabilir ya da alttaki kodu Wire'a elle girerek doğrulayabilirsiniz. +Numaranızı doğrulamak için: ${url}. diff --git a/services/brig/deb/opt/brig/templates/tr/user/sms/deletion.txt b/services/brig/deb/opt/brig/templates/tr/user/sms/deletion.txt index b73080d74e9..41a4be3755a 100644 --- a/services/brig/deb/opt/brig/templates/tr/user/sms/deletion.txt +++ b/services/brig/deb/opt/brig/templates/tr/user/sms/deletion.txt @@ -1,2 +1,2 @@ -Wire hesabınızı silmek için tıklayın. -${url} +${brand} hesabınızı silmek için tıklayın. +${url} diff --git a/services/brig/deb/opt/brig/templates/tr/user/sms/login.txt b/services/brig/deb/opt/brig/templates/tr/user/sms/login.txt index f078a5785a2..7cd50436ad3 100644 --- a/services/brig/deb/opt/brig/templates/tr/user/sms/login.txt +++ b/services/brig/deb/opt/brig/templates/tr/user/sms/login.txt @@ -1,3 +1,3 @@ -Wire giriş kodunuz ${code}. +${brand}} giriş kodunuz ${code}. -Giriş yapmak için ${url} adresine gidebilir ya da bu kodu Wire uygulamasına girebilirsiniz: ${code}. +Giriş yapmak için: ${url}. diff --git a/services/brig/deb/opt/brig/templates/tr/user/sms/password-reset.txt b/services/brig/deb/opt/brig/templates/tr/user/sms/password-reset.txt index 53861b2cad9..2b4f0933ef2 100644 --- a/services/brig/deb/opt/brig/templates/tr/user/sms/password-reset.txt +++ b/services/brig/deb/opt/brig/templates/tr/user/sms/password-reset.txt @@ -1,3 +1,3 @@ -Wire kurtarma kodunuz ${code}. +${brand} kurtarma kodunuz ${code}. -Wire uygulamasını açın ve bu kodu şifre sıfırlama işlemini tamamlamak için kullanın. \ No newline at end of file +Şifre sıfırlama işlemini tamamlamak için bu kodu kullanın. diff --git a/services/brig/deb/opt/brig/templates/version b/services/brig/deb/opt/brig/templates/version index 4af04f0f334..fea60e70c1a 100644 --- a/services/brig/deb/opt/brig/templates/version +++ b/services/brig/deb/opt/brig/templates/version @@ -1 +1 @@ -v1.0.102 +v1.0.121 diff --git a/services/brig/deb/opt/brig/templates/vi/user/call/activation.txt b/services/brig/deb/opt/brig/templates/vi/user/call/activation.txt new file mode 100644 index 00000000000..bc29d9b108e --- /dev/null +++ b/services/brig/deb/opt/brig/templates/vi/user/call/activation.txt @@ -0,0 +1 @@ +Xin chào, mã xác thực Wire của bạn là: ${code}. Một lần nữa, mã của bạn là: ${code} \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/vi/user/call/login.txt b/services/brig/deb/opt/brig/templates/vi/user/call/login.txt new file mode 100644 index 00000000000..d1e101d5e58 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/vi/user/call/login.txt @@ -0,0 +1 @@ +Xin chào, mã đăng nhập Wire của bạn là: ${code}. Một lần nữa, mã của bạn là: ${code} \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/vi/user/email/activation-subject.txt b/services/brig/deb/opt/brig/templates/vi/user/email/activation-subject.txt new file mode 100644 index 00000000000..dfdc7bcec75 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/vi/user/email/activation-subject.txt @@ -0,0 +1 @@ +Tài khoản ${brand} của bạn \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/vi/user/email/activation.html b/services/brig/deb/opt/brig/templates/vi/user/email/activation.html new file mode 100644 index 00000000000..3b47400c118 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/vi/user/email/activation.html @@ -0,0 +1 @@ +Tài khoản ${brand} của bạn

${brand_label_url}

Xác minh địa chỉ emal của bạn

${email} đã được dùng để đăng ký ${brand}.
Nhấp vào nút để xác minh địa chỉ của bạn.

 
Xác minh
 

Nếu bạn không thể nhấp vào nút, sao chép và gán đường dẫn này vào trình duyệt của bạn:

${url}

Nếu bạn có bất kỳ thắc mắc nào, xin vui lòng liên hệ với chúng tôi.

Chính sách riêng tư và điều khoản sử dụng · Báo cáo Lạm dụng
${copyright}. ĐÃ ĐƯỢC ĐĂNG KÝ BẢN QUYỀN.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/vi/user/email/activation.txt b/services/brig/deb/opt/brig/templates/vi/user/email/activation.txt new file mode 100644 index 00000000000..9fd76c0cace --- /dev/null +++ b/services/brig/deb/opt/brig/templates/vi/user/email/activation.txt @@ -0,0 +1,21 @@ +[${brand_logo}] + +${brand_label_url} [${brand_url}] + +XÁC MINH ĐỊA CHỈ EMAL CỦA BẠN +${email} đã được dùng để đăng ký ${brand}. +Nhấp vào nút để xác minh địa chỉ của bạn. + +Xác minh [${url}]Nếu bạn không thể nhấp vào nút, sao chép và gán đường dẫn này +vào trình duyệt của bạn: + +${url} + +Nếu bạn có bất kỳ thắc mắc nào, xin vui lòng liên hệ với chúng tôi [${support}]. + + +-------------------------------------------------------------------------------- + +Chính sách riêng tư và điều khoản sử dụng [${legal}] · Báo cáo Lạm dụng +[${misuse}] +${copyright}. ĐÃ ĐƯỢC ĐĂNG KÝ BẢN QUYỀN. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/vi/user/email/deletion-subject.txt b/services/brig/deb/opt/brig/templates/vi/user/email/deletion-subject.txt new file mode 100644 index 00000000000..1969ad4a62c --- /dev/null +++ b/services/brig/deb/opt/brig/templates/vi/user/email/deletion-subject.txt @@ -0,0 +1 @@ +Xoá tài khoản? \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/vi/user/email/deletion.html b/services/brig/deb/opt/brig/templates/vi/user/email/deletion.html new file mode 100644 index 00000000000..274ee2d08b4 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/vi/user/email/deletion.html @@ -0,0 +1 @@ +Xoá tài khoản?

${brand_label_url}

Xoá tài khoản của bạn

Chúng tôi nhận được một yêu cầu xoá tài khoản ${brand} của bạn. Nhấp vào nút phía bên dưới trong vòng 10 phút để xoá toàn bộ cuộc hội thoại, nội dung và mọi kết nối của bạn.

 
Xoá tài khoản
 

Nếu bạn không thể nhấp vào nút, sao chép và gán đường dẫn này vào trình duyệt của bạn:

${url}

Nếu bạn không thực hiện yêu cầu này, thay đổi mật khẩu của bạn ngay.

Nếu bạn có bất kỳ thắc mắc nào, xin vui lòng liên hệ với chúng tôi.

Chính sách riêng tư và điều khoản sử dụng · Báo cáo Lạm dụng
${copyright}. ĐÃ ĐƯỢC ĐĂNG KÝ BẢN QUYỀN.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/vi/user/email/deletion.txt b/services/brig/deb/opt/brig/templates/vi/user/email/deletion.txt new file mode 100644 index 00000000000..3dfd5366e04 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/vi/user/email/deletion.txt @@ -0,0 +1,24 @@ +[${brand_logo}] + +${brand_label_url} [${brand_url}] + +XOÁ TÀI KHOẢN CỦA BẠN +Chúng tôi nhận được một yêu cầu xoá tài khoản ${brand} của bạn. Nhấp vào nút +phía bên dưới trong vòng 10 phút để xoá toàn bộ cuộc hội thoại, nội dung và mọi +kết nối của bạn. + +Xoá tài khoản [${url}]Nếu bạn không thể nhấp vào nút, sao chép và gán đường dẫn +này vào trình duyệt của bạn: + +${url} + +Nếu bạn không thực hiện yêu cầu này, thay đổi mật khẩu của bạn ngay [${forgot}]. + +Nếu bạn có bất kỳ thắc mắc nào, xin vui lòng liên hệ với chúng tôi [${support}]. + + +-------------------------------------------------------------------------------- + +Chính sách riêng tư và điều khoản sử dụng [${legal}] · Báo cáo Lạm dụng +[${misuse}] +${copyright}. ĐÃ ĐƯỢC ĐĂNG KÝ BẢN QUYỀN. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/vi/user/email/new-client-subject.txt b/services/brig/deb/opt/brig/templates/vi/user/email/new-client-subject.txt new file mode 100644 index 00000000000..96c0793c38b --- /dev/null +++ b/services/brig/deb/opt/brig/templates/vi/user/email/new-client-subject.txt @@ -0,0 +1 @@ +Thiết bị mới \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/vi/user/email/new-client.html b/services/brig/deb/opt/brig/templates/vi/user/email/new-client.html new file mode 100644 index 00000000000..bf10025c64c --- /dev/null +++ b/services/brig/deb/opt/brig/templates/vi/user/email/new-client.html @@ -0,0 +1 @@ +Thiết bị mới

${brand_label_url}

Thiết bị mới

Tài khoản ${brand} của bạn đã được sử dụng vào:

${date}

${model}

Bạn có thể cài đặt ${brand} trên một thiết bị mới hoặc cài đặt lại trên một thiết bị đã tồn tại. Nếu không phải các trường hợp đó, đi đến Cài đặt ${brand}, gỡ bỏ thiết bị và thay đổi mật khẩu của bạn.

Nếu bạn có bất kỳ thắc mắc nào, xin vui lòng liên hệ với chúng tôi.

Chính sách riêng tư và điều khoản sử dụng · Báo cáo Lạm dụng
${copyright}. ĐÃ ĐƯỢC ĐĂNG KÝ BẢN QUYỀN.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/vi/user/email/new-client.txt b/services/brig/deb/opt/brig/templates/vi/user/email/new-client.txt new file mode 100644 index 00000000000..14b08a02a49 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/vi/user/email/new-client.txt @@ -0,0 +1,23 @@ +[${brand_logo}] + +${brand_label_url} [${brand_url}] + +THIẾT BỊ MỚI +Tài khoản ${brand} của bạn đã được sử dụng vào: + +${date} + +${model} + +Bạn có thể cài đặt ${brand} trên một thiết bị mới hoặc cài đặt lại trên một +thiết bị đã tồn tại. Nếu không phải các trường hợp đó, đi đến Cài đặt ${brand}, +gỡ bỏ thiết bị và thay đổi mật khẩu của bạn [${forgot}]. + +Nếu bạn có bất kỳ thắc mắc nào, xin vui lòng liên hệ với chúng tôi [${support}]. + + +-------------------------------------------------------------------------------- + +Chính sách riêng tư và điều khoản sử dụng [${legal}] · Báo cáo Lạm dụng +[${misuse}] +${copyright}. ĐÃ ĐƯỢC ĐĂNG KÝ BẢN QUYỀN. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/vi/user/email/password-reset-subject.txt b/services/brig/deb/opt/brig/templates/vi/user/email/password-reset-subject.txt new file mode 100644 index 00000000000..dde2762d74b --- /dev/null +++ b/services/brig/deb/opt/brig/templates/vi/user/email/password-reset-subject.txt @@ -0,0 +1 @@ +Thay đổi mật khẩu ${brand} \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/vi/user/email/password-reset.html b/services/brig/deb/opt/brig/templates/vi/user/email/password-reset.html new file mode 100644 index 00000000000..3aad8d78af1 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/vi/user/email/password-reset.html @@ -0,0 +1 @@ +Thay đổi mật khẩu ${brand}

${brand_label_url}

Đặt lại mật khẩu của bạn

Chúng tôi nhận được một yêu cầu đặt lại mật khẩu cho tài khoản ${brand} của bạn. Để tạo một tài khoản mới, nhấp vào nút phía bên dưới.

 
Đặt lại mật khẩu
 

Nếu bạn không thể nhấp vào nút, sao chép và gán đường dẫn này vào trình duyệt của bạn:

${url}

Nếu bạn có bất kỳ thắc mắc nào, xin vui lòng liên hệ với chúng tôi.

Chính sách riêng tư và điều khoản sử dụng · Báo cáo Lạm dụng
${copyright}. ĐÃ ĐƯỢC ĐĂNG KÝ BẢN QUYỀN.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/vi/user/email/password-reset.txt b/services/brig/deb/opt/brig/templates/vi/user/email/password-reset.txt new file mode 100644 index 00000000000..19be97f5f4e --- /dev/null +++ b/services/brig/deb/opt/brig/templates/vi/user/email/password-reset.txt @@ -0,0 +1,21 @@ +[${brand_logo}] + +${brand_label_url} [${brand_url}] + +ĐẶT LẠI MẬT KHẨU CỦA BẠN +Chúng tôi nhận được một yêu cầu đặt lại mật khẩu cho tài khoản ${brand} của bạn. +Để tạo một tài khoản mới, nhấp vào nút phía bên dưới. + +Đặt lại mật khẩu [${url}]Nếu bạn không thể nhấp vào nút, sao chép và gán đường +dẫn này vào trình duyệt của bạn: + +${url} + +Nếu bạn có bất kỳ thắc mắc nào, xin vui lòng liên hệ với chúng tôi [${support}]. + + +-------------------------------------------------------------------------------- + +Chính sách riêng tư và điều khoản sử dụng [${legal}] · Báo cáo Lạm dụng +[${misuse}] +${copyright}. ĐÃ ĐƯỢC ĐĂNG KÝ BẢN QUYỀN. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/vi/user/email/team-activation-subject.txt b/services/brig/deb/opt/brig/templates/vi/user/email/team-activation-subject.txt new file mode 100644 index 00000000000..8dc750aa201 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/vi/user/email/team-activation-subject.txt @@ -0,0 +1 @@ +Tài khoản ${brand} \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/vi/user/email/team-activation.html b/services/brig/deb/opt/brig/templates/vi/user/email/team-activation.html new file mode 100644 index 00000000000..48edcff50b3 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/vi/user/email/team-activation.html @@ -0,0 +1 @@ +Tài khoản ${brand}

${brand_label_url}

Tài khoản mới của bạn trên ${brand}

Một nhóm ${brand} đã được tại với ${email}. Vui lòng xác minh địa chỉ email của bạn.

 
Xác minh
 

Nếu bạn không thể nhấp vào nút, sao chép và gán đường dẫn này vào trình duyệt của bạn:

${url}

Nếu bạn có bất kỳ thắc mắc nào, xin vui lòng liên hệ với chúng tôi.

Chính sách riêng tư và điều khoản sử dụng · Báo cáo Lạm dụng
${copyright}. ĐÃ ĐƯỢC ĐĂNG KÝ BẢN QUYỀN.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/vi/user/email/team-activation.txt b/services/brig/deb/opt/brig/templates/vi/user/email/team-activation.txt new file mode 100644 index 00000000000..021963e3ac9 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/vi/user/email/team-activation.txt @@ -0,0 +1,21 @@ +[${brand_logo}] + +${brand_label_url} [${brand_url}] + +TÀI KHOẢN MỚI CỦA BẠN TRÊN ${BRAND} +Một nhóm ${brand} đã được tại với ${email}. Vui lòng xác minh địa chỉ email của +bạn. + +Xác minh [${url}]Nếu bạn không thể nhấp vào nút, sao chép và gán đường dẫn này +vào trình duyệt của bạn: + +${url} + +Nếu bạn có bất kỳ thắc mắc nào, xin vui lòng liên hệ với chúng tôi [${support}]. + + +-------------------------------------------------------------------------------- + +Chính sách riêng tư và điều khoản sử dụng [${legal}] · Báo cáo Lạm dụng +[${misuse}] +${copyright}. ĐÃ ĐƯỢC ĐĂNG KÝ BẢN QUYỀN. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/vi/user/email/update-subject.txt b/services/brig/deb/opt/brig/templates/vi/user/email/update-subject.txt new file mode 100644 index 00000000000..e78a90293d5 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/vi/user/email/update-subject.txt @@ -0,0 +1 @@ +Địa chỉ eamil mới trên ${brand} \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/vi/user/email/update.html b/services/brig/deb/opt/brig/templates/vi/user/email/update.html new file mode 100644 index 00000000000..d227a8e59d7 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/vi/user/email/update.html @@ -0,0 +1 @@ +Địa chỉ eamil mới trên ${brand}

${brand_label_url}

Xác minh địa chỉ emal của bạn

${email} đã được đăng ký như là địa chỉ email mới của bạn trên ${brand}. Nhấp vào nút phía bên dưới để xác minh địa chỉ email của bạn.

 
Xác minh
 

Nếu bạn không thể nhấp vào nút, sao chép và gán đường dẫn này vào trình duyệt của bạn:

${url}

Nếu bạn có bất kỳ thắc mắc nào, xin vui lòng liên hệ với chúng tôi.

Chính sách riêng tư và điều khoản sử dụng · Báo cáo Lạm dụng
${copyright}. ĐÃ ĐƯỢC ĐĂNG KÝ BẢN QUYỀN.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/vi/user/email/update.txt b/services/brig/deb/opt/brig/templates/vi/user/email/update.txt new file mode 100644 index 00000000000..721f2a11b0f --- /dev/null +++ b/services/brig/deb/opt/brig/templates/vi/user/email/update.txt @@ -0,0 +1,21 @@ +[${brand_logo}] + +${brand_label_url} [${brand_url}] + +XÁC MINH ĐỊA CHỈ EMAL CỦA BẠN +${email} đã được đăng ký như là địa chỉ email mới của bạn trên ${brand}. Nhấp +vào nút phía bên dưới để xác minh địa chỉ email của bạn. + +Xác minh [${url}]Nếu bạn không thể nhấp vào nút, sao chép và gán đường dẫn này +vào trình duyệt của bạn: + +${url} + +Nếu bạn có bất kỳ thắc mắc nào, xin vui lòng liên hệ với chúng tôi [${support}]. + + +-------------------------------------------------------------------------------- + +Chính sách riêng tư và điều khoản sử dụng [${legal}] · Báo cáo Lạm dụng +[${misuse}] +${copyright}. ĐÃ ĐƯỢC ĐĂNG KÝ BẢN QUYỀN. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/vi/user/email/verification-delete-team-subject.txt b/services/brig/deb/opt/brig/templates/vi/user/email/verification-delete-team-subject.txt new file mode 100644 index 00000000000..27223da6a8c --- /dev/null +++ b/services/brig/deb/opt/brig/templates/vi/user/email/verification-delete-team-subject.txt @@ -0,0 +1 @@ +Mã xác minh ${brand} của bạn là ${code} \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/vi/user/email/verification-delete-team.html b/services/brig/deb/opt/brig/templates/vi/user/email/verification-delete-team.html new file mode 100644 index 00000000000..c9e3dc52d87 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/vi/user/email/verification-delete-team.html @@ -0,0 +1 @@ +Mã xác minh ${brand} của bạn là ${code}

${brand_label_url}

Xác minh việc xóa nhóm

${email} đã được sử dụng để xóa nhóm ${brand} của bạn. Nhập đoạn mã này để xác nhận email của bạn và xóa nhóm.

 

${code}

 

Nếu bạn có bất kỳ thắc mắc nào, xin vui lòng liên hệ với chúng tôi.

Chính sách riêng tư và điều khoản sử dụng · Báo cáo Lạm dụng
${copyright}. ĐÃ ĐƯỢC ĐĂNG KÝ BẢN QUYỀN.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/vi/user/email/verification-delete-team.txt b/services/brig/deb/opt/brig/templates/vi/user/email/verification-delete-team.txt new file mode 100644 index 00000000000..1e238a77a06 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/vi/user/email/verification-delete-team.txt @@ -0,0 +1,18 @@ +[${brand_logo}] + +${brand_label_url} [${brand_url}] + +XÁC MINH VIỆC XÓA NHÓM +${email} đã được sử dụng để xóa nhóm ${brand} của bạn. Nhập đoạn mã này để xác +nhận email của bạn và xóa nhóm. + +${code} + +Nếu bạn có bất kỳ thắc mắc nào, xin vui lòng liên hệ với chúng tôi [${support}]. + + +-------------------------------------------------------------------------------- + +Chính sách riêng tư và điều khoản sử dụng [${legal}] · Báo cáo Lạm dụng +[${misuse}] +${copyright}. ĐÃ ĐƯỢC ĐĂNG KÝ BẢN QUYỀN. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/vi/user/email/verification-login-subject.txt b/services/brig/deb/opt/brig/templates/vi/user/email/verification-login-subject.txt new file mode 100644 index 00000000000..27223da6a8c --- /dev/null +++ b/services/brig/deb/opt/brig/templates/vi/user/email/verification-login-subject.txt @@ -0,0 +1 @@ +Mã xác minh ${brand} của bạn là ${code} \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/vi/user/email/verification-login.html b/services/brig/deb/opt/brig/templates/vi/user/email/verification-login.html new file mode 100644 index 00000000000..61ef970b3d4 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/vi/user/email/verification-login.html @@ -0,0 +1 @@ +Mã xác minh ${brand} của bạn là ${code}

${brand_label_url}

Xác minh đăng nhập

${email} đã được sử dụng để đưng nhập vào tài khoản ${brand} của bạn. Nhập đoạn mã này để xác thực email của bạn và đăng nhập.

 

${code}

 

Nếu bạn có bất kỳ thắc mắc nào, xin vui lòng liên hệ với chúng tôi.

Chính sách riêng tư và điều khoản sử dụng · Báo cáo Lạm dụng
${copyright}. ĐÃ ĐƯỢC ĐĂNG KÝ BẢN QUYỀN.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/vi/user/email/verification-login.txt b/services/brig/deb/opt/brig/templates/vi/user/email/verification-login.txt new file mode 100644 index 00000000000..7cd8b52fa89 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/vi/user/email/verification-login.txt @@ -0,0 +1,18 @@ +[${brand_logo}] + +${brand_label_url} [${brand_url}] + +XÁC MINH ĐĂNG NHẬP +${email} đã được sử dụng để đưng nhập vào tài khoản ${brand} của bạn. Nhập đoạn +mã này để xác thực email của bạn và đăng nhập. + +${code} + +Nếu bạn có bất kỳ thắc mắc nào, xin vui lòng liên hệ với chúng tôi [${support}]. + + +-------------------------------------------------------------------------------- + +Chính sách riêng tư và điều khoản sử dụng [${legal}] · Báo cáo Lạm dụng +[${misuse}] +${copyright}. ĐÃ ĐƯỢC ĐĂNG KÝ BẢN QUYỀN. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/vi/user/email/verification-scim-token-subject.txt b/services/brig/deb/opt/brig/templates/vi/user/email/verification-scim-token-subject.txt new file mode 100644 index 00000000000..27223da6a8c --- /dev/null +++ b/services/brig/deb/opt/brig/templates/vi/user/email/verification-scim-token-subject.txt @@ -0,0 +1 @@ +Mã xác minh ${brand} của bạn là ${code} \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/vi/user/email/verification-scim-token.html b/services/brig/deb/opt/brig/templates/vi/user/email/verification-scim-token.html new file mode 100644 index 00000000000..18bd7b87856 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/vi/user/email/verification-scim-token.html @@ -0,0 +1 @@ +Mã xác minh ${brand} của bạn là ${code}

${brand_label_url}

Xác minh về việc tạo SCIM token

${email} được sử dụng để tạo một mã SCIM token. Nhập đoạn mã này để xác minh email và tạo mã token.

 

${code}

 

Nếu bạn có bất kỳ thắc mắc nào, xin vui lòng liên hệ với chúng tôi.

Chính sách riêng tư và điều khoản sử dụng · Báo cáo Lạm dụng
${copyright}. ĐÃ ĐƯỢC ĐĂNG KÝ BẢN QUYỀN.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/vi/user/email/verification-scim-token.txt b/services/brig/deb/opt/brig/templates/vi/user/email/verification-scim-token.txt new file mode 100644 index 00000000000..009edf61f53 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/vi/user/email/verification-scim-token.txt @@ -0,0 +1,18 @@ +[${brand_logo}] + +${brand_label_url} [${brand_url}] + +XÁC MINH VỀ VIỆC TẠO SCIM TOKEN +${email} được sử dụng để tạo một mã SCIM token. Nhập đoạn mã này để xác minh +email và tạo mã token. + +${code} + +Nếu bạn có bất kỳ thắc mắc nào, xin vui lòng liên hệ với chúng tôi [${support}]. + + +-------------------------------------------------------------------------------- + +Chính sách riêng tư và điều khoản sử dụng [${legal}] · Báo cáo Lạm dụng +[${misuse}] +${copyright}. ĐÃ ĐƯỢC ĐĂNG KÝ BẢN QUYỀN. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/vi/user/email/verification-subject.txt b/services/brig/deb/opt/brig/templates/vi/user/email/verification-subject.txt new file mode 100644 index 00000000000..c1a38dc6a24 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/vi/user/email/verification-subject.txt @@ -0,0 +1 @@ +${code} là mã xác nhận ${brand} của bạn \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/vi/user/email/verification.html b/services/brig/deb/opt/brig/templates/vi/user/email/verification.html new file mode 100644 index 00000000000..601ada7eb42 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/vi/user/email/verification.html @@ -0,0 +1 @@ +${code} là mã xác nhận ${brand} của bạn

${brand_label_url}

Xác minh địa chỉ emal của bạn

${email} đã được dùng để đăng ký ${brand}. Nhập mã này để xác minh địa chỉ email và tạo tài khoản của bạn.

 

${code}

 

Nếu bạn có bất kỳ thắc mắc nào, xin vui lòng liên hệ với chúng tôi.

Chính sách riêng tư và điều khoản sử dụng · Báo cáo Lạm dụng
${copyright}. ĐÃ ĐƯỢC ĐĂNG KÝ BẢN QUYỀN.

                                                           
\ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/vi/user/email/verification.txt b/services/brig/deb/opt/brig/templates/vi/user/email/verification.txt new file mode 100644 index 00000000000..499224ab2d6 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/vi/user/email/verification.txt @@ -0,0 +1,18 @@ +[${brand_logo}] + +${brand_label_url} [${brand_url}] + +XÁC MINH ĐỊA CHỈ EMAL CỦA BẠN +${email} đã được dùng để đăng ký ${brand}. Nhập mã này để xác minh địa chỉ email +và tạo tài khoản của bạn. + +${code} + +Nếu bạn có bất kỳ thắc mắc nào, xin vui lòng liên hệ với chúng tôi [${support}]. + + +-------------------------------------------------------------------------------- + +Chính sách riêng tư và điều khoản sử dụng [${legal}] · Báo cáo Lạm dụng +[${misuse}] +${copyright}. ĐÃ ĐƯỢC ĐĂNG KÝ BẢN QUYỀN. \ No newline at end of file diff --git a/services/brig/deb/opt/brig/templates/vi/user/sms/activation.txt b/services/brig/deb/opt/brig/templates/vi/user/sms/activation.txt new file mode 100644 index 00000000000..e9987182a50 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/vi/user/sms/activation.txt @@ -0,0 +1,3 @@ +Mã ${brand} của bạn là ${code}. + +Mở ${url} để xác minh số điện thoại của bạn. diff --git a/services/brig/deb/opt/brig/templates/vi/user/sms/deletion.txt b/services/brig/deb/opt/brig/templates/vi/user/sms/deletion.txt new file mode 100644 index 00000000000..63b7431b400 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/vi/user/sms/deletion.txt @@ -0,0 +1,2 @@ +Chạm để xoá tài khoản ${brand} của bạn. +${url} diff --git a/services/brig/deb/opt/brig/templates/vi/user/sms/login.txt b/services/brig/deb/opt/brig/templates/vi/user/sms/login.txt new file mode 100644 index 00000000000..e12fa3949bd --- /dev/null +++ b/services/brig/deb/opt/brig/templates/vi/user/sms/login.txt @@ -0,0 +1,3 @@ +Mã đăng nhập ${brand} của bạn là ${code}. + +Mở ${url} để đăng nhập. diff --git a/services/brig/deb/opt/brig/templates/vi/user/sms/password-reset.txt b/services/brig/deb/opt/brig/templates/vi/user/sms/password-reset.txt new file mode 100644 index 00000000000..de5c4600cd4 --- /dev/null +++ b/services/brig/deb/opt/brig/templates/vi/user/sms/password-reset.txt @@ -0,0 +1,3 @@ +Mã khôi phục ${brand} của bạn là ${code}. + +Sử dụng mã này để hoàn tất việc đặt lại mật khẩu. diff --git a/services/brig/default.nix b/services/brig/default.nix index a7c6a8cfdb9..4a2369d7813 100644 --- a/services/brig/default.nix +++ b/services/brig/default.nix @@ -51,11 +51,8 @@ , gitignoreSource , gundeck-types , hashable -, HaskellNet -, HaskellNet-SSL , hscim , HsOpenSSL -, html-entities , http-api-data , http-client , http-client-openssl @@ -95,15 +92,14 @@ , polysemy-wire-zoo , postie , process +, prometheus-client , proto-lens , QuickCheck , random , random-shuffle , raw-strings-qq -, resource-pool , resourcet , retry -, ropes , safe , safe-exceptions , saml2-web-sso @@ -194,7 +190,7 @@ mkDerivation { cql cryptobox-haskell currency-codes - data-timeout + data-default dns dns-util enclosed-exceptions @@ -209,10 +205,7 @@ mkDerivation { galley-types gundeck-types hashable - HaskellNet - HaskellNet-SSL HsOpenSSL - html-entities http-client http-client-openssl http-media @@ -243,13 +236,12 @@ mkDerivation { polysemy-plugin polysemy-time polysemy-wire-zoo + prometheus-client proto-lens random-shuffle raw-strings-qq - resource-pool resourcet retry - ropes safe-exceptions saml2-web-sso schema-profunctor @@ -382,6 +374,7 @@ mkDerivation { warp-tls wire-api wire-api-federation + wire-subsystems yaml zauth ]; diff --git a/services/brig/src/Brig/API/Auth.hs b/services/brig/src/Brig/API/Auth.hs index bc88f31413b..581876fe0ce 100644 --- a/services/brig/src/Brig/API/Auth.hs +++ b/services/brig/src/Brig/API/Auth.hs @@ -46,14 +46,22 @@ import Network.Wai.Utilities.Error qualified as Wai import Polysemy import Polysemy.Input (Input) import Polysemy.TinyLog (TinyLog) +import Wire.API.Error +import Wire.API.Error.Brig qualified as E import Wire.API.User import Wire.API.User.Auth hiding (access) import Wire.API.User.Auth.LegalHold import Wire.API.User.Auth.ReAuth import Wire.API.User.Auth.Sso +import Wire.EmailSubsystem (EmailSubsystem) import Wire.GalleyAPIAccess import Wire.NotificationSubsystem +import Wire.PasswordStore (PasswordStore) import Wire.Sem.Paging.Cassandra (InternalPaging) +import Wire.UserKeyStore +import Wire.UserStore +import Wire.UserSubsystem +import Wire.VerificationCodeSubsystem (VerificationCodeSubsystem) accessH :: ( Member TinyLog r, @@ -90,11 +98,10 @@ access mcid t mt = traverse mkUserTokenCookie =<< Auth.renewAccess (List1 t) mt mcid !>> zauthError -sendLoginCode :: (Member TinyLog r) => SendLoginCode -> Handler r LoginCodeTimeout -sendLoginCode (SendLoginCode phone call force) = do - checkAllowlist (Right phone) - c <- Auth.sendLoginCode phone call force !>> sendLoginCodeError - pure $ LoginCodeTimeout (pendingLoginTimeout c) +sendLoginCode :: SendLoginCode -> Handler r LoginCodeTimeout +sendLoginCode _ = + -- Login by phone is unsupported + throwStd (errorToWai @'E.InvalidPhone) login :: ( Member GalleyAPIAccess r, @@ -103,7 +110,11 @@ login :: Member NotificationSubsystem r, Member (Input (Local ())) r, Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r + Member (ConnectionStore InternalPaging) r, + Member PasswordStore r, + Member UserKeyStore r, + Member UserStore r, + Member VerificationCodeSubsystem r ) => Login -> Maybe Bool -> @@ -123,12 +134,15 @@ logoutH uts' mat' = do partitionTokens uts mat >>= either (uncurry logout) (uncurry logout) -logout :: TokenPair u a => NonEmpty (Token u) -> Maybe (Token a) -> Handler r () +logout :: (TokenPair u a) => NonEmpty (Token u) -> Maybe (Token a) -> Handler r () logout _ Nothing = throwStd authMissingToken logout uts (Just at) = Auth.logout (List1 uts) at !>> zauthError changeSelfEmailH :: - Member BlacklistStore r => + ( Member BlacklistStore r, + Member UserKeyStore r, + Member EmailSubsystem r + ) => [Either Text SomeUserToken] -> Maybe (Either Text SomeAccessToken) -> EmailUpdate -> @@ -139,10 +153,10 @@ changeSelfEmailH uts' mat' up = do toks <- partitionTokens uts mat usr <- either (uncurry validateCredentials) (uncurry validateCredentials) toks let email = euEmail up - changeSelfEmail usr email ForbidSCIMUpdates + changeSelfEmail usr email UpdateOriginWireClient validateCredentials :: - TokenPair u a => + (TokenPair u a) => NonEmpty (Token u) -> Maybe (Token a) -> Handler r UserId @@ -155,7 +169,7 @@ listCookies lusr (fold -> labels) = CookieList <$> wrapClientE (Auth.listCookies (tUnqualified lusr) (toList labels)) -removeCookies :: (Member TinyLog r) => Local UserId -> RemoveCookies -> Handler r () +removeCookies :: (Member TinyLog r, Member PasswordStore r) => Local UserId -> RemoveCookies -> Handler r () removeCookies lusr (RemoveCookies pw lls ids) = Auth.revokeAccess (tUnqualified lusr) pw ids lls !>> authError @@ -191,12 +205,10 @@ ssoLogin l (fromMaybe False -> persist) = do c <- Auth.ssoLogin l typ !>> loginError traverse mkUserTokenCookie c -getLoginCode :: (Member TinyLog r) => Phone -> Handler r PendingLoginCode -getLoginCode phone = do - code <- lift $ Auth.lookupLoginCode phone - maybe (throwStd loginCodeNotFound) pure code +getLoginCode :: Phone -> Handler r PendingLoginCode +getLoginCode _ = throwStd loginCodeNotFound -reauthenticate :: Member GalleyAPIAccess r => UserId -> ReAuthUser -> Handler r () +reauthenticate :: (Member GalleyAPIAccess r, Member VerificationCodeSubsystem r) => UserId -> ReAuthUser -> Handler r () reauthenticate uid body = do wrapClientE (User.reauthenticate uid (reAuthPassword body)) !>> reauthError case reAuthCodeAction body of diff --git a/services/brig/src/Brig/API/Client.hs b/services/brig/src/Brig/API/Client.hs index 3176421f984..e4511fae9a1 100644 --- a/services/brig/src/Brig/API/Client.hs +++ b/services/brig/src/Brig/API/Client.hs @@ -67,7 +67,6 @@ import Brig.Types.Intra import Brig.Types.Team.LegalHold (LegalHoldClientRequest (..)) import Brig.User.Auth qualified as UserAuth import Brig.User.Auth.Cookie qualified as Auth -import Brig.User.Email import Cassandra (MonadClient) import Control.Error import Control.Lens (view) @@ -109,6 +108,7 @@ import Wire.API.User.Client.Prekey import Wire.API.UserEvent import Wire.API.UserMap (QualifiedUserMap (QualifiedUserMap, qualifiedUserMap), UserMap (userMap)) import Wire.DeleteQueue +import Wire.EmailSubsystem (EmailSubsystem, sendNewClientEmail) import Wire.GalleyAPIAccess (GalleyAPIAccess) import Wire.GalleyAPIAccess qualified as GalleyAPIAccess import Wire.NotificationSubsystem @@ -116,6 +116,7 @@ import Wire.Sem.Concurrency import Wire.Sem.FromUTC (FromUTC (fromUTCTime)) import Wire.Sem.Now as Now import Wire.Sem.Paging.Cassandra (InternalPaging) +import Wire.VerificationCodeSubsystem (VerificationCodeSubsystem) lookupLocalClient :: UserId -> ClientId -> (AppT r) (Maybe Client) lookupLocalClient uid = wrapClient . Data.lookupClient uid @@ -168,7 +169,9 @@ addClient :: Member DeleteQueue r, Member (Input (Local ())) r, Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r + Member (ConnectionStore InternalPaging) r, + Member EmailSubsystem r, + Member VerificationCodeSubsystem r ) => UserId -> Maybe ConnId -> @@ -187,7 +190,9 @@ addClientWithReAuthPolicy :: Member (Input (Local ())) r, Member (Input UTCTime) r, Member DeleteQueue r, - Member (ConnectionStore InternalPaging) r + Member (ConnectionStore InternalPaging) r, + Member EmailSubsystem r, + Member VerificationCodeSubsystem r ) => Data.ReAuthPolicy -> UserId -> @@ -220,7 +225,7 @@ addClientWithReAuthPolicy policy u con new = do when (count > 1) $ for_ (userEmail usr) $ \email -> - sendNewClientEmail (userDisplayName usr) email clt (userLocale usr) + liftSem $ sendNewClientEmail email (userDisplayName usr) clt (userLocale usr) pure clt where clientId' = clientIdFromPrekey (unpackLastPrekey $ newClientLastKey new) @@ -237,7 +242,7 @@ addClientWithReAuthPolicy policy u con new = do VerificationCodeNoPendingCode -> throwE ClientCodeAuthenticationFailed VerificationCodeNoEmail -> throwE ClientCodeAuthenticationFailed -updateClient :: MonadClient m => UserId -> ClientId -> UpdateClient -> ExceptT ClientError m () +updateClient :: (MonadClient m) => UserId -> ClientId -> UpdateClient -> ExceptT ClientError m () updateClient u c r = do client <- lift (Data.lookupClient u c) >>= maybe (throwE ClientNotFound) pure for_ (updateClientLabel r) $ lift . Data.updateClientLabel u c . Just @@ -253,7 +258,7 @@ updateClient u c r = do -- nb. We must ensure that the set of clients known to brig is always -- a superset of the clients known to galley. rmClient :: - Member DeleteQueue r => + (Member DeleteQueue r) => UserId -> ConnId -> ClientId -> @@ -273,7 +278,7 @@ rmClient u con clt pw = lift $ execDelete u (Just con) client claimPrekey :: - Member DeleteQueue r => + (Member DeleteQueue r) => LegalholdProtectee -> UserId -> Domain -> @@ -286,7 +291,7 @@ claimPrekey protectee u d c = do else wrapClientE $ claimRemotePrekey (Qualified u d) c claimLocalPrekey :: - Member DeleteQueue r => + (Member DeleteQueue r) => LegalholdProtectee -> UserId -> ClientId -> @@ -467,7 +472,7 @@ claimLocalMultiPrekeyBundles protectee userClients = do -- | Enqueue an orderly deletion of an existing client. execDelete :: - Member DeleteQueue r => + (Member DeleteQueue r) => UserId -> Maybe ConnId -> Client -> @@ -483,7 +488,7 @@ execDelete u con c = do -- thus repairing any inconsistencies related to distributed -- (and possibly duplicated) client data. noPrekeys :: - Member DeleteQueue r => + (Member DeleteQueue r) => UserId -> ClientId -> (AppT r) () diff --git a/services/brig/src/Brig/API/Connection.hs b/services/brig/src/Brig/API/Connection.hs index cc499656310..f718cd465d1 100644 --- a/services/brig/src/Brig/API/Connection.hs +++ b/services/brig/src/Brig/API/Connection.hs @@ -71,8 +71,9 @@ import Wire.API.UserEvent import Wire.GalleyAPIAccess import Wire.GalleyAPIAccess qualified as GalleyAPIAccess import Wire.NotificationSubsystem +import Wire.UserStore -ensureNotSameTeam :: Member GalleyAPIAccess r => Local UserId -> Local UserId -> (ConnectionM r) () +ensureNotSameTeam :: (Member GalleyAPIAccess r) => Local UserId -> Local UserId -> (ConnectionM r) () ensureNotSameTeam self target = do selfTeam <- lift $ liftSem $ GalleyAPIAccess.getTeamId (tUnqualified self) targetTeam <- lift $ liftSem $ GalleyAPIAccess.getTeamId (tUnqualified target) @@ -84,6 +85,7 @@ createConnection :: Member GalleyAPIAccess r, Member NotificationSubsystem r, Member TinyLog r, + Member UserStore r, Member (Embed HttpClientIO) r ) => Local UserId -> @@ -103,6 +105,7 @@ createConnectionToLocalUser :: ( Member GalleyAPIAccess r, Member NotificationSubsystem r, Member TinyLog r, + Member UserStore r, Member (Embed HttpClientIO) r ) => Local UserId -> @@ -191,7 +194,7 @@ createConnectionToLocalUser self conn target = do -- FUTUREWORK: we may want to move this to the LH application logic, so we can recycle it for -- group conv creation and possibly other situations. checkLegalholdPolicyConflict :: - Member GalleyAPIAccess r => + (Member GalleyAPIAccess r) => UserId -> UserId -> ExceptT ConnectionError (AppT r) () @@ -205,10 +208,10 @@ checkLegalholdPolicyConflict uid1 uid2 = do status2 <- lift (getLegalHoldStatus uid2) >>= catchProfileNotFound let oneway s1 s2 = case (s1, s2) of + (LH.UserLegalHoldNoConsent, LH.UserLegalHoldEnabled) -> throwE ConnectMissingLegalholdConsent (LH.UserLegalHoldNoConsent, LH.UserLegalHoldNoConsent) -> pure () (LH.UserLegalHoldNoConsent, LH.UserLegalHoldDisabled) -> pure () - (LH.UserLegalHoldNoConsent, LH.UserLegalHoldPending) -> throwE ConnectMissingLegalholdConsent - (LH.UserLegalHoldNoConsent, LH.UserLegalHoldEnabled) -> throwE ConnectMissingLegalholdConsent + (LH.UserLegalHoldNoConsent, LH.UserLegalHoldPending) -> pure () (LH.UserLegalHoldDisabled, _) -> pure () (LH.UserLegalHoldPending, _) -> pure () (LH.UserLegalHoldEnabled, _) -> pure () @@ -397,7 +400,7 @@ localConnection la lb = do lift (wrapClient $ Data.lookupConnection la (tUntagged lb)) >>= tryJust (NotConnected (tUnqualified la) (tUntagged lb)) -mkRelationWithHistory :: HasCallStack => Relation -> Relation -> RelationWithHistory +mkRelationWithHistory :: (HasCallStack) => Relation -> Relation -> RelationWithHistory mkRelationWithHistory oldRel = \case Accepted -> AcceptedWithHistory Blocked -> BlockedWithHistory diff --git a/services/brig/src/Brig/API/Connection/Remote.hs b/services/brig/src/Brig/API/Connection/Remote.hs index d9de83ccef5..03b650731c8 100644 --- a/services/brig/src/Brig/API/Connection/Remote.hs +++ b/services/brig/src/Brig/API/Connection/Remote.hs @@ -53,6 +53,7 @@ import Wire.API.User import Wire.API.UserEvent import Wire.GalleyAPIAccess import Wire.NotificationSubsystem +import Wire.UserStore data LocalConnectionAction = LocalConnect @@ -300,6 +301,7 @@ performRemoteAction self other mconnection action = do createConnectionToRemoteUser :: ( Member GalleyAPIAccess r, Member FederationConfigStore r, + Member UserStore r, Member NotificationSubsystem r ) => Local UserId -> @@ -347,7 +349,7 @@ checkLimitForLocalAction u oldRel action = -- | Check if the local backend federates with the remote user's team. Throw an -- exception if it does not federate. ensureFederatesWith :: - Member FederationConfigStore r => + (Member FederationConfigStore r) => Remote UserId -> ConnectionM r () ensureFederatesWith remote = do diff --git a/services/brig/src/Brig/API/Connection/Util.hs b/services/brig/src/Brig/API/Connection/Util.hs index 6b3cf894483..118c03bcc03 100644 --- a/services/brig/src/Brig/API/Connection/Util.hs +++ b/services/brig/src/Brig/API/Connection/Util.hs @@ -26,7 +26,6 @@ where import Brig.API.Types import Brig.App import Brig.Data.Connection qualified as Data -import Brig.Data.User qualified as Data import Brig.Options (Settings (setUserMaxConnections)) import Control.Error (MaybeT, noteT) import Control.Lens (view) @@ -34,7 +33,9 @@ import Control.Monad.Trans.Except import Data.Id (UserId) import Data.Qualified import Imports +import Polysemy import Wire.API.Connection (Relation (..)) +import Wire.UserStore type ConnectionM r = ExceptT ConnectionError (AppT r) @@ -46,14 +47,14 @@ checkLimit u = noteT (TooManyConnections (tUnqualified u)) $ do l <- setUserMaxConnections <$> view settings guard (n < l) -ensureNotSameAndActivated :: Local UserId -> Qualified UserId -> ConnectionM r () +ensureNotSameAndActivated :: (Member UserStore r) => Local UserId -> Qualified UserId -> ConnectionM r () ensureNotSameAndActivated self target = do when (tUntagged self == target) $ throwE (InvalidUser target) noteT ConnectNoIdentity $ ensureIsActivated self -ensureIsActivated :: Local UserId -> MaybeT (AppT r) () +ensureIsActivated :: (Member UserStore r) => Local UserId -> MaybeT (AppT r) () ensureIsActivated lusr = do - active <- lift . wrapClient $ Data.isActivated (tUnqualified lusr) + active <- lift . liftSem $ isActivated (tUnqualified lusr) guard active diff --git a/services/brig/src/Brig/API/Error.hs b/services/brig/src/Brig/API/Error.hs index 23a24bad4e2..9c120e6d5b5 100644 --- a/services/brig/src/Brig/API/Error.hs +++ b/services/brig/src/Brig/API/Error.hs @@ -18,10 +18,8 @@ module Brig.API.Error where import Brig.API.Types -import Brig.Phone (PhoneException (..)) -import Control.Monad.Error.Class hiding (Error) +import Control.Monad.Error.Class import Data.Aeson -import Data.Aeson.KeyMap qualified as KeyMap import Data.ByteString.Conversion import Data.Domain (Domain) import Data.Jwt.Tools (DPoPTokenGenerationError (..)) @@ -35,40 +33,23 @@ import Wire.API.Error import Wire.API.Error.Brig qualified as E import Wire.API.Federation.Error import Wire.API.User +import Wire.Error -data Error where - StdError :: !Wai.Error -> Error - RichError :: ToJSON a => !Wai.Error -> !a -> [Header] -> Error - -errorLabel :: Error -> LText -errorLabel (StdError e) = Wai.label e -errorLabel (RichError e _ _) = Wai.label e - -errorStatus :: Error -> Status -errorStatus (StdError e) = Wai.code e -errorStatus (RichError e _ _) = Wai.code e - -throwStd :: MonadError Error m => Wai.Error -> m a +throwStd :: (MonadError HttpError m) => Wai.Error -> m a throwStd = throwError . StdError -throwRich :: (MonadError Error m, ToJSON x) => Wai.Error -> x -> [Header] -> m a +throwRich :: (MonadError HttpError m, ToJSON x) => Wai.Error -> x -> [Header] -> m a throwRich e x h = throwError (RichError e x h) -instance ToJSON Error where - toJSON (StdError e) = toJSON e - toJSON (RichError e x _) = case (toJSON e, toJSON x) of - (Object o1, Object o2) -> Object (KeyMap.union o1 o2) - (j, _) -> j - -- Error Mapping ---------------------------------------------------------- -connError :: ConnectionError -> Error +connError :: ConnectionError -> HttpError connError TooManyConnections {} = StdError (errorToWai @'E.ConnectionLimitReached) connError InvalidTransition {} = StdError (errorToWai @'E.InvalidTransition) connError NotConnected {} = StdError (errorToWai @'E.NotConnected) connError InvalidUser {} = StdError (errorToWai @'E.InvalidUser) connError ConnectNoIdentity {} = StdError (errorToWai @'E.NoIdentity) -connError (ConnectBlacklistedUserKey k) = StdError $ foldKey (const blacklistedEmail) (const (errorToWai @'E.BlacklistedPhone)) k +connError (ConnectBlacklistedUserKey _) = StdError blacklistedEmail connError (ConnectInvalidEmail _ _) = StdError (errorToWai @'E.InvalidEmail) connError ConnectInvalidPhone {} = StdError (errorToWai @'E.InvalidPhone) connError ConnectSameBindingTeamUsers = StdError sameBindingTeamUsers @@ -77,14 +58,14 @@ connError ConnectMissingLegalholdConsent = StdError (errorToWai @'E.MissingLegal connError (ConnectFederationError e) = fedError e connError ConnectTeamFederationError = StdError (errorToWai @'E.TeamsNotFederating) -actError :: ActivationError -> Error +actError :: ActivationError -> HttpError actError (UserKeyExists _) = StdError (errorToWai @'E.UserKeyExists) actError InvalidActivationCodeWrongUser = StdError (errorToWai @'E.InvalidActivationCodeWrongUser) actError InvalidActivationCodeWrongCode = StdError (errorToWai @'E.InvalidActivationCodeWrongCode) actError (InvalidActivationEmail _ _) = StdError (errorToWai @'E.InvalidEmail) actError (InvalidActivationPhone _) = StdError (errorToWai @'E.InvalidPhone) -pwResetError :: PasswordResetError -> Error +pwResetError :: PasswordResetError -> HttpError pwResetError InvalidPasswordResetKey = StdError (errorToWai @'E.InvalidPasswordResetKey) pwResetError InvalidPasswordResetCode = StdError (errorToWai @'E.InvalidPasswordResetCode) pwResetError (PasswordResetInProgress Nothing) = StdError (errorToWai @'E.PasswordResetInProgress) @@ -95,34 +76,30 @@ pwResetError (PasswordResetInProgress (Just t)) = [("Retry-After", toByteString' t)] pwResetError ResetPasswordMustDiffer = StdError (errorToWai @'E.ResetPasswordMustDiffer) -sendLoginCodeError :: SendLoginCodeError -> Error -sendLoginCodeError (SendLoginInvalidPhone _) = StdError (errorToWai @'E.InvalidPhone) -sendLoginCodeError SendLoginPasswordExists = StdError (errorToWai @'E.PasswordExists) - -sendActCodeError :: SendActivationCodeError -> Error -sendActCodeError (InvalidRecipient k) = StdError $ foldKey (const (errorToWai @'E.InvalidEmail)) (const (errorToWai @'E.InvalidPhone)) k +sendActCodeError :: SendActivationCodeError -> HttpError +sendActCodeError (InvalidRecipient _) = StdError $ errorToWai @'E.InvalidEmail sendActCodeError (UserKeyInUse _) = StdError (errorToWai @'E.UserKeyExists) -sendActCodeError (ActivationBlacklistedUserKey k) = StdError $ foldKey (const blacklistedEmail) (const (errorToWai @'E.BlacklistedPhone)) k +sendActCodeError (ActivationBlacklistedUserKey _) = StdError blacklistedEmail -changeEmailError :: ChangeEmailError -> Error +changeEmailError :: ChangeEmailError -> HttpError changeEmailError (InvalidNewEmail _ _) = StdError (errorToWai @'E.InvalidEmail) changeEmailError (EmailExists _) = StdError (errorToWai @'E.UserKeyExists) changeEmailError (ChangeBlacklistedEmail _) = StdError blacklistedEmail changeEmailError EmailManagedByScim = StdError $ propertyManagedByScim "email" -changeHandleError :: ChangeHandleError -> Error +changeHandleError :: ChangeHandleError -> HttpError changeHandleError ChangeHandleNoIdentity = StdError (errorToWai @'E.NoIdentity) changeHandleError ChangeHandleExists = StdError (errorToWai @'E.HandleExists) changeHandleError ChangeHandleInvalid = StdError (errorToWai @'E.InvalidHandle) changeHandleError ChangeHandleManagedByScim = StdError (errorToWai @'E.HandleManagedByScim) -legalHoldLoginError :: LegalHoldLoginError -> Error +legalHoldLoginError :: LegalHoldLoginError -> HttpError legalHoldLoginError LegalHoldLoginNoBindingTeam = StdError noBindingTeam legalHoldLoginError LegalHoldLoginLegalHoldNotEnabled = StdError legalHoldNotEnabled legalHoldLoginError (LegalHoldLoginError e) = loginError e legalHoldLoginError (LegalHoldReAuthError e) = reauthError e -loginError :: LoginError -> Error +loginError :: LoginError -> HttpError loginError LoginFailed = StdError (errorToWai @'E.BadCredentials) loginError LoginSuspended = StdError (errorToWai @'E.AccountSuspended) loginError LoginEphemeral = StdError (errorToWai @'E.AccountEphemeral) @@ -141,27 +118,27 @@ loginError (LoginBlocked wait) = loginError LoginCodeRequired = StdError (errorToWai @'E.CodeAuthenticationRequired) loginError LoginCodeInvalid = StdError (errorToWai @'E.CodeAuthenticationFailed) -authError :: AuthError -> Error +authError :: AuthError -> HttpError authError AuthInvalidUser = StdError (errorToWai @'E.BadCredentials) authError AuthInvalidCredentials = StdError (errorToWai @'E.BadCredentials) authError AuthSuspended = StdError (errorToWai @'E.AccountSuspended) authError AuthEphemeral = StdError (errorToWai @'E.AccountEphemeral) authError AuthPendingInvitation = StdError (errorToWai @'E.AccountPending) -reauthError :: ReAuthError -> Error +reauthError :: ReAuthError -> HttpError reauthError ReAuthMissingPassword = StdError (errorToWai @'E.MissingAuth) reauthError (ReAuthError e) = authError e reauthError ReAuthCodeVerificationRequired = StdError verificationCodeRequired reauthError ReAuthCodeVerificationNoPendingCode = StdError verificationCodeNoPendingCode reauthError ReAuthCodeVerificationNoEmail = StdError verificationCodeNoEmail -zauthError :: ZAuth.Failure -> Error +zauthError :: ZAuth.Failure -> HttpError zauthError ZAuth.Expired = StdError authTokenExpired zauthError ZAuth.Falsified = StdError authTokenInvalid zauthError ZAuth.Invalid = StdError authTokenInvalid zauthError ZAuth.Unsupported = StdError authTokenUnsupported -clientError :: ClientError -> Error +clientError :: ClientError -> HttpError clientError ClientNotFound = StdError (errorToWai @'E.ClientNotFound) clientError (ClientDataError e) = clientDataError e clientError (ClientUserNotFound _) = StdError (errorToWai @'E.InvalidUser) @@ -177,7 +154,7 @@ clientError ClientCodeAuthenticationRequired = StdError verificationCodeRequired -- Note that UnknownError, FfiError, and ImplementationError semantically should rather be 500s than 400s. -- However, the errors returned from the FFI are not always correct, -- and we don't want to bombard our environments with 500 log messages, so we treat them as 400s, for now. -certEnrollmentError :: CertEnrollmentError -> Error +certEnrollmentError :: CertEnrollmentError -> HttpError certEnrollmentError (RustError NoError) = StdError $ Wai.mkError status400 "internal-error" "The server experienced an internal error during DPoP token generation. Unexpected NoError." certEnrollmentError (RustError UnknownError) = StdError $ Wai.mkError status400 "internal-error" "The server experienced an internal error during DPoP token generation. Unknown error." certEnrollmentError (RustError FfiError) = StdError $ Wai.mkError status400 "internal-error" "The server experienced an internal error during DPoP token generation" @@ -230,13 +207,13 @@ certEnrollmentError NotATeamUser = StdError $ Wai.mkError status400 "not-a-team- certEnrollmentError MissingHandle = StdError $ Wai.mkError status400 "missing-handle" "The user has no handle" certEnrollmentError MissingName = StdError $ Wai.mkError status400 "missing-name" "The user has no name" -fedError :: FederationError -> Error +fedError :: FederationError -> HttpError fedError = StdError . federationErrorToWai -propDataError :: PropertiesDataError -> Error +propDataError :: PropertiesDataError -> HttpError propDataError TooManyProperties = StdError tooManyProperties -clientDataError :: ClientDataError -> Error +clientDataError :: ClientDataError -> HttpError clientDataError TooManyClients = StdError (errorToWai @'E.TooManyClients) clientDataError (ClientReAuthError e) = reauthError e clientDataError ClientMissingAuth = StdError (errorToWai @'E.MissingAuth) @@ -246,7 +223,7 @@ clientDataError KeyPackageDecodingError = StdError (errorToWai @'E.KeyPackageDec clientDataError InvalidKeyPackageRef = StdError (errorToWai @'E.InvalidKeyPackageRef) clientDataError MLSNotEnabled = StdError (errorToWai @'E.MLSNotEnabled) -deleteUserError :: DeleteUserError -> Error +deleteUserError :: DeleteUserError -> HttpError deleteUserError DeleteUserInvalid = StdError (errorToWai @'E.InvalidUser) deleteUserError DeleteUserInvalidCode = StdError (errorToWai @'E.InvalidCode) deleteUserError DeleteUserInvalidPassword = StdError (errorToWai @'E.BadCredentials) @@ -254,28 +231,20 @@ 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))] + verificationCodeThrottledError (VerificationCodeThrottled t) -accountStatusError :: AccountStatusError -> Error +accountStatusError :: AccountStatusError -> HttpError accountStatusError InvalidAccountStatus = StdError invalidAccountStatus accountStatusError AccountNotFound = StdError (notFound "Account not found") -phoneError :: PhoneException -> Error -phoneError PhoneNumberUnreachable = StdError (errorToWai @'E.InvalidPhone) -phoneError PhoneNumberBarred = StdError (errorToWai @'E.BlacklistedPhone) -phoneError (PhoneBudgetExhausted t) = RichError phoneBudgetExhausted (PhoneBudgetTimeout t) [] - -updateProfileError :: UpdateProfileError -> Error +updateProfileError :: UpdateProfileError -> HttpError updateProfileError DisplayNameManagedByScim = StdError (propertyManagedByScim "name") updateProfileError ProfileNotFound = StdError (errorToWai @'E.UserNotFound) -verificationCodeThrottledError :: VerificationCodeThrottledError -> Error +verificationCodeThrottledError :: VerificationCodeThrottledError -> HttpError verificationCodeThrottledError (VerificationCodeThrottled t) = RichError - verificationCodeThrottled + (dynErrorToWai $ dynError @(MapError 'E.VerificationCodeThrottled)) () [("Retry-After", toByteString' (retryAfterSeconds t))] @@ -327,7 +296,7 @@ deletionCodePending :: Wai.Error deletionCodePending = Wai.mkError status403 "pending-delete" "A verification code for account deletion is still pending." allowlistError :: Wai.Error -allowlistError = Wai.mkError status403 "unauthorized" "Unauthorized e-mail address or phone number." +allowlistError = Wai.mkError status403 "unauthorized" "Unauthorized e-mail address" blacklistedEmail :: Wai.Error blacklistedEmail = @@ -411,9 +380,6 @@ 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/Federation.hs b/services/brig/src/Brig/API/Federation.hs index b48dd6e10fd..58af99451bf 100644 --- a/services/brig/src/Brig/API/Federation.hs +++ b/services/brig/src/Brig/API/Federation.hs @@ -41,7 +41,8 @@ import Control.Error.Util import Control.Lens ((^.)) import Control.Monad.Trans.Except import Data.Domain -import Data.Handle (Handle (..), parseHandle) +import Data.Handle (Handle (..)) +import Data.Handle qualified as Handle import Data.Id (ClientId, TeamId, UserId) import Data.List.NonEmpty (nonEmpty) import Data.Qualified @@ -70,9 +71,11 @@ import Wire.API.User.Search hiding (searchPolicy) import Wire.API.UserEvent import Wire.API.UserMap (UserMap) import Wire.DeleteQueue +import Wire.Error import Wire.GalleyAPIAccess (GalleyAPIAccess) import Wire.NotificationSubsystem import Wire.Sem.Concurrency +import Wire.UserStore import Wire.UserSubsystem type FederationAPI = "federation" :> BrigApi @@ -83,6 +86,7 @@ federationSitemap :: Member FederationConfigStore r, Member NotificationSubsystem r, Member UserSubsystem r, + Member UserStore r, Member DeleteQueue r ) => ServerT FederationAPI (Handler r) @@ -116,6 +120,7 @@ getFederationStatus _ request = do sendConnectionAction :: ( Member FederationConfigStore r, Member GalleyAPIAccess r, + Member UserStore r, Member NotificationSubsystem r ) => Domain -> @@ -126,7 +131,7 @@ sendConnectionAction originDomain NewConnectionRequest {..} = do federates <- lift . liftSem . E.backendFederatesWith $ rTeam if federates then do - active <- lift $ wrapClient $ Data.isActivated to + active <- lift . liftSem $ isActivated to if active then do self <- qualifyLocal to @@ -139,11 +144,12 @@ sendConnectionAction originDomain NewConnectionRequest {..} = do getUserByHandle :: ( Member FederationConfigStore r, - Member UserSubsystem r + Member UserSubsystem r, + Member UserStore r ) => Domain -> Handle -> - ExceptT Error (AppT r) (Maybe UserProfile) + ExceptT HttpError (AppT r) (Maybe UserProfile) getUserByHandle domain handle = do searchPolicy <- lookupSearchPolicy domain @@ -155,7 +161,7 @@ getUserByHandle domain handle = do if not performHandleLookup then pure Nothing else lift $ do - maybeOwnerId <- wrapClient $ API.lookupHandle handle + maybeOwnerId <- liftSem $ API.lookupHandle handle case maybeOwnerId of Nothing -> pure Nothing @@ -167,7 +173,7 @@ getUsersByIds :: (Member UserSubsystem r) => Domain -> [UserId] -> - ExceptT Error (AppT r) [UserProfile] + ExceptT HttpError (AppT r) [UserProfile] getUsersByIds _ uids = do luids <- qualifyLocal uids lift $ liftSem $ getLocalUserProfiles luids @@ -202,11 +208,12 @@ fedClaimKeyPackages domain ckpr = searchUsers :: forall r. ( Member FederationConfigStore r, - Member UserSubsystem r + Member UserSubsystem r, + Member UserStore r ) => Domain -> SearchRequest -> - ExceptT Error (AppT r) SearchResponse + ExceptT HttpError (AppT r) SearchResponse searchUsers domain (SearchRequest _ mTeam (Just [])) = do searchPolicy <- lookupSearchPolicyWithTeam domain mTeam pure $ SearchResponse [] searchPolicy @@ -223,22 +230,22 @@ searchUsers domain (SearchRequest searchTerm mTeam mOnlyInTeams) = do contacts <- go [] maxResults searches pure $ SearchResponse contacts searchPolicy where - go :: [Contact] -> Int -> [Int -> ExceptT Error (AppT r) [Contact]] -> ExceptT Error (AppT r) [Contact] + go :: [Contact] -> Int -> [Int -> ExceptT HttpError (AppT r) [Contact]] -> ExceptT HttpError (AppT r) [Contact] go contacts _ [] = pure contacts go contacts maxResult (search : searches) = do contactsNew <- search maxResult go (contacts <> contactsNew) (maxResult - length contactsNew) searches - fullSearch :: Int -> ExceptT Error (AppT r) [Contact] + fullSearch :: Int -> ExceptT HttpError (AppT r) [Contact] fullSearch n | n > 0 = lift $ searchResults <$> Q.searchIndex (Q.FederatedSearch mOnlyInTeams) searchTerm n | otherwise = pure [] - exactHandleSearch :: Int -> ExceptT Error (AppT r) [Contact] + exactHandleSearch :: Int -> ExceptT HttpError (AppT r) [Contact] exactHandleSearch n | n > 0 = do - let maybeHandle = parseHandle searchTerm - maybeOwnerId <- maybe (pure Nothing) (wrapHttpClientE . API.lookupHandle) maybeHandle + let maybeHandle = Handle.parseHandle searchTerm + maybeOwnerId <- maybe (pure Nothing) (lift . liftSem . API.lookupHandle) maybeHandle case maybeOwnerId of Nothing -> pure [] Just foundUser -> do diff --git a/services/brig/src/Brig/API/Handler.hs b/services/brig/src/Brig/API/Handler.hs index 4c6e92e341a..2971f28e4e9 100644 --- a/services/brig/src/Brig/API/Handler.hs +++ b/services/brig/src/Brig/API/Handler.hs @@ -32,12 +32,9 @@ where import Bilge (RequestId (..)) import Brig.API.Error import Brig.AWS qualified as AWS -import Brig.Allowlists qualified as Allowlists import Brig.App import Brig.CanonicalInterpreter (BrigCanonicalEffects, runBrigToIO) -import Brig.Email (Email) -import Brig.Options (setAllowlistEmailDomains, setAllowlistPhonePrefixes) -import Brig.Phone (Phone, PhoneException (..)) +import Brig.Options (setAllowlistEmailDomains) import Control.Error import Control.Exception (throwIO) import Control.Lens (view) @@ -58,13 +55,16 @@ import Network.Wai.Utilities.Server qualified as Server import Servant qualified import System.Logger qualified as Log import System.Logger.Class (Logger) +import Wire.API.Allowlists qualified as Allowlists import Wire.API.Error import Wire.API.Error.Brig +import Wire.API.User (Email) +import Wire.Error ------------------------------------------------------------------------------- -- HTTP Handler Monad -type Handler r = ExceptT Error (AppT r) +type Handler r = ExceptT HttpError (AppT r) toServantHandler :: Env -> (Handler BrigCanonicalEffects) a -> Servant.Handler a toServantHandler env action = do @@ -72,7 +72,7 @@ toServantHandler env action = do reqId = unRequestId $ view requestId env a <- liftIO $ - runBrigToIO env (runExceptT action) + (runBrigToIO env (runExceptT action)) `catches` brigErrorHandlers logger reqId case a of Left werr -> handleWaiErrors logger reqId werr @@ -85,7 +85,9 @@ toServantHandler env action = do \case -- throw in IO so that the `catchErrors` middleware can turn this error -- into a response and log accordingly - StdError werr -> liftIO $ throwIO werr + StdError werr -> do + Server.logError' logger (Just reqId) werr + liftIO $ throwIO werr RichError werr body headers -> do when (statusCode (WaiError.code werr) < 500) $ -- 5xx are logged by the middleware, so we only log errors < 500 to avoid duplicated entries @@ -98,16 +100,16 @@ newtype UserNotAllowedToJoinTeam = UserNotAllowedToJoinTeam WaiError.Error instance Exception UserNotAllowedToJoinTeam -brigErrorHandlers :: Logger -> ByteString -> [Catch.Handler IO (Either Error a)] +brigErrorHandlers :: Logger -> ByteString -> [Catch.Handler IO (Either HttpError a)] brigErrorHandlers logger reqId = - [ Catch.Handler $ \(ex :: PhoneException) -> - pure (Left (phoneError ex)), - Catch.Handler $ \(ex :: ZV.Failure) -> + [ Catch.Handler $ \(ex :: ZV.Failure) -> pure (Left (zauthError ex)), Catch.Handler $ \(ex :: AWS.Error) -> case ex of - AWS.SESInvalidDomain -> pure (Left (StdError (errorToWai @'InvalidEmail))) + AWS.SESInvalidDomain -> + pure (Left (StdError (errorToWai @'InvalidEmail))) _ -> throwM ex, + Catch.Handler $ \(e :: HttpError) -> pure $ Left e, Catch.Handler $ \(UserNotAllowedToJoinTeam e) -> pure (Left $ StdError e), Catch.Handler $ \(e :: SomeException) -> do Log.err logger $ @@ -123,20 +125,19 @@ brigErrorHandlers logger reqId = -- This could go to libs/wai-utilities. There is a `parseJson'` in -- "Network.Wai.Utilities.Request", but adding `parseJsonBody` there would require to move -- more code out of brig. -parseJsonBody :: (FromJSON a, MonadIO m) => JsonRequest a -> ExceptT Error m a +parseJsonBody :: (FromJSON a, MonadIO m) => JsonRequest a -> ExceptT HttpError m a parseJsonBody req = parseBody req !>> StdError . badRequest -- | If an Allowlist is configured, consult it, otherwise a no-op. {#RefActivationAllowlist} -checkAllowlist :: Either Email Phone -> (Handler r) () +checkAllowlist :: Email -> Handler r () checkAllowlist = wrapHttpClientE . checkAllowlistWithError (StdError allowlistError) --- checkAllowlistWithError :: (MonadReader Env m, MonadIO m, Catch.MonadMask m, MonadHttp m, MonadError e m) => e -> Either Email Phone -> m () -checkAllowlistWithError :: (MonadReader Env m, MonadError e m) => e -> Either Email Phone -> m () +checkAllowlistWithError :: (MonadReader Env m, MonadError e m) => e -> Email -> m () checkAllowlistWithError e key = do ok <- isAllowlisted key unless ok (throwError e) -isAllowlisted :: (MonadReader Env m) => Either Email Phone -> m Bool +isAllowlisted :: (MonadReader Env m) => Email -> m Bool isAllowlisted key = do env <- view settings - pure $ Allowlists.verify (setAllowlistEmailDomains env) (setAllowlistPhonePrefixes env) key + pure $ Allowlists.verify (setAllowlistEmailDomains env) key diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index 0cbe0829f48..1e05d13e6cf 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wno-ambiguous-fields #-} + -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2022 Wire Swiss GmbH @@ -29,24 +31,24 @@ import Brig.API.MLS.KeyPackages.Validation import Brig.API.OAuth (internalOauthAPI) import Brig.API.Types import Brig.API.User qualified as API -import Brig.API.Util import Brig.App -import Brig.Code qualified as Code import Brig.Data.Activation import Brig.Data.Client qualified as Data import Brig.Data.Connection qualified as Data import Brig.Data.MLS.KeyPackage qualified as Data import Brig.Data.User qualified as Data -import Brig.Effects.BlacklistPhonePrefixStore (BlacklistPhonePrefixStore) import Brig.Effects.BlacklistStore (BlacklistStore) -import Brig.Effects.CodeStore (CodeStore) import Brig.Effects.ConnectionStore (ConnectionStore) -import Brig.Effects.FederationConfigStore (AddFederationRemoteResult (..), AddFederationRemoteTeamResult (..), FederationConfigStore, UpdateFederationResult (..)) +import Brig.Effects.FederationConfigStore + ( AddFederationRemoteResult (..), + AddFederationRemoteTeamResult (..), + FederationConfigStore, + UpdateFederationResult (..), + ) import Brig.Effects.FederationConfigStore qualified as E -import Brig.Effects.PasswordResetStore (PasswordResetStore) import Brig.Effects.UserPendingActivationStore (UserPendingActivationStore) import Brig.IO.Intra qualified as Intra -import Brig.Options hiding (internalEvents, sesQueue) +import Brig.Options hiding (internalEvents) import Brig.Provider.API qualified as Provider import Brig.Team.API qualified as Team import Brig.Team.DB (lookupInvitationByEmail) @@ -60,7 +62,9 @@ import Brig.User.Search.Index qualified as Index import Control.Error hiding (bool) import Control.Lens (view) import Data.ByteString.Conversion (toByteString) +import Data.Code qualified as Code import Data.CommaSeparatedList +import Data.Default import Data.Domain (Domain) import Data.Handle import Data.Id as Id @@ -68,7 +72,6 @@ import Data.Map.Strict qualified as Map import Data.Qualified import Data.Set qualified as Set import Data.Text qualified as T -import Data.Text.Lazy qualified as LT import Data.Time.Clock (UTCTime) import Data.Time.Clock.System import Imports hiding (head) @@ -96,31 +99,45 @@ import Wire.API.User.Activation import Wire.API.User.Client import Wire.API.User.RichInfo import Wire.API.UserEvent +import Wire.AuthenticationSubsystem (AuthenticationSubsystem) import Wire.DeleteQueue +import Wire.EmailSending (EmailSending) +import Wire.EmailSubsystem (EmailSubsystem) import Wire.GalleyAPIAccess (GalleyAPIAccess, ShowOrHideInvitationUrl (..)) import Wire.NotificationSubsystem import Wire.Rpc import Wire.Sem.Concurrency import Wire.Sem.Paging.Cassandra (InternalPaging) +import Wire.UserKeyStore +import Wire.UserStore +import Wire.UserSubsystem +import Wire.UserSubsystem qualified as UserSubsystem +import Wire.VerificationCode +import Wire.VerificationCodeGen +import Wire.VerificationCodeSubsystem servantSitemap :: forall r p. - ( Member BlacklistPhonePrefixStore r, - Member BlacklistStore r, + ( Member BlacklistStore r, Member DeleteQueue r, - Member CodeStore r, Member (Concurrency 'Unsafe) r, Member (ConnectionStore InternalPaging) r, Member (Embed HttpClientIO) r, Member FederationConfigStore r, + Member AuthenticationSubsystem r, Member GalleyAPIAccess r, Member (Input (Local ())) r, Member (Input UTCTime) r, Member NotificationSubsystem r, - Member PasswordResetStore r, + Member UserSubsystem r, + Member UserStore r, + Member UserKeyStore r, Member Rpc r, Member TinyLog r, - Member (UserPendingActivationStore p) r + Member (UserPendingActivationStore p) r, + Member EmailSending r, + Member EmailSubsystem r, + Member VerificationCodeSubsystem r ) => ServerT BrigIRoutes.API (Handler r) servantSitemap = @@ -144,6 +161,7 @@ istatusAPI = Named @"get-status" (pure NoContent) ejpdAPI :: ( Member GalleyAPIAccess r, Member NotificationSubsystem r, + Member UserStore r, Member Rpc r ) => ServerT BrigIRoutes.EJPDRequest (Handler r) @@ -155,18 +173,21 @@ mlsAPI = getMLSClients accountAPI :: ( Member BlacklistStore r, - Member CodeStore r, - Member BlacklistPhonePrefixStore r, - Member PasswordResetStore r, Member GalleyAPIAccess r, + Member AuthenticationSubsystem r, Member DeleteQueue r, Member (UserPendingActivationStore p) r, Member (Embed HttpClientIO) r, Member NotificationSubsystem r, + Member UserSubsystem r, + Member UserKeyStore r, + Member UserStore r, Member TinyLog r, Member (Input (Local ())) r, Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r + Member (ConnectionStore InternalPaging) r, + Member EmailSubsystem r, + Member VerificationCodeSubsystem r ) => ServerT BrigIRoutes.AccountAPI (Handler r) accountAPI = @@ -183,21 +204,18 @@ accountAPI = :<|> Named @"iGetUserStatus" getAccountStatusH :<|> Named @"iGetUsersByVariousKeys" listActivatedAccountsH :<|> Named @"iGetUserContacts" getContactListH - :<|> Named @"iGetUserActivationCode" getActivationCodeH + :<|> Named @"iGetUserActivationCode" getActivationCode :<|> Named @"iGetUserPasswordResetCode" getPasswordResetCodeH :<|> Named @"iRevokeIdentity" revokeIdentityH - :<|> Named @"iHeadBlacklist" checkBlacklistH - :<|> Named @"iDeleteBlacklist" deleteFromBlacklistH - :<|> Named @"iPostBlacklist" addBlacklistH - :<|> Named @"iGetPhonePrefix" (callsFed (exposeAnnotations getPhonePrefixesH)) - :<|> Named @"iDeletePhonePrefix" deleteFromPhonePrefixH - :<|> Named @"iPostPhonePrefix" addPhonePrefixH + :<|> Named @"iHeadBlacklist" checkBlacklist + :<|> Named @"iDeleteBlacklist" deleteFromBlacklist + :<|> Named @"iPostBlacklist" addBlacklist :<|> Named @"iPutUserSsoId" updateSSOIdH :<|> Named @"iDeleteUserSsoId" deleteSSOIdH :<|> Named @"iPutManagedBy" updateManagedByH :<|> Named @"iPutRichInfo" updateRichInfoH :<|> Named @"iPutHandle" updateHandleH - :<|> Named @"iPutHandle" updateUserNameH + :<|> Named @"iPutUserName" updateUserNameH :<|> Named @"iGetRichInfo" getRichInfoH :<|> Named @"iGetRichInfoMulti" getRichInfoMultiH :<|> Named @"iHeadHandle" checkHandleInternalH @@ -214,11 +232,13 @@ teamsAPI :: Member BlacklistStore r, Member (Embed HttpClientIO) r, Member NotificationSubsystem r, + Member UserKeyStore r, Member (Concurrency 'Unsafe) r, Member TinyLog r, Member (Input (Local ())) r, Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r + Member (ConnectionStore InternalPaging) r, + Member EmailSending r ) => ServerT BrigIRoutes.TeamsAPI (Handler r) teamsAPI = @@ -230,7 +250,7 @@ teamsAPI = :<|> Named @"team-size" Team.teamSize :<|> Named @"create-invitations-via-scim" Team.createInvitationViaScim -userAPI :: ServerT BrigIRoutes.UserAPI (Handler r) +userAPI :: (Member UserSubsystem r) => ServerT BrigIRoutes.UserAPI (Handler r) userAPI = updateLocale :<|> deleteLocale @@ -246,7 +266,8 @@ authAPI :: Member NotificationSubsystem r, Member (Input (Local ())) r, Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r + Member (ConnectionStore InternalPaging) r, + Member VerificationCodeSubsystem r ) => ServerT BrigIRoutes.AuthAPI (Handler r) authAPI = @@ -355,16 +376,13 @@ getMLSClients usr suite = do (cid,) . (> 0) <$> Data.countKeyPackages lusr cid suiteTag -getVerificationCode :: UserId -> VerificationAction -> Handler r (Maybe Code.Value) -getVerificationCode uid action = do - user <- wrapClientE $ API.lookupUser NoPendingInvitations uid - maybe (pure Nothing) (lookupCode action) (userEmail =<< user) - where - lookupCode :: VerificationAction -> Email -> (Handler r) (Maybe Code.Value) - lookupCode a e = do - key <- Code.mkKey (Code.ForEmail e) - code <- wrapClientE $ Code.lookup key (Code.scopeFromAction a) - pure $ Code.codeValue <$> code +getVerificationCode :: forall r. (Member VerificationCodeSubsystem r) => UserId -> VerificationAction -> Handler r (Maybe Code.Value) +getVerificationCode uid action = runMaybeT do + user <- MaybeT . wrapClientE $ API.lookupUser NoPendingInvitations uid + email <- MaybeT . pure $ userEmail user + let key = mkKey email + code <- MaybeT . lift . liftSem $ internalLookupCode key (scopeFromAction action) + pure code.codeValue internalSearchIndexAPI :: forall r. ServerT BrigIRoutes.ISearchIndexAPI (Handler r) internalSearchIndexAPI = @@ -384,7 +402,9 @@ addClientInternalH :: Member TinyLog r, Member (Input (Local ())) r, Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r + Member (ConnectionStore InternalPaging) r, + Member EmailSubsystem r, + Member VerificationCodeSubsystem r ) => UserId -> Maybe Bool -> @@ -441,6 +461,7 @@ createUserNoVerify :: Member TinyLog r, Member (Embed HttpClientIO) r, Member NotificationSubsystem r, + Member UserKeyStore r, Member (Input (Local ())) r, Member (Input UTCTime) r, Member (ConnectionStore InternalPaging) r @@ -453,8 +474,7 @@ createUserNoVerify uData = lift . runExceptT $ do let usr = accountUser acc let uid = userId usr let eac = createdEmailActivation result - let pac = createdPhoneActivation result - for_ (catMaybes [eac, pac]) $ \adata -> + for_ eac $ \adata -> let key = ActivateKey $ activationKey adata code = activationCode adata in API.activate key code (Just uid) !>> activationErrorToRegisterError @@ -464,6 +484,7 @@ createUserNoVerifySpar :: ( Member GalleyAPIAccess r, Member (Embed HttpClientIO) r, Member NotificationSubsystem r, + Member UserSubsystem r, Member TinyLog r, Member (Input (Local ())) r, Member (Input UTCTime) r, @@ -478,8 +499,7 @@ createUserNoVerifySpar uData = let usr = accountUser acc let uid = userId usr let eac = createdEmailActivation result - let pac = createdPhoneActivation result - for_ (catMaybes [eac, pac]) $ \adata -> + for_ eac $ \adata -> let key = ActivateKey $ activationKey adata code = activationCode adata in API.activate key code (Just uid) !>> CreateUserSparRegistrationError . activationErrorToRegisterError @@ -488,7 +508,9 @@ createUserNoVerifySpar uData = deleteUserNoAuthH :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, + Member UserStore r, Member TinyLog r, + Member UserKeyStore r, Member (Input (Local ())) r, Member (Input UTCTime) r, Member (ConnectionStore InternalPaging) r @@ -502,14 +524,14 @@ deleteUserNoAuthH uid = do AccountAlreadyDeleted -> pure UserResponseAccountAlreadyDeleted AccountDeleted -> pure UserResponseAccountDeleted -changeSelfEmailMaybeSendH :: (Member BlacklistStore r) => UserId -> EmailUpdate -> Maybe Bool -> (Handler r) ChangeEmailResponse +changeSelfEmailMaybeSendH :: (Member BlacklistStore r, Member UserKeyStore r, Member EmailSubsystem r) => UserId -> EmailUpdate -> Maybe Bool -> (Handler r) ChangeEmailResponse changeSelfEmailMaybeSendH u body (fromMaybe False -> validate) = do let email = euEmail body - changeSelfEmailMaybeSend u (if validate then ActuallySendEmail else DoNotSendEmail) email API.AllowSCIMUpdates + changeSelfEmailMaybeSend u (if validate then ActuallySendEmail else DoNotSendEmail) email UpdateOriginScim data MaybeSendEmail = ActuallySendEmail | DoNotSendEmail -changeSelfEmailMaybeSend :: (Member BlacklistStore r) => UserId -> MaybeSendEmail -> Email -> API.AllowSCIMUpdates -> (Handler r) ChangeEmailResponse +changeSelfEmailMaybeSend :: (Member BlacklistStore r, Member UserKeyStore r, Member EmailSubsystem r) => UserId -> MaybeSendEmail -> Email -> UpdateOriginType -> (Handler r) ChangeEmailResponse changeSelfEmailMaybeSend u ActuallySendEmail email allowScim = do API.changeSelfEmail u email allowScim changeSelfEmailMaybeSend u DoNotSendEmail email allowScim = do @@ -522,45 +544,46 @@ changeSelfEmailMaybeSend u DoNotSendEmail email allowScim = do -- handler allows up to 4 lists of various user keys, and returns the union of the lookups. -- Empty list is forbidden for backwards compatibility. listActivatedAccountsH :: - Member DeleteQueue r => + ( Member DeleteQueue r, + Member UserKeyStore r, + Member UserStore r + ) => Maybe (CommaSeparatedList UserId) -> Maybe (CommaSeparatedList Handle) -> Maybe (CommaSeparatedList Email) -> - Maybe (CommaSeparatedList Phone) -> Maybe Bool -> - (Handler r) [UserAccount] + Handler r [UserAccount] listActivatedAccountsH (maybe [] fromCommaSeparatedList -> uids) (maybe [] fromCommaSeparatedList -> handles) (maybe [] fromCommaSeparatedList -> emails) - (maybe [] fromCommaSeparatedList -> phones) (fromMaybe False -> includePendingInvitations) = do - when (length uids + length handles + length emails + length phones == 0) $ do + when (length uids + length handles + length emails == 0) $ do throwStd (notFound "no user keys") lift $ do u1 <- listActivatedAccounts (Left uids) includePendingInvitations u2 <- listActivatedAccounts (Right handles) includePendingInvitations - u3 <- (\email -> API.lookupAccountsByIdentity (Left email) includePendingInvitations) `mapM` emails - u4 <- (\phone -> API.lookupAccountsByIdentity (Right phone) includePendingInvitations) `mapM` phones - pure $ u1 <> u2 <> join u3 <> join u4 + u3 <- (\email -> API.lookupAccountsByIdentity email includePendingInvitations) `mapM` emails + pure $ u1 <> u2 <> join u3 +-- FUTUREWORK: this should use UserStore only through UserSubsystem. listActivatedAccounts :: - Member DeleteQueue r => + (Member DeleteQueue r, Member UserStore r) => Either [UserId] [Handle] -> Bool -> - (AppT r) [UserAccount] + AppT r [UserAccount] listActivatedAccounts elh includePendingInvitations = do Log.debug (Log.msg $ "listActivatedAccounts: " <> show (elh, includePendingInvitations)) case elh of Left us -> byIds us Right hs -> do - us <- mapM (wrapClient . API.lookupHandle) hs + us <- liftSem $ mapM API.lookupHandle hs byIds (catMaybes us) where - byIds :: Member DeleteQueue r => [UserId] -> (AppT r) [UserAccount] + byIds :: (Member DeleteQueue r) => [UserId] -> (AppT r) [UserAccount] byIds uids = wrapClient (API.lookupAccounts uids) >>= filterM accountValid - accountValid :: Member DeleteQueue r => UserAccount -> (AppT r) Bool + accountValid :: (Member DeleteQueue r) => UserAccount -> (AppT r) Bool accountValid account = case userIdentity . accountUser $ account of Nothing -> pure False Just ident -> @@ -579,45 +602,26 @@ listActivatedAccounts elh includePendingInvitations = do (Deleted, _, _) -> pure True (Ephemeral, _, _) -> pure True -getActivationCodeH :: Maybe Email -> Maybe Phone -> (Handler r) GetActivationCodeResp -getActivationCodeH (Just email) Nothing = getActivationCode (Left email) -getActivationCodeH Nothing (Just phone) = getActivationCode (Right phone) -getActivationCodeH bade badp = - throwStd - ( badRequest - ( "need exactly one of email, phone: " - <> LT.pack (show (bade, badp)) - ) - ) - -getActivationCode :: Either Email Phone -> (Handler r) GetActivationCodeResp -getActivationCode emailOrPhone = do - apair <- lift . wrapClient $ API.lookupActivationCode emailOrPhone +getActivationCode :: Email -> Handler r GetActivationCodeResp +getActivationCode email = do + apair <- lift . wrapClient $ API.lookupActivationCode email maybe (throwStd activationKeyNotFound) (pure . GetActivationCodeResp) apair getPasswordResetCodeH :: - ( Member CodeStore r, - Member PasswordResetStore r + ( Member AuthenticationSubsystem r ) => - Maybe Email -> - Maybe Phone -> - (Handler r) GetPasswordResetCodeResp -getPasswordResetCodeH (Just email) Nothing = getPasswordResetCode (Left email) -getPasswordResetCodeH Nothing (Just phone) = getPasswordResetCode (Right phone) -getPasswordResetCodeH bade badp = - throwStd - ( badRequest - ("need exactly one of email, phone: " <> LT.pack (show (bade, badp))) - ) + Email -> + Handler r GetPasswordResetCodeResp +getPasswordResetCodeH email = getPasswordResetCode email getPasswordResetCode :: - ( Member CodeStore r, - Member PasswordResetStore r + ( Member AuthenticationSubsystem r ) => - Either Email Phone -> - (Handler r) GetPasswordResetCodeResp -getPasswordResetCode emailOrPhone = - (GetPasswordResetCodeResp <$$> lift (API.lookupPasswordResetCode emailOrPhone)) >>= maybe (throwStd (errorToWai @'E.InvalidPasswordResetKey)) pure + Email -> + Handler r GetPasswordResetCodeResp +getPasswordResetCode email = + (GetPasswordResetCodeResp <$$> lift (API.lookupPasswordResetCode email)) + >>= maybe (throwStd (errorToWai @'E.InvalidPasswordResetKey)) pure changeAccountStatusH :: ( Member (Embed HttpClientIO) r, @@ -635,9 +639,9 @@ changeAccountStatusH usr (suStatus -> status) = do API.changeSingleAccountStatus usr status !>> accountStatusError -- FUTUREWORK: use CanThrow and related machinery pure NoContent -getAccountStatusH :: UserId -> (Handler r) AccountStatusResp +getAccountStatusH :: (Member UserStore r) => UserId -> (Handler r) AccountStatusResp getAccountStatusH uid = do - status <- lift $ wrapClient $ API.lookupStatus uid + status <- lift $ liftSem $ lookupStatus uid maybe (throwStd (errorToWai @'E.UserNotFound)) (pure . AccountStatusResp) @@ -668,23 +672,12 @@ getConnectionsStatus (ConnectionsStatusRequestV2 froms mtos mrel) = do filterByRelation l rel = filter ((== rel) . csv2Status) l revokeIdentityH :: - ( Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member TinyLog r, - Member (Input (Local ())) r, - Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r + ( Member UserSubsystem r, + Member UserKeyStore r ) => - Maybe Email -> - Maybe Phone -> - (Handler r) NoContent -revokeIdentityH (Just email) Nothing = lift $ NoContent <$ API.revokeIdentity (Left email) -revokeIdentityH Nothing (Just phone) = lift $ NoContent <$ API.revokeIdentity (Right phone) -revokeIdentityH bade badp = - throwStd - ( badRequest - ("need exactly one of email, phone: " <> LT.pack (show (bade, badp))) - ) + Email -> + Handler r NoContent +revokeIdentityH email = lift $ NoContent <$ API.revokeIdentity email updateConnectionInternalH :: ( Member GalleyAPIAccess r, @@ -698,57 +691,14 @@ updateConnectionInternalH updateConn = do API.updateConnectionInternal updateConn !>> connError pure NoContent -checkBlacklistH :: Member BlacklistStore r => Maybe Email -> Maybe Phone -> (Handler r) CheckBlacklistResponse -checkBlacklistH (Just email) Nothing = checkBlacklist (Left email) -checkBlacklistH Nothing (Just phone) = checkBlacklist (Right phone) -checkBlacklistH bade badp = - throwStd - ( badRequest - ("need exactly one of email, phone: " <> LT.pack (show (bade, badp))) - ) - -checkBlacklist :: Member BlacklistStore r => Either Email Phone -> (Handler r) CheckBlacklistResponse -checkBlacklist emailOrPhone = lift $ bool NotBlacklisted YesBlacklisted <$> API.isBlacklisted emailOrPhone - -deleteFromBlacklistH :: Member BlacklistStore r => Maybe Email -> Maybe Phone -> (Handler r) NoContent -deleteFromBlacklistH (Just email) Nothing = deleteFromBlacklist (Left email) -deleteFromBlacklistH Nothing (Just phone) = deleteFromBlacklist (Right phone) -deleteFromBlacklistH bade badp = - throwStd - ( badRequest - ("need exactly one of email, phone: " <> LT.pack (show (bade, badp))) - ) - -deleteFromBlacklist :: Member BlacklistStore r => Either Email Phone -> (Handler r) NoContent -deleteFromBlacklist emailOrPhone = lift $ NoContent <$ API.blacklistDelete emailOrPhone - -addBlacklistH :: Member BlacklistStore r => Maybe Email -> Maybe Phone -> (Handler r) NoContent -addBlacklistH (Just email) Nothing = addBlacklist (Left email) -addBlacklistH Nothing (Just phone) = addBlacklist (Right phone) -addBlacklistH bade badp = - throwStd - ( badRequest - ("need exactly one of email, phone: " <> LT.pack (show (bade, badp))) - ) - -addBlacklist :: Member BlacklistStore r => Either Email Phone -> (Handler r) NoContent -addBlacklist emailOrPhone = lift $ NoContent <$ API.blacklistInsert emailOrPhone - --- | Get any matching prefixes. Also try for shorter prefix matches, --- i.e. checking for +123456 also checks for +12345, +1234, ... -getPhonePrefixesH :: Member BlacklistPhonePrefixStore r => PhonePrefix -> (Handler r) GetPhonePrefixResponse -getPhonePrefixesH prefix = lift $ do - results <- API.phonePrefixGet prefix - pure $ case results of - [] -> PhonePrefixNotFound - (_ : _) -> PhonePrefixesFound results - --- | Delete a phone prefix entry (must be an exact match) -deleteFromPhonePrefixH :: Member BlacklistPhonePrefixStore r => PhonePrefix -> (Handler r) NoContent -deleteFromPhonePrefixH prefix = lift $ NoContent <$ API.phonePrefixDelete prefix - -addPhonePrefixH :: Member BlacklistPhonePrefixStore r => ExcludedPrefix -> (Handler r) NoContent -addPhonePrefixH prefix = lift $ NoContent <$ API.phonePrefixInsert prefix +checkBlacklist :: (Member BlacklistStore r) => Email -> Handler r CheckBlacklistResponse +checkBlacklist email = lift $ bool NotBlacklisted YesBlacklisted <$> API.isBlacklisted email + +deleteFromBlacklist :: (Member BlacklistStore r) => Email -> Handler r NoContent +deleteFromBlacklist email = lift $ NoContent <$ API.blacklistDelete email + +addBlacklist :: (Member BlacklistStore r) => Email -> Handler r NoContent +addBlacklist email = lift $ NoContent <$ API.blacklistInsert email updateSSOIdH :: ( Member (Embed HttpClientIO) r, @@ -801,15 +751,18 @@ updateRichInfoH uid rup = -- Intra.onUserEvent uid (Just conn) (richInfoUpdate uid ri) lift $ wrapClient $ Data.updateRichInfo uid (mkRichInfoAssocList richInfo) -updateLocale :: UserId -> LocaleUpdate -> (Handler r) LocaleUpdate -updateLocale uid locale = do - lift $ wrapClient $ Data.updateLocale uid (luLocale locale) - pure locale +updateLocale :: (Member UserSubsystem r) => UserId -> LocaleUpdate -> (Handler r) LocaleUpdate +updateLocale uid upd@(LocaleUpdate locale) = do + qUid <- qualifyLocal uid + lift . liftSem $ updateUserProfile qUid Nothing UpdateOriginScim def {locale = Just locale} + pure upd -deleteLocale :: UserId -> (Handler r) NoContent +deleteLocale :: (Member UserSubsystem r) => UserId -> (Handler r) NoContent deleteLocale uid = do defLoc <- setDefaultUserLocale <$> view settings - lift $ wrapClient $ Data.updateLocale uid defLoc $> NoContent + qUid <- qualifyLocal uid + lift . liftSem $ updateUserProfile qUid Nothing UpdateOriginScim def {locale = Just defLoc} + pure NoContent getDefaultUserLocale :: (Handler r) LocaleUpdate getDefaultUserLocale = do @@ -837,54 +790,33 @@ getRichInfoMultiH (maybe [] fromCommaSeparatedList -> uids) = lift $ wrapClient $ API.lookupRichInfoMultiUsers uids updateHandleH :: - ( Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member GalleyAPIAccess r, - Member TinyLog r, - Member (Input (Local ())) r, - Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r - ) => + (Member UserSubsystem r) => UserId -> HandleUpdate -> - (Handler r) NoContent + Handler r NoContent updateHandleH uid (HandleUpdate handleUpd) = NoContent <$ do - handle <- validateHandle handleUpd - API.changeHandle uid Nothing handle API.AllowSCIMUpdates !>> changeHandleError + quid <- qualifyLocal uid + lift . liftSem $ UserSubsystem.updateHandle quid Nothing UpdateOriginScim handleUpd updateUserNameH :: - ( Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member GalleyAPIAccess r, - Member TinyLog r, - Member (Input (Local ())) r, - Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r - ) => + (Member UserSubsystem r) => UserId -> NameUpdate -> (Handler r) NoContent updateUserNameH uid (NameUpdate nameUpd) = NoContent <$ do + luid <- qualifyLocal uid name <- either (const $ throwStd (errorToWai @'E.InvalidUser)) pure $ mkName nameUpd - let uu = - UserUpdate - { uupName = Just name, - uupPict = Nothing, - uupAssets = Nothing, - uupAccentId = Nothing - } lift (wrapClient $ Data.lookupUser WithPendingInvitations uid) >>= \case - Just _ -> API.updateUser uid Nothing uu API.AllowSCIMUpdates !>> updateProfileError + Just _ -> lift . liftSem $ updateUserProfile luid Nothing UpdateOriginScim (def {name = Just name}) Nothing -> throwStd (errorToWai @'E.InvalidUser) -checkHandleInternalH :: Handle -> (Handler r) CheckHandleResponse -checkHandleInternalH (Handle h) = - API.checkHandle h >>= \case - API.CheckHandleInvalid -> throwE (StdError (errorToWai @'E.InvalidHandle)) - API.CheckHandleFound -> pure CheckHandleResponseFound - API.CheckHandleNotFound -> pure CheckHandleResponseNotFound +checkHandleInternalH :: (Member UserSubsystem r) => Handle -> Handler r CheckHandleResponse +checkHandleInternalH h = lift $ liftSem do + API.checkHandle (fromHandle h) <&> \case + API.CheckHandleFound -> CheckHandleResponseFound + API.CheckHandleNotFound -> CheckHandleResponseNotFound getContactListH :: UserId -> (Handler r) UserIds getContactListH uid = lift . wrapClient $ UserIds <$> API.lookupContactList uid diff --git a/services/brig/src/Brig/API/MLS/KeyPackages.hs b/services/brig/src/Brig/API/MLS/KeyPackages.hs index 35d1edba025..9226a4db7be 100644 --- a/services/brig/src/Brig/API/MLS/KeyPackages.hs +++ b/services/brig/src/Brig/API/MLS/KeyPackages.hs @@ -138,7 +138,7 @@ claimRemoteKeyPackages lusr suite target = do pure bundle where - handleFailure :: Monad m => Maybe x -> ExceptT ClientError m x + handleFailure :: (Monad m) => Maybe x -> ExceptT ClientError m x handleFailure = maybe (throwE (ClientUserNotFound (tUnqualified target))) pure countKeyPackages :: Local UserId -> ClientId -> Maybe CipherSuite -> Handler r KeyPackageCount diff --git a/services/brig/src/Brig/API/OAuth.hs b/services/brig/src/Brig/API/OAuth.hs index 8643e8eff6d..5ff461bf652 100644 --- a/services/brig/src/Brig/API/OAuth.hs +++ b/services/brig/src/Brig/API/OAuth.hs @@ -47,7 +47,7 @@ import Polysemy (Member) import Servant hiding (Handler, Tagged) import Wire.API.Error import Wire.API.OAuth as OAuth -import Wire.API.Password (Password, mkSafePassword) +import Wire.API.Password (Password, mkSafePasswordScrypt) import Wire.API.Routes.Internal.Brig.OAuth qualified as I import Wire.API.Routes.Named (Named (Named)) import Wire.API.Routes.Public.Brig.OAuth @@ -89,13 +89,13 @@ registerOAuthClient (OAuthClientConfig name uri) = do lift $ wrapClient $ insertOAuthClient cid name uri safeSecret pure credentials where - createSecret :: MonadIO m => m OAuthClientPlainTextSecret + createSecret :: (MonadIO m) => m OAuthClientPlainTextSecret createSecret = OAuthClientPlainTextSecret <$> rand32Bytes - hashClientSecret :: MonadIO m => OAuthClientPlainTextSecret -> m Password - hashClientSecret = mkSafePassword . plainTextPassword8Unsafe . toText . unOAuthClientPlainTextSecret + hashClientSecret :: (MonadIO m) => OAuthClientPlainTextSecret -> m Password + hashClientSecret = mkSafePasswordScrypt . plainTextPassword8Unsafe . toText . unOAuthClientPlainTextSecret -rand32Bytes :: MonadIO m => m AsciiBase16 +rand32Bytes :: (MonadIO m) => m AsciiBase16 rand32Bytes = liftIO . fmap encodeBase16 $ randBytes 32 getOAuthClientById :: OAuthClientId -> (Handler r) OAuthClient @@ -205,7 +205,9 @@ createAccessTokenWithRefreshToken req = do lookupVerifyAndDeleteToken :: JWK -> OAuthRefreshToken -> (Handler r) OAuthRefreshTokenInfo lookupVerifyAndDeleteToken key = verifyRefreshToken key - >=> lift . wrapClient . lookupAndDeleteOAuthRefreshToken + >=> lift + . wrapClient + . lookupAndDeleteOAuthRefreshToken >=> maybe (throwStd $ errorToWai @'OAuthInvalidRefreshToken) pure verifyRefreshToken :: JWK -> OAuthRefreshToken -> (Handler r) OAuthRefreshTokenId @@ -230,7 +232,7 @@ createAccessTokenWithAuthorizationCode req = do key <- signingKey createAccessToken key uid cid scope -signingKey :: Member Jwk r => (Handler r) JWK +signingKey :: (Member Jwk r) => (Handler r) JWK signingKey = do fp <- view settings >>= maybe (throwStd $ errorToWai @'OAuthJwtError) pure . Opt.setOAuthJwkKeyPair lift (liftSem $ Jwk.get fp) >>= maybe (throwStd $ errorToWai @'OAuthJwtError) pure @@ -254,14 +256,14 @@ createAccessToken key uid cid scope = do let claims = emptyClaimsSet & claimSub ?~ sub (rid,) . OAuthToken <$> signRefreshToken claims - mkAccessToken :: Member Now r => (Handler r) OAuthAccessToken + mkAccessToken :: (Member Now r) => (Handler r) OAuthAccessToken mkAccessToken = do domain <- Opt.setFederationDomain <$> view settings exp <- fromIntegral . Opt.setOAuthAccessTokenExpirationTimeSecs <$> view settings claims <- mkAccessTokenClaims uid domain scope exp OAuthToken <$> signAccessToken claims - mkAccessTokenClaims :: Member Now r => UserId -> Domain -> OAuthScopes -> NominalDiffTime -> (Handler r) OAuthClaimsSet + mkAccessTokenClaims :: (Member Now r) => UserId -> Domain -> OAuthScopes -> NominalDiffTime -> (Handler r) OAuthClaimsSet mkAccessTokenClaims u domain scopes ttl = do iat <- lift (liftSem Now.get) uri <- maybe (throwStd $ errorToWai @'OAuthJwtError) pure $ domainText domain ^? stringOrUri @@ -298,7 +300,7 @@ createAccessToken key uid cid scope = do -------------------------------------------------------------------------------- -revokeRefreshToken :: Member Jwk r => OAuthRevokeRefreshTokenRequest -> (Handler r) () +revokeRefreshToken :: (Member Jwk r) => OAuthRevokeRefreshTokenRequest -> (Handler r) () revokeRefreshToken req = do key <- signingKey info <- lookupAndVerifyToken key req.refreshToken @@ -308,7 +310,9 @@ revokeRefreshToken req = do lookupAndVerifyToken :: JWK -> OAuthRefreshToken -> (Handler r) OAuthRefreshTokenInfo lookupAndVerifyToken key = verifyRefreshToken key - >=> lift . wrapClient . lookupOAuthRefreshTokenInfo + >=> lift + . wrapClient + . lookupOAuthRefreshTokenInfo >=> maybe (throwStd $ errorToWai @'OAuthInvalidRefreshToken) pure -------------------------------------------------------------------------------- diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index ec797bf83fa..e468afda8af 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -37,25 +37,19 @@ import Brig.API.Public.Swagger import Brig.API.Types import Brig.API.User qualified as API import Brig.API.Util -import Brig.API.Util qualified as API import Brig.App import Brig.Calling.API qualified as Calling -import Brig.Code qualified as Code import Brig.Data.Connection qualified as Data import Brig.Data.Nonce as Nonce import Brig.Data.User qualified as Data -import Brig.Data.UserKey qualified as UserKey -import Brig.Effects.BlacklistPhonePrefixStore (BlacklistPhonePrefixStore) import Brig.Effects.BlacklistStore (BlacklistStore) -import Brig.Effects.CodeStore (CodeStore) import Brig.Effects.ConnectionStore (ConnectionStore) import Brig.Effects.FederationConfigStore (FederationConfigStore) import Brig.Effects.JwtTools (JwtTools) -import Brig.Effects.PasswordResetStore (PasswordResetStore) import Brig.Effects.PublicKeyBundle (PublicKeyBundle) import Brig.Effects.SFT import Brig.Effects.UserPendingActivationStore (UserPendingActivationStore) -import Brig.Options hiding (internalEvents, sesQueue) +import Brig.Options hiding (internalEvents) import Brig.Provider.API import Brig.Team.API qualified as Team import Brig.Team.Email qualified as Team @@ -66,11 +60,9 @@ import Brig.User.API.Handle qualified as Handle import Brig.User.API.Search (teamUserSearch) import Brig.User.API.Search qualified as Search import Brig.User.Auth.Cookie qualified as Auth -import Brig.User.Email -import Brig.User.Phone import Cassandra qualified as C import Cassandra qualified as Data -import Control.Error hiding (bool) +import Control.Error hiding (bool, note) import Control.Lens (view, (.~), (?~), (^.)) import Control.Monad.Catch (throwM) import Control.Monad.Except @@ -80,10 +72,13 @@ import Data.ByteString (fromStrict, toStrict) import Data.ByteString.Lazy qualified as Lazy import Data.ByteString.Lazy.Char8 qualified as LBS import Data.ByteString.UTF8 qualified as UTF8 +import Data.Code qualified as Code import Data.CommaSeparatedList +import Data.Default import Data.Domain import Data.FileEmbed -import Data.Handle (Handle, parseHandle) +import Data.Handle (Handle) +import Data.Handle qualified as Handle import Data.Id import Data.Id qualified as Id import Data.List.NonEmpty (nonEmpty) @@ -156,15 +151,26 @@ import Wire.API.User.Password qualified as Public import Wire.API.User.RichInfo qualified as Public import Wire.API.UserMap qualified as Public import Wire.API.Wrapped qualified as Public +import Wire.AuthenticationSubsystem (AuthenticationSubsystem, createPasswordResetCode, resetPassword) import Wire.DeleteQueue +import Wire.EmailSending (EmailSending) +import Wire.EmailSubsystem +import Wire.Error import Wire.GalleyAPIAccess (GalleyAPIAccess) import Wire.GalleyAPIAccess qualified as GalleyAPIAccess import Wire.NotificationSubsystem +import Wire.PasswordStore (PasswordStore, lookupHashedPassword) import Wire.Sem.Concurrency import Wire.Sem.Jwk (Jwk) import Wire.Sem.Now (Now) import Wire.Sem.Paging.Cassandra (InternalPaging) -import Wire.UserSubsystem +import Wire.UserKeyStore +import Wire.UserStore (UserStore) +import Wire.UserSubsystem hiding (checkHandle, checkHandles) +import Wire.UserSubsystem qualified as UserSubsystem +import Wire.VerificationCode +import Wire.VerificationCodeGen +import Wire.VerificationCodeSubsystem -- User API ----------------------------------------------------------- @@ -276,9 +282,7 @@ internalEndpointsSwaggerDocsAPI service examplePort swagger Nothing = servantSitemap :: forall r p. - ( Member BlacklistPhonePrefixStore r, - Member BlacklistStore r, - Member CodeStore r, + ( Member BlacklistStore r, Member DeleteQueue r, Member (Concurrency 'Unsafe) r, Member (ConnectionStore InternalPaging) r, @@ -286,18 +290,24 @@ servantSitemap :: Member (Embed IO) r, Member FederationConfigStore r, Member (Input (Local ())) r, + Member AuthenticationSubsystem r, Member (Input UTCTime) r, Member Jwk r, Member GalleyAPIAccess r, Member JwtTools r, Member NotificationSubsystem r, Member UserSubsystem r, + Member UserStore r, + Member PasswordStore r, + Member UserKeyStore r, Member Now r, - Member PasswordResetStore r, Member PublicKeyBundle r, Member SFT r, Member TinyLog r, - Member (UserPendingActivationStore p) r + Member (UserPendingActivationStore p) r, + Member EmailSubsystem r, + Member EmailSending r, + Member VerificationCodeSubsystem r ) => ServerT BrigAPI (Handler r) servantSitemap = @@ -523,7 +533,7 @@ listPropertyKeysAndValues u = do Public.PropertyKeysAndValues <$> traverse parseStoredPropertyValue keysAndVals getPrekeyUnqualifiedH :: - Member DeleteQueue r => + (Member DeleteQueue r) => UserId -> UserId -> ClientId -> @@ -533,7 +543,7 @@ getPrekeyUnqualifiedH zusr user client = do getPrekeyH zusr (Qualified user domain) client getPrekeyH :: - Member DeleteQueue r => + (Member DeleteQueue r) => UserId -> Qualified UserId -> ClientId -> @@ -565,7 +575,7 @@ getMultiUserPrekeyBundleUnqualifiedH zusr userClients = do API.claimLocalMultiPrekeyBundles (ProtectedUser zusr) userClients !>> clientError getMultiUserPrekeyBundleHInternal :: - (MonadReader Env m, MonadError Brig.API.Error.Error m) => + (MonadReader Env m, MonadError HttpError m) => Public.QualifiedUserClients -> m () getMultiUserPrekeyBundleHInternal qualUserClients = do @@ -607,7 +617,9 @@ addClient :: Member TinyLog r, Member (Input (Local ())) r, Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r + Member (ConnectionStore InternalPaging) r, + Member EmailSubsystem r, + Member VerificationCodeSubsystem r ) => UserId -> ConnId -> @@ -621,7 +633,7 @@ addClient usr con new = do !>> clientError deleteClient :: - Member DeleteQueue r => + (Member DeleteQueue r) => UserId -> ConnId -> ClientId -> @@ -733,23 +745,29 @@ createUser :: Member TinyLog r, Member (Embed HttpClientIO) r, Member NotificationSubsystem r, + Member UserKeyStore r, Member (Input (Local ())) r, Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r + Member (ConnectionStore InternalPaging) r, + Member EmailSubsystem r, + Member EmailSending r ) => Public.NewUserPublic -> - (Handler r) (Either Public.RegisterError Public.RegisterSuccess) + Handler r (Either Public.RegisterError Public.RegisterSuccess) createUser (Public.NewUserPublic new) = lift . runExceptT $ do API.checkRestrictedUserCreation new - for_ (Public.newUserEmail new) $ mapExceptT wrapHttp . checkAllowlistWithError RegisterErrorAllowlistError . Left - for_ (Public.newUserPhone new) $ mapExceptT wrapHttp . checkAllowlistWithError RegisterErrorAllowlistError . Right + for_ (Public.newUserEmail new) $ + mapExceptT wrapHttp . checkAllowlistWithError RegisterErrorAllowlistError + + -- prevent registration with a phone number + when (isJust (Public.newUserPhone new)) $ + throwE Public.RegisterErrorInvalidPhone + result <- API.createUser new let acc = createdAccount result let eac = createdEmailActivation result - let pac = createdPhoneActivation result let epair = (,) <$> (activationKey <$> eac) <*> (activationCode <$> eac) - let ppair = (,) <$> (activationKey <$> pac) <*> (activationCode <$> pac) let newUserLabel = Public.newUserLabel new let newUserTeam = Public.newUserTeam new let usr = accountUser acc @@ -769,13 +787,10 @@ createUser (Public.NewUserPublic new) = lift . runExceptT $ do let Public.User {userLocale, userDisplayName} = usr userEmail = Public.userEmail usr - userPhone = Public.userPhone usr userId = Public.userId usr lift $ do for_ (liftM2 (,) userEmail epair) $ \(e, p) -> sendActivationEmail e userDisplayName p (Just userLocale) newUserTeam - for_ (liftM2 (,) userPhone ppair) $ \(p, c) -> - wrapClient $ sendActivationSms p c (Just userLocale) for_ (liftM3 (,,) userEmail (createdUserTeam result) newUserTeam) $ \(e, ct, ut) -> sendWelcomeEmail e ct ut (Just userLocale) cok <- @@ -789,16 +804,16 @@ createUser (Public.NewUserPublic new) = lift . runExceptT $ do -- pure $ CreateUserResponse cok userId (Public.SelfProfile usr) pure $ Public.RegisterSuccess cok (Public.SelfProfile usr) where - sendActivationEmail :: Public.Email -> Public.Name -> ActivationPair -> Maybe Public.Locale -> Maybe Public.NewTeamUser -> (AppT r) () - sendActivationEmail e u p l mTeamUser + sendActivationEmail :: (Member EmailSubsystem r) => Public.Email -> Public.Name -> ActivationPair -> Maybe Public.Locale -> Maybe Public.NewTeamUser -> (AppT r) () + sendActivationEmail email name (key, code) locale mTeamUser | Just teamUser <- mTeamUser, Public.NewTeamCreator creator <- teamUser, let Public.BindingNewTeamUser (Public.BindingNewTeam team) _ = creator = - sendTeamActivationMail e u p l (fromRange $ team ^. Public.newTeamName) + liftSem $ sendTeamActivationMail email name key code locale (fromRange $ team ^. Public.newTeamName) | otherwise = - sendActivationMail e u p l Nothing + liftSem $ sendActivationMail email name key code locale - sendWelcomeEmail :: Public.Email -> CreateUserTeam -> Public.NewTeamUser -> Maybe Public.Locale -> (AppT r) () + sendWelcomeEmail :: (Member EmailSending r) => Public.Email -> CreateUserTeam -> Public.NewTeamUser -> Maybe Public.Locale -> (AppT r) () -- NOTE: Welcome e-mails for the team creator are not dealt by brig anymore sendWelcomeEmail e (CreateUserTeam t n) newUser l = case newUser of Public.NewTeamCreator _ -> @@ -808,11 +823,10 @@ createUser (Public.NewUserPublic new) = lift . runExceptT $ do Public.NewTeamMemberSSO _ -> Team.sendMemberWelcomeMail e t n l -getSelf :: Member GalleyAPIAccess r => UserId -> (Handler r) Public.SelfProfile +getSelf :: (Member UserSubsystem r) => Local UserId -> Handler r Public.SelfProfile getSelf self = - lift (API.lookupSelfProfile self) + lift (liftSem (getSelfProfile self)) >>= ifNothing (errorToWai @'E.UserNotFound) - >>= lift . liftSem . API.hackForBlockingHandleChangeForE2EIdTeams getUserProfileH :: (Member UserSubsystem r) => @@ -832,7 +846,7 @@ getUserUnqualifiedH self uid = do -- FUTUREWORK: Make servant understand that at least one of these is required listUsersByUnqualifiedIdsOrHandles :: - (Member UserSubsystem r) => + (Member UserSubsystem r, Member UserStore r) => UserId -> Maybe (CommaSeparatedList UserId) -> Maybe (Range 1 4 (CommaSeparatedList Handle)) -> @@ -852,20 +866,27 @@ listUsersByUnqualifiedIdsOrHandles self mUids mHandles = do in listUsersByIdsOrHandlesV3 self (Public.ListUsersByHandles qualifiedRangedList) (Nothing, Nothing) -> throwStd $ badRequest "at least one ids or handles must be provided" -listUsersByIdsOrHandlesGetIds :: [Handle] -> (Handler r) [Qualified UserId] +listUsersByIdsOrHandlesGetIds :: + (Member UserStore r) => + [Handle] -> + Handler r [Qualified UserId] listUsersByIdsOrHandlesGetIds localHandles = do - localUsers <- catMaybes <$> traverse (lift . wrapClient . API.lookupHandle) localHandles + localUsers <- catMaybes <$> traverse (lift . liftSem . API.lookupHandle) localHandles domain <- viewFederationDomain pure $ map (`Qualified` domain) localUsers -listUsersByIdsOrHandlesGetUsers :: Local x -> Range n m [Qualified Handle] -> Handler r [Qualified UserId] +listUsersByIdsOrHandlesGetUsers :: + (Member UserStore r) => + Local x -> + Range n m [Qualified Handle] -> + Handler r [Qualified UserId] listUsersByIdsOrHandlesGetUsers lself hs = do let (localHandles, _) = partitionQualified lself (fromRange hs) listUsersByIdsOrHandlesGetIds localHandles listUsersByIdsOrHandlesV3 :: forall r. - (Member UserSubsystem r) => + (Member UserSubsystem r, Member UserStore r) => UserId -> Public.ListUsersQuery -> (Handler r) [Public.UserProfile] @@ -888,7 +909,7 @@ listUsersByIdsOrHandlesV3 self q = do -- using a new return type listUsersByIdsOrHandles :: forall r. - (Member UserSubsystem r) => + (Member UserSubsystem r, Member UserStore r) => UserId -> Public.ListUsersQuery -> Handler r ListUsersById @@ -917,121 +938,101 @@ instance ToJSON GetActivationCodeResp where toJSON (GetActivationCodeResp (k, c)) = object ["key" .= k, "code" .= c] updateUser :: - ( Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member GalleyAPIAccess r, - Member TinyLog r, - Member (Input (Local ())) r, - Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r - ) => - UserId -> + (Member UserSubsystem r) => + Local UserId -> ConnId -> Public.UserUpdate -> - (Handler r) (Maybe Public.UpdateProfileError) + Handler r () updateUser uid conn uu = do - eithErr <- lift $ runExceptT $ API.updateUser uid (Just conn) uu API.ForbidSCIMUpdates - pure $ either Just (const Nothing) eithErr - + let update = + def + { name = uu.uupName, + pict = uu.uupPict, + assets = uu.uupAssets, + accentId = uu.uupAccentId + } + lift . liftSem $ + updateUserProfile uid (Just conn) UpdateOriginWireClient update + +-- | Phone based functionality is not supported any more, but the handler is +-- kept here so long as client API version 5 is supported. changePhone :: - ( Member BlacklistStore r, - Member BlacklistPhonePrefixStore r - ) => UserId -> ConnId -> Public.PhoneUpdate -> (Handler r) (Maybe Public.ChangePhoneError) -changePhone u _ (Public.puPhone -> phone) = lift . exceptTToMaybe $ do - (adata, pn) <- API.changePhone u phone - loc <- lift $ wrapClient $ API.lookupLocale u - let apair = (activationKey adata, activationCode adata) - lift . wrapClient $ sendActivationSms pn apair loc +changePhone _ _ _ = pure . Just $ Public.InvalidNewPhone -removePhone :: - ( Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member TinyLog r, - Member (Input (Local ())) r, - Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r - ) => - UserId -> - ConnId -> - (Handler r) (Maybe Public.RemoveIdentityError) -removePhone self conn = - lift . exceptTToMaybe $ API.removePhone self conn +removePhone :: UserId -> Handler r (Maybe Public.RemoveIdentityError) +removePhone self = lift . exceptTToMaybe $ API.removePhone self removeEmail :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, + Member UserKeyStore r, Member TinyLog r, Member (Input (Local ())) r, Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r + Member (ConnectionStore InternalPaging) r, + Member UserSubsystem r ) => UserId -> - ConnId -> - (Handler r) (Maybe Public.RemoveIdentityError) -removeEmail self conn = - lift . exceptTToMaybe $ API.removeEmail self conn + Handler r (Maybe Public.RemoveIdentityError) +removeEmail self = lift . exceptTToMaybe $ API.removeEmail self -checkPasswordExists :: UserId -> (Handler r) Bool -checkPasswordExists = fmap isJust . lift . wrapClient . API.lookupPassword +checkPasswordExists :: (Member PasswordStore r) => UserId -> (Handler r) Bool +checkPasswordExists = fmap isJust . lift . liftSem . lookupHashedPassword -changePassword :: UserId -> Public.PasswordChange -> (Handler r) (Maybe Public.ChangePasswordError) +changePassword :: (Member PasswordStore r, Member UserStore r) => UserId -> Public.PasswordChange -> (Handler r) (Maybe Public.ChangePasswordError) changePassword u cp = lift . exceptTToMaybe $ API.changePassword u cp changeLocale :: - ( Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member TinyLog r, - Member (Input (Local ())) r, - Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r - ) => - UserId -> + (Member UserSubsystem r) => + Local UserId -> ConnId -> Public.LocaleUpdate -> (Handler r) () -changeLocale u conn l = lift $ API.changeLocale u conn l +changeLocale lusr conn l = + lift . liftSem $ + updateUserProfile + lusr + (Just conn) + UserSubsystem.UpdateOriginWireClient + def {locale = Just l.luLocale} changeSupportedProtocols :: - ( Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member TinyLog r, - Member (Input (Local ())) r, - Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r - ) => + (Member UserSubsystem r) => Local UserId -> ConnId -> Public.SupportedProtocolUpdate -> Handler r () -changeSupportedProtocols (tUnqualified -> u) conn (Public.SupportedProtocolUpdate prots) = - lift $ API.changeSupportedProtocols u conn prots +changeSupportedProtocols u conn (Public.SupportedProtocolUpdate prots) = + lift . liftSem $ UserSubsystem.updateUserProfile u (Just conn) UpdateOriginWireClient upd + where + upd = def {supportedProtocols = Just prots} -- | (zusr is ignored by this handler, ie. checking handles is allowed as long as you have -- *any* account.) -checkHandle :: UserId -> Text -> Handler r () +checkHandle :: (Member UserSubsystem r) => UserId -> Text -> Handler r () checkHandle _uid hndl = - API.checkHandle hndl >>= \case - API.CheckHandleInvalid -> throwStd (errorToWai @'E.InvalidHandle) + lift (liftSem $ UserSubsystem.checkHandle hndl) >>= \case API.CheckHandleFound -> pure () API.CheckHandleNotFound -> throwStd (errorToWai @'E.HandleNotFound) -- | (zusr is ignored by this handler, ie. checking handles is allowed as long as you have -- *any* account.) -checkHandles :: UserId -> Public.CheckHandles -> Handler r [Handle] +checkHandles :: (Member UserSubsystem r) => UserId -> Public.CheckHandles -> Handler r [Handle] checkHandles _ (Public.CheckHandles hs num) = do - let handles = mapMaybe parseHandle (fromRange hs) - lift $ wrapHttpClient $ API.checkHandles handles (fromRange num) + let handles = mapMaybe Handle.parseHandle (fromRange hs) + lift $ liftSem $ API.checkHandles handles (fromRange num) -- | This endpoint returns UserHandleInfo instead of UserProfile for backwards -- compatibility, whereas the corresponding qualified endpoint (implemented by -- 'Handle.getHandleInfo') returns UserProfile to reduce traffic between backends -- in a federated scenario. getHandleInfoUnqualifiedH :: - ( Member UserSubsystem r + ( Member UserSubsystem r, + Member UserStore r ) => UserId -> Handle -> @@ -1041,58 +1042,48 @@ getHandleInfoUnqualifiedH self handle = do Public.UserHandleInfo . Public.profileQualifiedId <$$> Handle.getHandleInfo self (Qualified handle domain) -changeHandle :: - ( Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member GalleyAPIAccess r, - Member TinyLog r, - Member (Input (Local ())) r, - Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r - ) => - UserId -> - ConnId -> - Public.HandleUpdate -> - (Handler r) (Maybe Public.ChangeHandleError) -changeHandle u conn (Public.HandleUpdate h) = lift . exceptTToMaybe $ do - handle <- maybe (throwError Public.ChangeHandleInvalid) pure $ parseHandle h - API.changeHandle u (Just conn) handle API.ForbidSCIMUpdates +changeHandle :: (Member UserSubsystem r) => Local UserId -> ConnId -> Public.HandleUpdate -> Handler r () +changeHandle u conn (Public.HandleUpdate h) = lift $ liftSem do + UserSubsystem.updateHandle u (Just conn) UpdateOriginWireClient h beginPasswordReset :: - (Member PasswordResetStore r, Member TinyLog r) => + (Member AuthenticationSubsystem r) => Public.NewPasswordReset -> - (Handler r) () -beginPasswordReset (Public.NewPasswordReset target) = do - checkAllowlist target - (u, pair) <- API.beginPasswordReset target !>> pwResetError - loc <- lift $ wrapClient $ API.lookupLocale u - lift $ case target of - Left email -> sendPasswordResetMail email pair loc - Right phone -> wrapClient $ sendPasswordResetSms phone pair loc + Handler r () +beginPasswordReset Public.NewPasswordResetUnsupportedPhone = + throwStd (errorToWai @'E.InvalidPhone) +beginPasswordReset (Public.NewPasswordReset target) = + lift (liftSem $ createPasswordResetCode $ mkEmailKey target) completePasswordReset :: - ( Member CodeStore r, - Member PasswordResetStore r, - Member TinyLog r + ( Member AuthenticationSubsystem r ) => Public.CompletePasswordReset -> - (Handler r) () + Handler r () completePasswordReset req = do - API.completePasswordReset (Public.cpwrIdent req) (Public.cpwrCode req) (Public.cpwrPassword req) !>> pwResetError + lift . liftSem $ + resetPassword + (Public.cpwrIdent req) + (Public.cpwrCode req) + (Public.cpwrPassword req) -- docs/reference/user/activation.md {#RefActivationRequest} -- docs/reference/user/registration.md {#RefRegistration} sendActivationCode :: ( Member BlacklistStore r, - Member BlacklistPhonePrefixStore r, - Member GalleyAPIAccess r + Member EmailSubsystem r, + Member GalleyAPIAccess r, + Member UserKeyStore r ) => Public.SendActivationCode -> - (Handler r) () + Handler r () sendActivationCode Public.SendActivationCode {..} = do - either customerExtensionCheckBlockedDomains (const $ pure ()) saUserKey - checkAllowlist saUserKey - API.sendActivationCode saUserKey saLocale saCall !>> sendActCodeError + email <- case saUserKey of + Left email -> pure email + Right _ -> throwStd (errorToWai @'E.InvalidPhone) + customerExtensionCheckBlockedDomains email + checkAllowlist email + API.sendActivationCode email saLocale saCall !>> sendActCodeError -- | If the user presents an email address from a blocked domain, throw an error. -- @@ -1114,6 +1105,7 @@ createConnectionUnqualified :: ( Member GalleyAPIAccess r, Member NotificationSubsystem r, Member TinyLog r, + Member UserStore r, Member (Embed HttpClientIO) r ) => UserId -> @@ -1129,6 +1121,7 @@ createConnection :: ( Member FederationConfigStore r, Member GalleyAPIAccess r, Member NotificationSubsystem r, + Member UserStore r, Member TinyLog r, Member (Embed HttpClientIO) r ) => @@ -1236,10 +1229,15 @@ deleteSelfUser :: ( Member GalleyAPIAccess r, Member TinyLog r, Member (Embed HttpClientIO) r, + Member UserKeyStore r, Member NotificationSubsystem r, + Member UserStore r, + Member PasswordStore r, Member (Input (Local ())) r, Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r + Member (ConnectionStore InternalPaging) r, + Member EmailSubsystem r, + Member VerificationCodeSubsystem r ) => UserId -> Public.DeleteUser -> @@ -1250,10 +1248,13 @@ deleteSelfUser u body = do verifyDeleteUser :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, + Member UserStore r, Member TinyLog r, Member (Input (Local ())) r, + Member UserKeyStore r, Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r + Member (ConnectionStore InternalPaging) r, + Member VerificationCodeSubsystem r ) => Public.VerifyDeleteUser -> Handler r () @@ -1262,7 +1263,9 @@ verifyDeleteUser body = API.verifyDeleteUser body !>> deleteUserError updateUserEmail :: forall r. ( Member BlacklistStore r, - Member GalleyAPIAccess r + Member UserKeyStore r, + Member GalleyAPIAccess r, + Member EmailSubsystem r ) => UserId -> UserId -> @@ -1273,7 +1276,7 @@ updateUserEmail zuserId emailOwnerId (Public.EmailUpdate email) = do whenM (not <$> assertHasPerm maybeZuserTeamId) $ throwStd insufficientTeamPermissions maybeEmailOwnerTeamId <- lift $ wrapClient $ Data.lookupUserTeam emailOwnerId checkSameTeam maybeZuserTeamId maybeEmailOwnerTeamId - void $ API.changeSelfEmail emailOwnerId email API.AllowSCIMUpdates + void $ API.changeSelfEmail emailOwnerId email UpdateOriginWireClient where checkSameTeam :: Maybe TeamId -> Maybe TeamId -> (Handler r) () checkSameTeam (Just zuserTeamId) maybeEmailOwnerTeamId = @@ -1333,7 +1336,11 @@ activateKey (Public.Activate tgt code dryrun) sendVerificationCode :: forall r. - Member GalleyAPIAccess r => + ( Member GalleyAPIAccess r, + Member UserKeyStore r, + Member EmailSubsystem r, + Member VerificationCodeSubsystem r + ) => Public.SendVerificationCode -> (Handler r) () sendVerificationCode req = do @@ -1343,27 +1350,27 @@ sendVerificationCode req = do featureEnabled <- getFeatureStatus mbAccount case (mbAccount, featureEnabled) of (Just account, True) -> do - gen <- Code.mk6DigitGen $ Code.ForEmail email + let gen = mk6DigitVerificationCodeGen email timeout <- setVerificationTimeout <$> view settings code <- - Code.generate - gen - (Code.scopeFromAction action) - (Code.Retries 3) - timeout - (Just $ toUUID $ Public.userId $ accountUser account) - tryInsertVerificationCode code $ verificationCodeThrottledError . VerificationCodeThrottled - sendMail email (Code.codeValue code) (Just $ Public.userLocale $ accountUser account) action + lift . liftSem $ + createCodeOverwritePrevious + gen + (scopeFromAction action) + (Retries 3) + timeout + (Just $ toUUID $ Public.userId $ accountUser account) + sendMail email code.codeValue (Just $ Public.userLocale $ accountUser account) action _ -> pure () where getAccount :: Public.Email -> (Handler r) (Maybe UserAccount) getAccount email = lift $ do - mbUserId <- wrapClient . UserKey.lookupKey $ UserKey.userEmailKey email + mbUserId <- liftSem $ lookupKey $ mkEmailKey email join <$> wrapClient (Data.lookupAccount `traverse` mbUserId) sendMail :: Public.Email -> Code.Value -> Maybe Public.Locale -> Public.VerificationAction -> (Handler r) () sendMail email value mbLocale = - lift . \case + lift . liftSem . \case Public.CreateScimToken -> sendCreateScimTokenVerificationMail email value mbLocale Public.Login -> sendLoginVerificationMail email value mbLocale Public.DeleteTeam -> sendTeamDeletionVerificationMail email value mbLocale @@ -1393,19 +1400,17 @@ deprecatedOnboarding :: UserId -> JsonValue -> (Handler r) DeprecatedMatchingRes deprecatedOnboarding _ _ = pure DeprecatedMatchingResult deprecatedCompletePasswordReset :: - ( Member CodeStore r, - Member PasswordResetStore r, - Member TinyLog r + ( Member AuthenticationSubsystem r ) => Public.PasswordResetKey -> Public.PasswordReset -> (Handler r) () deprecatedCompletePasswordReset k pwr = do - API.completePasswordReset - (Public.PasswordResetIdentityKey k) - (Public.pwrCode pwr) - (Public.pwrPassword pwr) - !>> pwResetError + lift . liftSem $ + resetPassword + (Public.PasswordResetIdentityKey k) + (Public.pwrCode pwr) + (Public.pwrPassword pwr) -- Utilities diff --git a/services/brig/src/Brig/API/Public/Swagger.hs b/services/brig/src/Brig/API/Public/Swagger.hs index bce174ab17f..6db030d193f 100644 --- a/services/brig/src/Brig/API/Public/Swagger.hs +++ b/services/brig/src/Brig/API/Public/Swagger.hs @@ -164,7 +164,7 @@ eventNotificationSchemas = fst . (`S.runDeclare` mempty) <$> renderAll render @Wire.API.Event.Team.Event "Wire.API.Event.Team.Event" ] - render :: forall a. S.ToSchema a => Text -> S.Declare (S.Definitions S.Schema) () + render :: forall a. (S.ToSchema a) => Text -> S.Declare (S.Definitions S.Schema) () render eventTypeName = do eventSchema <- S.declareNamedSchema (Proxy @a) <&> view S.schema S.declare (HM.singleton eventTypeName eventSchema) diff --git a/services/brig/src/Brig/API/Types.hs b/services/brig/src/Brig/API/Types.hs index 721ec2cde36..2152214961c 100644 --- a/services/brig/src/Brig/API/Types.hs +++ b/services/brig/src/Brig/API/Types.hs @@ -28,7 +28,6 @@ module Brig.API.Types LegalHoldLoginError (..), RetryAfter (..), ListUsersById (..), - foldKey, ) where @@ -36,7 +35,6 @@ import Brig.Data.Activation (Activation (..), ActivationError (..)) import Brig.Data.Client (ClientDataError (..)) import Brig.Data.Properties (PropertiesDataError (..)) import Brig.Data.User (AuthError (..), ReAuthError (..)) -import Brig.Data.UserKey (UserKey, foldKey) import Brig.Types.Intra import Data.Code import Data.Id @@ -47,6 +45,7 @@ import Imports import Network.Wai.Utilities.Error qualified as Wai import Wire.API.Federation.Error import Wire.API.User +import Wire.UserKeyStore ------------------------------------------------------------------------------- -- Successes @@ -56,8 +55,6 @@ data CreateUserResult = CreateUserResult createdAccount :: !UserAccount, -- | Activation data for the registered email address, if any. createdEmailActivation :: !(Maybe Activation), - -- | Activation data for the registered phone number, if any. - createdPhoneActivation :: !(Maybe Activation), -- | Info of a team just created/joined createdUserTeam :: !(Maybe CreateUserTeam) } @@ -92,8 +89,8 @@ data CreateUserError | PhoneActivationError ActivationError | InvalidEmail Email String | InvalidPhone Phone - | DuplicateUserKey UserKey - | BlacklistedUserKey UserKey + | DuplicateUserKey EmailKey + | BlacklistedUserKey EmailKey | TooManyTeamMembers | UserCreationRestricted | -- | Some precondition on another Wire service failed. We propagate this error. @@ -118,7 +115,7 @@ data ConnectionError -- no verified user identity. ConnectNoIdentity | -- | An attempt at creating an invitation to a blacklisted user key. - ConnectBlacklistedUserKey UserKey + ConnectBlacklistedUserKey EmailKey | -- | An attempt at creating an invitation to an invalid email address. ConnectInvalidEmail Email String | -- | An attempt at creating an invitation to an invalid phone nbumber. @@ -169,13 +166,9 @@ data ChangeEmailError | EmailManagedByScim data SendActivationCodeError - = InvalidRecipient UserKey - | UserKeyInUse UserKey - | ActivationBlacklistedUserKey UserKey - -data SendLoginCodeError - = SendLoginInvalidPhone Phone - | SendLoginPasswordExists + = InvalidRecipient EmailKey + | UserKeyInUse EmailKey + | ActivationBlacklistedUserKey EmailKey data ClientError = ClientNotFound diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index c80dd866ff6..0e820430a54 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wno-ambiguous-fields #-} + -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2022 Wire Swiss GmbH @@ -22,27 +24,20 @@ module Brig.API.User createUserSpar, createUserInviteViaScim, checkRestrictedUserCreation, - Brig.API.User.updateUser, - changeLocale, changeSelfEmail, changeEmail, - changePhone, - changeHandle, CheckHandleResp (..), checkHandle, lookupHandle, changeManagedBy, - changeSupportedProtocols, changeAccountStatus, changeSingleAccountStatus, Data.lookupAccounts, Data.lookupAccount, - Data.lookupStatus, lookupAccountsByIdentity, lookupProfilesV3, getLegalHoldStatus, Data.lookupName, - Data.lookupLocale, Data.lookupUser, Data.lookupRichInfo, Data.lookupRichInfoMultiUsers, @@ -58,44 +53,32 @@ module Brig.API.User checkHandles, isBlacklistedHandle, Data.reauthenticate, - AllowSCIMUpdates (..), -- * Activation sendActivationCode, preverify, activate, Brig.API.User.lookupActivationCode, - Data.isActivated, -- * Password Management changePassword, - beginPasswordReset, - completePasswordReset, lookupPasswordResetCode, - Data.lookupPassword, -- * Blacklisting isBlacklisted, blacklistDelete, blacklistInsert, - -- * Phone Prefix blocking - phonePrefixGet, - phonePrefixDelete, - phonePrefixInsert, - -- * Utilities fetchUserIdentity, - hackForBlockingHandleChangeForE2EIdTeams, ) where import Brig.API.Error qualified as Error -import Brig.API.Handler qualified as API (Handler, UserNotAllowedToJoinTeam (..)) +import Brig.API.Handler qualified as API (UserNotAllowedToJoinTeam (..)) import Brig.API.Types import Brig.API.Util import Brig.App -import Brig.Code qualified as Code import Brig.Data.Activation (ActivationEvent (..), activationErrorToRegisterError) import Brig.Data.Activation qualified as Data import Brig.Data.Client qualified as Data @@ -104,30 +87,17 @@ import Brig.Data.Connection qualified as Data import Brig.Data.Properties qualified as Data import Brig.Data.User import Brig.Data.User qualified as Data -import Brig.Data.UserKey -import Brig.Data.UserKey qualified as Data -import Brig.Effects.BlacklistPhonePrefixStore (BlacklistPhonePrefixStore) -import Brig.Effects.BlacklistPhonePrefixStore qualified as BlacklistPhonePrefixStore import Brig.Effects.BlacklistStore (BlacklistStore) import Brig.Effects.BlacklistStore qualified as BlacklistStore -import Brig.Effects.CodeStore (CodeStore) -import Brig.Effects.CodeStore qualified as E import Brig.Effects.ConnectionStore (ConnectionStore) -import Brig.Effects.PasswordResetStore (PasswordResetStore) -import Brig.Effects.PasswordResetStore qualified as E import Brig.Effects.UserPendingActivationStore (UserPendingActivation (..), UserPendingActivationStore) import Brig.Effects.UserPendingActivationStore qualified as UserPendingActivationStore import Brig.IO.Intra qualified as Intra import Brig.Options hiding (Timeout, internalEvents) import Brig.Team.DB qualified as Team import Brig.Types.Activation (ActivationPair) -import Brig.Types.Connection import Brig.Types.Intra -import Brig.User.Auth.Cookie (listCookies, revokeAllCookies) -import Brig.User.Email -import Brig.User.Handle -import Brig.User.Handle.Blacklist -import Brig.User.Phone +import Brig.User.Auth.Cookie qualified as Auth import Brig.User.Search.Index (reindex) import Brig.User.Search.TeamSize qualified as TeamSize import Cassandra hiding (Set) @@ -137,13 +107,12 @@ import Control.Monad.Catch import Data.ByteString.Conversion import Data.Code import Data.Currency qualified as Currency -import Data.Handle (Handle (fromHandle), parseHandle) +import Data.Handle (Handle (fromHandle)) import Data.Id as Id import Data.Json.Util import Data.LegalHold (UserLegalHoldStatus (..), defUserLegalHoldStatus) import Data.List.Extra import Data.List1 as List1 (List1, singleton) -import Data.Metrics qualified as Metrics import Data.Misc import Data.Qualified import Data.Range @@ -155,6 +124,7 @@ import Polysemy import Polysemy.Input (Input) import Polysemy.TinyLog (TinyLog) import Polysemy.TinyLog qualified as Log +import Prometheus qualified as Prom import System.Logger.Message import UnliftIO.Async (mapConcurrently_) import Wire.API.Connection @@ -173,50 +143,55 @@ import Wire.API.Team.Size import Wire.API.User import Wire.API.User.Activation import Wire.API.User.Client -import Wire.API.User.Password import Wire.API.User.RichInfo import Wire.API.UserEvent +import Wire.AuthenticationSubsystem (AuthenticationSubsystem, internalLookupPasswordResetCode) import Wire.DeleteQueue +import Wire.EmailSubsystem +import Wire.Error import Wire.GalleyAPIAccess as GalleyAPIAccess import Wire.NotificationSubsystem +import Wire.PasswordStore (PasswordStore, lookupHashedPassword, upsertHashedPassword) import Wire.Sem.Concurrency import Wire.Sem.Paging.Cassandra (InternalPaging) -import Wire.UserSubsystem - -data AllowSCIMUpdates - = AllowSCIMUpdates - | ForbidSCIMUpdates - deriving (Show, Eq, Ord) +import Wire.UserKeyStore +import Wire.UserStore +import Wire.UserSubsystem as User +import Wire.UserSubsystem.HandleBlacklist +import Wire.VerificationCode qualified as VerificationCode +import Wire.VerificationCodeGen (mkVerificationCodeGen) +import Wire.VerificationCodeSubsystem ------------------------------------------------------------------------------- -- Create User data IdentityError = IdentityErrorBlacklistedEmail - | IdentityErrorBlacklistedPhone | IdentityErrorUserKeyExists identityErrorToRegisterError :: IdentityError -> RegisterError identityErrorToRegisterError = \case IdentityErrorBlacklistedEmail -> RegisterErrorBlacklistedEmail - IdentityErrorBlacklistedPhone -> RegisterErrorBlacklistedPhone IdentityErrorUserKeyExists -> RegisterErrorUserKeyExists -identityErrorToBrigError :: IdentityError -> Error.Error +identityErrorToBrigError :: IdentityError -> HttpError identityErrorToBrigError = \case - IdentityErrorBlacklistedEmail -> Error.StdError $ errorToWai @'E.BlacklistedEmail - IdentityErrorBlacklistedPhone -> Error.StdError $ errorToWai @'E.BlacklistedPhone - IdentityErrorUserKeyExists -> Error.StdError $ errorToWai @'E.UserKeyExists + IdentityErrorBlacklistedEmail -> StdError $ errorToWai @'E.BlacklistedEmail + IdentityErrorUserKeyExists -> StdError $ errorToWai @'E.UserKeyExists -verifyUniquenessAndCheckBlacklist :: Member BlacklistStore r => UserKey -> ExceptT IdentityError (AppT r) () +verifyUniquenessAndCheckBlacklist :: + ( Member BlacklistStore r, + Member UserKeyStore r + ) => + EmailKey -> + ExceptT IdentityError (AppT r) () verifyUniquenessAndCheckBlacklist uk = do - wrapClientE $ checkKey Nothing uk + checkKey Nothing uk blacklisted <- lift $ liftSem $ BlacklistStore.exists uk - when blacklisted $ - throwE (foldKey (const IdentityErrorBlacklistedEmail) (const IdentityErrorBlacklistedPhone) uk) + when blacklisted $ throwE IdentityErrorBlacklistedEmail where checkKey u k = do - av <- lift $ Data.keyAvailable k u + av <- lift $ liftSem $ keyAvailable k u unless av $ throwE IdentityErrorUserKeyExists @@ -228,6 +203,7 @@ createUserSpar :: Member TinyLog r, Member (Input (Local ())) r, Member (Input UTCTime) r, + Member UserSubsystem r, Member (ConnectionStore InternalPaging) r ) => NewUserSpar -> @@ -255,23 +231,21 @@ createUserSpar new = do pure account -- Add to team - userTeam <- withExceptT CreateUserSparRegistrationError $ addUserToTeamSSO account tid (SSOIdentity ident Nothing Nothing) (newUserSparRole new) + userTeam <- withExceptT CreateUserSparRegistrationError $ addUserToTeamSSO account tid (SSOIdentity ident Nothing) (newUserSparRole new) -- Set up feature flags - let uid = userId (accountUser account) - lift $ initAccountFeatureConfig uid + luid <- lift $ ensureLocal (userQualifiedId (accountUser account)) + lift $ initAccountFeatureConfig (tUnqualified luid) -- Set handle - updateHandle' uid handle' + lift $ updateHandle' luid handle' - pure $! CreateUserResult account Nothing Nothing (Just userTeam) + pure $! CreateUserResult account Nothing (Just userTeam) where - updateHandle' :: UserId -> Maybe Handle -> ExceptT CreateUserSparError (AppT r) () + updateHandle' :: Local UserId -> Maybe Handle -> AppT r () updateHandle' _ Nothing = pure () - updateHandle' uid (Just h) = do - case parseHandle . fromHandle $ h of - Just handl -> withExceptT CreateUserSparHandleError $ changeHandle uid Nothing handl AllowSCIMUpdates - Nothing -> throwE $ CreateUserSparHandleError ChangeHandleInvalid + updateHandle' luid (Just h) = + liftSem $ User.updateHandle luid Nothing UpdateOriginScim (fromHandle h) addUserToTeamSSO :: UserAccount -> TeamId -> UserIdentity -> Role -> ExceptT RegisterError (AppT r) CreateUserTeam addUserToTeamSSO account tid ident role = do @@ -296,6 +270,7 @@ createUser :: ( Member BlacklistStore r, Member GalleyAPIAccess r, Member (UserPendingActivationStore p) r, + Member UserKeyStore r, Member TinyLog r, Member (Embed HttpClientIO) r, Member NotificationSubsystem r, @@ -306,13 +281,13 @@ createUser :: NewUser -> ExceptT RegisterError (AppT r) CreateUserResult createUser new = do - (email, phone) <- validateEmailAndPhone new + email <- validateEmailAndPhone new -- get invitation and existing account (mNewTeamUser, teamInvitation, tid) <- case newUserTeam new of Just (NewTeamMember i) -> do - mbTeamInv <- findTeamInvitation (userEmailKey <$> email) i + mbTeamInv <- findTeamInvitation (mkEmailKey <$> email) i case mbTeamInv of Just (inv, info, tid) -> pure (Nothing, Just (inv, info), Just tid) @@ -329,7 +304,7 @@ createUser new = do let (new', mbHandle) = case mbExistingAccount of Nothing -> - ( new {newUserIdentity = newIdentity email phone (newUserSSOId new)}, + ( new {newUserIdentity = newIdentity email (newUserSSOId new)}, Nothing ) Just existingAccount -> @@ -343,7 +318,7 @@ createUser new = do _ -> newUserSSOId new in ( new { newUserManagedBy = Just (userManagedBy existingUser), - newUserIdentity = newIdentity email phone mbSSOid + newUserIdentity = newIdentity email mbSSOid }, userHandle existingUser ) @@ -381,13 +356,13 @@ createUser new = do joinedTeamInvite <- case teamInvitation of Just (inv, invInfo) -> do let em = Team.inInviteeEmail inv - acceptTeamInvitation account inv invInfo (userEmailKey em) (EmailIdentity em) + acceptTeamInvitation account inv invInfo (mkEmailKey em) (EmailIdentity em) Team.TeamName nm <- lift $ liftSem $ GalleyAPIAccess.getTeamName (Team.inTeam inv) pure (Just $ CreateUserTeam (Team.inTeam inv) nm) Nothing -> pure Nothing joinedTeamSSO <- case (newUserIdentity new', tid) of - (Just ident@(SSOIdentity (UserSSOId _) _ _), Just tid') -> Just <$> addUserToTeamSSO account tid' ident + (Just ident@(SSOIdentity (UserSSOId _) _), Just tid') -> Just <$> addUserToTeamSSO account tid' ident _ -> pure Nothing pure (activatedTeam <|> joinedTeamInvite <|> joinedTeamSSO) @@ -397,15 +372,13 @@ createUser new = do then pure Nothing else handleEmailActivation email uid mNewTeamUser - pdata <- handlePhoneActivation phone uid - lift $ initAccountFeatureConfig uid - pure $! CreateUserResult account edata pdata createUserTeam + pure $! CreateUserResult account edata createUserTeam where -- NOTE: all functions in the where block don't use any arguments of createUser - validateEmailAndPhone :: NewUser -> ExceptT RegisterError (AppT r) (Maybe Email, Maybe Phone) + validateEmailAndPhone :: NewUser -> ExceptT RegisterError (AppT r) (Maybe Email) validateEmailAndPhone newUser = do -- Validate e-mail email <- for (newUserEmail newUser) $ \e -> @@ -414,19 +387,16 @@ createUser new = do pure (validateEmail e) - -- Validate phone - phone <- for (newUserPhone newUser) $ \p -> - maybe - (throwE RegisterErrorInvalidPhone) - pure - =<< lift (wrapClient $ validatePhone p) + -- Disallow registering a user with a phone number + when (isJust (newUserPhone newUser)) $ + throwE RegisterErrorInvalidPhone - for_ (catMaybes [userEmailKey <$> email, userPhoneKey <$> phone]) $ \k -> + for_ (mkEmailKey <$> email) $ \k -> verifyUniquenessAndCheckBlacklist k !>> identityErrorToRegisterError - pure (email, phone) + pure email - findTeamInvitation :: Maybe UserKey -> InvitationCode -> ExceptT RegisterError (AppT r) (Maybe (Team.Invitation, Team.InvitationInfo, TeamId)) + findTeamInvitation :: Maybe EmailKey -> InvitationCode -> ExceptT RegisterError (AppT r) (Maybe (Team.Invitation, Team.InvitationInfo, TeamId)) findTeamInvitation Nothing _ = throwE RegisterErrorMissingIdentity findTeamInvitation (Just e) c = lift (wrapClient $ Team.lookupInvitationInfo c) >>= \case @@ -434,7 +404,7 @@ createUser new = do inv <- lift . wrapClient $ Team.lookupInvitation HideInvitationUrl (Team.iiTeam ii) (Team.iiInvId ii) case (inv, Team.inInviteeEmail <$> inv) of (Just invite, Just em) - | e == userEmailKey em -> do + | e == mkEmailKey em -> do _ <- ensureMemberCanJoin (Team.iiTeam ii) pure $ Just (invite, ii, Team.iiTeam ii) _ -> throwE RegisterErrorInvalidInvitationCode @@ -457,12 +427,12 @@ createUser new = do UserAccount -> Team.Invitation -> Team.InvitationInfo -> - UserKey -> + EmailKey -> UserIdentity -> ExceptT RegisterError (AppT r) () acceptTeamInvitation account inv ii uk ident = do let uid = userId (accountUser account) - ok <- lift . wrapClient $ Data.claimKey uk uid + ok <- lift $ liftSem $ claimKey uk uid unless ok $ throwE RegisterErrorUserKeyExists let minvmeta :: (Maybe (UserId, UTCTimeMillis), Role) @@ -502,7 +472,7 @@ createUser new = do -- Handle e-mail activation (deprecated, see #RefRegistrationNoPreverification in /docs/reference/user/registration.md) handleEmailActivation :: Maybe Email -> UserId -> Maybe BindingNewTeamUser -> ExceptT RegisterError (AppT r) (Maybe Activation) handleEmailActivation email uid newTeam = do - fmap join . for (userEmailKey <$> email) $ \ek -> case newUserEmailCode new of + fmap join . for (mkEmailKey <$> email) $ \ek -> case newUserEmailCode new of Nothing -> do timeout <- setActivationTimeout <$> view settings edata <- lift . wrapClient $ Data.newActivation ek timeout (Just uid) @@ -518,41 +488,25 @@ createUser new = do !>> activationErrorToRegisterError pure Nothing - -- Handle phone activation (deprecated, see #RefRegistrationNoPreverification in /docs/reference/user/registration.md) - handlePhoneActivation :: Maybe Phone -> UserId -> ExceptT RegisterError (AppT r) (Maybe Activation) - handlePhoneActivation phone uid = do - fmap join . for (userPhoneKey <$> phone) $ \pk -> case newUserPhoneCode new of - Nothing -> do - timeout <- setActivationTimeout <$> view settings - pdata <- lift . wrapClient $ Data.newActivation pk timeout (Just uid) - lift . liftSem . Log.info $ - field "user" (toByteString uid) - . field "activation.key" (toByteString $ activationKey pdata) - . msg (val "Created phone activation key/code pair") - pure $ Just pdata - Just c -> do - ak <- liftIO $ Data.mkActivationKey pk - void $ activate (ActivateKey ak) c (Just uid) !>> activationErrorToRegisterError - pure Nothing - initAccountFeatureConfig :: UserId -> (AppT r) () initAccountFeatureConfig uid = do mbCciDefNew <- view (settings . getAfcConferenceCallingDefNewMaybe) forM_ (forgetLock <$> mbCciDefNew) $ wrapClient . Data.updateFeatureConferenceCalling uid . Just --- | 'createUser' is becoming hard to maintian, and instead of adding more case distinctions +-- | 'createUser' is becoming hard to maintain, and instead of adding more case distinctions -- all over the place there, we add a new function that handles just the one new flow where -- users are invited to the team via scim. createUserInviteViaScim :: ( Member BlacklistStore r, + Member UserKeyStore r, Member (UserPendingActivationStore p) r, Member TinyLog r ) => NewUserScimInvitation -> - ExceptT Error.Error (AppT r) UserAccount + ExceptT HttpError (AppT r) UserAccount createUserInviteViaScim (NewUserScimInvitation tid uid loc name rawEmail _) = do - email <- either (const . throwE . Error.StdError $ errorToWai @'E.InvalidEmail) pure (validateEmail rawEmail) - let emKey = userEmailKey email + email <- either (const . throwE . StdError $ errorToWai @'E.InvalidEmail) pure (validateEmail rawEmail) + let emKey = mkEmailKey email verifyUniquenessAndCheckBlacklist emKey !>> identityErrorToBrigError account <- lift . wrapClient $ newAccountInviteViaScim uid tid loc name email lift . liftSem . Log.debug $ field "user" (toByteString . userId . accountUser $ account) . field "action" (val "User.createUserInviteViaScim") @@ -584,60 +538,6 @@ checkRestrictedUserCreation new = do ) $ throwE RegisterErrorUserCreationRestricted -------------------------------------------------------------------------------- --- Update Profile - -updateUser :: - ( Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member GalleyAPIAccess r, - Member TinyLog r, - Member (Input (Local ())) r, - Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r - ) => - UserId -> - Maybe ConnId -> - UserUpdate -> - AllowSCIMUpdates -> - ExceptT UpdateProfileError (AppT r) () -updateUser uid mconn uu allowScim = do - for_ (uupName uu) $ \newName -> do - mbUser <- lift . wrapClient $ Data.lookupUser WithPendingInvitations uid - user <- maybe (throwE ProfileNotFound) pure mbUser - unless - ( userManagedBy user /= ManagedByScim - || userDisplayName user == newName - || allowScim == AllowSCIMUpdates - ) - $ throwE DisplayNameManagedByScim - hasE2EId <- lift . liftSem . userUnderE2EId $ uid - when (hasE2EId && newName /= userDisplayName user) $ - throwE DisplayNameManagedByScim - - lift $ do - wrapClient $ Data.updateUser uid uu - liftSem $ Intra.onUserEvent uid mconn (profileUpdated uid uu) - -------------------------------------------------------------------------------- --- Update Locale - -changeLocale :: - ( Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member TinyLog r, - Member (Input (Local ())) r, - Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r - ) => - UserId -> - ConnId -> - LocaleUpdate -> - (AppT r) () -changeLocale uid conn (LocaleUpdate loc) = do - wrapClient $ Data.updateLocale uid loc - liftSem $ Intra.onUserEvent uid (Just conn) (localeUpdate uid loc) - ------------------------------------------------------------------------------- -- Update ManagedBy @@ -657,149 +557,43 @@ changeManagedBy uid conn (ManagedByUpdate mb) = do wrapClient $ Data.updateManagedBy uid mb liftSem $ Intra.onUserEvent uid (Just conn) (managedByUpdate uid mb) -------------------------------------------------------------------------------- --- Update supported protocols - -changeSupportedProtocols :: - ( Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member TinyLog r, - Member (Input (Local ())) r, - Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r - ) => - UserId -> - ConnId -> - Set BaseProtocolTag -> - AppT r () -changeSupportedProtocols uid conn prots = do - wrapClient $ Data.updateSupportedProtocols uid prots - liftSem $ Intra.onUserEvent uid (Just conn) (supportedProtocolUpdate uid prots) - --------------------------------------------------------------------------------- --- Change Handle - -changeHandle :: - ( Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member GalleyAPIAccess r, - Member TinyLog r, - Member (Input (Local ())) r, - Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r - ) => - UserId -> - Maybe ConnId -> - Handle -> - AllowSCIMUpdates -> - ExceptT ChangeHandleError (AppT r) () -changeHandle uid mconn hdl allowScim = do - when (isBlacklistedHandle hdl) $ - throwE ChangeHandleInvalid - usr <- lift $ wrapClient $ Data.lookupUser WithPendingInvitations uid - case usr of - Nothing -> throwE ChangeHandleNoIdentity - Just u -> do - unless - ( userManagedBy u /= ManagedByScim - || Just hdl == userHandle u - || allowScim == AllowSCIMUpdates - ) - $ throwE ChangeHandleManagedByScim - hasE2EId <- lift . liftSem . userUnderE2EId . userId $ u - when (hasE2EId && userHandle u `notElem` [Nothing, Just hdl]) $ - throwE ChangeHandleManagedByScim - claim u - where - claim u = do - unless (isJust (userIdentity u)) $ - throwE ChangeHandleNoIdentity - claimed <- lift . wrapClient $ claimHandle (userId u) (userHandle u) hdl - unless claimed $ - throwE ChangeHandleExists - lift $ liftSem $ Intra.onUserEvent uid mconn (handleUpdated uid hdl) - --------------------------------------------------------------------------------- --- Check Handle - -data CheckHandleResp - = CheckHandleInvalid - | CheckHandleFound - | CheckHandleNotFound - -checkHandle :: Text -> API.Handler r CheckHandleResp -checkHandle uhandle = do - xhandle <- validateHandle uhandle - owner <- lift . wrapClient $ lookupHandle xhandle - if - | isJust owner -> - -- Handle is taken (=> getHandleInfo will return 200) - pure CheckHandleFound - | isBlacklistedHandle xhandle -> - -- Handle is free but cannot be taken - -- - -- FUTUREWORK: i wonder if this is correct? isn't this the error for malformed - -- handles? shouldn't we throw not-found here? or should there be a fourth case - -- 'CheckHandleBlacklisted'? - pure CheckHandleInvalid - | otherwise -> - -- Handle is free and can be taken - pure CheckHandleNotFound - --------------------------------------------------------------------------------- --- Check Handles - -checkHandles :: MonadClient m => [Handle] -> Word -> m [Handle] -checkHandles check num = reverse <$> collectFree [] check num - where - collectFree free _ 0 = pure free - collectFree free [] _ = pure free - collectFree free (h : hs) n = - if isBlacklistedHandle h - then collectFree free hs n - else do - owner <- glimpseHandle h - case owner of - Nothing -> collectFree (h : free) hs (n - 1) - Just _ -> collectFree free hs n - ------------------------------------------------------------------------------- -- Change Email -- | Call 'changeEmail' and process result: if email changes to itself, succeed, if not, send -- validation email. -changeSelfEmail :: Member BlacklistStore r => UserId -> Email -> AllowSCIMUpdates -> ExceptT Error.Error (AppT r) ChangeEmailResponse +changeSelfEmail :: (Member BlacklistStore r, Member UserKeyStore r, Member EmailSubsystem r) => UserId -> Email -> UpdateOriginType -> ExceptT HttpError (AppT r) ChangeEmailResponse changeSelfEmail u email allowScim = do changeEmail u email allowScim !>> Error.changeEmailError >>= \case ChangeEmailIdempotent -> pure ChangeEmailResponseIdempotent ChangeEmailNeedsActivation (usr, adata, en) -> lift $ do - sendOutEmail usr adata en + liftSem $ sendOutEmail usr adata en wrapClient $ Data.updateEmailUnvalidated u email wrapClient $ reindex u pure ChangeEmailResponseNeedsActivation where sendOutEmail usr adata en = do - sendActivationMail + (maybe sendActivationMail (const sendEmailAddressUpdateMail) usr.userIdentity) en (userDisplayName usr) - (activationKey adata, activationCode adata) + (activationKey adata) + (activationCode adata) (Just (userLocale usr)) - (userIdentity usr) -- | Prepare changing the email (checking a number of invariants). -changeEmail :: Member BlacklistStore r => UserId -> Email -> AllowSCIMUpdates -> ExceptT ChangeEmailError (AppT r) ChangeEmailResult -changeEmail u email allowScim = do +changeEmail :: (Member BlacklistStore r, Member UserKeyStore r) => UserId -> Email -> UpdateOriginType -> ExceptT ChangeEmailError (AppT r) ChangeEmailResult +changeEmail u email updateOrigin = do em <- either (throwE . InvalidNewEmail email) pure (validateEmail email) - let ek = userEmailKey em + let ek = mkEmailKey em blacklisted <- lift . liftSem $ BlacklistStore.exists ek when blacklisted $ throwE (ChangeBlacklistedEmail email) - available <- lift . wrapClient $ Data.keyAvailable ek (Just u) + available <- lift $ liftSem $ keyAvailable ek (Just u) unless available $ throwE $ EmailExists email @@ -808,142 +602,60 @@ changeEmail u email allowScim = do -- The user already has an email address and the new one is exactly the same Just current | current == em -> pure ChangeEmailIdempotent _ -> do - unless - ( userManagedBy usr /= ManagedByScim - || allowScim == AllowSCIMUpdates - ) - $ throwE EmailManagedByScim + unless (userManagedBy usr /= ManagedByScim || updateOrigin == UpdateOriginScim) $ + throwE EmailManagedByScim timeout <- setActivationTimeout <$> view settings act <- lift . wrapClient $ Data.newActivation ek timeout (Just u) pure $ ChangeEmailNeedsActivation (usr, act, em) -------------------------------------------------------------------------------- --- Change Phone - -changePhone :: - ( Member BlacklistStore r, - Member BlacklistPhonePrefixStore r - ) => - UserId -> - Phone -> - ExceptT ChangePhoneError (AppT r) (Activation, Phone) -changePhone u phone = do - canonical <- - maybe - (throwE InvalidNewPhone) - pure - =<< lift (wrapClient $ validatePhone phone) - let pk = userPhoneKey canonical - available <- lift . wrapClient $ Data.keyAvailable pk (Just u) - unless available $ - throwE PhoneExists - timeout <- setActivationTimeout <$> view settings - blacklisted <- lift . liftSem $ BlacklistStore.exists pk - when blacklisted $ - throwE BlacklistedNewPhone - -- check if any prefixes of this phone number are blocked - prefixExcluded <- lift . liftSem $ BlacklistPhonePrefixStore.existsAny canonical - when prefixExcluded $ - throwE BlacklistedNewPhone - act <- lift . wrapClient $ Data.newActivation pk timeout (Just u) - pure (act, canonical) - ------------------------------------------------------------------------------- -- Remove Email removeEmail :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, + Member UserKeyStore r, Member TinyLog r, Member (Input (Local ())) r, Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r + Member (ConnectionStore InternalPaging) r, + Member UserSubsystem r ) => UserId -> - ConnId -> ExceptT RemoveIdentityError (AppT r) () -removeEmail uid conn = do +removeEmail uid = do ident <- lift $ fetchUserIdentity uid case ident of - Just (FullIdentity e _) -> lift $ do - wrapClient . deleteKey $ userEmailKey e + Just (SSOIdentity (UserSSOId _) (Just e)) -> lift $ do + liftSem $ deleteKey $ mkEmailKey e wrapClient $ Data.deleteEmail uid - liftSem $ Intra.onUserEvent uid (Just conn) (emailRemoved uid e) + liftSem $ Intra.onUserEvent uid Nothing (emailRemoved uid e) Just _ -> throwE LastIdentity Nothing -> throwE NoIdentity ------------------------------------------------------------------------------- -- Remove Phone -removePhone :: - ( Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member TinyLog r, - Member (Input (Local ())) r, - Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r - ) => - UserId -> - ConnId -> - ExceptT RemoveIdentityError (AppT r) () -removePhone uid conn = do - ident <- lift $ fetchUserIdentity uid - case ident of - Just (FullIdentity _ p) -> do - pw <- lift . wrapClient $ Data.lookupPassword uid - unless (isJust pw) $ - throwE NoPassword - lift $ do - wrapClient . deleteKey $ userPhoneKey p - wrapClient $ Data.deletePhone uid - liftSem $ Intra.onUserEvent uid (Just conn) (phoneRemoved uid p) - Just _ -> throwE LastIdentity - Nothing -> throwE NoIdentity +-- | Phones are not supported any longer. +removePhone :: UserId -> ExceptT RemoveIdentityError (AppT r) () +removePhone _uid = pure () ------------------------------------------------------------------------------- -- Forcefully revoke a verified identity +-- | Now that a user can only have an email-based identity, revoking an identity +-- boils down to deactivating the user. revokeIdentity :: - forall r. - ( Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member TinyLog r, - Member (Input (Local ())) r, - Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r + ( Member UserSubsystem r, + Member UserKeyStore r ) => - Either Email Phone -> + Email -> AppT r () revokeIdentity key = do - let uk = either userEmailKey userPhoneKey key - mu <- wrapClient $ Data.lookupKey uk - case mu of - Nothing -> pure () - Just u -> - fetchUserIdentity u >>= \case - Just (FullIdentity _ _) -> revokeKey u uk - Just (EmailIdentity e) | Left e == key -> do - revokeKey u uk - wrapClient $ Data.deactivateUser u - Just (PhoneIdentity p) | Right p == key -> do - revokeKey u uk - wrapClient $ Data.deactivateUser u - _ -> pure () - where - revokeKey :: UserId -> UserKey -> AppT r () - revokeKey u uk = do - wrapClient $ deleteKey uk - wrapClient $ - foldKey - (\(_ :: Email) -> Data.deleteEmail u) - (\(_ :: Phone) -> Data.deletePhone u) - uk - liftSem $ - Intra.onUserEvent u Nothing $ - foldKey - (emailRemoved u) - (phoneRemoved u) - uk + mu <- liftSem . lookupKey . mkEmailKey $ key + for_ mu $ \u -> do + deactivate <- maybe False (not . isSSOIdentity) <$> fetchUserIdentity u + when deactivate . wrapClient . Data.deactivateUser $ u ------------------------------------------------------------------------------- -- Change Account Status @@ -996,7 +708,7 @@ mkUserEvent usrs status = case status of Active -> pure UserResumed Suspended -> do - lift $ wrapHttpClient (mapConcurrently_ revokeAllCookies usrs) + lift $ wrapHttpClient (mapConcurrently_ Auth.revokeAllCookies usrs) pure UserSuspended Deleted -> throwE InvalidAccountStatus Ephemeral -> throwE InvalidAccountStatus @@ -1078,7 +790,7 @@ onActivated :: Member (ConnectionStore InternalPaging) r ) => ActivationEvent -> - (AppT r) (UserId, Maybe UserIdentity, Bool) + AppT r (UserId, Maybe UserIdentity, Bool) onActivated (AccountActivated account) = liftSem $ do let uid = userId (accountUser account) Log.debug $ field "user" (toByteString uid) . field "action" (val "User.onActivated") @@ -1089,65 +801,36 @@ onActivated (EmailActivated uid email) = do liftSem $ Intra.onUserEvent uid Nothing (emailUpdated uid email) wrapHttpClient $ Data.deleteEmailUnvalidated uid pure (uid, Just (EmailIdentity email), False) -onActivated (PhoneActivated uid phone) = do - liftSem $ Intra.onUserEvent uid Nothing (phoneUpdated uid phone) - pure (uid, Just (PhoneIdentity phone), False) -- docs/reference/user/activation.md {#RefActivationRequest} sendActivationCode :: ( Member BlacklistStore r, - Member BlacklistPhonePrefixStore r, - Member GalleyAPIAccess r + Member EmailSubsystem r, + Member GalleyAPIAccess r, + Member UserKeyStore r ) => - Either Email Phone -> + Email -> Maybe Locale -> Bool -> ExceptT SendActivationCodeError (AppT r) () -sendActivationCode emailOrPhone loc call = case emailOrPhone of - Left email -> do - ek <- - either - (const . throwE . InvalidRecipient $ userEmailKey email) - (pure . userEmailKey) - (validateEmail email) - exists <- lift $ isJust <$> wrapClient (Data.lookupKey ek) - when exists $ - throwE $ - UserKeyInUse ek - blacklisted <- lift . liftSem $ BlacklistStore.exists ek - when blacklisted $ - throwE (ActivationBlacklistedUserKey ek) - uc <- lift . wrapClient $ Data.lookupActivationCode ek - case uc of - Nothing -> sendVerificationEmail ek Nothing -- Fresh code request, no user - Just (Nothing, c) -> sendVerificationEmail ek (Just c) -- Re-requesting existing code - Just (Just uid, c) -> sendActivationEmail ek c uid -- User re-requesting activation - Right phone -> do - -- validatePhone returns the canonical E.164 phone number format - canonical <- - maybe - (throwE $ InvalidRecipient (userPhoneKey phone)) - pure - =<< lift (wrapClient $ validatePhone phone) - let pk = userPhoneKey canonical - exists <- lift $ isJust <$> wrapClient (Data.lookupKey pk) - when exists $ - throwE $ - UserKeyInUse pk - blacklisted <- lift . liftSem $ BlacklistStore.exists pk - when blacklisted $ - throwE (ActivationBlacklistedUserKey pk) - -- check if any prefixes of this phone number are blocked - prefixExcluded <- lift . liftSem $ BlacklistPhonePrefixStore.existsAny canonical - when prefixExcluded $ - throwE (ActivationBlacklistedUserKey pk) - c <- lift . wrapClient $ fmap snd <$> Data.lookupActivationCode pk - p <- wrapClientE $ mkPair pk c Nothing - void . forPhoneKey pk $ \ph -> - lift $ - if call - then wrapClient $ sendActivationCall ph p loc - else wrapClient $ sendActivationSms ph p loc +sendActivationCode email loc _call = do + ek <- + either + (const . throwE . InvalidRecipient $ mkEmailKey email) + (pure . mkEmailKey) + (validateEmail email) + exists <- lift $ liftSem $ isJust <$> lookupKey ek + when exists $ + throwE $ + UserKeyInUse ek + blacklisted <- lift . liftSem $ BlacklistStore.exists ek + when blacklisted $ + throwE (ActivationBlacklistedUserKey ek) + uc <- lift . wrapClient $ Data.lookupActivationCode ek + case uc of + Nothing -> sendVerificationEmail ek Nothing -- Fresh code request, no user + Just (Nothing, c) -> sendVerificationEmail ek (Just c) -- Re-requesting existing code + Just (Just uid, c) -> sendActivationEmail ek c uid -- User re-requesting activation where notFound = throwM . UserDisplayNameNotFound mkPair k c u = do @@ -1158,19 +841,19 @@ sendActivationCode emailOrPhone loc call = case emailOrPhone of dat <- Data.newActivation k timeout u pure (activationKey dat, activationCode dat) sendVerificationEmail ek uc = do - p <- wrapClientE $ mkPair ek uc Nothing - void . forEmailKey ek $ \em -> - lift $ - sendVerificationMail em p loc + (key, code) <- wrapClientE $ mkPair ek uc Nothing + let em = emailKeyOrig ek + lift $ liftSem $ sendVerificationMail em key code loc sendActivationEmail ek uc uid = do -- FUTUREWORK(fisx): we allow for 'PendingInvitations' here, but I'm not sure this -- top-level function isn't another piece of a deprecated onboarding flow? u <- maybe (notFound uid) pure =<< lift (wrapClient $ Data.lookupUser WithPendingInvitations uid) - p <- wrapClientE $ mkPair ek (Just uc) (Just uid) + (aKey, aCode) <- wrapClientE $ mkPair ek (Just uc) (Just uid) let ident = userIdentity u name = userDisplayName u loc' = loc <|> Just (userLocale u) - void . forEmailKey ek $ \em -> lift $ do + em = emailKeyOrig ek + lift $ do -- Get user's team, if any. mbTeam <- mapM (fmap Team.tdTeam . liftSem . GalleyAPIAccess.getTeam) (userTeam u) -- Depending on whether the user is a team creator, send either @@ -1180,9 +863,9 @@ sendActivationCode emailOrPhone loc call = case emailOrPhone of case mbTeam of Just team | team ^. teamCreator == uid -> - sendTeamActivationMail em name p loc' (team ^. teamName) + liftSem $ sendTeamActivationMail em name aKey aCode loc' (team ^. teamName) _otherwise -> - sendActivationMail em name p loc' ident + liftSem $ (maybe sendActivationMail (const sendEmailAddressUpdateMail) ident) em name aKey aCode loc' mkActivationKey :: (MonadClient m, MonadReader Env m) => ActivationTarget -> ExceptT ActivationError m ActivationKey mkActivationKey (ActivateKey k) = pure k @@ -1190,29 +873,24 @@ mkActivationKey (ActivateEmail e) = do ek <- either (throwE . InvalidActivationEmail e) - (pure . userEmailKey) + (pure . mkEmailKey) (validateEmail e) liftIO $ Data.mkActivationKey ek -mkActivationKey (ActivatePhone p) = do - pk <- - maybe - (throwE $ InvalidActivationPhone p) - (pure . userPhoneKey) - =<< lift (validatePhone p) - liftIO $ Data.mkActivationKey pk +mkActivationKey (ActivatePhone p) = throwE $ InvalidActivationPhone p ------------------------------------------------------------------------------- -- Password Management -changePassword :: UserId -> PasswordChange -> ExceptT ChangePasswordError (AppT r) () +changePassword :: (Member PasswordStore r, Member UserStore r) => UserId -> PasswordChange -> ExceptT ChangePasswordError (AppT r) () changePassword uid cp = do - activated <- lift . wrapClient $ Data.isActivated uid + activated <- lift $ liftSem $ isActivated uid unless activated $ throwE ChangePasswordNoIdentity - currpw <- lift . wrapClient $ Data.lookupPassword uid + currpw <- lift $ liftSem $ lookupHashedPassword uid let newpw = cpNewPassword cp + hashedNewPw <- mkSafePasswordScrypt newpw case (currpw, cpOldPassword cp) of - (Nothing, _) -> lift . wrapClient $ Data.updatePassword uid newpw + (Nothing, _) -> lift . liftSem $ upsertHashedPassword uid hashedNewPw (Just _, Nothing) -> throwE InvalidCurrentPassword (Just pw, Just pw') -> do -- We are updating the pwd here anyway, so we don't care about the pwd status @@ -1220,72 +898,7 @@ changePassword uid cp = do throwE InvalidCurrentPassword when (verifyPassword newpw pw) $ throwE ChangePasswordMustDiffer - lift $ wrapClient (Data.updatePassword uid newpw) >> wrapClient (revokeAllCookies uid) - -beginPasswordReset :: - ( Member TinyLog r, - Member PasswordResetStore r - ) => - Either Email Phone -> - ExceptT PasswordResetError (AppT r) (UserId, PasswordResetPair) -beginPasswordReset target = do - let key = either userEmailKey userPhoneKey target - user <- lift (wrapClient $ Data.lookupKey key) >>= maybe (throwE InvalidPasswordResetKey) pure - lift . liftSem . Log.debug $ field "user" (toByteString user) . field "action" (val "User.beginPasswordReset") - status <- lift . wrapClient $ Data.lookupStatus user - unless (status == Just Active) $ - throwE InvalidPasswordResetKey - code <- lift . liftSem $ E.lookupPasswordResetCode user - when (isJust code) $ - throwE (PasswordResetInProgress Nothing) - (user,) <$> lift (liftSem $ E.createPasswordResetCode user target) - -completePasswordReset :: - ( Member CodeStore r, - Member PasswordResetStore r, - Member TinyLog r - ) => - PasswordResetIdentity -> - PasswordResetCode -> - PlainTextPassword8 -> - ExceptT PasswordResetError (AppT r) () -completePasswordReset ident code pw = do - key <- mkPasswordResetKey ident - muid :: Maybe UserId <- lift . liftSem $ E.verifyPasswordResetCode (key, code) - case muid of - Nothing -> throwE InvalidPasswordResetCode - Just uid -> do - lift . liftSem . Log.debug $ field "user" (toByteString uid) . field "action" (val "User.completePasswordReset") - checkNewIsDifferent uid pw - lift $ do - wrapClient $ Data.updatePassword uid pw - liftSem $ E.codeDelete key - wrapClient $ revokeAllCookies uid - --- | Pull the current password of a user and compare it against the one about to be installed. --- If the two are the same, throw an error. If no current password can be found, do nothing. -checkNewIsDifferent :: UserId -> PlainTextPassword' t -> ExceptT PasswordResetError (AppT r) () -checkNewIsDifferent uid pw = do - mcurrpw <- lift . wrapClient $ Data.lookupPassword uid - case mcurrpw of - Just currpw - | (verifyPassword pw currpw) -> throwE ResetPasswordMustDiffer - _ -> pure () - -mkPasswordResetKey :: - Member CodeStore r => - PasswordResetIdentity -> - ExceptT PasswordResetError (AppT r) PasswordResetKey -mkPasswordResetKey ident = case ident of - PasswordResetIdentityKey k -> pure k - PasswordResetEmailIdentity e -> - wrapClientE (user (userEmailKey e)) - >>= lift . liftSem . E.mkPasswordResetKey - PasswordResetPhoneIdentity p -> - wrapClientE (user (userPhoneKey p)) - >>= lift . liftSem . E.mkPasswordResetKey - where - user uk = lift (Data.lookupKey uk) >>= maybe (throwE InvalidPasswordResetKey) pure + lift $ liftSem (upsertHashedPassword uid hashedNewPw) >> wrapClient (Auth.revokeAllCookies uid) ------------------------------------------------------------------------------- -- User Deletion @@ -1298,15 +911,23 @@ mkPasswordResetKey ident = case ident of -- delete them in the team settings. This protects teams against orphanhood. -- -- TODO: communicate deletions of SSO users to SSO service. +-- +-- FUTUREWORK(mangoiv): this uses 'UserStore', hence it must be moved to 'UserSubsystem' +-- as an effet operation deleteSelfUser :: forall r. ( Member GalleyAPIAccess r, Member TinyLog r, Member (Embed HttpClientIO) r, + Member UserKeyStore r, Member NotificationSubsystem r, Member (Input (Local ())) r, + Member PasswordStore r, + Member UserStore r, Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r + Member (ConnectionStore InternalPaging) r, + Member EmailSubsystem r, + Member VerificationCodeSubsystem r ) => UserId -> Maybe PlainTextPassword6 -> @@ -1330,14 +951,7 @@ deleteSelfUser uid pwd = do isOwner <- lift $ liftSem $ GalleyAPIAccess.memberIsTeamOwner tid uid when isOwner $ throwE DeleteUserOwnerDeletingSelf go a = maybe (byIdentity a) (byPassword a) pwd - getEmailOrPhone :: UserIdentity -> Maybe (Either Email Phone) - getEmailOrPhone (FullIdentity e _) = Just $ Left e - getEmailOrPhone (EmailIdentity e) = Just $ Left e - getEmailOrPhone (SSOIdentity _ (Just e) _) = Just $ Left e - getEmailOrPhone (PhoneIdentity p) = Just $ Right p - getEmailOrPhone (SSOIdentity _ _ (Just p)) = Just $ Right p - getEmailOrPhone (SSOIdentity _ Nothing Nothing) = Nothing - byIdentity a = case getEmailOrPhone =<< userIdentity (accountUser a) of + byIdentity a = case emailIdentity =<< userIdentity (accountUser a) of Just emailOrPhone -> sendCode a emailOrPhone Nothing -> case pwd of Just _ -> throwE DeleteUserMissingPassword @@ -1346,7 +960,7 @@ deleteSelfUser uid pwd = do lift . liftSem . Log.info $ field "user" (toByteString uid) . msg (val "Attempting account deletion with a password") - actual <- lift . wrapClient $ Data.lookupPassword uid + actual <- lift $ liftSem $ lookupHashedPassword uid case actual of Nothing -> throwE DeleteUserInvalidPassword Just p -> do @@ -1355,63 +969,62 @@ deleteSelfUser uid pwd = do throwE DeleteUserInvalidPassword lift . liftSem $ deleteAccount a >> pure Nothing sendCode a target = do - gen <- Code.mkGen (either Code.ForEmail Code.ForPhone target) - pending <- lift . wrapClient $ Code.lookup (Code.genKey gen) Code.AccountDeletion - case pending of - Just c -> throwE $! DeleteUserPendingCode (Code.codeTTL c) - Nothing -> do + let gen = mkVerificationCodeGen target + (lift . liftSem $ createCode gen VerificationCode.AccountDeletion (VerificationCode.Retries 3) (VerificationCode.Timeout 600) (Just (toUUID uid))) >>= \case + Left (CodeAlreadyExists c) -> throwE $! DeleteUserPendingCode (VerificationCode.codeTTL c) + Right c -> do lift . liftSem . Log.info $ field "user" (toByteString uid) . msg (val "Sending verification code for account deletion") - c <- - Code.generate - gen - Code.AccountDeletion - (Code.Retries 3) - (Code.Timeout 600) - (Just (toUUID uid)) - tryInsertVerificationCode c DeleteUserVerificationCodeThrottled - let k = Code.codeKey c - let v = Code.codeValue c + let k = VerificationCode.codeKey c + let v = VerificationCode.codeValue c let l = userLocale (accountUser a) let n = userDisplayName (accountUser a) - either - (\e -> lift $ sendDeletionEmail n e k v l) - (\p -> lift $ wrapClient $ sendDeletionSms p k v l) - target - `onException` wrapClientE (Code.delete k Code.AccountDeletion) - pure $! Just $! Code.codeTTL c + lift (liftSem $ sendAccountDeletionEmail target n k v l) + `onException` lift (liftSem $ deleteCode k VerificationCode.AccountDeletion) + pure $! Just $! VerificationCode.codeTTL c -- | Conclude validation and scheduling of user's deletion request that was initiated in -- 'deleteUser'. Called via @post /delete@. +-- +-- FUTUREWORK(mangoiv): this uses 'UserStore', hence it must be moved to 'UserSubsystem' +-- as an effet operation verifyDeleteUser :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, + Member UserKeyStore r, Member TinyLog r, Member (Input (Local ())) r, + Member UserStore r, Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r + Member (ConnectionStore InternalPaging) r, + Member VerificationCodeSubsystem r ) => VerifyDeleteUser -> ExceptT DeleteUserError (AppT r) () verifyDeleteUser d = do let key = verifyDeleteUserKey d let code = verifyDeleteUserCode d - c <- lift . wrapClient $ Code.verify key Code.AccountDeletion code - a <- maybe (throwE DeleteUserInvalidCode) pure (Code.codeAccount =<< c) + c <- lift . liftSem $ verifyCode key VerificationCode.AccountDeletion code + a <- maybe (throwE DeleteUserInvalidCode) pure (VerificationCode.codeAccount =<< c) account <- lift . wrapClient $ Data.lookupAccount (Id a) for_ account $ lift . liftSem . deleteAccount - lift . wrapClient $ Code.delete key Code.AccountDeletion + lift . liftSem $ deleteCode key VerificationCode.AccountDeletion -- | Check if `deleteAccount` succeeded and run it again if needed. -- Called via @delete /i/user/:uid@. +-- +-- FUTUREWORK(mangoiv): this uses 'UserStore', hence it must be moved to 'UserSubsystem' +-- as an effet operation ensureAccountDeleted :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, Member TinyLog r, + Member UserKeyStore r, Member (Input (Local ())) r, Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r + Member (ConnectionStore InternalPaging) r, + Member UserStore r ) => UserId -> AppT r DeleteUserResult @@ -1427,7 +1040,7 @@ ensureAccountDeleted uid = do localUid <- qualifyLocal uid conCount <- wrapClient $ countConnections localUid [(minBound @Relation) .. maxBound] - cookies <- wrapClient $ listCookies uid [] + cookies <- wrapClient $ Auth.listCookies uid [] if notNull probs || not accIsDeleted @@ -1448,86 +1061,66 @@ ensureAccountDeleted uid = do -- N.B.: As Cassandra doesn't support transactions, the order of database -- statements matters! Other functions reason upon some states to imply other -- states. Please change this order only with care! +-- +-- FUTUREWORK(mangoiv): this uses 'UserStore', hence it must be moved to 'UserSubsystem' +-- as an effet operation +-- FUTUREWORK: this does not need the whole UserAccount structure, only the User. deleteAccount :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, + Member UserKeyStore r, Member TinyLog r, Member (Input (Local ())) r, + Member UserStore r, Member (Input UTCTime) r, Member (ConnectionStore InternalPaging) r ) => UserAccount -> Sem r () -deleteAccount account@(accountUser -> user) = do +deleteAccount (accountUser -> user) = do let uid = userId user Log.info $ field "user" (toByteString uid) . msg (val "Deleting account") - embed $ do + do -- Free unique keys - for_ (userEmail user) $ deleteKeyForUser uid . userEmailKey - for_ (userPhone user) $ deleteKeyForUser uid . userPhoneKey - for_ (userHandle user) $ freeHandle (userId user) - -- Wipe data - Data.clearProperties uid - tombstone <- mkTombstone - Data.insertAccount tombstone Nothing Nothing False + for_ (userEmail user) $ deleteKeyForUser uid . mkEmailKey + + embed $ Data.clearProperties uid + + deleteUser user + Intra.rmUser uid (userAssets user) embed $ Data.lookupClients uid >>= mapM_ (Data.rmClient uid . clientId) luid <- embed $ qualifyLocal uid Intra.onUserEvent uid Nothing (UserDeleted (tUntagged luid)) - embed $ do + embed do -- Note: Connections can only be deleted afterwards, since -- they need to be notified. Data.deleteConnections uid - revokeAllCookies uid - where - mkTombstone = do - defLoc <- setDefaultUserLocale <$> view settings - pure $ - account - { accountStatus = Deleted, - accountUser = - user - { userDisplayName = Name "default", - userAccentId = defaultAccentId, - userPict = noPict, - userAssets = [], - userHandle = Nothing, - userLocale = defLoc, - userIdentity = Nothing - } - } + Auth.revokeAllCookies uid ------------------------------------------------------------------------------- -- Lookups lookupActivationCode :: - MonadClient m => - Either Email Phone -> + (MonadClient m) => + Email -> m (Maybe ActivationPair) -lookupActivationCode emailOrPhone = do - let uk = either userEmailKey userPhoneKey emailOrPhone +lookupActivationCode email = do + let uk = mkEmailKey email k <- liftIO $ Data.mkActivationKey uk c <- fmap snd <$> Data.lookupActivationCode uk pure $ (k,) <$> c lookupPasswordResetCode :: - ( Member CodeStore r, - Member PasswordResetStore r + ( Member AuthenticationSubsystem r ) => - Either Email Phone -> + Email -> (AppT r) (Maybe PasswordResetPair) -lookupPasswordResetCode emailOrPhone = do - let uk = either userEmailKey userPhoneKey emailOrPhone - usr <- wrapClient $ Data.lookupKey uk - liftSem $ case usr of - Nothing -> pure Nothing - Just u -> do - k <- E.mkPasswordResetKey u - c <- E.lookupPasswordResetCode u - pure $ (k,) <$> c +lookupPasswordResetCode = + liftSem . internalLookupPasswordResetCode . mkEmailKey deleteUserNoVerify :: - Member DeleteQueue r => + (Member DeleteQueue r) => UserId -> Sem r () deleteUserNoVerify uid = do @@ -1539,9 +1132,28 @@ deleteUsersNoVerify :: AppT r () deleteUsersNoVerify uids = do liftSem $ for_ uids deleteUserNoVerify - m <- view metrics - Metrics.counterAdd (fromIntegral . length $ uids) (Metrics.path "user.enqueue_multi_delete_total") m - Metrics.counterIncr (Metrics.path "user.enqueue_multi_delete_calls_total") m + void $ Prom.addCounter enqueueMultiDeleteCounter (fromIntegral $ length uids) + Prom.incCounter enqueueMultiDeleteCallsCounter + +{-# NOINLINE enqueueMultiDeleteCounter #-} +enqueueMultiDeleteCounter :: Prom.Counter +enqueueMultiDeleteCounter = + Prom.unsafeRegister $ + Prom.counter + Prom.Info + { Prom.metricName = "user.enqueue_multi_delete_total", + Prom.metricHelp = "Number of users enqueued to be deleted" + } + +{-# NOINLINE enqueueMultiDeleteCallsCounter #-} +enqueueMultiDeleteCallsCounter :: Prom.Counter +enqueueMultiDeleteCallsCounter = + Prom.unsafeRegister $ + Prom.counter + Prom.Info + { Prom.metricName = "user.enqueue_multi_delete_calls_total", + Prom.metricHelp = "Number of users enqueued to be deleted" + } -- | Similar to lookupProfiles except it returns all results and all errors -- allowing for partial success. @@ -1554,13 +1166,13 @@ lookupProfilesV3 :: lookupProfilesV3 self others = getUserProfilesWithErrors self others getLegalHoldStatus :: - Member GalleyAPIAccess r => + (Member GalleyAPIAccess r) => UserId -> AppT r (Maybe UserLegalHoldStatus) getLegalHoldStatus uid = traverse (liftSem . getLegalHoldStatus' . accountUser) =<< wrapHttpClient (lookupAccount uid) getLegalHoldStatus' :: - Member GalleyAPIAccess r => + (Member GalleyAPIAccess r) => User -> Sem r UserLegalHoldStatus getLegalHoldStatus' user = @@ -1572,57 +1184,31 @@ getLegalHoldStatus' user = -- | Find user accounts for a given identity, both activated and those -- currently pending activation. -lookupAccountsByIdentity :: Either Email Phone -> Bool -> (AppT r) [UserAccount] -lookupAccountsByIdentity emailOrPhone includePendingInvitations = do - let uk = either userEmailKey userPhoneKey emailOrPhone - activeUid <- wrapClient $ Data.lookupKey uk +lookupAccountsByIdentity :: + (Member UserKeyStore r) => + Email -> + Bool -> + AppT r [UserAccount] +lookupAccountsByIdentity email includePendingInvitations = do + let uk = mkEmailKey email + activeUid <- liftSem $ lookupKey uk uidFromKey <- (>>= fst) <$> wrapClient (Data.lookupActivationCode uk) result <- wrapClient $ Data.lookupAccounts (nub $ catMaybes [activeUid, uidFromKey]) if includePendingInvitations then pure result else pure $ filter ((/= PendingInvitation) . accountStatus) result -isBlacklisted :: Member BlacklistStore r => Either Email Phone -> AppT r Bool -isBlacklisted emailOrPhone = do - let uk = either userEmailKey userPhoneKey emailOrPhone +isBlacklisted :: (Member BlacklistStore r) => Email -> AppT r Bool +isBlacklisted email = do + let uk = mkEmailKey email liftSem $ BlacklistStore.exists uk -blacklistInsert :: Member BlacklistStore r => Either Email Phone -> AppT r () -blacklistInsert emailOrPhone = do - let uk = either userEmailKey userPhoneKey emailOrPhone +blacklistInsert :: (Member BlacklistStore r) => Email -> AppT r () +blacklistInsert email = do + let uk = mkEmailKey email liftSem $ BlacklistStore.insert uk -blacklistDelete :: Member BlacklistStore r => Either Email Phone -> AppT r () -blacklistDelete emailOrPhone = do - let uk = either userEmailKey userPhoneKey emailOrPhone +blacklistDelete :: (Member BlacklistStore r) => Email -> AppT r () +blacklistDelete email = do + let uk = mkEmailKey email liftSem $ BlacklistStore.delete uk - -phonePrefixGet :: Member BlacklistPhonePrefixStore r => PhonePrefix -> (AppT r) [ExcludedPrefix] -phonePrefixGet = liftSem . BlacklistPhonePrefixStore.getAll - -phonePrefixDelete :: Member BlacklistPhonePrefixStore r => PhonePrefix -> (AppT r) () -phonePrefixDelete = liftSem . BlacklistPhonePrefixStore.delete - -phonePrefixInsert :: Member BlacklistPhonePrefixStore r => ExcludedPrefix -> (AppT r) () -phonePrefixInsert = liftSem . BlacklistPhonePrefixStore.insert - -userUnderE2EId :: Member GalleyAPIAccess r => UserId -> Sem r Bool -userUnderE2EId uid = do - wsStatus . afcMlsE2EId <$> getAllFeatureConfigsForUser (Just uid) <&> \case - FeatureStatusEnabled -> True - FeatureStatusDisabled -> False - --- | This is a hack! --- --- Background: --- - https://wearezeta.atlassian.net/browse/WPB-6189. --- - comments in `testUpdateHandle` in `/integration`. --- --- FUTUREWORK: figure out a better way for clients to detect E2EId (V6?) -hackForBlockingHandleChangeForE2EIdTeams :: Member GalleyAPIAccess r => SelfProfile -> Sem r SelfProfile -hackForBlockingHandleChangeForE2EIdTeams (SelfProfile user) = do - hasE2EId <- userUnderE2EId . userId $ user - pure . SelfProfile $ - if (hasE2EId && isJust (userHandle user)) - then user {userManagedBy = ManagedByScim} - else user diff --git a/services/brig/src/Brig/API/Util.hs b/services/brig/src/Brig/API/Util.hs index 54f04975a51..6a1d1d532d7 100644 --- a/services/brig/src/Brig/API/Util.hs +++ b/services/brig/src/Brig/API/Util.hs @@ -18,7 +18,6 @@ module Brig.API.Util ( fetchUserIdentity, lookupProfilesMaybeFilterSameTeamOnly, - lookupSelfProfile, logInvitationCode, validateHandle, logEmail, @@ -29,7 +28,6 @@ module Brig.API.Util traverseConcurrentlyWithErrorsAppT, exceptTToMaybe, ensureLocal, - tryInsertVerificationCode, ) where @@ -37,17 +35,13 @@ import Brig.API.Error import Brig.API.Handler import Brig.API.Types import Brig.App -import Brig.Code qualified as Code import Brig.Data.User qualified as Data -import Brig.Options (set2FACodeGenerationDelaySecs) -import Control.Lens (view) import Control.Monad.Catch (throwM) import Control.Monad.Trans.Except import Data.Bifunctor import Data.Handle (Handle, parseHandle) import Data.Id import Data.Maybe -import Data.Qualified import Data.Text qualified as T import Data.Text.Ascii (AsciiText (toText)) import Imports @@ -60,9 +54,9 @@ import UnliftIO.Exception (throwIO, try) import Util.Logging (sha256String) import Wire.API.Error import Wire.API.Error.Brig -import Wire.API.Federation.Error import Wire.API.User import Wire.Sem.Concurrency qualified as C +import Wire.UserSubsystem lookupProfilesMaybeFilterSameTeamOnly :: UserId -> [UserProfile] -> (Handler r) [UserProfile] lookupProfilesMaybeFilterSameTeamOnly self us = do @@ -71,19 +65,14 @@ lookupProfilesMaybeFilterSameTeamOnly self us = do Just team -> filter (\x -> profileTeam x == Just team) us Nothing -> us -fetchUserIdentity :: UserId -> (AppT r) (Maybe UserIdentity) -fetchUserIdentity uid = - lookupSelfProfile uid +fetchUserIdentity :: (Member UserSubsystem r) => UserId -> AppT r (Maybe UserIdentity) +fetchUserIdentity uid = do + luid <- qualifyLocal uid + liftSem (getSelfProfile luid) >>= maybe (throwM $ UserProfileNotFound uid) (pure . userIdentity . selfUser) --- | Obtain a profile for a user as he can see himself. -lookupSelfProfile :: UserId -> (AppT r) (Maybe SelfProfile) -lookupSelfProfile = fmap (fmap mk) . wrapClient . Data.lookupAccount - where - mk a = SelfProfile (accountUser a) - validateHandle :: Text -> (Handler r) Handle validateHandle = maybe (throwStd (errorToWai @'InvalidHandle)) pure . parseHandle @@ -160,17 +149,5 @@ traverseConcurrentlyWithErrorsAppT f t = do (mapExceptT (lowerAppT env) . f) t -exceptTToMaybe :: Monad m => ExceptT e m () -> m (Maybe e) +exceptTToMaybe :: (Monad m) => ExceptT e m () -> m (Maybe e) exceptTToMaybe = (pure . either Just (const Nothing)) <=< runExceptT - --- | Convert a qualified value into a local one. Throw if the value is not actually local. -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/AWS.hs b/services/brig/src/Brig/AWS.hs index 54a93e85c5b..48e927124be 100644 --- a/services/brig/src/Brig/AWS.hs +++ b/services/brig/src/Brig/AWS.hs @@ -30,9 +30,6 @@ module Brig.AWS prekeyTable, Error (..), - -- * SES - sendMail, - -- * SQS listen, enqueueFIFO, @@ -47,10 +44,8 @@ where import Amazonka (AWSRequest, AWSResponse) import Amazonka qualified as AWS -import Amazonka.Data.Text qualified as AWS import Amazonka.DynamoDB qualified as DDB import Amazonka.SES qualified as SES -import Amazonka.SES.Lens qualified as SES import Amazonka.SQS qualified as SQS import Amazonka.SQS.Lens qualified as SQS import Brig.Options qualified as Opt @@ -61,18 +56,18 @@ import Control.Retry import Data.Aeson hiding ((.=)) import Data.ByteString.Builder (toLazyByteString) import Data.ByteString.Lazy qualified as BL -import Data.Text qualified as Text import Data.Text.Encoding qualified as Text import Data.UUID hiding (null) import Imports hiding (group) -import Network.HTTP.Client (HttpException (..), HttpExceptionContent (..), Manager) -import Network.HTTP.Types.Status (status400) -import Network.Mail.Mime +import Network.HTTP.Client (Manager) +import Polysemy (runM) +import Polysemy.Input (runInputConst) import System.Logger qualified as Logger import System.Logger.Class import UnliftIO.Async import UnliftIO.Exception import Util.Options +import Wire.AWS data Env = Env { _logger :: !Logger, @@ -151,7 +146,7 @@ getQueueUrl :: m Text getQueueUrl e q = view SQS.getQueueUrlResponse_queueUrl <$> exec e (SQS.newGetQueueUrl q) -execute :: MonadIO m => Env -> Amazon a -> m a +execute :: (MonadIO m) => Env -> Amazon a -> m a execute e m = liftIO $ runResourceT (runReaderT (unAmazon m) e) data Error where @@ -190,61 +185,33 @@ listen throttleMillis url callback = forever . handleAny unexpectedError $ do threadDelay 3000000 enqueueStandard :: Text -> BL.ByteString -> Amazon SQS.SendMessageResponse -enqueueStandard url m = retrying retry5x (const canRetry) (const (sendCatch req)) >>= throwA +enqueueStandard url m = retrying retry5x (const $ pure . canRetry) (const (sendCatchAmazon req)) >>= throwA where req = SQS.newSendMessage url $ Text.decodeLatin1 (BL.toStrict m) enqueueFIFO :: Text -> Text -> UUID -> BL.ByteString -> Amazon SQS.SendMessageResponse -enqueueFIFO url group dedup m = retrying retry5x (const canRetry) (const (sendCatch req)) >>= throwA +enqueueFIFO url group dedup m = retrying retry5x (const $ pure . canRetry) (const (sendCatchAmazon req)) >>= throwA where req = SQS.newSendMessage url (Text.decodeLatin1 (BL.toStrict m)) & SQS.sendMessage_messageGroupId ?~ group & SQS.sendMessage_messageDeduplicationId ?~ toText dedup -------------------------------------------------------------------------------- --- SES - -sendMail :: Mail -> Amazon () -sendMail m = do - body <- liftIO $ BL.toStrict <$> renderMail' m - let raw = - SES.newSendRawEmail (SES.newRawMessage body) - & SES.sendRawEmail_destinations ?~ fmap addressEmail (mailTo m) - & SES.sendRawEmail_source ?~ addressEmail (mailFrom m) - resp <- retrying retry5x (const canRetry) $ const (sendCatch raw) - void $ either check pure resp - where - check x = case x of - -- To map rejected domain names by SES to 400 responses, in order - -- not to trigger false 5xx alerts. Upfront domain name validation - -- is only according to the syntax rules of RFC5322 but additional - -- constraints may be applied by email servers (in this case SES). - -- Since such additional constraints are neither standardised nor - -- documented in the cases of SES, we can only handle the errors - -- after the fact. - AWS.ServiceError se - | se - ^. AWS.serviceError_status - == status400 - && "Invalid domain name" - `Text.isPrefixOf` AWS.toText (se ^. AWS.serviceError_code) -> - throwM SESInvalidDomain - _ -> throwM (GeneralError x) - -------------------------------------------------------------------------------- -- Utilities -sendCatch :: (AWSRequest r, Typeable r, Typeable (AWSResponse r)) => r -> Amazon (Either AWS.Error (AWSResponse r)) -sendCatch req = do - env <- view amazonkaEnv - AWS.trying AWS._Error . AWS.send env $ req - send :: (AWSRequest r, Typeable r, Typeable (AWSResponse r)) => r -> Amazon (AWSResponse r) -send r = throwA =<< sendCatch r +send r = throwA =<< sendCatchAmazon r + +-- | Temporary helper to translate polysemy to Amazon monad, it should go away +-- with more polysemisation +sendCatchAmazon :: (AWSRequest req, Typeable req, Typeable (AWSResponse req)) => req -> Amazon (Either AWS.Error (AWS.AWSResponse req)) +sendCatchAmazon req = do + env <- view amazonkaEnv + liftIO . runM . runInputConst env $ sendCatch req throwA :: Either AWS.Error a -> Amazon a throwA = either (throwM . GeneralError) pure @@ -276,12 +243,5 @@ exec :: m (AWSResponse a) exec e cmd = liftIO (execCatch e cmd) >>= either (throwM . GeneralError) pure -canRetry :: MonadIO m => Either AWS.Error a -> m Bool -canRetry (Right _) = pure False -canRetry (Left e) = case e of - AWS.TransportError (HttpExceptionRequest _ ResponseTimeout) -> pure True - AWS.ServiceError se | se ^. AWS.serviceError_code == AWS.ErrorCode "RequestThrottled" -> pure True - _ -> pure False - retry5x :: (Monad m) => RetryPolicyM m retry5x = limitRetries 5 <> exponentialBackoff 100000 diff --git a/services/brig/src/Brig/AWS/SesNotification.hs b/services/brig/src/Brig/AWS/SesNotification.hs index 97f75c55f8a..9902d260830 100644 --- a/services/brig/src/Brig/AWS/SesNotification.hs +++ b/services/brig/src/Brig/AWS/SesNotification.hs @@ -22,7 +22,6 @@ where import Brig.AWS.Types import Brig.App -import Brig.Data.UserKey (userEmailKey) import Brig.Effects.BlacklistStore (BlacklistStore) import Brig.Effects.BlacklistStore qualified as BlacklistStore import Imports @@ -30,17 +29,18 @@ import Polysemy (Member) import System.Logger.Class (field, msg, (~~)) import System.Logger.Class qualified as Log import Wire.API.User.Identity +import Wire.UserKeyStore -onEvent :: Member BlacklistStore r => SESNotification -> AppT r () +onEvent :: (Member BlacklistStore r) => SESNotification -> AppT r () onEvent (MailBounce BouncePermanent es) = onPermanentBounce es onEvent (MailBounce BounceTransient es) = onTransientBounce es onEvent (MailBounce BounceUndetermined es) = onUndeterminedBounce es onEvent (MailComplaint es) = onComplaint es -onPermanentBounce :: Member BlacklistStore r => [Email] -> AppT r () +onPermanentBounce :: (Member BlacklistStore r) => [Email] -> AppT r () onPermanentBounce = mapM_ $ \e -> do logEmailEvent "Permanent bounce" e - liftSem $ BlacklistStore.insert (userEmailKey e) + liftSem $ BlacklistStore.insert (mkEmailKey e) onTransientBounce :: [Email] -> AppT r () onTransientBounce = mapM_ (logEmailEvent "Transient bounce") @@ -48,10 +48,10 @@ onTransientBounce = mapM_ (logEmailEvent "Transient bounce") onUndeterminedBounce :: [Email] -> AppT r () onUndeterminedBounce = mapM_ (logEmailEvent "Undetermined bounce") -onComplaint :: Member BlacklistStore r => [Email] -> AppT r () +onComplaint :: (Member BlacklistStore r) => [Email] -> AppT r () onComplaint = mapM_ $ \e -> do logEmailEvent "Complaint" e - liftSem $ BlacklistStore.insert (userEmailKey e) + liftSem $ BlacklistStore.insert (mkEmailKey e) logEmailEvent :: Text -> Email -> AppT r () logEmailEvent t e = Log.info $ field "email" (fromEmail e) ~~ msg t diff --git a/services/brig/src/Brig/App.hs b/services/brig/src/Brig/App.hs index ad1a74c246a..9d475b37262 100644 --- a/services/brig/src/Brig/App.hs +++ b/services/brig/src/Brig/App.hs @@ -40,6 +40,7 @@ module Brig.App federator, casClient, userTemplates, + usrTemplates, providerTemplates, teamTemplates, templateBranding, @@ -47,14 +48,11 @@ module Brig.App httpManager, http2Manager, extGetManager, - nexmoCreds, - twilioCreds, settings, currentTime, zauthEnv, digestSHA256, digestMD5, - metrics, applog, turnEnv, sftEnv, @@ -73,6 +71,7 @@ module Brig.App viewFederationDomain, qualifyLocal, qualifyLocal', + ensureLocal, -- * Crutches that should be removed once Brig has been completely transitioned to Polysemy wrapClient, @@ -87,6 +86,8 @@ module Brig.App lowerAppT, temporaryGetEnv, initHttpManagerWithTLSConfig, + adhocUserKeyStoreInterpreter, + adhocSessionStoreInterpreter, ) where @@ -102,15 +103,14 @@ import Brig.Options qualified as Opt import Brig.Provider.Template import Brig.Queue.Stomp qualified as Stomp import Brig.Queue.Types -import Brig.SMTP qualified as SMTP import Brig.Schema.Run qualified as Migrations import Brig.Team.Template -import Brig.Template (Localised, TemplateBranding, forLocale, genTemplateBranding) +import Brig.Template (Localised, genTemplateBranding) import Brig.User.Search.Index (IndexEnv (..), MonadIndexIO (..), runIndexIO) import Brig.User.Template import Brig.ZAuth (MonadZAuth (..), runZAuth) import Brig.ZAuth qualified as ZAuth -import Cassandra (runClient) +import Cassandra (MonadClient, runClient) import Cassandra qualified as Cas import Cassandra.Util (initCassandraForService) import Control.AutoUpdate @@ -121,8 +121,6 @@ import Control.Monad.Trans.Resource import Data.ByteString.Conversion import Data.Credentials (Credentials (..)) import Data.Domain -import Data.Metrics (Metrics) -import Data.Metrics.Middleware qualified as Metrics import Data.Misc import Data.Qualified import Data.Text qualified as Text @@ -143,17 +141,25 @@ import OpenSSL.Session qualified as SSL import Polysemy import Polysemy.Final import Polysemy.Input (Input, input) -import Ropes.Nexmo qualified as Nexmo -import Ropes.Twilio qualified as Twilio +import Prometheus import Ssl.Util import System.FSNotify qualified as FS import System.Logger.Class hiding (Settings, settings) import System.Logger.Class qualified as LC import System.Logger.Extended qualified as Log import Util.Options +import Wire.API.Federation.Error (federationNotImplemented) +import Wire.API.Locale (Locale) import Wire.API.Routes.Version import Wire.API.User.Identity (Email) -import Wire.API.User.Profile (Locale) +import Wire.EmailSending.SMTP qualified as SMTP +import Wire.EmailSubsystem.Template (TemplateBranding, forLocale) +import Wire.SessionStore +import Wire.SessionStore.Cassandra +import Wire.UserKeyStore +import Wire.UserKeyStore.Cassandra +import Wire.UserStore +import Wire.UserStore.Cassandra schemaVersion :: Int32 schemaVersion = Migrations.lastSchemaVersion @@ -172,7 +178,6 @@ data Env = Env _smtpEnv :: Maybe SMTP.SMTP, _emailSender :: Email, _awsEnv :: AWS.Env, - _metrics :: Metrics, _applog :: Logger, _internalEvents :: QueueEnv, _requestId :: RequestId, @@ -184,8 +189,6 @@ data Env = Env _http2Manager :: Http2Manager, _extGetManager :: (Manager, [Fingerprint Rsa] -> SSL.SSL -> IO ()), _settings :: Settings, - _nexmoCreds :: Nexmo.Credentials, - _twilioCreds :: Twilio.Credentials, _fsWatcher :: FS.WatchManager, _turnEnv :: Calling.TurnEnv, _sftEnv :: Maybe Calling.SFTEnv, @@ -216,7 +219,6 @@ newEnv o = do Just md5 <- getDigestByName "MD5" Just sha256 <- getDigestByName "SHA256" Just sha512 <- getDigestByName "SHA512" - mtr <- Metrics.metrics lgr <- Log.mkLogger (Opt.logLevel o) (Opt.logNetStrings o) (Opt.logFormat o) cas <- initCassandra o lgr mgr <- initHttpManager @@ -237,8 +239,6 @@ newEnv o = do turnSecret <- Text.encodeUtf8 . Text.strip <$> Text.readFile (Opt.secret turnOpts) turn <- Calling.mkTurnEnv (Opt.serversSource turnOpts) (Opt.tokenTTL turnOpts) (Opt.configTTL turnOpts) turnSecret sha512 let sett = Opt.optSettings o - nxm <- initCredentials (Opt.setNexmo sett) - twl <- initCredentials (Opt.setTwilio sett) eventsQueue :: QueueEnv <- case Opt.internalEventsQueue (Opt.internalEvents o) of StompQueueOpts q -> do stomp :: Stomp.Env <- case (Opt.stomp o, Opt.setStomp sett) of @@ -261,7 +261,7 @@ newEnv o = do kpLock <- newMVar () rabbitChan <- traverse (Q.mkRabbitMqChannelMVar lgr) o.rabbitmq let allDisabledVersions = foldMap expandVersionExp (Opt.setDisabledAPIVersions sett) - idxEnv <- mkIndexEnv o.elasticsearch lgr mtr (Opt.galley o) mgr + idxEnv <- mkIndexEnv o.elasticsearch lgr (Opt.galley o) mgr pure $! Env { _cargohold = mkEndpoint $ Opt.cargohold o, @@ -274,7 +274,6 @@ newEnv o = do _smtpEnv = emailSMTP, _emailSender = Opt.emailSender . Opt.general . Opt.emailSMS $ o, _awsEnv = aws, -- used by `journalEvent` directly - _metrics = mtr, _applog = lgr, _internalEvents = (eventsQueue :: QueueEnv), _requestId = RequestId "N/A", @@ -286,8 +285,6 @@ newEnv o = do _http2Manager = h2Mgr, _extGetManager = ext, _settings = sett, - _nexmoCreds = nxm, - _twilioCreds = twl, _turnEnv = turn, _sftEnv = mSFTEnv, _fsWatcher = w, @@ -315,8 +312,8 @@ newEnv o = do pure (Nothing, Just smtp) mkEndpoint service = RPC.host (encodeUtf8 (service ^. host)) . RPC.port (service ^. port) $ RPC.empty -mkIndexEnv :: ElasticSearchOpts -> Logger -> Metrics -> Endpoint -> Manager -> IO IndexEnv -mkIndexEnv esOpts logger metricsStorage galleyEp rpcHttpManager = do +mkIndexEnv :: ElasticSearchOpts -> Logger -> Endpoint -> Manager -> IO IndexEnv +mkIndexEnv esOpts logger galleyEp rpcHttpManager = do mEsCreds :: Maybe Credentials <- for esOpts.credentials initCredentials mEsAddCreds :: Maybe Credentials <- for esOpts.additionalCredentials initCredentials @@ -331,8 +328,7 @@ mkIndexEnv esOpts logger metricsStorage galleyEp rpcHttpManager = do mkBhEnv esOpts.additionalInsecureSkipVerifyTls esOpts.additionalCaCert mEsAddCreds pure $ IndexEnv - { idxMetrics = metricsStorage, - idxLogger = esLogger, + { idxLogger = esLogger, idxElastic = bhEnv, idxRequest = Nothing, idxName = esOpts.index, @@ -488,6 +484,9 @@ instance Monad (AppT r) where instance MonadIO (AppT r) where liftIO io = AppT $ lift $ embedFinal io +instance MonadMonitor (AppT r) where + doIO = liftIO + instance MonadThrow (AppT r) where throwM = liftIO . throwM @@ -583,7 +582,7 @@ newtype HttpClientIO a = HttpClientIO MonadIndexIO ) -runHttpClientIO :: MonadIO m => Env -> HttpClientIO a -> m a +runHttpClientIO :: (MonadIO m) => Env -> HttpClientIO a -> m a runHttpClientIO env = runClient (env ^. casClient) . runHttpT (env ^. httpManager) @@ -602,6 +601,9 @@ instance Cas.MonadClient HttpClientIO where liftIO $ runClient (view casClient env) cl localState f = local (casClient %~ f) +instance MonadMonitor HttpClientIO where + doIO = liftIO + wrapHttpClient :: HttpClientIO a -> AppT r a @@ -623,14 +625,37 @@ instance (MonadIndexIO (AppT r)) => MonadIndexIO (ExceptT err (AppT r)) where instance HasRequestId (AppT r) where getRequestId = view requestId +------------------------------------------------------------------------------- +-- Ad hoc interpreters + +-- | similarly to `wrapClient`, this function serves as a crutch while Brig is being polysemised. +adhocUserKeyStoreInterpreter :: (MonadClient m, MonadReader Env m) => Sem '[UserKeyStore, UserStore, Embed IO] a -> m a +adhocUserKeyStoreInterpreter action = do + clientState <- asks (view casClient) + liftIO $ runM . interpretUserStoreCassandra clientState . interpretUserKeyStoreCassandra clientState $ action + +-- | similarly to `wrapClient`, this function serves as a crutch while Brig is being polysemised. +adhocSessionStoreInterpreter :: (MonadClient m, MonadReader Env m) => Sem '[SessionStore, Embed IO] a -> m a +adhocSessionStoreInterpreter action = do + clientState <- asks (view casClient) + liftIO $ runM . interpretSessionStoreCassandra clientState $ action + -------------------------------------------------------------------------------- -- Federation viewFederationDomain :: (MonadReader Env m) => m Domain viewFederationDomain = view (settings . Opt.federationDomain) +-- FUTUREWORK: rename to 'qualifyLocalMtl' qualifyLocal :: (MonadReader Env m) => a -> m (Local a) qualifyLocal a = toLocalUnsafe <$> viewFederationDomain <*> pure a -qualifyLocal' :: (Member (Input (Local ()))) r => a -> Sem r (Local a) +-- FUTUREWORK: rename to 'qualifyLocalPoly' +qualifyLocal' :: ((Member (Input (Local ()))) r) => a -> Sem r (Local a) qualifyLocal' a = flip toLocalUnsafe a . tDomain <$> input + +-- | Convert a qualified value into a local one. Throw if the value is not actually local. +ensureLocal :: Qualified a -> AppT r (Local a) +ensureLocal x = do + loc <- qualifyLocal () + foldQualified loc pure (\_ -> throwM federationNotImplemented) x diff --git a/services/brig/src/Brig/Budget.hs b/services/brig/src/Brig/Budget.hs index cf952a3ed76..2cd24cdee95 100644 --- a/services/brig/src/Brig/Budget.hs +++ b/services/brig/src/Brig/Budget.hs @@ -58,7 +58,7 @@ newtype BudgetKey = BudgetKey Text -- -- FUTUREWORK: exceptions are not handled very nicely, but it's not clear what it would mean -- to improve this. -withBudget :: MonadClient m => BudgetKey -> Budget -> m a -> m (Budgeted a) +withBudget :: (MonadClient m) => BudgetKey -> Budget -> m a -> m (Budgeted a) withBudget k b ma = do Budget ttl val <- fromMaybe b <$> lookupBudget k let remaining = val - 1 @@ -70,7 +70,7 @@ withBudget k b ma = do pure (BudgetedValue a remaining) -- | Like 'withBudget', but does not decrease budget, only takes a look. -checkBudget :: MonadClient m => BudgetKey -> Budget -> m (Budgeted ()) +checkBudget :: (MonadClient m) => BudgetKey -> Budget -> m (Budgeted ()) checkBudget k b = do Budget ttl val <- fromMaybe b <$> lookupBudget k let remaining = val - 1 @@ -79,12 +79,12 @@ checkBudget k b = do then BudgetExhausted ttl else BudgetedValue () remaining -lookupBudget :: MonadClient m => BudgetKey -> m (Maybe Budget) +lookupBudget :: (MonadClient m) => BudgetKey -> m (Maybe Budget) lookupBudget k = fmap mk <$> query1 budgetSelect (params One (Identity k)) where mk (val, ttl) = Budget (fromIntegral ttl) val -insertBudget :: MonadClient m => BudgetKey -> Budget -> m () +insertBudget :: (MonadClient m) => BudgetKey -> Budget -> m () insertBudget k (Budget ttl val) = retry x5 $ write budgetInsert (params One (k, val, round ttl)) diff --git a/services/brig/src/Brig/Calling/API.hs b/services/brig/src/Brig/Calling/API.hs index 998b92ee874..e97c51e19c2 100644 --- a/services/brig/src/Brig/Calling/API.hs +++ b/services/brig/src/Brig/Calling/API.hs @@ -57,29 +57,38 @@ import Polysemy.Error qualified as Polysemy import System.Logger.Class qualified as Log import System.Random.MWC qualified as MWC import Wire.API.Call.Config qualified as Public +import Wire.API.Team.Feature (AllFeatureConfigs (afcConferenceCalling), FeatureStatus (FeatureStatusDisabled, FeatureStatusEnabled), wsStatus) +import Wire.Error +import Wire.GalleyAPIAccess (GalleyAPIAccess, getAllFeatureConfigsForUser) import Wire.Network.DNS.SRV (srvTarget) -- | ('UserId', 'ConnId' are required as args here to make sure this is an authenticated end-point.) getCallsConfigV2 :: ( Member (Embed IO) r, - Member SFT r + Member SFT r, + Member GalleyAPIAccess r ) => UserId -> ConnId -> Maybe (Range 1 10 Int) -> (Handler r) Public.RTCConfiguration -getCallsConfigV2 _ _ limit = do +getCallsConfigV2 uid _ limit = do env <- view turnEnv staticUrl <- view $ settings . Opt.sftStaticUrl sftListAllServers <- fromMaybe Opt.HideAllSFTServers <$> view (settings . Opt.sftListAllServers) sftEnv' <- view sftEnv sftFederation <- view enableSFTFederation discoveredServers <- turnServersV2 (env ^. turnServers) + shared <- do + ccStatus <- lift $ liftSem $ (wsStatus . afcConferenceCalling <$> getAllFeatureConfigsForUser (Just uid)) + pure $ case ccStatus of + FeatureStatusEnabled -> True + FeatureStatusDisabled -> False eitherConfig <- lift . liftSem . Polysemy.runError - $ newConfig env discoveredServers staticUrl sftEnv' limit sftListAllServers (CallsConfigV2 sftFederation) + $ newConfig env discoveredServers staticUrl sftEnv' limit sftListAllServers (CallsConfigV2 sftFederation) shared handleNoTurnServers eitherConfig -- | Throws '500 Internal Server Error' when no turn servers are found. This is @@ -96,20 +105,26 @@ handleNoTurnServers (Left NoTurnServers) = do getCallsConfig :: ( Member (Embed IO) r, - Member SFT r + Member SFT r, + Member GalleyAPIAccess r ) => UserId -> ConnId -> (Handler r) Public.RTCConfiguration -getCallsConfig _ _ = do +getCallsConfig uid _ = do env <- view turnEnv discoveredServers <- turnServersV1 (env ^. turnServers) + shared <- do + ccStatus <- lift $ liftSem $ (wsStatus . afcConferenceCalling <$> getAllFeatureConfigsForUser (Just uid)) + pure $ case ccStatus of + FeatureStatusEnabled -> True + FeatureStatusDisabled -> False eitherConfig <- (dropTransport <$$>) . lift . liftSem . Polysemy.runError - $ newConfig env discoveredServers Nothing Nothing Nothing HideAllSFTServers CallsConfigDeprecated + $ newConfig env discoveredServers Nothing Nothing Nothing HideAllSFTServers CallsConfigDeprecated shared handleNoTurnServers eitherConfig where -- In order to avoid being backwards incompatible, remove the `transport` query param from the URIs @@ -145,8 +160,9 @@ newConfig :: Maybe (Range 1 10 Int) -> ListAllSFTServers -> CallsConfigVersion -> + Bool -> Sem r Public.RTCConfiguration -newConfig env discoveredServers sftStaticUrl mSftEnv limit listAllServers version = do +newConfig env discoveredServers sftStaticUrl mSftEnv limit listAllServers version shared = do -- randomize list of servers (before limiting the list, to ensure not always the same servers are chosen if limit is set) randomizedUris <- liftIO . randomize @@ -194,19 +210,23 @@ newConfig env discoveredServers sftStaticUrl mSftEnv limit listAllServers versio -- it should also be safe to assume the returning list has length >= 1 NonEmpty.nonEmpty (Public.limitServers (NonEmpty.toList uris) (fromRange lim)) & fromMaybe (error "newConfig:limitedList: empty list of servers") + genUsername :: Word32 -> MWC.GenIO -> IO (POSIXTime, Text) genUsername ttl prng = do rnd <- view (packedBytes . utf8) <$> replicateM 16 (MWC.uniformR (97, 122) prng) t <- fromIntegral . (+ ttl) . round <$> getPOSIXTime pure $ (t, rnd) + genTurnUsername :: Word32 -> MWC.GenIO -> IO Public.TurnUsername genTurnUsername = (fmap (uncurry Public.turnUsername) .) . genUsername + genSFTUsername :: Word32 -> MWC.GenIO -> IO Public.SFTUsername - genSFTUsername = (fmap (uncurry Public.mkSFTUsername) .) . genUsername - computeCred :: ToByteString a => Digest -> ByteString -> a -> AsciiBase64 + genSFTUsername = (fmap (uncurry (Public.mkSFTUsername shared)) .) . genUsername + + computeCred :: (ToByteString a) => Digest -> ByteString -> a -> AsciiBase64 computeCred dig secret = encodeBase64 . hmacBS dig secret . toByteString' authenticate :: - Member (Embed IO) r => + (Member (Embed IO) r) => Public.SFTServer -> Sem r Public.AuthSFTServer authenticate = diff --git a/services/brig/src/Brig/CanonicalInterpreter.hs b/services/brig/src/Brig/CanonicalInterpreter.hs index f4ab597711e..13158e6f03d 100644 --- a/services/brig/src/Brig/CanonicalInterpreter.hs +++ b/services/brig/src/Brig/CanonicalInterpreter.hs @@ -1,24 +1,20 @@ module Brig.CanonicalInterpreter where +import Brig.AWS (amazonkaEnv) import Brig.App as App import Brig.DeleteQueue.Interpreter as DQ -import Brig.Effects.BlacklistPhonePrefixStore (BlacklistPhonePrefixStore) -import Brig.Effects.BlacklistPhonePrefixStore.Cassandra (interpretBlacklistPhonePrefixStoreToCassandra) import Brig.Effects.BlacklistStore (BlacklistStore) import Brig.Effects.BlacklistStore.Cassandra (interpretBlacklistStoreToCassandra) -import Brig.Effects.CodeStore (CodeStore) -import Brig.Effects.CodeStore.Cassandra (codeStoreToCassandra, interpretClientToIO) import Brig.Effects.ConnectionStore (ConnectionStore) import Brig.Effects.ConnectionStore.Cassandra (connectionStoreToCassandra) import Brig.Effects.FederationConfigStore (FederationConfigStore) import Brig.Effects.FederationConfigStore.Cassandra (interpretFederationDomainConfig, remotesMapFromCfgFile) import Brig.Effects.JwtTools -import Brig.Effects.PasswordResetStore (PasswordResetStore) -import Brig.Effects.PasswordResetStore.CodeStore (passwordResetStoreToCodeStore) import Brig.Effects.PublicKeyBundle import Brig.Effects.SFT (SFT, interpretSFT) import Brig.Effects.UserPendingActivationStore (UserPendingActivationStore) import Brig.Effects.UserPendingActivationStore.Cassandra (userPendingActivationStoreToCassandra) +import Brig.IO.Intra (runUserEvents) import Brig.Options (ImplicitNoFederationRestriction (federationDomainConfig), federationDomainConfigs, federationStrategy) import Brig.Options qualified as Opt import Cassandra qualified as Cas @@ -35,55 +31,96 @@ import Polysemy.Embed (runEmbedded) import Polysemy.Error (Error, errorToIOFinal, mapError, runError) import Polysemy.Input (Input, runInputConst, runInputSem) import Polysemy.TinyLog (TinyLog) +import Wire.API.Allowlists (AllowlistEmailDomains) import Wire.API.Federation.Client qualified import Wire.API.Federation.Error +import Wire.AuthenticationSubsystem +import Wire.AuthenticationSubsystem.Interpreter import Wire.DeleteQueue +import Wire.EmailSending +import Wire.EmailSending.SES +import Wire.EmailSending.SMTP +import Wire.EmailSubsystem +import Wire.EmailSubsystem.Interpreter +import Wire.Error import Wire.FederationAPIAccess qualified import Wire.FederationAPIAccess.Interpreter (FederationAPIAccessConfig (..), interpretFederationAPIAccess) import Wire.GalleyAPIAccess (GalleyAPIAccess) import Wire.GalleyAPIAccess.Rpc import Wire.GundeckAPIAccess +import Wire.HashPassword import Wire.NotificationSubsystem import Wire.NotificationSubsystem.Interpreter (defaultNotificationSubsystemConfig, runNotificationSubsystemGundeck) import Wire.ParseException +import Wire.PasswordResetCodeStore (PasswordResetCodeStore) +import Wire.PasswordResetCodeStore.Cassandra (interpretClientToIO, passwordResetCodeStoreToCassandra) +import Wire.PasswordStore (PasswordStore) +import Wire.PasswordStore.Cassandra (interpretPasswordStore) import Wire.Rpc import Wire.Sem.Concurrency import Wire.Sem.Concurrency.IO import Wire.Sem.Delay import Wire.Sem.Jwk -import Wire.Sem.Logger.TinyLog (loggerToTinyLog) +import Wire.Sem.Logger.TinyLog (loggerToTinyLogReqId) import Wire.Sem.Now (Now) import Wire.Sem.Now.IO (nowToIOAction) import Wire.Sem.Paging.Cassandra (InternalPaging) +import Wire.Sem.Random +import Wire.Sem.Random.IO +import Wire.SessionStore +import Wire.SessionStore.Cassandra (interpretSessionStoreCassandra) +import Wire.UserEvents +import Wire.UserKeyStore +import Wire.UserKeyStore.Cassandra import Wire.UserStore import Wire.UserStore.Cassandra import Wire.UserSubsystem +import Wire.UserSubsystem.Error import Wire.UserSubsystem.Interpreter +import Wire.VerificationCodeStore +import Wire.VerificationCodeStore.Cassandra +import Wire.VerificationCodeSubsystem +import Wire.VerificationCodeSubsystem.Interpreter type BrigCanonicalEffects = - '[ UserSubsystem, + '[ AuthenticationSubsystem, + UserSubsystem, + EmailSubsystem, + VerificationCodeSubsystem, DeleteQueue, + UserEvents, + Error UserSubsystemError, + Error AuthenticationSubsystemError, Error Wire.API.Federation.Error.FederationError, + Error VerificationCodeSubsystemError, + Error HttpError, Wire.FederationAPIAccess.FederationAPIAccess Wire.API.Federation.Client.FederatorClient, + HashPassword, + UserKeyStore, UserStore, + SessionStore, + PasswordStore, + VerificationCodeStore, SFT, ConnectionStore InternalPaging, + Input VerificationCodeThrottleTTL, Input UTCTime, Input (Local ()), + Input (Maybe AllowlistEmailDomains), NotificationSubsystem, GundeckAPIAccess, FederationConfigStore, Jwk, PublicKeyBundle, JwtTools, - BlacklistPhonePrefixStore, BlacklistStore, - PasswordResetStore, UserPendingActivationStore InternalPaging, Now, Delay, - CodeStore, + Random, + PasswordResetCodeStore, GalleyAPIAccess, + EmailSending, Rpc, Embed Cas.Client, Error ParseException, @@ -119,42 +156,63 @@ runBrigToIO e (AppT ma) = do . interpretRace . embedToFinal . runEmbedded (runHttpClientIO e) - . loggerToTinyLog (e ^. applog) + . loggerToTinyLogReqId (e ^. App.requestId) (e ^. applog) . runError @SomeException . mapError @ErrorCall SomeException . mapError @ParseException SomeException . interpretClientToIO (e ^. casClient) . runRpcWithHttp (e ^. httpManager) (e ^. App.requestId) + . emailSendingInterpreter e . interpretGalleyAPIAccessToRpc (e ^. disabledVersions) (e ^. galleyEndpoint) - . codeStoreToCassandra @Cas.Client + . passwordResetCodeStoreToCassandra @Cas.Client + . randomToIO . runDelay . nowToIOAction (e ^. currentTime) . userPendingActivationStoreToCassandra - . passwordResetStoreToCodeStore . interpretBlacklistStoreToCassandra @Cas.Client - . interpretBlacklistPhonePrefixStoreToCassandra @Cas.Client . interpretJwtTools . interpretPublicKeyBundle . interpretJwk . interpretFederationDomainConfig (e ^. settings . federationStrategy) (foldMap (remotesMapFromCfgFile . fmap (.federationDomainConfig)) (e ^. settings . federationDomainConfigs)) . runGundeckAPIAccess (e ^. gundeckEndpoint) . runNotificationSubsystemGundeck (defaultNotificationSubsystemConfig (e ^. App.requestId)) + . runInputConst (e ^. settings . Opt.allowlistEmailDomains) . runInputConst (toLocalUnsafe (e ^. settings . Opt.federationDomain) ()) . runInputSem (embed getCurrentTime) + . runInputConst (e ^. settings . to Opt.set2FACodeGenerationDelaySecs . to fromIntegral) . connectionStoreToCassandra . interpretSFT (e ^. httpManager) + . interpretVerificationCodeStoreCassandra (e ^. casClient) + . interpretPasswordStore (e ^. casClient) + . interpretSessionStoreCassandra (e ^. casClient) . interpretUserStoreCassandra (e ^. casClient) + . interpretUserKeyStoreCassandra (e ^. casClient) + . runHashPassword . interpretFederationAPIAccess federationApiAccessConfig - . throwFederationErrorAsWaiError + . rethrowHttpErrorIO + . mapError verificationCodeSubsystemErrorToHttpError + . mapError (StdError . federationErrorToWai) + . mapError authenticationSubsystemErrorToHttpError + . mapError userSubsystemErrorToHttpError + . runUserEvents . runDeleteQueue (e ^. internalEvents) + . interpretVerificationCodeSubsystem + . emailSubsystemInterpreter (e ^. usrTemplates) (e ^. templateBranding) . runUserSubsystem userSubsystemConfig + . interpretAuthenticationSubsystem ) ) $ runReaderT ma e -throwFederationErrorAsWaiError :: Member (Final IO) r => InterpreterFor (Error FederationError) r -throwFederationErrorAsWaiError action = do - eithError <- errorToIOFinal action +rethrowHttpErrorIO :: (Member (Final IO) r) => InterpreterFor (Error HttpError) r +rethrowHttpErrorIO act = do + eithError <- errorToIOFinal act case eithError of - Left err -> embedToFinal $ throwM $ federationErrorToWai err + Left err -> embedToFinal $ throwM $ err Right a -> pure a + +emailSendingInterpreter :: (Member (Embed IO) r) => Env -> InterpreterFor EmailSending r +emailSendingInterpreter e = do + case (e ^. smtpEnv) of + Just smtp -> emailViaSMTPInterpreter (e ^. applog) smtp + Nothing -> emailViaSESInterpreter (e ^. awsEnv . amazonkaEnv) diff --git a/services/brig/src/Brig/Code.hs b/services/brig/src/Brig/Code.hs deleted file mode 100644 index 2ea506aa5e7..00000000000 --- a/services/brig/src/Brig/Code.hs +++ /dev/null @@ -1,370 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - --- 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 . - --- | Random, time-limited codes for e-mail addresses and phone numbers --- for use in a variety of 'Scope's. --- --- TODO: This module is supposed to (eventually) supersede the existing --- code verification functionality in the following modules: --- Brig.Data.Activation --- Brig.Data.PasswordReset --- Brig.Data.LoginCode -module Brig.Code - ( -- * Code - Code, - CodeFor (..), - Key (..), - Scope (..), - Value (..), - KeyValuePair (..), - Timeout (..), - Retries (..), - codeFor, - codeForEmail, - codeForPhone, - codeKey, - codeValue, - codeToKeyValuePair, - codeTTL, - codeAccount, - scopeFromAction, - - -- * Generation - Gen (genKey), - mkGen, - generate, - mk6DigitGen, - mkKey, - - -- * Storage - insert, - lookup, - verify, - delete, - ) -where - -import Brig.Email (emailKeyUniq, mkEmailKey) -import Brig.Phone (mkPhoneKey, phoneKeyUniq) -import Cassandra hiding (Value) -import Data.ByteString qualified as BS -import Data.Code -import Data.Range -import Data.RetryAfter (RetryAfter (RetryAfter)) -import Data.Text qualified as Text -import Data.Text.Ascii qualified as Ascii -import Data.Text.Encoding qualified as Text -import Data.UUID (UUID) -import Imports hiding (lookup) -import OpenSSL.BN (randIntegerZeroToNMinusOne) -import OpenSSL.EVP.Digest (Digest, digestBS, getDigestByName) -import OpenSSL.Random (randBytes) -import Text.Printf (printf) -import Wire.API.User qualified as User -import Wire.API.User.Identity - --------------------------------------------------------------------------------- --- Code - -data Code = Code - { codeKey :: !Key, - codeScope :: !Scope, - codeValue :: !Value, - codeRetries :: !Retries, - codeTTL :: !Timeout, - codeFor :: !CodeFor, - codeAccount :: !(Maybe UUID) - } - deriving (Eq, Show) - -data CodeFor - = ForEmail !Email - | ForPhone !Phone - deriving (Eq, Show) - -codeForEmail :: Code -> Maybe Email -codeForEmail c - | ForEmail e <- codeFor c = Just e - | otherwise = Nothing - -codeForPhone :: Code -> Maybe Phone -codeForPhone c - | ForPhone p <- codeFor c = Just p - | otherwise = Nothing - -scopeFromAction :: User.VerificationAction -> Scope -scopeFromAction = \case - User.CreateScimToken -> CreateScimToken - User.Login -> AccountLogin - User.DeleteTeam -> DeleteTeam - -codeToKeyValuePair :: Code -> KeyValuePair -codeToKeyValuePair code = KeyValuePair code.codeKey code.codeValue - --- | The same 'Key' can exist with different 'Value's in different --- 'Scope's at the same time. -data Scope - = AccountDeletion - | IdentityVerification - | PasswordReset - | AccountLogin - | AccountApproval - | CreateScimToken - | DeleteTeam - deriving (Eq, Show) - -instance Cql Scope where - ctype = Tagged IntColumn - - toCql AccountDeletion = CqlInt 1 - toCql IdentityVerification = CqlInt 2 - toCql PasswordReset = CqlInt 3 - toCql AccountLogin = CqlInt 4 - toCql AccountApproval = CqlInt 5 - toCql CreateScimToken = CqlInt 6 - toCql DeleteTeam = CqlInt 7 - - fromCql (CqlInt 1) = pure AccountDeletion - fromCql (CqlInt 2) = pure IdentityVerification - fromCql (CqlInt 3) = pure PasswordReset - fromCql (CqlInt 4) = pure AccountLogin - fromCql (CqlInt 5) = pure AccountApproval - fromCql (CqlInt 6) = pure CreateScimToken - fromCql (CqlInt 7) = pure DeleteTeam - fromCql _ = Left "fromCql: Scope: int expected" - -newtype Retries = Retries {numRetries :: Word8} - deriving (Eq, Show, Ord, Num, Integral, Enum, Real) - -instance Cql Retries where - ctype = Tagged IntColumn - toCql = CqlInt . fromIntegral . numRetries - fromCql (CqlInt n) = pure (Retries (fromIntegral n)) - fromCql _ = Left "fromCql: Retries: int expected" - --------------------------------------------------------------------------------- --- Generation - --- | A contextual string that is hashed into the key to yield distinct keys in --- different contexts for the same email address or phone number. --- TODO: newtype KeyContext = KeyContext ByteString -data Gen = Gen - { genFor :: !CodeFor, - genKey :: !Key, -- Note [Unique keys] - genValue :: IO Value - } - -mkKey :: MonadIO m => CodeFor -> m Key -mkKey cfor = liftIO $ do - Just sha256 <- getDigestByName "SHA256" - let uniqueK = case cfor of - ForEmail e -> emailKeyUniq (mkEmailKey e) - ForPhone p -> phoneKeyUniq (mkPhoneKey p) - pure $ mkKey' sha256 (Text.encodeUtf8 uniqueK) - --- | Initialise a 'Code' 'Gen'erator for a given natural key. This generates a link for emails and a 6-digit code for phone. See also: `mk6DigitGen`. -mkGen :: MonadIO m => CodeFor -> m Gen -mkGen cfor = liftIO $ do - Just sha256 <- getDigestByName "SHA256" - pure (initGen sha256 cfor) - where - initGen d (ForEmail e) = mkEmailLinkGen e d - initGen d _ = mk6DigitGen' cfor d - --- | Initialise a 'Code' 'Gen'erator for a given natural key. This generates a 6-digit code, matter whether it is sent to a phone or to an email address. See also: `mkGen`. -mk6DigitGen :: MonadIO m => CodeFor -> m Gen -mk6DigitGen cfor = liftIO $ do - Just sha256 <- getDigestByName "SHA256" - pure $ mk6DigitGen' cfor sha256 - -mk6DigitGen' :: CodeFor -> Digest -> Gen -mk6DigitGen' cfor d = - let uniqueK = case cfor of - ForEmail e -> emailKeyUniq (mkEmailKey e) - ForPhone p -> phoneKeyUniq (mkPhoneKey p) - key = mkKey' d $ Text.encodeUtf8 uniqueK - val = Value . unsafeRange . Ascii.unsafeFromText . Text.pack . printf "%06d" <$> randIntegerZeroToNMinusOne (10 ^ (6 :: Int)) - in Gen cfor key val - -mkEmailLinkGen :: Email -> Digest -> Gen -mkEmailLinkGen e d = - let key = mkKey' d (Text.encodeUtf8 (emailKeyUniq (mkEmailKey e))) - val = Value . unsafeRange . Ascii.encodeBase64Url <$> randBytes 15 - in Gen (ForEmail e) key val - -mkKey' :: Digest -> ByteString -> Key -mkKey' d = Key . unsafeRange . Ascii.encodeBase64Url . BS.take 15 . digestBS d - --- | Generate a new 'Code'. -generate :: - MonadIO m => - -- | The 'Gen'erator to use. - Gen -> - -- | The scope of the generated code. - Scope -> - -- | Maximum verification attempts. - Retries -> - -- | Time-to-live in seconds. - Timeout -> - -- | Associated account ID. - Maybe UUID -> - m Code -generate gen scope retries ttl account = do - let key = genKey gen - val <- liftIO $ genValue gen - pure $ mkCode key val - where - mkCode key val = - Code - { codeKey = key, - codeValue = val, - codeScope = scope, - codeRetries = retries, - codeTTL = ttl, - codeFor = genFor gen, - codeAccount = account - } - --- Note [Unique keys] --- --- We want unique, stable keys that we can associate the secret values with. --- Using the plain natural identifiers (e.g. e-mail addresses or phone numbers) --- has a few downsides: --- --- * The keys are often placed in URLs for verification purposes, --- giving them unnecessary exposure. --- * If the keys are not opaque, it can be harder to change their --- structure, possibly embedding additional information. --- * Since the keys are often placed in URLs, they must only contain --- URL-safe characters or otherwise require appropriate encoding. --- --- Therefore we use the following simple construction: --- --- * Compute the SHA-256 truncated to 120 bits of the plain, normalised, --- utf8-encoded natural identifier (i.e. e-mail address or phone number). --- * Apply URL-safe base64 encoding to yield the final key of length 20. --- --- Truncation of SHA-2 outputs is a safe and common practice, only reducing --- collision resistance (e.g. after 2^60 for truncated SHA-256/120 due to the --- birthday paradox). Collisions have no security implications in this context; --- at most it enables verification of one random e-mail address or phone --- number via another, at least one of which must be accessible. It is only --- important that keys be sufficiently unique and random collisions rare --- while keeping the length reasonably short, so that keys may be used in --- length-constrained contexts (e.g. SMS) or even be spelled out or typed. - --------------------------------------------------------------------------------- --- Storage - -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 - let r = fromIntegral (codeRetries c) - let a = codeAccount c - let e = codeForEmail c - let p = codeForPhone c - let t = round (codeTTL c) - retry x5 (write cql (params LocalQuorum (k, s, v, r, e, p, a, t))) - where - cql :: PrepQuery W (Key, Scope, Value, Retries, Maybe Email, Maybe Phone, Maybe UUID, Int32) () - cql = - "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))) - where - cql :: PrepQuery R (Key, Scope) (Value, Int32, Retries, Maybe Email, Maybe Phone, Maybe UUID) - cql = - "SELECT value, ttl(value), retries, email, phone, account \ - \FROM vcodes WHERE key = ? AND scope = ?" - --- | Lookup and verify the code for the given key and scope --- against the given value. -verify :: MonadClient m => Key -> Scope -> Value -> m (Maybe Code) -verify k s v = lookup k s >>= maybe (pure Nothing) continue - where - continue c - | codeValue c == v && codeRetries c > 0 = pure (Just c) - | codeRetries c > 0 = do - insertInternal (c {codeRetries = codeRetries c - 1}) - pure Nothing - | otherwise = pure Nothing - --- | Delete a code associated with the given key and scope. -delete :: MonadClient m => Key -> Scope -> m () -delete k s = retry x5 $ write cql (params LocalQuorum (k, s)) - where - cql :: PrepQuery W (Key, Scope) () - cql = "DELETE FROM vcodes WHERE key = ? AND scope = ?" - --------------------------------------------------------------------------------- --- Internal - -toCode :: Key -> Scope -> (Value, Int32, Retries, Maybe Email, Maybe Phone, Maybe UUID) -> Code -toCode k s (val, ttl, retries, email, phone, account) = - let ek = ForEmail <$> email - pk = ForPhone <$> phone - to = Timeout (fromIntegral ttl) - in case ek <|> pk of - Nothing -> error "toCode: email or phone must be present" - Just cf -> - Code - { codeKey = k, - codeScope = s, - codeValue = val, - codeTTL = to, - codeRetries = retries, - codeFor = cf, - codeAccount = account - } diff --git a/services/brig/src/Brig/Data/Activation.hs b/services/brig/src/Brig/Data/Activation.hs index 2afb23725fd..d665051b8ce 100644 --- a/services/brig/src/Brig/Data/Activation.hs +++ b/services/brig/src/Brig/Data/Activation.hs @@ -29,11 +29,8 @@ module Brig.Data.Activation ) where -import Brig.App (Env) +import Brig.App (Env, adhocUserKeyStoreInterpreter) import Brig.Data.User -import Brig.Data.UserKey -import Brig.Effects.CodeStore qualified as E -import Brig.Effects.CodeStore.Cassandra import Brig.Options import Brig.Types.Intra import Cassandra @@ -50,6 +47,10 @@ import Polysemy import Text.Printf (printf) import Wire.API.User import Wire.API.User.Activation +import Wire.API.User.Password +import Wire.PasswordResetCodeStore qualified as E +import Wire.PasswordResetCodeStore.Cassandra +import Wire.UserKeyStore -- | The information associated with the pending activation of a 'UserKey'. data Activation = Activation @@ -78,7 +79,6 @@ activationErrorToRegisterError = \case data ActivationEvent = AccountActivated !UserAccount | EmailActivated !UserId !Email - | PhoneActivated !UserId !Phone -- | Max. number of activation attempts per 'ActivationKey'. maxAttempts :: Int32 @@ -95,66 +95,59 @@ activateKey :: activateKey k c u = verifyCode k c >>= pickUser >>= activate where pickUser (uk, u') = maybe (throwE invalidUser) (pure . (uk,)) (u <|> u') - activate (key, uid) = do + activate (key :: EmailKey, uid) = do a <- lift (lookupAccount uid) >>= maybe (throwE invalidUser) pure unless (accountStatus a == Active) $ -- this is never 'PendingActivation' in the flow this function is used in. throwE invalidCode case userIdentity (accountUser a) of Nothing -> do claim key uid - let ident = foldKey EmailIdentity PhoneIdentity key + let ident = EmailIdentity (emailKeyOrig key) lift $ activateUser uid ident let a' = a {accountUser = (accountUser a) {userIdentity = Just ident}} pure . Just $ AccountActivated a' Just _ -> do let usr = accountUser a - (profileNeedsUpdate, oldKey) = - foldKey - (\(e :: Email) -> (Just e /= userEmail usr,) . fmap userEmailKey . userEmail) - (\(p :: Phone) -> (Just p /= userPhone usr,) . fmap userPhoneKey . userPhone) - key - usr + profileNeedsUpdate = Just (emailKeyOrig key) /= userEmail usr + oldKey :: Maybe EmailKey = mkEmailKey <$> userEmail usr in handleExistingIdentity uid profileNeedsUpdate oldKey key handleExistingIdentity uid profileNeedsUpdate oldKey key | oldKey == Just key && not profileNeedsUpdate = pure Nothing -- activating existing key and exactly same profile -- (can happen when a user clicks on activation links more than once) | oldKey == Just key && profileNeedsUpdate = do - lift $ foldKey (updateEmailAndDeleteEmailUnvalidated uid) (updatePhone uid) key - pure . Just $ foldKey (EmailActivated uid) (PhoneActivated uid) key + lift $ updateEmailAndDeleteEmailUnvalidated uid (emailKeyOrig key) + pure . Just $ EmailActivated uid (emailKeyOrig key) -- if the key is the same, we only want to update our profile | otherwise = do - lift (runM (codeStoreToCassandra @m @'[Embed m] (E.mkPasswordResetKey uid >>= E.codeDelete))) + lift (runM (passwordResetCodeStoreToCassandra @m @'[Embed m] (E.codeDelete (mkPasswordResetKey uid)))) claim key uid - lift $ foldKey (updateEmailAndDeleteEmailUnvalidated uid) (updatePhone uid) key - for_ oldKey $ lift . deleteKey - pure . Just $ foldKey (EmailActivated uid) (PhoneActivated uid) key + lift $ updateEmailAndDeleteEmailUnvalidated uid (emailKeyOrig key) + for_ oldKey $ lift . adhocUserKeyStoreInterpreter . deleteKey + pure . Just $ EmailActivated uid (emailKeyOrig key) where updateEmailAndDeleteEmailUnvalidated :: UserId -> Email -> m () updateEmailAndDeleteEmailUnvalidated u' email = updateEmail u' email <* deleteEmailUnvalidated u' claim key uid = do - ok <- lift $ claimKey key uid + ok <- lift $ adhocUserKeyStoreInterpreter (claimKey key uid) unless ok $ throwE . UserKeyExists . LT.fromStrict $ - foldKey fromEmail fromPhone key + fromEmail (emailKeyOrig key) --- | Create a new pending activation for a given 'UserKey'. +-- | Create a new pending activation for a given 'EmailKey'. newActivation :: - MonadClient m => - UserKey -> + (MonadClient m) => + EmailKey -> -- | The timeout for the activation code. Timeout -> -- | The user with whom to associate the activation code. Maybe UserId -> m Activation newActivation uk timeout u = do - (typ, key, code) <- - liftIO $ - foldKey - (\e -> ("email",fromEmail e,) <$> genCode) - (\p -> ("phone",fromPhone p,) <$> genCode) - uk + let typ = "email" + key = fromEmail (emailKeyOrig uk) + code <- liftIO $ genCode insert typ key code where insert t k c = do @@ -166,45 +159,42 @@ newActivation uk timeout u = do <$> randIntegerZeroToNMinusOne 1000000 -- | Lookup an activation code and it's associated owner (if any) for a 'UserKey'. -lookupActivationCode :: MonadClient m => UserKey -> m (Maybe (Maybe UserId, ActivationCode)) +lookupActivationCode :: (MonadClient m) => EmailKey -> m (Maybe (Maybe UserId, ActivationCode)) lookupActivationCode k = liftIO (mkActivationKey k) >>= retry x1 . query1 codeSelect . params LocalQuorum . Identity -- | Verify an activation code. verifyCode :: - MonadClient m => + (MonadClient m) => ActivationKey -> ActivationCode -> - ExceptT ActivationError m (UserKey, Maybe UserId) + ExceptT ActivationError m (EmailKey, Maybe UserId) verifyCode key code = do s <- lift . retry x1 . query1 keySelect $ params LocalQuorum (Identity key) case s of Just (ttl, Ascii t, k, c, u, r) -> if - | c == code -> mkScope t k u - | r >= 1 -> countdown (key, t, k, c, u, r - 1, ttl) >> throwE invalidCode - | otherwise -> revoke >> throwE invalidCode + | c == code -> mkScope t k u + | r >= 1 -> countdown (key, t, k, c, u, r - 1, ttl) >> throwE invalidCode + | otherwise -> revoke >> throwE invalidCode Nothing -> throwE invalidCode where mkScope "email" k u = case parseEmail k of - Just e -> pure (userEmailKey e, u) - Nothing -> throwE invalidCode - mkScope "phone" k u = case parsePhone k of - Just p -> pure (userPhoneKey p, u) + Just e -> pure (mkEmailKey e, u) Nothing -> throwE invalidCode mkScope _ _ _ = throwE invalidCode countdown = lift . retry x5 . write keyInsert . params LocalQuorum revoke = lift $ deleteActivationPair key -mkActivationKey :: UserKey -> IO ActivationKey +mkActivationKey :: EmailKey -> IO ActivationKey mkActivationKey k = do d <- liftIO $ getDigestByName "SHA256" d' <- maybe (fail "SHA256 not found") pure d - let bs = digestBS d' (T.encodeUtf8 $ keyText k) + let bs = digestBS d' (T.encodeUtf8 $ emailKeyUniq k) pure . ActivationKey $ Ascii.encodeBase64Url bs -deleteActivationPair :: MonadClient m => ActivationKey -> m () +deleteActivationPair :: (MonadClient m) => ActivationKey -> m () deleteActivationPair = write keyDelete . params LocalQuorum . Identity invalidUser :: ActivationError diff --git a/services/brig/src/Brig/Data/Client.hs b/services/brig/src/Brig/Data/Client.hs index 69e9ac0b829..946d58577b3 100644 --- a/services/brig/src/Brig/Data/Client.hs +++ b/services/brig/src/Brig/Data/Client.hs @@ -59,7 +59,6 @@ import Brig.App import Brig.Data.User (AuthError (..), ReAuthError (..)) import Brig.Data.User qualified as User import Brig.Types.Instances () -import Brig.User.Auth.DB.Instances () import Cassandra as C hiding (Client) import Cassandra.Settings as C hiding (Client) import Control.Error @@ -75,12 +74,12 @@ import Data.HashMap.Strict qualified as HashMap import Data.Id import Data.Json.Util (UTCTimeMillis, toUTCTimeMillis) import Data.Map qualified as Map -import Data.Metrics qualified as Metrics import Data.Set qualified as Set import Data.Text qualified as Text import Data.Time.Clock import Data.UUID qualified as UUID import Imports +import Prometheus qualified as Prom import System.CryptoBox (Result (Success)) import System.CryptoBox qualified as CryptoBox import System.Logger.Class (field, msg, val) @@ -184,7 +183,7 @@ addClientWithReAuthPolicy reAuthPolicy u newId c maxPermClients cps = do clientLastActive = Nothing } -lookupClient :: MonadClient m => UserId -> ClientId -> m (Maybe Client) +lookupClient :: (MonadClient m) => UserId -> ClientId -> m (Maybe Client) lookupClient u c = do keys <- retry x1 (query selectMLSPublicKeys (params LocalQuorum (u, c))) fmap (toClient keys) @@ -195,7 +194,7 @@ lookupClientsBulk uids = liftClient $ do userClientTuples <- pooledMapConcurrentlyN 50 getClientSetWithUser uids pure $ Map.fromList userClientTuples where - getClientSetWithUser :: MonadClient m => UserId -> m (UserId, Imports.Set Client) + getClientSetWithUser :: (MonadClient m) => UserId -> m (UserId, Imports.Set Client) getClientSetWithUser u = fmap ((u,) . Set.fromList) . lookupClients $ u lookupPubClientsBulk :: (MonadClient m) => [UserId] -> m (UserMap (Imports.Set PubClient)) @@ -203,13 +202,13 @@ lookupPubClientsBulk uids = liftClient $ do userClientTuples <- pooledMapConcurrentlyN 50 getClientSetWithUser uids pure $ UserMap $ Map.fromList userClientTuples where - getClientSetWithUser :: MonadClient m => UserId -> m (UserId, Imports.Set PubClient) + getClientSetWithUser :: (MonadClient m) => UserId -> m (UserId, Imports.Set PubClient) getClientSetWithUser u = (u,) . Set.fromList . map toPubClient <$> executeQuery u - executeQuery :: MonadClient m => UserId -> m [(ClientId, Maybe ClientClass)] + executeQuery :: (MonadClient m) => UserId -> m [(ClientId, Maybe ClientClass)] executeQuery u = retry x1 (query selectPubClients (params LocalQuorum (Identity u))) -lookupClients :: MonadClient m => UserId -> m [Client] +lookupClients :: (MonadClient m) => UserId -> m [Client] lookupClients u = do keys <- (\(cid, ss, Blob b) -> (cid, [(ss, LBS.toStrict b)])) @@ -223,23 +222,23 @@ lookupClients u = do updateKeys . toClient [] <$$> retry x1 (query selectClients (params LocalQuorum (Identity u))) -lookupClientIds :: MonadClient m => UserId -> m [ClientId] +lookupClientIds :: (MonadClient m) => UserId -> m [ClientId] lookupClientIds u = map runIdentity <$> retry x1 (query selectClientIds (params LocalQuorum (Identity u))) -lookupUsersClientIds :: MonadClient m => [UserId] -> m [(UserId, Set.Set ClientId)] +lookupUsersClientIds :: (MonadClient m) => [UserId] -> m [(UserId, Set.Set ClientId)] lookupUsersClientIds us = liftClient $ pooledMapConcurrentlyN 16 getClientIds us where getClientIds u = (u,) <$> fmap Set.fromList (lookupClientIds u) -lookupPrekeyIds :: MonadClient m => UserId -> ClientId -> m [PrekeyId] +lookupPrekeyIds :: (MonadClient m) => UserId -> ClientId -> m [PrekeyId] lookupPrekeyIds u c = map runIdentity <$> retry x1 (query selectPrekeyIds (params LocalQuorum (u, c))) -hasClient :: MonadClient m => UserId -> ClientId -> m Bool +hasClient :: (MonadClient m) => UserId -> ClientId -> m Bool hasClient u d = isJust <$> retry x1 (query1 checkClient (params LocalQuorum (u, d))) rmClient :: @@ -255,21 +254,21 @@ rmClient u c = do retry x5 $ write removeClientKeys (params LocalQuorum (u, c)) unlessM (isJust <$> view randomPrekeyLocalLock) $ deleteOptLock u c -updateClientLabel :: MonadClient m => UserId -> ClientId -> Maybe Text -> m () +updateClientLabel :: (MonadClient m) => UserId -> ClientId -> Maybe Text -> m () updateClientLabel u c l = retry x5 $ write updateClientLabelQuery (params LocalQuorum (l, u, c)) -updateClientCapabilities :: MonadClient m => UserId -> ClientId -> Maybe (Imports.Set ClientCapability) -> m () +updateClientCapabilities :: (MonadClient m) => UserId -> ClientId -> Maybe (Imports.Set ClientCapability) -> m () updateClientCapabilities u c fs = retry x5 $ write updateClientCapabilitiesQuery (params LocalQuorum (C.Set . Set.toList <$> fs, u, c)) -- | If the update fails, which can happen if device does not exist, then ignore the error silently. -updateClientLastActive :: MonadClient m => UserId -> ClientId -> UTCTime -> m () +updateClientLastActive :: (MonadClient m) => UserId -> ClientId -> UTCTime -> m () updateClientLastActive u c t = void . retry x5 $ trans updateClientLastActiveQuery (params LocalQuorum (t, u, c)) -updatePrekeys :: MonadClient m => UserId -> ClientId -> [Prekey] -> ExceptT ClientDataError m () +updatePrekeys :: (MonadClient m) => UserId -> ClientId -> [Prekey] -> ExceptT ClientDataError m () updatePrekeys u c pks = do plain <- mapM (hoistEither . fmapL (const MalformedPrekeys) . B64.decode . toByteString' . prekeyKey) pks binary <- liftIO $ zipWithM check pks plain @@ -289,7 +288,8 @@ claimPrekey :: ( Log.MonadLogger m, MonadMask m, MonadClient m, - MonadReader Brig.App.Env m + MonadReader Brig.App.Env m, + Prom.MonadMonitor m ) => UserId -> ClientId -> @@ -318,7 +318,7 @@ claimPrekey u c = pure $ Just (ClientPrekey c (Prekey i k)) removeAndReturnPreKey Nothing = pure Nothing - pickRandomPrekey :: MonadIO f => [(PrekeyId, Text)] -> f (Maybe (PrekeyId, Text)) + pickRandomPrekey :: (MonadIO f) => [(PrekeyId, Text)] -> f (Maybe (PrekeyId, Text)) pickRandomPrekey [] = pure Nothing -- unless we only have one key left pickRandomPrekey [pk] = pure $ Just pk @@ -329,7 +329,7 @@ claimPrekey u c = pure $ atMay pks' ind lookupMLSPublicKey :: - MonadClient m => + (MonadClient m) => UserId -> ClientId -> SignatureSchemeTag -> @@ -338,7 +338,7 @@ lookupMLSPublicKey u c ss = (fromBlob . runIdentity) <$$> retry x1 (query1 selectMLSPublicKey (params LocalQuorum (u, c, ss))) addMLSPublicKeys :: - MonadClient m => + (MonadClient m) => UserId -> ClientId -> [(SignatureSchemeTag, ByteString)] -> @@ -346,7 +346,7 @@ addMLSPublicKeys :: addMLSPublicKeys u c = traverse_ (uncurry (addMLSPublicKey u c)) addMLSPublicKey :: - MonadClient m => + (MonadClient m) => UserId -> ClientId -> SignatureSchemeTag -> @@ -498,7 +498,8 @@ withOptLock :: forall a m. ( MonadIO m, MonadReader Brig.App.Env m, - Log.MonadLogger m + Log.MonadLogger m, + Prom.MonadMonitor m ) => UserId -> ClientId -> @@ -545,15 +546,14 @@ withOptLock u c ma = go (10 :: Int) toAttributeValue :: Word32 -> AWS.AttributeValue toAttributeValue w = AWS.N $ AWS.toText (fromIntegral w :: Int) reportAttemptFailure :: m () - reportAttemptFailure = - Metrics.counterIncr (Metrics.path "client.opt_lock.optimistic_lock_grab_attempt_failed") =<< view metrics + reportAttemptFailure = Prom.incCounter optimisticLockGrabAttemptFailedCounter reportFailureAndLogError :: m () reportFailureAndLogError = do Log.err $ Log.field "user" (toByteString' u) . Log.field "client" (toByteString' c) . msg (val "PreKeys: Optimistic lock failed") - Metrics.counterIncr (Metrics.path "client.opt_lock.optimistic_lock_failed") =<< view metrics + Prom.incCounter optimisticLockFailedCounter execDyn :: forall r x. (AWS.AWSRequest r, Typeable r, Typeable (AWS.AWSResponse r)) => @@ -563,27 +563,55 @@ withOptLock u c ma = go (10 :: Int) execDyn cnv mkCmd = do cmd <- mkCmd <$> view (awsEnv . prekeyTable) e <- view (awsEnv . amazonkaEnv) - m <- view metrics - liftIO $ execDyn' e m cnv cmd + liftIO $ execDyn' e cnv cmd where execDyn' :: forall y p. (AWS.AWSRequest p, Typeable (AWS.AWSResponse p), Typeable p) => AWS.Env -> - Metrics.Metrics -> (AWS.AWSResponse p -> Maybe y) -> p -> IO (Maybe y) - execDyn' e m conv cmd = recovering policy handlers (const run) + execDyn' e conv cmd = recovering policy handlers (const run) where run = execCatch e cmd >>= either handleErr (pure . conv) handlers = httpHandlers ++ [const $ EL.handler_ AWS._ConditionalCheckFailedException (pure True)] policy = limitRetries 3 <> exponentialBackoff 100000 handleErr (AWS.ServiceError se) | se ^. AWS.serviceError_code == AWS.ErrorCode "ProvisionedThroughputExceeded" = do - Metrics.counterIncr (Metrics.path "client.opt_lock.provisioned_throughput_exceeded") m + Prom.incCounter dynProvisionedThroughputExceededCounter pure Nothing handleErr _ = pure Nothing withLocalLock :: (MonadMask m, MonadIO m) => MVar () -> m a -> m a withLocalLock l ma = do (takeMVar l *> ma) `finally` putMVar l () + +{-# NOINLINE optimisticLockGrabAttemptFailedCounter #-} +optimisticLockGrabAttemptFailedCounter :: Prom.Counter +optimisticLockGrabAttemptFailedCounter = + Prom.unsafeRegister $ + Prom.counter + Prom.Info + { Prom.metricName = "client.opt_lock.optimistic_lock_grab_attempt_failed", + Prom.metricHelp = "Number of times grab attempts for optimisitic lock on prekeys failed" + } + +{-# NOINLINE optimisticLockFailedCounter #-} +optimisticLockFailedCounter :: Prom.Counter +optimisticLockFailedCounter = + Prom.unsafeRegister $ + Prom.counter + Prom.Info + { Prom.metricName = "client.opt_lock.optimistic_lock_failed", + Prom.metricHelp = "Number of time optimisitic lock on prekeys failed" + } + +{-# NOINLINE dynProvisionedThroughputExceededCounter #-} +dynProvisionedThroughputExceededCounter :: Prom.Counter +dynProvisionedThroughputExceededCounter = + Prom.unsafeRegister $ + Prom.counter + Prom.Info + { Prom.metricName = "client.opt_lock.provisioned_throughput_exceeded", + Prom.metricHelp = "Number of times provisioned throughput on DynamoDB was exceeded" + } diff --git a/services/brig/src/Brig/Data/Connection.hs b/services/brig/src/Brig/Data/Connection.hs index ec46f3fe406..ff843f215f4 100644 --- a/services/brig/src/Brig/Data/Connection.hs +++ b/services/brig/src/Brig/Data/Connection.hs @@ -272,7 +272,7 @@ lookupRemoteConnectedUsersC u maxResults = paginateC remoteConnectionSelect (paramsP LocalQuorum (Identity (tUnqualified u)) maxResults) x1 .| C.map (\xs -> map (\x@(d, _, _, _, _, _) -> toRemoteUnsafe d (toRemoteUserConnection u x)) xs) -lookupRemoteConnectedUsersPaginated :: MonadClient m => Local UserId -> Int32 -> m (Page (Remote UserConnection)) +lookupRemoteConnectedUsersPaginated :: (MonadClient m) => Local UserId -> Int32 -> m (Page (Remote UserConnection)) lookupRemoteConnectedUsersPaginated u maxResults = do (\x@(d, _, _, _, _, _) -> toRemoteUnsafe d (toRemoteUserConnection u x)) <$$> retry x1 (paginate remoteConnectionSelect (paramsP LocalQuorum (Identity (tUnqualified u)) maxResults)) diff --git a/services/brig/src/Brig/Data/LoginCode.hs b/services/brig/src/Brig/Data/LoginCode.hs index 1f58dba7cc7..3103e939747 100644 --- a/services/brig/src/Brig/Data/LoginCode.hs +++ b/services/brig/src/Brig/Data/LoginCode.hs @@ -27,7 +27,6 @@ module Brig.Data.LoginCode where import Brig.App (Env, currentTime) -import Brig.User.Auth.DB.Instances () import Cassandra import Control.Lens (view) import Data.Code @@ -76,10 +75,10 @@ lookupLoginCode u = do pending c now t = PendingLoginCode c (timeout now t) timeout now t = Timeout (t `diffUTCTime` now) -deleteLoginCode :: MonadClient m => UserId -> m () +deleteLoginCode :: (MonadClient m) => UserId -> m () deleteLoginCode u = retry x5 . write codeDelete $ params LocalQuorum (Identity u) -insertLoginCode :: MonadClient m => UserId -> LoginCode -> Int32 -> UTCTime -> m () +insertLoginCode :: (MonadClient m) => UserId -> LoginCode -> Int32 -> UTCTime -> m () insertLoginCode u c n t = retry x5 . write codeInsert $ params LocalQuorum (u, c, n, t, round ttl) -- Queries diff --git a/services/brig/src/Brig/Data/MLS/KeyPackage.hs b/services/brig/src/Brig/Data/MLS/KeyPackage.hs index 7aaccc4d16c..de816cbbbf0 100644 --- a/services/brig/src/Brig/Data/MLS/KeyPackage.hs +++ b/services/brig/src/Brig/Data/MLS/KeyPackage.hs @@ -45,7 +45,7 @@ import Wire.API.MLS.LeafNode import Wire.API.MLS.Serialisation insertKeyPackages :: - MonadClient m => + (MonadClient m) => UserId -> ClientId -> [(KeyPackageRef, CipherSuiteTag, KeyPackageData)] -> @@ -134,7 +134,7 @@ countKeyPackages :: m Int64 countKeyPackages u c suite = fromIntegral . length <$> getNonClaimedKeyPackages u c suite -deleteKeyPackages :: MonadClient m => UserId -> ClientId -> CipherSuiteTag -> [KeyPackageRef] -> m () +deleteKeyPackages :: (MonadClient m) => UserId -> ClientId -> CipherSuiteTag -> [KeyPackageRef] -> m () deleteKeyPackages u c suite refs = retry x5 $ write diff --git a/services/brig/src/Brig/Data/Nonce.hs b/services/brig/src/Brig/Data/Nonce.hs index 8ca18fd1a53..00fda3fbcd5 100644 --- a/services/brig/src/Brig/Data/Nonce.hs +++ b/services/brig/src/Brig/Data/Nonce.hs @@ -28,7 +28,7 @@ import Data.Nonce (Nonce, NonceTtlSecs) import Imports insertNonce :: - MonadClient m => + (MonadClient m) => NonceTtlSecs -> UserId -> Text -> @@ -40,14 +40,14 @@ insertNonce ttl uid key nonce = retry x5 . write insert $ params LocalQuorum (ui insert = "INSERT INTO nonce (user, key, nonce) VALUES (?, ?, ?) USING TTL ?" lookupAndDeleteNonce :: - MonadClient m => + (MonadClient m) => UserId -> Text -> m (Maybe Nonce) lookupAndDeleteNonce uid key = lookupNonce uid key <* deleteNonce uid key lookupNonce :: - MonadClient m => + (MonadClient m) => UserId -> Text -> m (Maybe Nonce) @@ -57,7 +57,7 @@ lookupNonce uid key = (runIdentity <$$>) . retry x5 . query1 get $ params LocalQ get = "SELECT nonce FROM nonce WHERE user = ? AND key = ?" deleteNonce :: - MonadClient m => + (MonadClient m) => UserId -> Text -> m () diff --git a/services/brig/src/Brig/Data/Properties.hs b/services/brig/src/Brig/Data/Properties.hs index b073394584f..6fd099d8620 100644 --- a/services/brig/src/Brig/Data/Properties.hs +++ b/services/brig/src/Brig/Data/Properties.hs @@ -39,7 +39,7 @@ data PropertiesDataError = TooManyProperties insertProperty :: - MonadClient m => + (MonadClient m) => UserId -> PropertyKey -> RawPropertyValue -> @@ -50,23 +50,23 @@ insertProperty u k v = do throwE TooManyProperties lift . retry x5 $ write propertyInsert (params LocalQuorum (u, k, v)) -deleteProperty :: MonadClient m => UserId -> PropertyKey -> m () +deleteProperty :: (MonadClient m) => UserId -> PropertyKey -> m () deleteProperty u k = retry x5 $ write propertyDelete (params LocalQuorum (u, k)) -clearProperties :: MonadClient m => UserId -> m () +clearProperties :: (MonadClient m) => UserId -> m () clearProperties u = retry x5 $ write propertyReset (params LocalQuorum (Identity u)) -lookupProperty :: MonadClient m => UserId -> PropertyKey -> m (Maybe RawPropertyValue) +lookupProperty :: (MonadClient m) => UserId -> PropertyKey -> m (Maybe RawPropertyValue) lookupProperty u k = fmap runIdentity <$> retry x1 (query1 propertySelect (params LocalQuorum (u, k))) -lookupPropertyKeys :: MonadClient m => UserId -> m [PropertyKey] +lookupPropertyKeys :: (MonadClient m) => UserId -> m [PropertyKey] lookupPropertyKeys u = map runIdentity <$> retry x1 (query propertyKeysSelect (params LocalQuorum (Identity u))) -lookupPropertyKeysAndValues :: MonadClient m => UserId -> m [(PropertyKey, RawPropertyValue)] +lookupPropertyKeysAndValues :: (MonadClient m) => UserId -> m [(PropertyKey, RawPropertyValue)] lookupPropertyKeysAndValues u = retry x1 (query propertyKeysValuesSelect (params LocalQuorum (Identity u))) diff --git a/services/brig/src/Brig/Data/User.hs b/services/brig/src/Brig/Data/User.hs index 5eb86970276..7dcd1ed89d5 100644 --- a/services/brig/src/Brig/Data/User.hs +++ b/services/brig/src/Brig/Data/User.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- This file is part of the Wire Server implementation. @@ -30,7 +29,6 @@ module Brig.Data.User authenticate, reauthenticate, filterActive, - isActivated, isSamlUser, -- * Lookups @@ -39,9 +37,6 @@ module Brig.Data.User lookupUser, lookupUsers, lookupName, - lookupLocale, - lookupPassword, - lookupStatus, lookupRichInfo, lookupRichInfoMultiUsers, lookupUserTeam, @@ -51,31 +46,24 @@ module Brig.Data.User userExists, -- * Updates - updateUser, updateEmail, updateEmailUnvalidated, - updatePhone, updateSSOId, updateManagedBy, activateUser, deactivateUser, - updateLocale, - updatePassword, updateStatus, - updateHandle, - updateSupportedProtocols, updateRichInfo, updateFeatureConferenceCalling, -- * Deletions deleteEmail, deleteEmailUnvalidated, - deletePhone, deleteServiceUser, ) where -import Brig.App (Env, currentTime, settings, viewFederationDomain, zauthEnv) +import Brig.App import Brig.Options import Brig.Types.Intra import Brig.ZAuth qualified as ZAuth @@ -93,11 +81,13 @@ import Data.Range (fromRange) import Data.Time (addUTCTime) import Data.UUID.V4 import Imports +import Polysemy import Wire.API.Password import Wire.API.Provider.Service import Wire.API.Team.Feature qualified as ApiFt import Wire.API.User import Wire.API.User.RichInfo +import Wire.PasswordStore -- | Authentication errors. data AuthError @@ -133,7 +123,7 @@ newAccount u inv tid mbHandle = do (Just (toUUID -> uuid), _) -> pure uuid (_, Just uuid) -> pure uuid (Nothing, Nothing) -> liftIO nextRandom - passwd <- maybe (pure Nothing) (fmap Just . liftIO . mkSafePassword) pass + passwd <- maybe (pure Nothing) (fmap Just . liftIO . mkSafePasswordScrypt) pass expiry <- case status of Ephemeral -> do -- Ephemeral users' expiry time is in expires_in (default sessionTokenTimeout) seconds @@ -160,7 +150,7 @@ newAccount u inv tid mbHandle = do prots = fromMaybe defSupportedProtocols (newUserSupportedProtocols u) user uid domain l e = User (Qualified uid domain) ident name pict assets colour False l Nothing mbHandle e tid managedBy prots -newAccountInviteViaScim :: MonadReader Env m => UserId -> TeamId -> Maybe Locale -> Name -> Email -> m UserAccount +newAccountInviteViaScim :: (MonadReader Env m) => UserId -> TeamId -> Maybe Locale -> Name -> Email -> m UserAccount newAccountInviteViaScim uid tid locale name email = do defLoc <- setDefaultUserLocale <$> view settings let loc = fromMaybe defLoc locale @@ -185,9 +175,9 @@ newAccountInviteViaScim uid tid locale name email = do defSupportedProtocols -- | Mandatory password authentication. -authenticate :: MonadClient m => UserId -> PlainTextPassword6 -> ExceptT AuthError m () +authenticate :: forall r. (Member PasswordStore r) => UserId -> PlainTextPassword6 -> ExceptT AuthError (AppT r) () authenticate u pw = - lift (lookupAuth u) >>= \case + lift (wrapHttp $ lookupAuth u) >>= \case Nothing -> throwE AuthInvalidUser Just (_, Deleted) -> throwE AuthInvalidUser Just (_, Suspended) -> throwE AuthSuspended @@ -200,8 +190,13 @@ authenticate u pw = (True, PasswordStatusNeedsUpdate) -> do -- FUTUREWORK(elland): 6char pwd allowed for now -- throwE AuthStalePassword in the future - for_ (plainTextPassword8 . fromPlainTextPassword $ pw) (updatePassword u) + for_ (plainTextPassword8 . fromPlainTextPassword $ pw) (lift . hashAndUpdatePwd u) (True, _) -> pure () + where + hashAndUpdatePwd :: UserId -> PlainTextPassword8 -> AppT r () + hashAndUpdatePwd uid pwd = do + hashed <- mkSafePasswordScrypt pwd + liftSem $ upsertHashedPassword uid hashed -- | Password reauthentication. If the account has a password, reauthentication -- is mandatory. If the account has no password, or is an SSO user, and no password is given, @@ -227,11 +222,11 @@ isSamlUser :: (MonadClient m, MonadReader Env m) => UserId -> m Bool isSamlUser uid = do account <- lookupAccount uid case userIdentity . accountUser =<< account of - Just (SSOIdentity (UserSSOId _) _ _) -> pure True + Just (SSOIdentity (UserSSOId _) _) -> pure True _ -> pure False insertAccount :: - MonadClient m => + (MonadClient m) => UserAccount -> -- | If a bot: conversation and team -- (if a team conversation) @@ -251,7 +246,6 @@ insertAccount (UserAccount u status) mbConv password activated = retry x5 . batc userPict u, userAssets u, userEmail u, - userPhone u, userSSOId u, userAccentId u, password, @@ -283,28 +277,13 @@ insertAccount (UserAccount u status) mbConv password activated = retry x5 . batc "INSERT INTO service_team (provider, service, user, conv, team) \ \VALUES (?, ?, ?, ?, ?)" -updateLocale :: MonadClient m => UserId -> Locale -> m () -updateLocale u (Locale l c) = write userLocaleUpdate (params LocalQuorum (l, c, u)) - -updateUser :: MonadClient m => UserId -> UserUpdate -> m () -updateUser u UserUpdate {..} = retry x5 . batch $ do - setType BatchLogged - setConsistency LocalQuorum - for_ uupName $ \n -> addPrepQuery userDisplayNameUpdate (n, u) - for_ uupPict $ \p -> addPrepQuery userPictUpdate (p, u) - for_ uupAssets $ \a -> addPrepQuery userAssetsUpdate (a, u) - for_ uupAccentId $ \c -> addPrepQuery userAccentIdUpdate (c, u) - -updateEmail :: MonadClient m => UserId -> Email -> m () +updateEmail :: (MonadClient m) => UserId -> Email -> m () updateEmail u e = retry x5 $ write userEmailUpdate (params LocalQuorum (e, u)) -updateEmailUnvalidated :: MonadClient m => UserId -> Email -> m () +updateEmailUnvalidated :: (MonadClient m) => UserId -> Email -> m () updateEmailUnvalidated u e = retry x5 $ write userEmailUnvalidatedUpdate (params LocalQuorum (e, u)) -updatePhone :: MonadClient m => UserId -> Phone -> m () -updatePhone u p = retry x5 $ write userPhoneUpdate (params LocalQuorum (p, u)) - -updateSSOId :: MonadClient m => UserId -> Maybe UserSSOId -> m Bool +updateSSOId :: (MonadClient m) => UserId -> Maybe UserSSOId -> m Bool updateSSOId u ssoid = do mteamid <- lookupUserTeam u case mteamid of @@ -313,26 +292,13 @@ updateSSOId u ssoid = do pure True Nothing -> pure False -updateManagedBy :: MonadClient m => UserId -> ManagedBy -> m () +updateManagedBy :: (MonadClient m) => UserId -> ManagedBy -> m () updateManagedBy u h = retry x5 $ write userManagedByUpdate (params LocalQuorum (h, u)) -updateHandle :: MonadClient m => UserId -> Handle -> m () -updateHandle u h = retry x5 $ write userHandleUpdate (params LocalQuorum (h, u)) - -updateSupportedProtocols :: MonadClient m => UserId -> Set BaseProtocolTag -> m () -updateSupportedProtocols u prots = - retry x5 $ - write userSupportedProtocolUpdate (params LocalQuorum (prots, u)) - -updatePassword :: MonadClient m => UserId -> PlainTextPassword8 -> m () -updatePassword u t = do - p <- liftIO $ mkSafePassword t - retry x5 $ write userPasswordUpdate (params LocalQuorum (p, u)) - -updateRichInfo :: MonadClient m => UserId -> RichInfoAssocList -> m () +updateRichInfo :: (MonadClient m) => UserId -> RichInfoAssocList -> m () updateRichInfo u ri = retry x5 $ write userRichInfoUpdate (params LocalQuorum (ri, u)) -updateFeatureConferenceCalling :: MonadClient m => UserId -> Maybe (ApiFt.WithStatusNoLock ApiFt.ConferenceCallingConfig) -> m (Maybe (ApiFt.WithStatusNoLock ApiFt.ConferenceCallingConfig)) +updateFeatureConferenceCalling :: (MonadClient m) => UserId -> Maybe (ApiFt.WithStatusNoLock ApiFt.ConferenceCallingConfig) -> m (Maybe (ApiFt.WithStatusNoLock ApiFt.ConferenceCallingConfig)) updateFeatureConferenceCalling uid mbStatus = do let flag = ApiFt.wssStatus <$> mbStatus retry x5 $ write update (params LocalQuorum (flag, uid)) @@ -341,16 +307,13 @@ updateFeatureConferenceCalling uid mbStatus = do update :: PrepQuery W (Maybe ApiFt.FeatureStatus, UserId) () update = fromString "update user set feature_conference_calling = ? where id = ?" -deleteEmail :: MonadClient m => UserId -> m () +deleteEmail :: (MonadClient m) => UserId -> m () deleteEmail u = retry x5 $ write userEmailDelete (params LocalQuorum (Identity u)) -deleteEmailUnvalidated :: MonadClient m => UserId -> m () +deleteEmailUnvalidated :: (MonadClient m) => UserId -> m () deleteEmailUnvalidated u = retry x5 $ write userEmailUnvalidatedDelete (params LocalQuorum (Identity u)) -deletePhone :: MonadClient m => UserId -> m () -deletePhone u = retry x5 $ write userPhoneDelete (params LocalQuorum (Identity u)) - -deleteServiceUser :: MonadClient m => ProviderId -> ServiceId -> BotId -> m () +deleteServiceUser :: (MonadClient m) => ProviderId -> ServiceId -> BotId -> m () deleteServiceUser pid sid bid = do lookupServiceUser pid sid bid >>= \case Nothing -> pure () @@ -370,21 +333,14 @@ deleteServiceUser pid sid bid = do "DELETE FROM service_team \ \WHERE provider = ? AND service = ? AND team = ? AND user = ?" -updateStatus :: MonadClient m => UserId -> AccountStatus -> m () +updateStatus :: (MonadClient m) => UserId -> AccountStatus -> m () updateStatus u s = retry x5 $ write userStatusUpdate (params LocalQuorum (s, u)) -userExists :: MonadClient m => UserId -> m Bool +userExists :: (MonadClient m) => UserId -> m Bool userExists uid = isJust <$> retry x1 (query1 idSelect (params LocalQuorum (Identity uid))) --- | Whether the account has been activated by verifying --- an email address or phone number. -isActivated :: MonadClient m => UserId -> m Bool -isActivated u = - (== Just (Identity True)) - <$> retry x1 (query1 activatedSelect (params LocalQuorum (Identity u))) - -filterActive :: MonadClient m => [UserId] -> m [UserId] +filterActive :: (MonadClient m) => [UserId] -> m [UserId] filterActive us = map (view _1) . filter isActiveUser <$> retry x1 (query accountStateSelectAll (params LocalQuorum (Identity us))) @@ -396,43 +352,27 @@ filterActive us = lookupUser :: (MonadClient m, MonadReader Env m) => HavePendingInvitations -> UserId -> m (Maybe User) lookupUser hpi u = listToMaybe <$> lookupUsers hpi [u] -activateUser :: MonadClient m => UserId -> UserIdentity -> m () +activateUser :: (MonadClient m) => UserId -> UserIdentity -> m () activateUser u ident = do let email = emailIdentity ident - let phone = phoneIdentity ident - retry x5 $ write userActivatedUpdate (params LocalQuorum (email, phone, u)) + retry x5 $ write userActivatedUpdate (params LocalQuorum (email, u)) -deactivateUser :: MonadClient m => UserId -> m () +deactivateUser :: (MonadClient m) => UserId -> m () deactivateUser u = retry x5 $ write userDeactivatedUpdate (params LocalQuorum (Identity u)) -lookupLocale :: (MonadClient m, MonadReader Env m) => UserId -> m (Maybe Locale) -lookupLocale u = do - defLoc <- setDefaultUserLocale <$> view settings - fmap (toLocale defLoc) <$> retry x1 (query1 localeSelect (params LocalQuorum (Identity u))) - -lookupName :: MonadClient m => UserId -> m (Maybe Name) +lookupName :: (MonadClient m) => UserId -> m (Maybe Name) lookupName u = fmap runIdentity <$> retry x1 (query1 nameSelect (params LocalQuorum (Identity u))) -lookupPassword :: MonadClient m => UserId -> m (Maybe Password) -lookupPassword u = - (runIdentity =<<) - <$> retry x1 (query1 passwordSelect (params LocalQuorum (Identity u))) - -lookupStatus :: MonadClient m => UserId -> m (Maybe AccountStatus) -lookupStatus u = - (runIdentity =<<) - <$> retry x1 (query1 statusSelect (params LocalQuorum (Identity u))) - -lookupRichInfo :: MonadClient m => UserId -> m (Maybe RichInfoAssocList) +lookupRichInfo :: (MonadClient m) => UserId -> m (Maybe RichInfoAssocList) lookupRichInfo u = fmap runIdentity <$> retry x1 (query1 richInfoSelect (params LocalQuorum (Identity u))) -- | Returned rich infos are in the same order as users -lookupRichInfoMultiUsers :: MonadClient m => [UserId] -> m [(UserId, RichInfo)] +lookupRichInfoMultiUsers :: (MonadClient m) => [UserId] -> m [(UserId, RichInfo)] lookupRichInfoMultiUsers users = do mapMaybe (\(uid, mbRi) -> (uid,) . RichInfo <$> mbRi) <$> retry x1 (query richInfoSelectMulti (params LocalQuorum (Identity users))) @@ -440,12 +380,12 @@ lookupRichInfoMultiUsers users = do -- | Lookup user (no matter what status) and return 'TeamId'. Safe to use for authorization: -- suspended / deleted / ... users can't login, so no harm done if we authorize them *after* -- successful login. -lookupUserTeam :: MonadClient m => UserId -> m (Maybe TeamId) +lookupUserTeam :: (MonadClient m) => UserId -> m (Maybe TeamId) lookupUserTeam u = (runIdentity =<<) <$> retry x1 (query1 teamSelect (params LocalQuorum (Identity u))) -lookupAuth :: MonadClient m => UserId -> m (Maybe (Maybe Password, AccountStatus)) +lookupAuth :: (MonadClient m) => UserId -> m (Maybe (Maybe Password, AccountStatus)) lookupAuth u = fmap f <$> retry x1 (query1 authSelect (params LocalQuorum (Identity u))) where f (pw, st) = (pw, fromMaybe Active st) @@ -468,7 +408,7 @@ lookupAccounts usrs = do domain <- viewFederationDomain fmap (toUserAccount domain loc) <$> retry x1 (query accountsSelect (params LocalQuorum (Identity usrs))) -lookupServiceUser :: MonadClient m => ProviderId -> ServiceId -> BotId -> m (Maybe (ConvId, Maybe TeamId)) +lookupServiceUser :: (MonadClient m) => ProviderId -> ServiceId -> BotId -> m (Maybe (ConvId, Maybe TeamId)) lookupServiceUser pid sid bid = retry x1 (query1 cql (params LocalQuorum (pid, sid, bid))) where cql :: PrepQuery R (ProviderId, ServiceId, BotId) (ConvId, Maybe TeamId) @@ -478,7 +418,7 @@ lookupServiceUser pid sid bid = retry x1 (query1 cql (params LocalQuorum (pid, s -- | NB: might return a lot of users, and therefore we do streaming here (page-by-page). lookupServiceUsers :: - MonadClient m => + (MonadClient m) => ProviderId -> ServiceId -> ConduitM () [(BotId, ConvId, Maybe TeamId)] m () @@ -491,7 +431,7 @@ lookupServiceUsers pid sid = \WHERE provider = ? AND service = ?" lookupServiceUsersForTeam :: - MonadClient m => + (MonadClient m) => ProviderId -> ServiceId -> TeamId -> @@ -504,7 +444,7 @@ lookupServiceUsersForTeam pid sid tid = "SELECT user, conv FROM service_team \ \WHERE provider = ? AND service = ? AND team = ?" -lookupFeatureConferenceCalling :: MonadClient m => UserId -> m (Maybe (ApiFt.WithStatusNoLock ApiFt.ConferenceCallingConfig)) +lookupFeatureConferenceCalling :: (MonadClient m) => UserId -> m (Maybe (ApiFt.WithStatusNoLock ApiFt.ConferenceCallingConfig)) lookupFeatureConferenceCalling uid = do let q = query1 select (params LocalQuorum (Identity uid)) mStatusValue <- (>>= runIdentity) <$> retry x1 q @@ -525,7 +465,6 @@ type UserRow = Name, Maybe Pict, Maybe Email, - Maybe Phone, Maybe UserSSOId, ColourId, Maybe [Asset], @@ -548,7 +487,6 @@ type UserRowInsert = Pict, [Asset], Maybe Email, - Maybe Phone, Maybe UserSSOId, ColourId, Maybe Password, @@ -572,7 +510,7 @@ type AccountRow = UserRow usersSelect :: PrepQuery R (Identity [UserId]) UserRow usersSelect = - "SELECT id, name, picture, email, phone, sso_id, accent_id, assets, \ + "SELECT id, name, picture, email, sso_id, accent_id, assets, \ \activated, status, expires, language, country, provider, service, \ \handle, team, managed_by, supported_protocols \ \FROM user where id IN ?" @@ -583,24 +521,12 @@ idSelect = "SELECT id FROM user WHERE id = ?" nameSelect :: PrepQuery R (Identity UserId) (Identity Name) nameSelect = "SELECT name FROM user WHERE id = ?" -localeSelect :: PrepQuery R (Identity UserId) (Maybe Language, Maybe Country) -localeSelect = "SELECT language, country FROM user WHERE id = ?" - authSelect :: PrepQuery R (Identity UserId) (Maybe Password, Maybe AccountStatus) authSelect = "SELECT password, status FROM user WHERE id = ?" -passwordSelect :: PrepQuery R (Identity UserId) (Identity (Maybe Password)) -passwordSelect = "SELECT password FROM user WHERE id = ?" - -activatedSelect :: PrepQuery R (Identity UserId) (Identity Bool) -activatedSelect = "SELECT activated FROM user WHERE id = ?" - accountStateSelectAll :: PrepQuery R (Identity [UserId]) (UserId, Bool, Maybe AccountStatus) accountStateSelectAll = "SELECT id, activated, status FROM user WHERE id IN ?" -statusSelect :: PrepQuery R (Identity UserId) (Identity (Maybe AccountStatus)) -statusSelect = "SELECT status FROM user WHERE id = ?" - richInfoSelect :: PrepQuery R (Identity UserId) (Identity RichInfoAssocList) richInfoSelect = "SELECT json FROM rich_info WHERE user = ?" @@ -612,29 +538,17 @@ teamSelect = "SELECT team FROM user WHERE id = ?" accountsSelect :: PrepQuery R (Identity [UserId]) AccountRow accountsSelect = - "SELECT id, name, picture, email, phone, sso_id, accent_id, assets, \ + "SELECT id, name, picture, email, sso_id, accent_id, assets, \ \activated, status, expires, language, country, provider, \ \service, handle, team, managed_by, supported_protocols \ \FROM user WHERE id IN ?" userInsert :: PrepQuery W UserRowInsert () userInsert = - "INSERT INTO user (id, name, picture, assets, email, phone, sso_id, \ + "INSERT INTO user (id, name, picture, assets, email, sso_id, \ \accent_id, password, activated, status, expires, language, \ \country, provider, service, handle, team, managed_by, supported_protocols) \ - \VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)" - -userDisplayNameUpdate :: PrepQuery W (Name, UserId) () -userDisplayNameUpdate = {- `IF EXISTS`, but that requires benchmarking -} "UPDATE user SET name = ? WHERE id = ?" - -userPictUpdate :: PrepQuery W (Pict, UserId) () -userPictUpdate = {- `IF EXISTS`, but that requires benchmarking -} "UPDATE user SET picture = ? WHERE id = ?" - -userAssetsUpdate :: PrepQuery W ([Asset], UserId) () -userAssetsUpdate = {- `IF EXISTS`, but that requires benchmarking -} "UPDATE user SET assets = ? WHERE id = ?" - -userAccentIdUpdate :: PrepQuery W (ColourId, UserId) () -userAccentIdUpdate = {- `IF EXISTS`, but that requires benchmarking -} "UPDATE user SET accent_id = ? WHERE id = ?" + \VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)" userEmailUpdate :: PrepQuery W (Email, UserId) () userEmailUpdate = {- `IF EXISTS`, but that requires benchmarking -} "UPDATE user SET email = ? WHERE id = ?" @@ -645,42 +559,24 @@ userEmailUnvalidatedUpdate = {- `IF EXISTS`, but that requires benchmarking -} " userEmailUnvalidatedDelete :: PrepQuery W (Identity UserId) () userEmailUnvalidatedDelete = {- `IF EXISTS`, but that requires benchmarking -} "UPDATE user SET email_unvalidated = null WHERE id = ?" -userPhoneUpdate :: PrepQuery W (Phone, UserId) () -userPhoneUpdate = {- `IF EXISTS`, but that requires benchmarking -} "UPDATE user SET phone = ? WHERE id = ?" - userSSOIdUpdate :: PrepQuery W (Maybe UserSSOId, UserId) () userSSOIdUpdate = {- `IF EXISTS`, but that requires benchmarking -} "UPDATE user SET sso_id = ? WHERE id = ?" userManagedByUpdate :: PrepQuery W (ManagedBy, UserId) () userManagedByUpdate = {- `IF EXISTS`, but that requires benchmarking -} "UPDATE user SET managed_by = ? WHERE id = ?" -userHandleUpdate :: PrepQuery W (Handle, UserId) () -userHandleUpdate = {- `IF EXISTS`, but that requires benchmarking -} "UPDATE user SET handle = ? WHERE id = ?" - -userSupportedProtocolUpdate :: PrepQuery W (Set BaseProtocolTag, UserId) () -userSupportedProtocolUpdate = {- `IF EXISTS`, but that requires benchmarking -} "UPDATE user SET supported_protocols = ? WHERE id = ?" - -userPasswordUpdate :: PrepQuery W (Password, UserId) () -userPasswordUpdate = {- `IF EXISTS`, but that requires benchmarking -} "UPDATE user SET password = ? WHERE id = ?" - userStatusUpdate :: PrepQuery W (AccountStatus, UserId) () userStatusUpdate = {- `IF EXISTS`, but that requires benchmarking -} "UPDATE user SET status = ? WHERE id = ?" userDeactivatedUpdate :: PrepQuery W (Identity UserId) () userDeactivatedUpdate = {- `IF EXISTS`, but that requires benchmarking -} "UPDATE user SET activated = false WHERE id = ?" -userActivatedUpdate :: PrepQuery W (Maybe Email, Maybe Phone, UserId) () -userActivatedUpdate = {- `IF EXISTS`, but that requires benchmarking -} "UPDATE user SET activated = true, email = ?, phone = ? WHERE id = ?" - -userLocaleUpdate :: PrepQuery W (Language, Maybe Country, UserId) () -userLocaleUpdate = {- `IF EXISTS`, but that requires benchmarking -} "UPDATE user SET language = ?, country = ? WHERE id = ?" +userActivatedUpdate :: PrepQuery W (Maybe Email, UserId) () +userActivatedUpdate = {- `IF EXISTS`, but that requires benchmarking -} "UPDATE user SET activated = true, email = ? WHERE id = ?" userEmailDelete :: PrepQuery W (Identity UserId) () userEmailDelete = {- `IF EXISTS`, but that requires benchmarking -} "UPDATE user SET email = null WHERE id = ?" -userPhoneDelete :: PrepQuery W (Identity UserId) () -userPhoneDelete = {- `IF EXISTS`, but that requires benchmarking -} "UPDATE user SET phone = null WHERE id = ?" - userRichInfoUpdate :: PrepQuery W (RichInfoAssocList, UserId) () userRichInfoUpdate = {- `IF EXISTS`, but that requires benchmarking -} "UPDATE rich_info SET json = ? WHERE user = ?" @@ -696,7 +592,6 @@ toUserAccount name, pict, email, - phone, ssoid, accent, assets, @@ -712,7 +607,7 @@ toUserAccount managed_by, prots ) = - let ident = toIdentity activated email phone ssoid + let ident = toIdentity activated email ssoid deleted = Just Deleted == status expiration = if status == Just Ephemeral then expires else Nothing loc = toLocale defaultLocale (lan, con) @@ -748,7 +643,6 @@ toUsers domain defaultLocale havePendingInvitations = fmap mk . filter fp _name, _pict, _email, - _phone, _ssoid, _accent, _assets, @@ -772,7 +666,6 @@ toUsers domain defaultLocale havePendingInvitations = fmap mk . filter fp name, pict, email, - phone, ssoid, accent, assets, @@ -788,7 +681,7 @@ toUsers domain defaultLocale havePendingInvitations = fmap mk . filter fp managed_by, prots ) = - let ident = toIdentity activated email phone ssoid + let ident = toIdentity activated email ssoid deleted = Just Deleted == status expiration = if status == Just Ephemeral then expires else Nothing loc = toLocale defaultLocale (lan, con) @@ -825,12 +718,9 @@ toIdentity :: -- | Whether the user is activated Bool -> Maybe Email -> - Maybe Phone -> Maybe UserSSOId -> Maybe UserIdentity -toIdentity True (Just e) (Just p) Nothing = Just $! FullIdentity e p -toIdentity True (Just e) Nothing Nothing = Just $! EmailIdentity e -toIdentity True Nothing (Just p) Nothing = Just $! PhoneIdentity p -toIdentity True email phone (Just ssoid) = Just $! SSOIdentity ssoid email phone -toIdentity True Nothing Nothing Nothing = Nothing -toIdentity False _ _ _ = Nothing +toIdentity True (Just e) Nothing = Just $! EmailIdentity e +toIdentity True email (Just ssoid) = Just $! SSOIdentity ssoid email +toIdentity True Nothing Nothing = Nothing +toIdentity False _ _ = Nothing diff --git a/services/brig/src/Brig/Data/UserKey.hs b/services/brig/src/Brig/Data/UserKey.hs deleted file mode 100644 index 11128014a24..00000000000 --- a/services/brig/src/Brig/Data/UserKey.hs +++ /dev/null @@ -1,150 +0,0 @@ --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - --- | Natural, addressable external identifiers of users. -module Brig.Data.UserKey - ( UserKey, - userEmailKey, - userPhoneKey, - forEmailKey, - forPhoneKey, - foldKey, - keyText, - keyTextOriginal, - claimKey, - keyAvailable, - lookupKey, - deleteKey, - deleteKeyForUser, - ) -where - -import Brig.Data.User qualified as User -import Brig.Email -import Brig.Phone -import Cassandra -import Data.Id -import Imports -import Wire.API.User (fromEmail) - --- | A natural identifier (i.e. unique key) of a user. -data UserKey - = UserEmailKey !EmailKey - | UserPhoneKey !PhoneKey - -instance Eq UserKey where - (UserEmailKey k) == (UserEmailKey k') = k == k' - (UserPhoneKey k) == (UserPhoneKey k') = k == k' - _ == _ = False - -userEmailKey :: Email -> UserKey -userEmailKey = UserEmailKey . mkEmailKey - -userPhoneKey :: Phone -> UserKey -userPhoneKey = UserPhoneKey . mkPhoneKey - -foldKey :: (Email -> a) -> (Phone -> a) -> UserKey -> a -foldKey f g k = case k of - UserEmailKey ek -> f (emailKeyOrig ek) - UserPhoneKey pk -> g (phoneKeyOrig pk) - -forEmailKey :: Applicative f => UserKey -> (Email -> f a) -> f (Maybe a) -forEmailKey k f = foldKey (fmap Just . f) (const (pure Nothing)) k - -forPhoneKey :: Applicative f => UserKey -> (Phone -> f a) -> f (Maybe a) -forPhoneKey k f = foldKey (const (pure Nothing)) (fmap Just . f) k - --- | Get the normalised text of a 'UserKey'. -keyText :: UserKey -> Text -keyText (UserEmailKey k) = emailKeyUniq k -keyText (UserPhoneKey k) = phoneKeyUniq k - --- | Get the original text of a 'UserKey', i.e. the original phone number --- or email address. -keyTextOriginal :: UserKey -> Text -keyTextOriginal (UserEmailKey k) = fromEmail (emailKeyOrig k) -keyTextOriginal (UserPhoneKey k) = fromPhone (phoneKeyOrig k) - --- | Claim a 'UserKey' for a user. -claimKey :: - MonadClient m => - -- | The key to claim. - UserKey -> - -- | The user claiming the key. - UserId -> - m Bool -claimKey k u = do - free <- keyAvailable k (Just u) - when free (insertKey u k) - pure free - --- | Check whether a 'UserKey' is available. --- A key is available if it is not already actived for another user or --- if the other user and the user looking to claim the key are the same. -keyAvailable :: - MonadClient m => - -- | The key to check. - UserKey -> - -- | The user looking to claim the key, if any. - Maybe UserId -> - m Bool -keyAvailable k u = do - o <- lookupKey k - case (o, u) of - (Nothing, _) -> pure True - (Just x, Just y) | x == y -> pure True - (Just x, _) -> not <$> User.isActivated x - -lookupKey :: MonadClient m => UserKey -> m (Maybe UserId) -lookupKey k = - fmap runIdentity - <$> retry x1 (query1 keySelect (params LocalQuorum (Identity $ keyText k))) - -insertKey :: MonadClient m => UserId -> UserKey -> m () -insertKey u k = do - retry x5 $ write keyInsert (params LocalQuorum (keyText k, u)) - -deleteKey :: MonadClient m => UserKey -> m () -deleteKey k = do - retry x5 $ write keyDelete (params LocalQuorum (Identity $ keyText k)) - --- | Delete `UserKey` for `UserId` --- --- This function ensures that keys of other users aren't accidentally deleted. --- E.g. the email address or phone number of a partially deleted user could --- already belong to a new user. To not interrupt deletion flows (that may be --- executed several times due to cassandra not supporting transactions) --- `deleteKeyForUser` does not fail for missing keys or keys that belong to --- another user: It always returns `()` as result. -deleteKeyForUser :: MonadClient m => UserId -> UserKey -> m () -deleteKeyForUser uid k = do - mbKeyUid <- lookupKey k - case mbKeyUid of - Just keyUid | keyUid == uid -> deleteKey k - _ -> pure () - --------------------------------------------------------------------------------- --- Queries - -keyInsert :: PrepQuery W (Text, UserId) () -keyInsert = "INSERT INTO user_keys (key, user) VALUES (?, ?)" - -keySelect :: PrepQuery R (Identity Text) (Identity UserId) -keySelect = "SELECT user FROM user_keys WHERE key = ?" - -keyDelete :: PrepQuery W (Identity Text) () -keyDelete = "DELETE FROM user_keys WHERE key = ?" diff --git a/services/brig/src/Brig/DeleteQueue/Interpreter.hs b/services/brig/src/Brig/DeleteQueue/Interpreter.hs index e55b7453ef5..22e6dd90c73 100644 --- a/services/brig/src/Brig/DeleteQueue/Interpreter.hs +++ b/services/brig/src/Brig/DeleteQueue/Interpreter.hs @@ -49,7 +49,7 @@ enqueue :: Member (Logger (Log.Msg -> Log.Msg)) r, Member (Error ErrorCall) r ) => - ToJSON a => + (ToJSON a) => QueueEnv -> a -> Sem r () diff --git a/services/brig/src/Brig/Effects/BlacklistPhonePrefixStore.hs b/services/brig/src/Brig/Effects/BlacklistPhonePrefixStore.hs deleted file mode 100644 index 8f5463067d4..00000000000 --- a/services/brig/src/Brig/Effects/BlacklistPhonePrefixStore.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - -module Brig.Effects.BlacklistPhonePrefixStore where - -import Brig.Phone (Phone) -import Brig.Types.Common (ExcludedPrefix, PhonePrefix) -import Imports -import Polysemy - -data BlacklistPhonePrefixStore m a where - Insert :: ExcludedPrefix -> BlacklistPhonePrefixStore m () - Delete :: PhonePrefix -> BlacklistPhonePrefixStore m () - ExistsAny :: Phone -> BlacklistPhonePrefixStore m Bool - GetAll :: PhonePrefix -> BlacklistPhonePrefixStore m [ExcludedPrefix] - -makeSem ''BlacklistPhonePrefixStore diff --git a/services/brig/src/Brig/Effects/BlacklistPhonePrefixStore/Cassandra.hs b/services/brig/src/Brig/Effects/BlacklistPhonePrefixStore/Cassandra.hs deleted file mode 100644 index e8c1713f91b..00000000000 --- a/services/brig/src/Brig/Effects/BlacklistPhonePrefixStore/Cassandra.hs +++ /dev/null @@ -1,57 +0,0 @@ -module Brig.Effects.BlacklistPhonePrefixStore.Cassandra - ( interpretBlacklistPhonePrefixStoreToCassandra, - ) -where - -import Brig.Effects.BlacklistPhonePrefixStore -import Brig.Types.Common -import Cassandra -import Imports -import Polysemy -import Wire.API.User.Identity - -interpretBlacklistPhonePrefixStoreToCassandra :: - forall m r a. - (MonadClient m, Member (Embed m) r) => - Sem (BlacklistPhonePrefixStore ': r) a -> - Sem r a -interpretBlacklistPhonePrefixStoreToCassandra = - interpret $ - embed @m . \case - Insert ep -> insertPrefix ep - Delete pp -> deletePrefix pp - ExistsAny uk -> existsAnyPrefix uk - GetAll pp -> getAllPrefixes pp - --------------------------------------------------------------------------------- --- Excluded phone prefixes - -insertPrefix :: MonadClient m => ExcludedPrefix -> m () -insertPrefix prefix = retry x5 $ write ins (params LocalQuorum (phonePrefix prefix, comment prefix)) - where - ins :: PrepQuery W (PhonePrefix, Text) () - ins = "INSERT INTO excluded_phones (prefix, comment) VALUES (?, ?)" - -deletePrefix :: MonadClient m => PhonePrefix -> m () -deletePrefix prefix = retry x5 $ write del (params LocalQuorum (Identity prefix)) - where - del :: PrepQuery W (Identity PhonePrefix) () - del = "DELETE FROM excluded_phones WHERE prefix = ?" - -getAllPrefixes :: MonadClient m => PhonePrefix -> m [ExcludedPrefix] -getAllPrefixes prefix = do - let prefixes = fromPhonePrefix <$> allPrefixes (fromPhonePrefix prefix) - selectPrefixes prefixes - -existsAnyPrefix :: MonadClient m => Phone -> m Bool -existsAnyPrefix phone = do - let prefixes = fromPhonePrefix <$> allPrefixes (fromPhone phone) - not . null <$> selectPrefixes prefixes - -selectPrefixes :: MonadClient m => [Text] -> m [ExcludedPrefix] -selectPrefixes prefixes = do - results <- retry x1 (query sel (params LocalQuorum (Identity $ prefixes))) - pure $ uncurry ExcludedPrefix <$> results - where - sel :: PrepQuery R (Identity [Text]) (PhonePrefix, Text) - sel = "SELECT prefix, comment FROM excluded_phones WHERE prefix IN ?" diff --git a/services/brig/src/Brig/Effects/BlacklistStore.hs b/services/brig/src/Brig/Effects/BlacklistStore.hs index d116bc5b18e..e888194d7a3 100644 --- a/services/brig/src/Brig/Effects/BlacklistStore.hs +++ b/services/brig/src/Brig/Effects/BlacklistStore.hs @@ -2,13 +2,13 @@ module Brig.Effects.BlacklistStore where -import Brig.Data.UserKey import Imports import Polysemy +import Wire.UserKeyStore data BlacklistStore m a where - Insert :: UserKey -> BlacklistStore m () - Exists :: UserKey -> BlacklistStore m Bool - Delete :: UserKey -> BlacklistStore m () + Insert :: EmailKey -> BlacklistStore m () + Exists :: EmailKey -> BlacklistStore m Bool + Delete :: EmailKey -> BlacklistStore m () makeSem ''BlacklistStore diff --git a/services/brig/src/Brig/Effects/BlacklistStore/Cassandra.hs b/services/brig/src/Brig/Effects/BlacklistStore/Cassandra.hs index 995926b7040..45ada1cebc9 100644 --- a/services/brig/src/Brig/Effects/BlacklistStore/Cassandra.hs +++ b/services/brig/src/Brig/Effects/BlacklistStore/Cassandra.hs @@ -3,11 +3,11 @@ module Brig.Effects.BlacklistStore.Cassandra ) where -import Brig.Data.UserKey import Brig.Effects.BlacklistStore (BlacklistStore (..)) import Cassandra import Imports import Polysemy +import Wire.UserKeyStore interpretBlacklistStoreToCassandra :: forall m r a. @@ -24,16 +24,16 @@ interpretBlacklistStoreToCassandra = -------------------------------------------------------------------------------- -- UserKey blacklisting -insert :: MonadClient m => UserKey -> m () -insert uk = retry x5 $ write keyInsert (params LocalQuorum (Identity $ keyText uk)) +insert :: (MonadClient m) => EmailKey -> m () +insert uk = retry x5 $ write keyInsert (params LocalQuorum (Identity $ emailKeyUniq uk)) -exists :: MonadClient m => UserKey -> m Bool +exists :: (MonadClient m) => EmailKey -> m Bool exists uk = (pure . isJust) . fmap runIdentity - =<< retry x1 (query1 keySelect (params LocalQuorum (Identity $ keyText uk))) + =<< retry x1 (query1 keySelect (params LocalQuorum (Identity $ emailKeyUniq uk))) -delete :: MonadClient m => UserKey -> m () -delete uk = retry x5 $ write keyDelete (params LocalQuorum (Identity $ keyText uk)) +delete :: (MonadClient m) => EmailKey -> m () +delete uk = retry x5 $ write keyDelete (params LocalQuorum (Identity $ emailKeyUniq uk)) keyInsert :: PrepQuery W (Identity Text) () keyInsert = "INSERT INTO blacklist (key) VALUES (?)" diff --git a/services/brig/src/Brig/Effects/FederationConfigStore/Cassandra.hs b/services/brig/src/Brig/Effects/FederationConfigStore/Cassandra.hs index bc9fcd8f7b6..32b13005e25 100644 --- a/services/brig/src/Brig/Effects/FederationConfigStore/Cassandra.hs +++ b/services/brig/src/Brig/Effects/FederationConfigStore/Cassandra.hs @@ -103,7 +103,7 @@ getFederationConfigs' mFedStrategy cfgs = do maxKnownNodes :: Int maxKnownNodes = 10000 -getFederationConfig' :: MonadClient m => Map Domain FederationDomainConfig -> Domain -> m (Maybe FederationDomainConfig) +getFederationConfig' :: (MonadClient m) => Map Domain FederationDomainConfig -> Domain -> m (Maybe FederationDomainConfig) getFederationConfig' cfgs rDomain = case find ((== rDomain) . domain) cfgs of Just cfg -> pure . Just $ cfg -- the configuration from the file has precedence (if exists there should not be a db entry at all) Nothing -> do @@ -115,7 +115,7 @@ getFederationConfig' cfgs rDomain = case find ((== rDomain) . domain) cfgs of q :: PrepQuery R (Identity Domain) (FederatedUserSearchPolicy, Maybe Int32) q = "SELECT search_policy, restriction FROM federation_remotes WHERE domain = ?" -getFederationRemotesFromDb :: forall m. MonadClient m => m [FederationDomainConfig] +getFederationRemotesFromDb :: forall m. (MonadClient m) => m [FederationDomainConfig] getFederationRemotesFromDb = (\(d, p, r) -> FederationDomainConfig d p r) <$$> qry where qry :: m [(Domain, FederatedUserSearchPolicy, FederationRestriction)] @@ -127,7 +127,7 @@ getFederationRemotesFromDb = (\(d, p, r) -> FederationDomainConfig d p r) <$$> q get :: PrepQuery R () (Domain, FederatedUserSearchPolicy, Maybe Int32) get = fromString $ "SELECT domain, search_policy, restriction FROM federation_remotes LIMIT " <> show maxKnownNodes -addFederationConfig' :: MonadClient m => Map Domain FederationDomainConfig -> FederationDomainConfig -> m AddFederationRemoteResult +addFederationConfig' :: (MonadClient m) => Map Domain FederationDomainConfig -> FederationDomainConfig -> m AddFederationRemoteResult addFederationConfig' cfg (FederationDomainConfig rDomain searchPolicy restriction) = do -- if a domain already exists in a config, we do not allow to add it to the database conflict <- domainExistsInConfig (FederationDomainConfig rDomain searchPolicy restriction) @@ -159,7 +159,7 @@ addFederationConfig' cfg (FederationDomainConfig rDomain searchPolicy restrictio addTeams :: PrepQuery W (Domain, TeamId) () addTeams = "INSERT INTO federation_remote_teams (domain, team) VALUES (?, ?)" -updateFederationConfig' :: MonadClient m => Map Domain FederationDomainConfig -> FederationDomainConfig -> m UpdateFederationResult +updateFederationConfig' :: (MonadClient m) => Map Domain FederationDomainConfig -> FederationDomainConfig -> m UpdateFederationResult updateFederationConfig' cfgs (FederationDomainConfig rDomain searchPolicy restriction) = do -- if a domain already exists in a config, we do not allow update it if rDomain `elem` (domain <$> cfgs) @@ -182,7 +182,7 @@ updateFederationConfig' cfgs (FederationDomainConfig rDomain searchPolicy restri updateConfig :: PrepQuery W (FederatedUserSearchPolicy, Int32, Domain) x updateConfig = "UPDATE federation_remotes SET search_policy = ?, restriction = ? WHERE domain = ? IF EXISTS" - updateTeams :: MonadClient m => m () + updateTeams :: (MonadClient m) => m () updateTeams = retry x5 $ do write dropTeams (params LocalQuorum (Identity rDomain)) case restriction of @@ -196,7 +196,7 @@ updateFederationConfig' cfgs (FederationDomainConfig rDomain searchPolicy restri insertTeam :: PrepQuery W (Domain, TeamId) () insertTeam = "INSERT INTO federation_remote_teams (domain, team) VALUES (?, ?)" -addFederationRemoteTeam' :: MonadClient m => Map Domain FederationDomainConfig -> Domain -> TeamId -> m AddFederationRemoteTeamResult +addFederationRemoteTeam' :: (MonadClient m) => Map Domain FederationDomainConfig -> Domain -> TeamId -> m AddFederationRemoteTeamResult addFederationRemoteTeam' cfgs rDomain tid = do mDom <- getFederationConfig' cfgs rDomain case mDom of @@ -211,14 +211,14 @@ addFederationRemoteTeam' cfgs rDomain tid = do add :: PrepQuery W (Domain, TeamId) () add = "INSERT INTO federation_remote_teams (domain, team) VALUES (?, ?)" -getFederationRemoteTeams' :: MonadClient m => Domain -> m [FederationRemoteTeam] +getFederationRemoteTeams' :: (MonadClient m) => Domain -> m [FederationRemoteTeam] getFederationRemoteTeams' rDomain = do fmap (FederationRemoteTeam . runIdentity) <$> retry x1 (query get (params LocalQuorum (Identity rDomain))) where get :: PrepQuery R (Identity Domain) (Identity TeamId) get = "SELECT team FROM federation_remote_teams WHERE domain = ?" -removeFederationRemoteTeam' :: MonadClient m => Domain -> TeamId -> m () +removeFederationRemoteTeam' :: (MonadClient m) => Domain -> TeamId -> m () removeFederationRemoteTeam' rDomain rteam = retry x1 $ write delete (params LocalQuorum (rDomain, rteam)) where @@ -226,7 +226,7 @@ removeFederationRemoteTeam' rDomain rteam = delete = "DELETE FROM federation_remote_teams WHERE domain = ? AND team = ?" backendFederatesWithImpl :: - MonadClient m => + (MonadClient m) => Remote (Maybe TeamId) -> Map Domain FederationDomainConfig -> Maybe FederationStrategy -> @@ -258,7 +258,7 @@ instance Show RestrictionException where instance Exception RestrictionException -toRestriction :: MonadClient m => Domain -> Int32 -> m FederationRestriction +toRestriction :: (MonadClient m) => Domain -> Int32 -> m FederationRestriction toRestriction _ 0 = pure FederationRestrictionAllowAll toRestriction dom 1 = fmap FederationRestrictionByTeam $ diff --git a/services/brig/src/Brig/Effects/JwtTools.hs b/services/brig/src/Brig/Effects/JwtTools.hs index 1b9a1773413..a344f5b7ae4 100644 --- a/services/brig/src/Brig/Effects/JwtTools.hs +++ b/services/brig/src/Brig/Effects/JwtTools.hs @@ -55,7 +55,7 @@ data JwtTools m a where makeSem ''JwtTools -interpretJwtTools :: Member (Embed IO) r => Sem (JwtTools ': r) a -> Sem r a +interpretJwtTools :: (Member (Embed IO) r) => Sem (JwtTools ': r) a -> Sem r a interpretJwtTools = interpret $ \case GenerateDPoPAccessToken proof cid handle displayName tid nonce uri method skew ex now pem -> mapLeft RustError diff --git a/services/brig/src/Brig/Effects/PasswordResetStore/CodeStore.hs b/services/brig/src/Brig/Effects/PasswordResetStore/CodeStore.hs deleted file mode 100644 index d01e3f7524f..00000000000 --- a/services/brig/src/Brig/Effects/PasswordResetStore/CodeStore.hs +++ /dev/null @@ -1,99 +0,0 @@ --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module Brig.Effects.PasswordResetStore.CodeStore - ( passwordResetStoreToCodeStore, - ) -where - -import Brig.Effects.CodeStore -import Brig.Effects.PasswordResetStore -import Brig.Types.User (PasswordResetPair) -import Data.Id -import Data.Time -import Imports hiding (lookup) -import Polysemy -import Wire.API.User.Identity -import Wire.API.User.Password -import Wire.Sem.Now -import Wire.Sem.Now qualified as Now - -passwordResetStoreToCodeStore :: - forall r a. - ( Member CodeStore r, - Member Now r - ) => - Sem (PasswordResetStore ': r) a -> - Sem r a -passwordResetStoreToCodeStore = interpret $ \case - CreatePasswordResetCode uid eEmailPhone -> create uid eEmailPhone - LookupPasswordResetCode uid -> lookup uid - VerifyPasswordResetCode prp -> verify prp - -maxAttempts :: Int32 -maxAttempts = 3 - -ttl :: NominalDiffTime -ttl = 3600 -- 60 minutes - -create :: - ( Member CodeStore r, - Member Now r - ) => - UserId -> - Either Email Phone -> - Sem r PasswordResetPair -create u target = do - key <- mkPasswordResetKey u - now <- Now.get - code <- either (const generateEmailCode) (const generatePhoneCode) target - codeInsert - key - (PRQueryData code u (Identity maxAttempts) (Identity (ttl `addUTCTime` now))) - (round ttl) - pure (key, code) - -lookup :: - ( Member CodeStore r, - Member Now r - ) => - UserId -> - Sem r (Maybe PasswordResetCode) -lookup u = do - key <- mkPasswordResetKey u - now <- Now.get - validate now =<< codeSelect key - where - validate now (Just (PRQueryData c _ _ (Just t))) | t > now = pure $ Just c - validate _ _ = pure Nothing - -verify :: - ( Member CodeStore r, - Member Now r - ) => - PasswordResetPair -> - Sem r (Maybe UserId) -verify (k, c) = do - now <- Now.get - code <- codeSelect k - case code of - Just (PRQueryData c' u _ (Just t)) | c == c' && t >= now -> pure (Just u) - Just (PRQueryData c' u (Just n) (Just t)) | n > 1 && t > now -> do - codeInsert k (PRQueryData c' u (Identity (n - 1)) (Identity t)) (round ttl) - pure Nothing - Just PRQueryData {} -> codeDelete k $> Nothing - Nothing -> pure Nothing diff --git a/services/brig/src/Brig/Effects/PublicKeyBundle.hs b/services/brig/src/Brig/Effects/PublicKeyBundle.hs index bd7c680d994..3178d57380f 100644 --- a/services/brig/src/Brig/Effects/PublicKeyBundle.hs +++ b/services/brig/src/Brig/Effects/PublicKeyBundle.hs @@ -14,7 +14,7 @@ data PublicKeyBundle m a where makeSem ''PublicKeyBundle -interpretPublicKeyBundle :: Member (Embed IO) r => Sem (PublicKeyBundle ': r) a -> Sem r a +interpretPublicKeyBundle :: (Member (Embed IO) r) => Sem (PublicKeyBundle ': r) a -> Sem r a interpretPublicKeyBundle = interpret $ \(Get fp) -> do contents :: Either IOException ByteString <- liftIO $ try $ BS.readFile fp pure $ either (const Nothing) fromByteString contents diff --git a/services/brig/src/Brig/Effects/SFT.hs b/services/brig/src/Brig/Effects/SFT.hs index d1cdd9d2cde..04983783d5f 100644 --- a/services/brig/src/Brig/Effects/SFT.hs +++ b/services/brig/src/Brig/Effects/SFT.hs @@ -52,10 +52,10 @@ newtype SFTGetResponse = SFTGetResponse data SFT m a where SFTGetAllServers :: HttpsUrl -> SFT m SFTGetResponse -sftGetAllServers :: Member SFT r => HttpsUrl -> Sem r SFTGetResponse +sftGetAllServers :: (Member SFT r) => HttpsUrl -> Sem r SFTGetResponse sftGetAllServers = send . SFTGetAllServers -interpretSFT :: Members [Embed IO, TinyLog] r => Manager -> Sem (SFT ': r) a -> Sem r a +interpretSFT :: (Members [Embed IO, TinyLog] r) => Manager -> Sem (SFT ': r) a -> Sem r a interpretSFT httpManager = interpret $ \(SFTGetAllServers url) -> do let urlWithPath = ensureHttpsUrl $ (httpsUrl url) {uriPath = "/sft_servers_all.json"} fmap SFTGetResponse . runSftError urlWithPath $ do @@ -66,7 +66,7 @@ interpretSFT httpManager = interpret $ \(SFTGetAllServers url) -> do debug $ Log.field "URLs" (show res) . Log.msg ("Fetched the following server URLs" :: ByteString) pure res -runSftError :: Member TinyLog r => HttpsUrl -> Sem (Error SFTError : r) a -> Sem r (Either SFTError a) +runSftError :: (Member TinyLog r) => HttpsUrl -> Sem (Error SFTError : r) a -> Sem r (Either SFTError a) runSftError urlWithPath act = runError $ act @@ -85,7 +85,7 @@ instance ToSchema AllURLs where <$> unAllURLs .= field "sft_servers_all" (array schema) interpretSFTInMemory :: - Member TinyLog r => + (Member TinyLog r) => Map HttpsUrl SFTGetResponse -> Sem (SFT ': r) a -> Sem r a diff --git a/services/brig/src/Brig/Effects/UserPendingActivationStore.hs b/services/brig/src/Brig/Effects/UserPendingActivationStore.hs index 69a1db7397d..eb7cd15479a 100644 --- a/services/brig/src/Brig/Effects/UserPendingActivationStore.hs +++ b/services/brig/src/Brig/Effects/UserPendingActivationStore.hs @@ -23,5 +23,5 @@ data UserPendingActivationStore p m a where makeSem ''UserPendingActivationStore -remove :: forall p r. Member (UserPendingActivationStore p) r => UserId -> Sem r () +remove :: forall p r. (Member (UserPendingActivationStore p) r) => UserId -> Sem r () remove uid = removeMultiple [uid] diff --git a/services/brig/src/Brig/Effects/UserPendingActivationStore/Cassandra.hs b/services/brig/src/Brig/Effects/UserPendingActivationStore/Cassandra.hs index 44e6431e8e2..67023ee774e 100644 --- a/services/brig/src/Brig/Effects/UserPendingActivationStore/Cassandra.hs +++ b/services/brig/src/Brig/Effects/UserPendingActivationStore/Cassandra.hs @@ -27,14 +27,14 @@ userPendingActivationStoreToCassandra = List (Just ps) -> PC.ipNext ps RemoveMultiple uids -> usersPendingActivationRemoveMultiple uids -usersPendingActivationAdd :: MonadClient m => UserPendingActivation -> m () +usersPendingActivationAdd :: (MonadClient m) => UserPendingActivation -> m () usersPendingActivationAdd (UserPendingActivation uid expiresAt) = do retry x5 . write insertExpiration . params LocalQuorum $ (uid, expiresAt) where insertExpiration :: PrepQuery W (UserId, UTCTime) () insertExpiration = "INSERT INTO users_pending_activation (user, expires_at) VALUES (?, ?)" -usersPendingActivationList :: MonadClient m => m (Page UserPendingActivation) +usersPendingActivationList :: (MonadClient m) => m (Page UserPendingActivation) usersPendingActivationList = do uncurry UserPendingActivation <$$> retry x1 (paginate selectExpired (params LocalQuorum ())) where @@ -42,7 +42,7 @@ usersPendingActivationList = do selectExpired = "SELECT user, expires_at FROM users_pending_activation" -usersPendingActivationRemoveMultiple :: MonadClient m => [UserId] -> m () +usersPendingActivationRemoveMultiple :: (MonadClient m) => [UserId] -> m () usersPendingActivationRemoveMultiple uids = retry x5 . write deleteExpired . params LocalQuorum $ Identity uids where diff --git a/services/brig/src/Brig/Email.hs b/services/brig/src/Brig/Email.hs deleted file mode 100644 index 2954400dc2b..00000000000 --- a/services/brig/src/Brig/Email.hs +++ /dev/null @@ -1,104 +0,0 @@ --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module Brig.Email - ( -- * Validation - validateEmail, - - -- * Unique Keys - EmailKey, - mkEmailKey, - emailKeyUniq, - emailKeyOrig, - - -- * Re-exports - Email (..), - - -- * MIME Re-exports - Mail (..), - emptyMail, - plainPart, - htmlPart, - Address (..), - mkMimeAddress, - sendMail, - ) -where - -import Brig.AWS qualified as AWS -import Brig.App (Env, applog, awsEnv, smtpEnv) -import Brig.SMTP qualified as SMTP -import Control.Lens (view) -import Data.Text qualified as Text -import Imports -import Network.Mail.Mime -import Wire.API.User - -------------------------------------------------------------------------------- -sendMail :: (MonadIO m, MonadReader Env m) => Mail -> m () -sendMail m = - view smtpEnv >>= \case - Just smtp -> view applog >>= \logger -> SMTP.sendMail logger smtp m - Nothing -> view awsEnv >>= \e -> AWS.execute e $ AWS.sendMail m - -------------------------------------------------------------------------------- --- Unique Keys - --- | An 'EmailKey' is an 'Email' in a form that serves as a unique lookup key. -data EmailKey = EmailKey - { emailKeyUniq :: !Text, - emailKeyOrig :: !Email - } - -instance Show EmailKey where - showsPrec _ = shows . emailKeyUniq - -instance Eq EmailKey where - (EmailKey k _) == (EmailKey k' _) = k == k' - --- | Turn an 'Email' into an 'EmailKey'. --- --- The following transformations are performed: --- --- * Both local and domain parts are forced to lowercase to make --- e-mail addresses fully case-insensitive. --- * "+" suffixes on the local part are stripped unless the domain --- part is contained in a trusted whitelist. -mkEmailKey :: Email -> EmailKey -mkEmailKey orig@(Email localPart domain) = - let uniq = Text.toLower localPart' <> "@" <> Text.toLower domain - in EmailKey uniq orig - where - localPart' - | domain `notElem` trusted = Text.takeWhile (/= '+') localPart - | otherwise = localPart - trusted = ["wearezeta.com", "wire.com", "simulator.amazonses.com"] - -------------------------------------------------------------------------------- --- MIME Conversions - --- | Construct a MIME 'Address' from the given display 'Name' and 'Email' --- address that does not exceed 320 bytes in length when rendered for use --- in SMTP, which is a safe limit for most mail servers (including those of --- Amazon SES). The display name is only included if it fits within that --- limit, otherwise it is dropped. -mkMimeAddress :: Name -> Email -> Address -mkMimeAddress name email = - let addr = Address (Just (fromName name)) (fromEmail email) - in if Text.compareLength (renderAddress addr) 320 == GT - then Address Nothing (fromEmail email) - else addr diff --git a/services/brig/src/Brig/IO/Intra.hs b/services/brig/src/Brig/IO/Intra.hs index c8e82c586d0..650940bac87 100644 --- a/services/brig/src/Brig/IO/Intra.hs +++ b/services/brig/src/Brig/IO/Intra.hs @@ -25,6 +25,9 @@ module Brig.IO.Intra onPropertyEvent, onClientEvent, + -- * user subsystem interpretation for user events + runUserEvents, + -- * Conversations createConnectConv, acceptConnectConv, @@ -49,7 +52,6 @@ import Bilge hiding (head, options, requestId) import Bilge.RPC import Brig.API.Error (internalServerError) import Brig.API.Types -import Brig.API.Util import Brig.App import Brig.Data.Connection import Brig.Data.Connection qualified as Data @@ -102,6 +104,7 @@ import Wire.Rpc import Wire.Sem.Logger qualified as Log import Wire.Sem.Paging qualified as P import Wire.Sem.Paging.Cassandra (InternalPaging) +import Wire.UserEvents ----------------------------------------------------------------------------- -- Event Handlers @@ -123,6 +126,19 @@ onUserEvent orig conn e = *> dispatchNotifications orig conn e *> embed (journalEvent orig e) +runUserEvents :: + ( Member (Embed HttpClientIO) r, + Member NotificationSubsystem r, + Member TinyLog r, + Member (Input (Local ())) r, + Member (Input UTCTime) r, + Member (ConnectionStore InternalPaging) r + ) => + InterpreterFor UserEvents r +runUserEvents = interpret \case + -- FUTUREWORK(mangoiv): should this be in another module? + GenerateUserEvent uid mconnid event -> onUserEvent uid mconnid event + onConnectionEvent :: (Member NotificationSubsystem r) => -- | Originator of the event. @@ -176,7 +192,7 @@ onClientEvent orig conn e = do ] updateSearchIndex :: - Member (Embed HttpClientIO) r => + (Member (Embed HttpClientIO) r) => UserId -> UserEvent -> Sem r () diff --git a/services/brig/src/Brig/IO/Logging.hs b/services/brig/src/Brig/IO/Logging.hs index ec733caa119..56b805718bb 100644 --- a/services/brig/src/Brig/IO/Logging.hs +++ b/services/brig/src/Brig/IO/Logging.hs @@ -24,11 +24,16 @@ import System.Logger logConnection :: UserId -> Qualified UserId -> Msg -> Msg logConnection from (Qualified toUser toDomain) = - "connection.from" .= toByteString from - ~~ "connection.to" .= toByteString toUser - ~~ "connection.to_domain" .= toByteString toDomain + "connection.from" + .= toByteString from + ~~ "connection.to" + .= toByteString toUser + ~~ "connection.to_domain" + .= toByteString toDomain logLocalConnection :: UserId -> UserId -> Msg -> Msg logLocalConnection from to = - "connection.from" .= toByteString from - ~~ "connection.to" .= toByteString to + "connection.from" + .= toByteString from + ~~ "connection.to" + .= toByteString to diff --git a/services/brig/src/Brig/Index/Eval.hs b/services/brig/src/Brig/Index/Eval.hs index 05c5e688882..c19d000c5d9 100644 --- a/services/brig/src/Brig/Index/Eval.hs +++ b/services/brig/src/Brig/Index/Eval.hs @@ -37,7 +37,6 @@ import Data.Aeson (FromJSON) import Data.Aeson qualified as Aeson import Data.ByteString.Lazy.UTF8 qualified as UTF8 import Data.Credentials (Credentials (..)) -import Data.Metrics qualified as Metrics import Database.Bloodhound qualified as ES import Imports import System.Logger qualified as Log @@ -111,8 +110,7 @@ runCommand l = \case additionalCaCert = Nothing } - metricsStorage <- Metrics.metrics - mkIndexEnv esOpts l metricsStorage gly mgr + mkIndexEnv esOpts l gly mgr initES esURI mgr mCreds = let env = ES.mkBHEnv (toESServer esURI) mgr diff --git a/services/brig/src/Brig/Index/Migrations.hs b/services/brig/src/Brig/Index/Migrations.hs index f743f62c157..2fbb8ce5455 100644 --- a/services/brig/src/Brig/Index/Migrations.hs +++ b/services/brig/src/Brig/Index/Migrations.hs @@ -29,7 +29,6 @@ import Control.Lens (to, view, (^.)) import Control.Monad.Catch (MonadThrow, catchAll, finally, throwM) import Data.Aeson (Value, object, (.=)) import Data.Credentials (Credentials (..)) -import Data.Metrics qualified as Metrics import Data.Text qualified as Text import Database.Bloodhound qualified as ES import Imports @@ -87,7 +86,6 @@ mkEnv l es cas galleyEndpoint = do Env envWithAuth <$> initCassandra <*> initLogger - <*> Metrics.metrics <*> pure (view (Opts.esConnection . to Opts.esIndex) es) <*> pure mCreds <*> pure rpcMgr diff --git a/services/brig/src/Brig/Index/Migrations/Types.hs b/services/brig/src/Brig/Index/Migrations/Types.hs index 853570ffb6f..7854ce67aae 100644 --- a/services/brig/src/Brig/Index/Migrations/Types.hs +++ b/services/brig/src/Brig/Index/Migrations/Types.hs @@ -25,7 +25,6 @@ import Cassandra qualified as C import Control.Monad.Catch (MonadThrow) import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.:), (.=)) import Data.Credentials (Credentials) -import Data.Metrics (Metrics) import Database.Bloodhound qualified as ES import Imports import Network.HTTP.Client (Manager) @@ -63,25 +62,24 @@ instance (MonadIO m, MonadThrow m) => C.MonadClient (MigrationActionT m) where liftClient = liftCassandra localState f = local (\env -> env {cassandraClientState = f $ cassandraClientState env}) -instance MonadIO m => MonadLogger (MigrationActionT m) where +instance (MonadIO m) => MonadLogger (MigrationActionT m) where log level f = do env <- ask Logger.log (logger env) level f -instance MonadIO m => Search.MonadIndexIO (MigrationActionT m) where +instance (MonadIO m) => Search.MonadIndexIO (MigrationActionT m) where liftIndexIO m = do Env {..} <- ask - let indexEnv = Search.IndexEnv metrics logger bhEnv Nothing searchIndex Nothing Nothing galleyEndpoint httpManager searchIndexCredentials + let indexEnv = Search.IndexEnv logger bhEnv Nothing searchIndex Nothing Nothing galleyEndpoint httpManager searchIndexCredentials Search.runIndexIO indexEnv m -instance MonadIO m => ES.MonadBH (MigrationActionT m) where +instance (MonadIO m) => ES.MonadBH (MigrationActionT m) where getBHEnv = bhEnv <$> ask data Env = Env { bhEnv :: ES.BHEnv, cassandraClientState :: C.ClientState, logger :: Logger.Logger, - metrics :: Metrics, searchIndex :: ES.IndexName, searchIndexCredentials :: Maybe Credentials, httpManager :: Manager, @@ -92,11 +90,11 @@ runMigrationAction :: Env -> MigrationActionT m a -> m a runMigrationAction env action = runReaderT (unMigrationAction action) env -liftCassandra :: MonadIO m => C.Client a -> MigrationActionT m a +liftCassandra :: (MonadIO m) => C.Client a -> MigrationActionT m a liftCassandra m = do env <- ask lift $ C.runClient (cassandraClientState env) m -cleanup :: MonadIO m => Env -> m () +cleanup :: (MonadIO m) => Env -> m () cleanup env = do C.shutdown (cassandraClientState env) diff --git a/services/brig/src/Brig/InternalEvent/Process.hs b/services/brig/src/Brig/InternalEvent/Process.hs index b0e0ba1c870..912d5241c01 100644 --- a/services/brig/src/Brig/InternalEvent/Process.hs +++ b/services/brig/src/Brig/InternalEvent/Process.hs @@ -15,10 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Brig.InternalEvent.Process - ( onEvent, - ) -where +module Brig.InternalEvent.Process (onEvent) where import Brig.API.User qualified as API import Brig.App @@ -44,6 +41,8 @@ import Wire.API.UserEvent import Wire.NotificationSubsystem import Wire.Sem.Delay import Wire.Sem.Paging.Cassandra (InternalPaging) +import Wire.UserKeyStore +import Wire.UserStore (UserStore) -- | Handle an internal event. -- @@ -55,7 +54,9 @@ onEvent :: Member Delay r, Member Race r, Member (Input (Local ())) r, + Member UserKeyStore r, Member (Input UTCTime) r, + Member UserStore r, Member (ConnectionStore InternalPaging) r ) => InternalNotification -> diff --git a/services/brig/src/Brig/Locale.hs b/services/brig/src/Brig/Locale.hs deleted file mode 100644 index 6339895fa2d..00000000000 --- a/services/brig/src/Brig/Locale.hs +++ /dev/null @@ -1,115 +0,0 @@ --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module Brig.Locale - ( timeLocale, - formatDateTime, - deDe, - frFr, - ) -where - -import Data.LanguageCodes (ISO639_1 (DE, FR)) -import Data.Time.Clock (UTCTime) -import Data.Time.Format -import Data.Time.LocalTime (TimeZone (..), utc) -import Imports -import Wire.API.User - -timeLocale :: Locale -> TimeLocale -timeLocale (Locale (Language DE) _) = deDe -timeLocale (Locale (Language FR) _) = frFr -timeLocale _ = defaultTimeLocale - -formatDateTime :: String -> TimeLocale -> UTCTime -> Text -formatDateTime s l = fromString . formatTime l s - -deDe :: TimeLocale -deDe = - TimeLocale - { wDays = - [ ("Sonntag", "Son"), - ("Montag", "Mon"), - ("Dienstag", "Die"), - ("Mittwoch", "Mit"), - ("Donnerstag", "Don"), - ("Freitag", "Fre"), - ("Samstag", "Sam") - ], - months = - [ ("Januar", "Jan"), - ("Februar", "Feb"), - ("März", "Mär"), - ("April", "Apr"), - ("Mai", "Mai"), - ("Juni", "Jun"), - ("Juli", "Jul"), - ("August", "Aug"), - ("September", "Sep"), - ("Oktober", "Okt"), - ("November", "Nov"), - ("Dezember", "Dez") - ], - amPm = ("", ""), - dateTimeFmt = "%d. %B %Y %H:%M:%S %Z", - dateFmt = "%d.%m.%Y", - timeFmt = "%H:%M:%S", - time12Fmt = "%H:%M:%S", - knownTimeZones = - [ utc, - TimeZone 60 False "MEZ", - TimeZone 120 True "MESZ" - ] - } - -frFr :: TimeLocale -frFr = - TimeLocale - { wDays = - [ ("dimanche", "dim"), - ("lundi", "lun"), - ("mardi", "mar"), - ("mercredi", "mer"), - ("jeudi", "jeu"), - ("vendredi", "ven"), - ("samedi", "sam") - ], - months = - [ ("janvier", "jan"), - ("février", "fév"), - ("mars", "mar"), - ("avril", "avr"), - ("mai", "mai"), - ("juin", "jun"), - ("juillet", "jul"), - ("août", "aoû"), - ("septembre", "sep"), - ("octobre", "oct"), - ("novembre", "nov"), - ("décembre", "déc") - ], - amPm = ("", ""), - dateTimeFmt = "%d %B %Y %H h %M %Z", - dateFmt = "%d/%m/%Y", - timeFmt = "%H h %M", - time12Fmt = "%H h %M", - knownTimeZones = - [ utc, - TimeZone 60 False "HNEC", - TimeZone 120 True "HAEC" - ] - } diff --git a/services/brig/src/Brig/Options.hs b/services/brig/src/Brig/Options.hs index d837fb7a2f4..66e4ea9d69e 100644 --- a/services/brig/src/Brig/Options.hs +++ b/services/brig/src/Brig/Options.hs @@ -23,9 +23,7 @@ module Brig.Options where -import Brig.Allowlists (AllowlistEmailDomains (..), AllowlistPhonePrefixes (..)) import Brig.Queue.Types (QueueOpts (..)) -import Brig.SMTP (SMTPConnType (..)) import Brig.User.Auth.Cookie.Limit import Brig.ZAuth qualified as ZAuth import Control.Applicative @@ -56,11 +54,13 @@ import Network.AMQP.Extended import Network.DNS qualified as DNS import System.Logger.Extended (Level, LogFormat) import Util.Options +import Wire.API.Allowlists (AllowlistEmailDomains (..)) import Wire.API.Routes.FederationDomainConfig import Wire.API.Routes.Version import Wire.API.Team.Feature qualified as Public import Wire.API.User import Wire.Arbitrary (Arbitrary, arbitrary) +import Wire.EmailSending.SMTP (SMTPConnType (..)) newtype Timeout = Timeout { timeoutDiff :: NominalDiffTime @@ -457,15 +457,10 @@ data Settings = Settings setTeamInvitationTimeout :: !Timeout, -- | Check for expired users every so often, in seconds setExpiredUserCleanupTimeout :: !(Maybe Timeout), - -- | Twilio credentials - setTwilio :: !FilePathSecrets, - -- | Nexmo credentials - setNexmo :: !FilePathSecrets, -- | STOMP broker credentials setStomp :: !(Maybe FilePathSecrets), -- | Whitelist of allowed emails/phones setAllowlistEmailDomains :: !(Maybe AllowlistEmailDomains), - setAllowlistPhonePrefixes :: !(Maybe AllowlistPhonePrefixes), -- | Max. number of sent/accepted -- connections per user setUserMaxConnections :: !Int64, @@ -931,7 +926,9 @@ Lens.makeLensesFor ("setOAuthAccessTokenExpirationTimeSecsInternal", "oauthAccessTokenExpirationTimeSecsInternal"), ("setDisabledAPIVersions", "disabledAPIVersions"), ("setOAuthRefreshTokenExpirationTimeSecsInternal", "oauthRefreshTokenExpirationTimeSecsInternal"), - ("setOAuthMaxActiveRefreshTokensInternal", "oauthMaxActiveRefreshTokensInternal") + ("setOAuthMaxActiveRefreshTokensInternal", "oauthMaxActiveRefreshTokensInternal"), + ("setAllowlistEmailDomains", "allowlistEmailDomains"), + ("setAllowlistPhonePrefixes", "allowlistPhonePrefixes") ] ''Settings diff --git a/services/brig/src/Brig/Phone.hs b/services/brig/src/Brig/Phone.hs deleted file mode 100644 index 9df603e4cc1..00000000000 --- a/services/brig/src/Brig/Phone.hs +++ /dev/null @@ -1,319 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} - --- 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 Brig.Phone - ( SMSMessage (..), - PhoneException (..), - sendCall, - sendSms, - - -- * Validation - validatePhone, - - -- * Unique Keys - PhoneKey, - mkPhoneKey, - phoneKeyUniq, - phoneKeyOrig, - - -- * Re-exports - Phone (..), - ) -where - -import Bilge.Retry (httpHandlers) -import Brig.App -import Brig.Budget -import Cassandra (MonadClient) -import Control.Lens (view) -import Control.Monad.Catch -import Control.Retry -import Data.LanguageCodes -import Data.Metrics qualified as Metrics -import Data.Text qualified as Text -import Data.Time.Clock -import Imports -import Network.HTTP.Client (HttpException, Manager) -import Ropes.Nexmo qualified as Nexmo -import Ropes.Twilio (LookupDetail (..)) -import Ropes.Twilio qualified as Twilio -import System.Logger.Class qualified as Log -import System.Logger.Message (field, msg, val, (~~)) -import Wire.API.User - -------------------------------------------------------------------------------- --- Sending SMS and Voice Calls - -data SMSMessage = SMSMessage - { smsFrom :: !Text, - smsTo :: !Text, - smsText :: !Text - } - -data PhoneException - = PhoneNumberUnreachable - | PhoneNumberBarred - | PhoneBudgetExhausted NominalDiffTime - deriving (Show, Typeable) - -instance Exception PhoneException - -sendCall :: - (MonadClient m, MonadReader Env m, Log.MonadLogger m) => - Nexmo.Call -> - m () -sendCall call = unless (isTestPhone $ Nexmo.callTo call) $ do - m <- view httpManager - cred <- view nexmoCreds - withCallBudget (Nexmo.callTo call) $ do - r <- - liftIO . try @_ @Nexmo.CallErrorResponse . recovering x3 nexmoHandlers $ - const $ - Nexmo.sendCall cred m call - case r of - Left ex -> case Nexmo.caStatus ex of - Nexmo.CallDestinationNotPermitted -> unreachable ex - Nexmo.CallInvalidDestinationAddress -> unreachable ex - Nexmo.CallUnroutable -> unreachable ex - Nexmo.CallDestinationBarred -> barred ex - _ -> throwM ex - Right _ -> pure () - where - nexmoHandlers = - httpHandlers - ++ [ const . Handler $ \(ex :: Nexmo.CallErrorResponse) -> - pure $ case Nexmo.caStatus ex of - Nexmo.CallThrottled -> True - Nexmo.CallInternal -> True - _ -> False - ] - unreachable ex = warn (toException ex) >> throwM PhoneNumberUnreachable - barred ex = warn (toException ex) >> throwM PhoneNumberBarred - warn ex = - Log.warn $ - msg (val "Voice call failed.") - ~~ field "error" (show ex) - ~~ field "phone" (Nexmo.callTo call) - -sendSms :: - ( MonadClient m, - MonadCatch m, - Log.MonadLogger m, - MonadReader Env m - ) => - Locale -> - SMSMessage -> - m () -sendSms loc SMSMessage {..} = unless (isTestPhone smsTo) $ do - m <- view httpManager - withSmsBudget smsTo $ do - -- We try Nexmo first (cheaper and specialised to SMS) - f <- (sendNexmoSms m $> Nothing) `catches` nexmoFailed - for_ f $ \ex -> do - warn ex - r <- try @_ @Twilio.ErrorResponse $ sendTwilioSms m - case r of - Left ex' -> case Twilio.errStatus ex' of - -- Invalid "To" number for SMS - 14101 -> unreachable ex' - -- 'To' number is not a valid mobile number - 21614 -> unreachable ex' - -- "To" number is not currently reachable - 21612 -> unreachable ex' - -- Customer replied with "STOP" - 21610 -> barred ex' - -- A real problem - _ -> throwM ex' - Right () -> pure () - where - sendNexmoSms :: (MonadIO f, MonadReader Env f) => Manager -> f () - sendNexmoSms mgr = do - crd <- view nexmoCreds - void . liftIO . recovering x3 nexmoHandlers $ - const $ - Nexmo.sendMessage crd mgr $ - Nexmo.Message "Wire" smsTo smsText (toNexmoCharset loc) - toNexmoCharset :: Locale -> Nexmo.Charset - toNexmoCharset l = case fromLanguage (lLanguage l) of - RU -> Nexmo.UCS2 - AR -> Nexmo.UCS2 - UK -> Nexmo.UCS2 - FA -> Nexmo.UCS2 - TR -> Nexmo.UCS2 - ES -> Nexmo.UCS2 - ZH -> Nexmo.UCS2 - _ -> Nexmo.GSM7 - sendTwilioSms :: (MonadIO f, MonadReader Env f) => Manager -> f () - sendTwilioSms mgr = do - crd <- view twilioCreds - void . liftIO . recovering x3 twilioHandlers $ - const $ - Twilio.sendMessage crd mgr (Twilio.Message smsFrom smsTo smsText) - nexmoFailed = - [ Handler $ \(ex :: HttpException) -> - pure (Just (SomeException ex)), - Handler $ \(ex :: Nexmo.MessageErrorResponse) -> - pure (Just (SomeException ex)) - ] - nexmoHandlers = - httpHandlers - ++ [ const . Handler $ \(ex :: Nexmo.MessageErrorResponse) -> - pure $ case Nexmo.erStatus ex of - Nexmo.MessageThrottled -> True - Nexmo.MessageInternal -> True - Nexmo.MessageCommunicationFailed -> True - _ -> False - ] - twilioHandlers = - httpHandlers - ++ [ const . Handler $ \(ex :: Twilio.ErrorResponse) -> - pure $ case Twilio.errStatus ex of - 20429 -> True -- Too Many Requests - 20500 -> True -- Internal Server Error - 20503 -> True -- Temporarily Unavailable - _ -> False - ] - unreachable ex = warn (toException ex) >> throwM PhoneNumberUnreachable - barred ex = warn (toException ex) >> throwM PhoneNumberBarred - warn ex = - Log.warn $ - msg (val "SMS failed.") - ~~ field "error" (show ex) - ~~ field "phone" smsTo - -------------------------------------------------------------------------------- --- Phone Number Validation - --- | Validate a phone number. Returns the canonical --- E.164 format of the given phone number on success. -validatePhone :: (MonadClient m, MonadReader Env m) => Phone -> m (Maybe Phone) -validatePhone (Phone p) - | isTestPhone p = pure (Just (Phone p)) - | otherwise = do - c <- view twilioCreds - m <- view httpManager - r <- - liftIO . try @_ @Twilio.ErrorResponse $ - recovering x3 httpHandlers $ - const $ - Twilio.lookupPhone c m p LookupNoDetail Nothing - case r of - Right x -> pure (Just (Phone (Twilio.lookupE164 x))) - Left e | Twilio.errStatus e == 404 -> pure Nothing - Left e -> throwM e - -isTestPhone :: Text -> Bool -isTestPhone = Text.isPrefixOf "+0" - --------------------------------------------------------------------------------- --- SMS Budgeting - -smsBudget :: Budget -smsBudget = - Budget - { budgetTimeout = 3600 * 24, -- 24 hours - budgetValue = 5 -- # of SMS within timeout - } - -withSmsBudget :: - ( MonadClient m, - Log.MonadLogger m, - MonadReader Env m - ) => - Text -> - m a -> - m a -withSmsBudget phone go = do - let k = BudgetKey ("sms#" <> phone) - r <- withBudget k smsBudget go - case r of - BudgetExhausted t -> do - Log.info $ - msg (val "SMS budget exhausted.") - ~~ field "phone" phone - Metrics.counterIncr (Metrics.path "budget.sms.exhausted") =<< view metrics - throwM (PhoneBudgetExhausted t) - BudgetedValue a b -> do - Log.debug $ - msg (val "SMS budget deducted.") - ~~ field "budget" b - ~~ field "phone" phone - pure a - --------------------------------------------------------------------------------- --- Voice Call Budgeting - -callBudget :: Budget -callBudget = - Budget - { budgetTimeout = 3600 * 24 * 7, -- 7 days - budgetValue = 2 -- # of voice calls within timeout - } - -withCallBudget :: - ( MonadClient m, - Log.MonadLogger m, - MonadReader Env m - ) => - Text -> - m a -> - m a -withCallBudget phone go = do - let k = BudgetKey ("call#" <> phone) - r <- withBudget k callBudget go - case r of - BudgetExhausted t -> do - Log.info $ - msg (val "Voice call budget exhausted.") - ~~ field "phone" phone - Metrics.counterIncr (Metrics.path "budget.call.exhausted") =<< view metrics - throwM (PhoneBudgetExhausted t) - BudgetedValue a b -> do - Log.debug $ - msg (val "Voice call budget deducted.") - ~~ field "budget" b - ~~ field "phone" phone - pure a - --------------------------------------------------------------------------------- --- Unique Keys - -data PhoneKey = PhoneKey - { -- | canonical form of 'phoneKeyOrig', without whitespace. - phoneKeyUniq :: !Text, - -- | phone number with whitespace. - phoneKeyOrig :: !Phone - } - -instance Show PhoneKey where - showsPrec _ = shows . phoneKeyUniq - -instance Eq PhoneKey where - (PhoneKey k _) == (PhoneKey k' _) = k == k' - -mkPhoneKey :: Phone -> PhoneKey -mkPhoneKey orig = - let uniq = Text.filter (not . isSpace) (fromPhone orig) - in PhoneKey uniq orig - -------------------------------------------------------------------------------- --- Retry Settings - -x3 :: RetryPolicy -x3 = limitRetries 3 <> exponentialBackoff 100000 diff --git a/services/brig/src/Brig/Provider/API.hs b/services/brig/src/Brig/Provider/API.hs index 56587b0d68f..c9e13f86cdf 100644 --- a/services/brig/src/Brig/Provider/API.hs +++ b/services/brig/src/Brig/Provider/API.hs @@ -32,13 +32,10 @@ import Bilge.RPC (HasRequestId) import Brig.API.Client qualified as Client import Brig.API.Error import Brig.API.Handler -import Brig.API.Types (PasswordResetError (..), VerificationCodeThrottledError (VerificationCodeThrottled)) -import Brig.API.Util +import Brig.API.Types (PasswordResetError (..)) import Brig.App -import Brig.Code qualified as Code import Brig.Data.Client qualified as User import Brig.Data.User qualified as User -import Brig.Email (mkEmailKey) import Brig.Options (Settings (..)) import Brig.Options qualified as Opt import Brig.Provider.DB (ServiceConn (..)) @@ -56,6 +53,7 @@ import Control.Monad.Catch (MonadMask) import Control.Monad.Except import Data.ByteString.Conversion import Data.ByteString.Lazy.Char8 qualified as LC8 +import Data.Code qualified as Code import Data.CommaSeparatedList (CommaSeparatedList (fromCommaSeparatedList)) import Data.Conduit (runConduit, (.|)) import Data.Conduit.List qualified as C @@ -120,9 +118,15 @@ import Wire.API.User.Client qualified as Public (Client, ClientCapability (Clien import Wire.API.User.Client.Prekey qualified as Public (PrekeyId) import Wire.API.User.Identity qualified as Public (Email) import Wire.DeleteQueue +import Wire.EmailSending (EmailSending) +import Wire.Error import Wire.GalleyAPIAccess (GalleyAPIAccess) import Wire.GalleyAPIAccess qualified as GalleyAPIAccess import Wire.Sem.Concurrency (Concurrency, ConcurrencySafety (Unsafe)) +import Wire.UserKeyStore (mkEmailKey) +import Wire.VerificationCode as VerificationCode +import Wire.VerificationCodeGen +import Wire.VerificationCodeSubsystem botAPI :: ( Member GalleyAPIAccess r, @@ -160,7 +164,7 @@ servicesAPI = :<|> Named @"get-whitelisted-services-by-team-id" searchTeamServiceProfiles :<|> Named @"post-team-whitelist-by-team-id" updateServiceWhitelist -providerAPI :: Member GalleyAPIAccess r => ServerT ProviderAPI (Handler r) +providerAPI :: (Member GalleyAPIAccess r, Member EmailSending r, Member VerificationCodeSubsystem r) => ServerT ProviderAPI (Handler r) providerAPI = Named @"provider-register" newAccount :<|> Named @"provider-activate" activateAccountKey @@ -174,13 +178,13 @@ providerAPI = :<|> Named @"provider-get-account" getAccount :<|> Named @"provider-get-profile" getProviderProfile -internalProviderAPI :: Member GalleyAPIAccess r => ServerT BrigIRoutes.ProviderAPI (Handler r) +internalProviderAPI :: (Member GalleyAPIAccess r, Member VerificationCodeSubsystem r) => ServerT BrigIRoutes.ProviderAPI (Handler r) internalProviderAPI = Named @"get-provider-activation-code" getActivationCodeH -------------------------------------------------------------------------------- -- Public API (Unauthenticated) -newAccount :: Member GalleyAPIAccess r => Public.NewProvider -> (Handler r) Public.NewProviderResponse +newAccount :: (Member GalleyAPIAccess r, Member EmailSending r, Member VerificationCodeSubsystem r) => Public.NewProvider -> (Handler r) Public.NewProviderResponse newAccount new = do guardSecondFactorDisabled Nothing email <- case validateEmail (Public.newProviderEmail new) of @@ -193,31 +197,31 @@ newAccount new = do let emailKey = mkEmailKey email wrapClientE (DB.lookupKey emailKey) >>= mapM_ (const $ throwStd emailExists) (safePass, newPass) <- case pass of - Just newPass -> (,Nothing) <$> mkSafePassword newPass + Just newPass -> (,Nothing) <$> mkSafePasswordScrypt newPass Nothing -> do newPass <- genPassword - safePass <- mkSafePassword newPass + safePass <- mkSafePasswordScrypt newPass pure (safePass, Just newPass) pid <- wrapClientE $ DB.insertAccount name safePass url descr - gen <- Code.mkGen (Code.ForEmail email) + let gen = mkVerificationCodeGen email code <- - Code.generate - gen - Code.IdentityVerification - (Code.Retries 3) - (Code.Timeout (3600 * 24)) -- 24h - (Just (toUUID pid)) - tryInsertVerificationCode code $ verificationCodeThrottledError . VerificationCodeThrottled - let key = Code.codeKey code - let val = Code.codeValue code + lift . liftSem $ + createCodeOverwritePrevious + gen + IdentityVerification + (Retries 3) + (Timeout (3600 * 24)) -- 24h + (Just (toUUID pid)) + let key = codeKey code + let val = codeValue code lift $ sendActivationMail name email key val False pure $ Public.NewProviderResponse pid newPass -activateAccountKey :: Member GalleyAPIAccess r => Code.Key -> Code.Value -> (Handler r) (Maybe Public.ProviderActivationResponse) +activateAccountKey :: (Member GalleyAPIAccess r, Member EmailSending r, Member VerificationCodeSubsystem r) => Code.Key -> Code.Value -> (Handler r) (Maybe Public.ProviderActivationResponse) activateAccountKey key val = do guardSecondFactorDisabled Nothing - c <- wrapClientE (Code.verify key Code.IdentityVerification val) >>= maybeInvalidCode - (pid, email) <- case (Code.codeAccount c, Code.codeForEmail c) of + c <- (lift . liftSem $ verifyCode key IdentityVerification val) >>= maybeInvalidCode + (pid, email) <- case (codeAccount c, Just (codeFor c)) of (Just p, Just e) -> pure (Id p, e) _ -> throwStd (errorToWai @'E.InvalidCode) (name, memail, _url, _descr) <- wrapClientE (DB.lookupAccountData pid) >>= maybeInvalidCode @@ -225,8 +229,8 @@ activateAccountKey key val = do Just email' | email == email' -> pure Nothing Just email' -> do -- Ensure we remove any pending password reset - gen <- Code.mkGen (Code.ForEmail email') - lift $ wrapClient $ Code.delete (Code.genKey gen) Code.PasswordReset + let gen = mkVerificationCodeGen email' + lift $ liftSem $ deleteCode gen.genKey VerificationCode.PasswordReset -- Activate the new and remove the old key activate pid (Just email') email pure . Just $ Public.ProviderActivationResponse email @@ -236,17 +240,17 @@ activateAccountKey key val = do lift $ sendApprovalConfirmMail name email pure . Just $ Public.ProviderActivationResponse email -getActivationCodeH :: Member GalleyAPIAccess r => Public.Email -> (Handler r) Code.KeyValuePair +getActivationCodeH :: (Member GalleyAPIAccess r, Member VerificationCodeSubsystem r) => Public.Email -> (Handler r) Code.KeyValuePair getActivationCodeH e = do guardSecondFactorDisabled Nothing email <- case validateEmail e of Right em -> pure em Left _ -> throwStd (errorToWai @'E.InvalidEmail) - gen <- Code.mkGen (Code.ForEmail email) - code <- wrapClientE $ Code.lookup (Code.genKey gen) Code.IdentityVerification - maybe (throwStd activationKeyNotFound) (pure . Code.codeToKeyValuePair) code + let gen = mkVerificationCodeGen email + code <- lift . liftSem $ internalLookupCode gen.genKey IdentityVerification + maybe (throwStd activationKeyNotFound) (pure . codeToKeyValuePair) code -login :: Member GalleyAPIAccess r => ProviderLogin -> Handler r ProviderTokenCookie +login :: (Member GalleyAPIAccess r) => ProviderLogin -> Handler r ProviderTokenCookie login l = do guardSecondFactorDisabled Nothing pid <- wrapClientE (DB.lookupKey (mkEmailKey (providerLoginEmail l))) >>= maybeBadCredentials @@ -257,29 +261,22 @@ login l = do s <- view settings pure $ ProviderTokenCookie (ProviderToken token) (not (setCookieInsecure s)) -beginPasswordReset :: Member GalleyAPIAccess r => Public.PasswordReset -> (Handler r) () +beginPasswordReset :: (Member GalleyAPIAccess r, Member EmailSending r, Member VerificationCodeSubsystem r) => Public.PasswordReset -> (Handler r) () beginPasswordReset (Public.PasswordReset target) = do guardSecondFactorDisabled Nothing pid <- wrapClientE (DB.lookupKey (mkEmailKey target)) >>= maybeBadCredentials - gen <- Code.mkGen (Code.ForEmail target) - pending <- lift . wrapClient $ Code.lookup (Code.genKey gen) Code.PasswordReset - code <- case pending of - Just p -> throwE $ pwResetError (PasswordResetInProgress . Just $ Code.codeTTL p) - Nothing -> - Code.generate - gen - Code.PasswordReset - (Code.Retries 3) - (Code.Timeout 3600) -- 1h - (Just (toUUID pid)) - tryInsertVerificationCode code $ verificationCodeThrottledError . VerificationCodeThrottled - lift $ sendPasswordResetMail target (Code.codeKey code) (Code.codeValue code) - -completePasswordReset :: Member GalleyAPIAccess r => Public.CompletePasswordReset -> (Handler r) () + let gen = mkVerificationCodeGen target + (lift . liftSem $ createCode gen VerificationCode.PasswordReset (Retries 3) (Timeout 3600) (Just (toUUID pid))) >>= \case + Left (CodeAlreadyExists code) -> + throwE $ pwResetError (PasswordResetInProgress $ Just code.codeTTL) + Right code -> + lift $ sendPasswordResetMail target (code.codeKey) (code.codeValue) + +completePasswordReset :: (Member GalleyAPIAccess r, Member VerificationCodeSubsystem r) => Public.CompletePasswordReset -> (Handler r) () completePasswordReset (Public.CompletePasswordReset key val newpwd) = do guardSecondFactorDisabled Nothing - code <- wrapClientE (Code.verify key Code.PasswordReset val) >>= maybeInvalidCode - case Id <$> Code.codeAccount code of + code <- (lift . liftSem $ verifyCode key VerificationCode.PasswordReset val) >>= maybeInvalidCode + case Id <$> code.codeAccount of Nothing -> throwStd (errorToWai @'E.InvalidPasswordResetCode) Just pid -> do oldpass <- wrapClientE (DB.lookupPassword pid) >>= maybeBadCredentials @@ -287,17 +284,17 @@ completePasswordReset (Public.CompletePasswordReset key val newpwd) = do throwStd (errorToWai @'E.ResetPasswordMustDiffer) wrapClientE $ do DB.updateAccountPassword pid newpwd - Code.delete key Code.PasswordReset + lift . liftSem $ deleteCode key VerificationCode.PasswordReset -------------------------------------------------------------------------------- -- Provider API -getAccount :: Member GalleyAPIAccess r => ProviderId -> (Handler r) (Maybe Public.Provider) +getAccount :: (Member GalleyAPIAccess r) => ProviderId -> (Handler r) (Maybe Public.Provider) getAccount pid = do guardSecondFactorDisabled Nothing wrapClientE $ DB.lookupAccount pid -updateAccountProfile :: Member GalleyAPIAccess r => ProviderId -> Public.UpdateProvider -> (Handler r) () +updateAccountProfile :: (Member GalleyAPIAccess r) => ProviderId -> Public.UpdateProvider -> (Handler r) () updateAccountProfile pid upd = do guardSecondFactorDisabled Nothing _ <- wrapClientE (DB.lookupAccount pid) >>= maybeInvalidProvider @@ -308,7 +305,7 @@ updateAccountProfile pid upd = do (updateProviderUrl upd) (updateProviderDescr upd) -updateAccountEmail :: Member GalleyAPIAccess r => ProviderId -> Public.EmailUpdate -> (Handler r) () +updateAccountEmail :: (Member GalleyAPIAccess r, Member EmailSending r, Member VerificationCodeSubsystem r) => ProviderId -> Public.EmailUpdate -> (Handler r) () updateAccountEmail pid (Public.EmailUpdate new) = do guardSecondFactorDisabled Nothing email <- case validateEmail new of @@ -316,18 +313,18 @@ updateAccountEmail pid (Public.EmailUpdate new) = do Left _ -> throwStd (errorToWai @'E.InvalidEmail) let emailKey = mkEmailKey email wrapClientE (DB.lookupKey emailKey) >>= mapM_ (const $ throwStd emailExists) - gen <- Code.mkGen (Code.ForEmail email) + let gen = mkVerificationCodeGen email code <- - Code.generate - gen - Code.IdentityVerification - (Code.Retries 3) - (Code.Timeout (3600 * 24)) -- 24h - (Just (toUUID pid)) - tryInsertVerificationCode code $ verificationCodeThrottledError . VerificationCodeThrottled - lift $ sendActivationMail (Name "name") email (Code.codeKey code) (Code.codeValue code) True - -updateAccountPassword :: Member GalleyAPIAccess r => ProviderId -> Public.PasswordChange -> (Handler r) () + lift . liftSem $ + createCodeOverwritePrevious + gen + IdentityVerification + (Retries 3) + (Timeout (3600 * 24)) -- 24h + (Just (toUUID pid)) + lift $ sendActivationMail (Name "name") email code.codeKey code.codeValue True + +updateAccountPassword :: (Member GalleyAPIAccess r) => ProviderId -> Public.PasswordChange -> (Handler r) () updateAccountPassword pid upd = do guardSecondFactorDisabled Nothing pass <- wrapClientE (DB.lookupPassword pid) >>= maybeBadCredentials @@ -338,7 +335,7 @@ updateAccountPassword pid upd = do wrapClientE $ DB.updateAccountPassword pid (newPassword upd) addService :: - Member GalleyAPIAccess r => + (Member GalleyAPIAccess r) => ProviderId -> Public.NewService -> (Handler r) Public.NewServiceResponse @@ -358,13 +355,13 @@ addService pid new = do let rstoken = maybe (Just token) (const Nothing) (newServiceToken new) pure $ Public.NewServiceResponse sid rstoken -listServices :: Member GalleyAPIAccess r => ProviderId -> (Handler r) [Public.Service] +listServices :: (Member GalleyAPIAccess r) => ProviderId -> (Handler r) [Public.Service] listServices pid = do guardSecondFactorDisabled Nothing wrapClientE $ DB.listServices pid getService :: - Member GalleyAPIAccess r => + (Member GalleyAPIAccess r) => ProviderId -> ServiceId -> (Handler r) Public.Service @@ -373,7 +370,7 @@ getService pid sid = do wrapClientE (DB.lookupService pid sid) >>= maybeServiceNotFound updateService :: - Member GalleyAPIAccess r => + (Member GalleyAPIAccess r) => ProviderId -> ServiceId -> Public.UpdateService -> @@ -407,7 +404,7 @@ updateService pid sid upd = do (serviceEnabled svc) updateServiceConn :: - Member GalleyAPIAccess r => + (Member GalleyAPIAccess r) => ProviderId -> ServiceId -> Public.UpdateServiceConn -> @@ -524,17 +521,17 @@ deleteAccount pid del = do -------------------------------------------------------------------------------- -- User API -getProviderProfile :: Member GalleyAPIAccess r => UserId -> ProviderId -> (Handler r) (Maybe Public.ProviderProfile) +getProviderProfile :: (Member GalleyAPIAccess r) => UserId -> ProviderId -> (Handler r) (Maybe Public.ProviderProfile) getProviderProfile _ pid = do guardSecondFactorDisabled Nothing wrapClientE (DB.lookupAccountProfile pid) -listServiceProfiles :: Member GalleyAPIAccess r => UserId -> ProviderId -> (Handler r) [Public.ServiceProfile] +listServiceProfiles :: (Member GalleyAPIAccess r) => UserId -> ProviderId -> (Handler r) [Public.ServiceProfile] listServiceProfiles _ pid = do guardSecondFactorDisabled Nothing wrapClientE $ DB.listServiceProfiles pid -getServiceProfile :: Member GalleyAPIAccess r => UserId -> ProviderId -> ServiceId -> (Handler r) Public.ServiceProfile +getServiceProfile :: (Member GalleyAPIAccess r) => UserId -> ProviderId -> ServiceId -> (Handler r) Public.ServiceProfile getServiceProfile _ pid sid = do guardSecondFactorDisabled Nothing wrapClientE (DB.lookupServiceProfile pid sid) >>= maybeServiceNotFound @@ -543,7 +540,7 @@ getServiceProfile _ pid sid = do -- pagination here, we need both 'start' and 'prefix'. -- -- Also see Note [buggy pagination]. -searchServiceProfiles :: Member GalleyAPIAccess r => UserId -> Maybe (Public.QueryAnyTags 1 3) -> Maybe Text -> Maybe (Range 10 100 Int32) -> (Handler r) Public.ServiceProfilePage +searchServiceProfiles :: (Member GalleyAPIAccess r) => UserId -> Maybe (Public.QueryAnyTags 1 3) -> Maybe Text -> Maybe (Range 10 100 Int32) -> (Handler r) Public.ServiceProfilePage searchServiceProfiles _ Nothing (Just start) mSize = do guardSecondFactorDisabled Nothing prefix :: Range 1 128 Text <- rangeChecked start @@ -577,14 +574,14 @@ searchTeamServiceProfiles uid tid prefix mFilterDisabled mSize = do -- Get search results wrapClientE $ DB.paginateServiceWhitelist tid prefix filterDisabled (fromRange size) -getServiceTagList :: Member GalleyAPIAccess r => UserId -> (Handler r) Public.ServiceTagList +getServiceTagList :: (Member GalleyAPIAccess r) => UserId -> (Handler r) Public.ServiceTagList getServiceTagList _ = do guardSecondFactorDisabled Nothing pure (Public.ServiceTagList allTags) where allTags = [(minBound :: Public.ServiceTag) ..] -updateServiceWhitelist :: Member GalleyAPIAccess r => UserId -> ConnId -> TeamId -> Public.UpdateServiceWhitelist -> (Handler r) UpdateServiceWhitelistResp +updateServiceWhitelist :: (Member GalleyAPIAccess r) => UserId -> ConnId -> TeamId -> Public.UpdateServiceWhitelist -> (Handler r) UpdateServiceWhitelistResp updateServiceWhitelist uid con tid upd = do guardSecondFactorDisabled (Just uid) let pid = updateServiceWhitelistProvider upd @@ -621,7 +618,7 @@ updateServiceWhitelist uid con tid upd = do -------------------------------------------------------------------------------- -- Bot API -addBot :: Member GalleyAPIAccess r => UserId -> ConnId -> ConvId -> Public.AddBot -> (Handler r) Public.AddBotResponse +addBot :: (Member GalleyAPIAccess r) => UserId -> ConnId -> ConvId -> Public.AddBot -> (Handler r) Public.AddBotResponse addBot zuid zcon cid add = do guardSecondFactorDisabled (Just zuid) zusr <- lift (wrapClient $ User.lookupUser NoPendingInvitations zuid) >>= maybeInvalidUser @@ -705,7 +702,7 @@ addBot zuid zcon cid add = do Public.rsAddBotEvent = ev } -removeBot :: Member GalleyAPIAccess r => UserId -> ConnId -> ConvId -> BotId -> (Handler r) (Maybe Public.RemoveBotResponse) +removeBot :: (Member GalleyAPIAccess r) => UserId -> ConnId -> ConvId -> BotId -> (Handler r) (Maybe Public.RemoveBotResponse) removeBot zusr zcon cid bid = do guardSecondFactorDisabled (Just zusr) -- Get the conversation and check preconditions @@ -728,7 +725,7 @@ removeBot zusr zcon cid bid = do Just _ -> do lift $ Public.RemoveBotResponse <$$> wrapHttpClient (deleteBot zusr (Just zcon) bid cid) -guardConvAdmin :: Conversation -> ExceptT Error (AppT r) () +guardConvAdmin :: Conversation -> ExceptT HttpError (AppT r) () guardConvAdmin conv = do let selfMember = cmSelf . cnvMembers $ conv unless (memConvRoleName selfMember == roleNameWireAdmin) $ (throwStd (errorToWai @'E.AccessDenied)) @@ -738,12 +735,12 @@ botGetSelf bot = do p <- lift $ wrapClient $ User.lookupUser NoPendingInvitations (botUserId bot) maybe (throwStd (errorToWai @'E.UserNotFound)) (\u -> pure $ Public.mkUserProfile EmailVisibleToSelf u UserLegalHoldNoConsent) p -botGetClient :: Member GalleyAPIAccess r => BotId -> (Handler r) (Maybe Public.Client) +botGetClient :: (Member GalleyAPIAccess r) => BotId -> (Handler r) (Maybe Public.Client) botGetClient bot = do guardSecondFactorDisabled (Just (botUserId bot)) lift $ listToMaybe <$> wrapClient (User.lookupClients (botUserId bot)) -botListPrekeys :: Member GalleyAPIAccess r => BotId -> (Handler r) [Public.PrekeyId] +botListPrekeys :: (Member GalleyAPIAccess r) => BotId -> (Handler r) [Public.PrekeyId] botListPrekeys bot = do guardSecondFactorDisabled (Just (botUserId bot)) clt <- lift $ listToMaybe <$> wrapClient (User.lookupClients (botUserId bot)) @@ -751,7 +748,7 @@ botListPrekeys bot = do Nothing -> pure [] Just ci -> lift (wrapClient $ User.lookupPrekeyIds (botUserId bot) ci) -botUpdatePrekeys :: Member GalleyAPIAccess r => BotId -> Public.UpdateBotPrekeys -> (Handler r) () +botUpdatePrekeys :: (Member GalleyAPIAccess r) => BotId -> Public.UpdateBotPrekeys -> (Handler r) () botUpdatePrekeys bot upd = do guardSecondFactorDisabled (Just (botUserId bot)) clt <- lift $ listToMaybe <$> wrapClient (User.lookupClients (botUserId bot)) @@ -776,20 +773,20 @@ botClaimUsersPrekeys _ body = do throwStd (errorToWai @'E.TooManyClients) Client.claimLocalMultiPrekeyBundles UnprotectedBot body !>> clientError -botListUserProfiles :: Member GalleyAPIAccess r => BotId -> (CommaSeparatedList UserId) -> (Handler r) [Public.BotUserView] +botListUserProfiles :: (Member GalleyAPIAccess r) => BotId -> (CommaSeparatedList UserId) -> (Handler r) [Public.BotUserView] botListUserProfiles _ uids = do guardSecondFactorDisabled Nothing -- should we check all user ids? us <- lift . wrapClient $ User.lookupUsers NoPendingInvitations (fromCommaSeparatedList uids) pure (map mkBotUserView us) -botGetUserClients :: Member GalleyAPIAccess r => BotId -> UserId -> (Handler r) [Public.PubClient] +botGetUserClients :: (Member GalleyAPIAccess r) => BotId -> UserId -> (Handler r) [Public.PubClient] botGetUserClients _ uid = do guardSecondFactorDisabled (Just uid) lift $ pubClient <$$> wrapClient (User.lookupClients uid) where pubClient c = Public.PubClient (clientId c) (clientClass c) -botDeleteSelf :: Member GalleyAPIAccess r => BotId -> ConvId -> (Handler r) () +botDeleteSelf :: (Member GalleyAPIAccess r) => BotId -> ConvId -> (Handler r) () botDeleteSelf bid cid = do guardSecondFactorDisabled (Just (botUserId bid)) bot <- lift . wrapClient $ User.lookupUser NoPendingInvitations (botUserId bid) @@ -803,9 +800,9 @@ botDeleteSelf bid cid = do -- | If second factor auth is enabled, make sure that end-points that don't support it, but should, are blocked completely. -- (This is a workaround until we have 2FA for those end-points as well.) guardSecondFactorDisabled :: - Member GalleyAPIAccess r => + (Member GalleyAPIAccess r) => Maybe UserId -> - ExceptT Error (AppT r) () + ExceptT HttpError (AppT r) () guardSecondFactorDisabled mbUserId = do enabled <- lift $ liftSem $ (==) Feature.FeatureStatusEnabled . Feature.wsStatus . Feature.afcSndFactorPasswordChallenge <$> GalleyAPIAccess.getAllFeatureConfigsForUser mbUserId when enabled $ (throwStd (errorToWai @'E.AccessDenied)) @@ -850,7 +847,7 @@ deleteBot zusr zcon bid cid = do void $ runExceptT $ User.updateStatus buid Deleted pure ev -validateServiceKey :: MonadIO m => Public.ServiceKeyPEM -> m (Maybe (Public.ServiceKey, Fingerprint Rsa)) +validateServiceKey :: (MonadIO m) => Public.ServiceKeyPEM -> m (Maybe (Public.ServiceKey, Fingerprint Rsa)) validateServiceKey pem = liftIO $ readPublicKey >>= \pk -> @@ -882,28 +879,28 @@ mkBotUserView u = Ext.botUserViewTeam = userTeam u } -maybeInvalidProvider :: Monad m => Maybe a -> (ExceptT Error m) a +maybeInvalidProvider :: (Monad m) => Maybe a -> (ExceptT HttpError m) a maybeInvalidProvider = maybe (throwStd (errorToWai @'E.ProviderNotFound)) pure -maybeInvalidCode :: Monad m => Maybe a -> (ExceptT Error m) a +maybeInvalidCode :: (Monad m) => Maybe a -> (ExceptT HttpError m) a maybeInvalidCode = maybe (throwStd (errorToWai @'E.InvalidCode)) pure -maybeServiceNotFound :: Monad m => Maybe a -> (ExceptT Error m) a +maybeServiceNotFound :: (Monad m) => Maybe a -> (ExceptT HttpError m) a maybeServiceNotFound = maybe (throwStd (errorToWai @'E.ServiceNotFound)) pure -maybeConvNotFound :: Monad m => Maybe a -> (ExceptT Error m) a +maybeConvNotFound :: (Monad m) => Maybe a -> (ExceptT HttpError m) a maybeConvNotFound = maybe (throwStd (notFound "Conversation not found")) pure -maybeBadCredentials :: Monad m => Maybe a -> (ExceptT Error m) a +maybeBadCredentials :: (Monad m) => Maybe a -> (ExceptT HttpError m) a maybeBadCredentials = maybe (throwStd (errorToWai @'E.BadCredentials)) pure -maybeInvalidServiceKey :: Monad m => Maybe a -> (ExceptT Error m) a +maybeInvalidServiceKey :: (Monad m) => Maybe a -> (ExceptT HttpError m) a maybeInvalidServiceKey = maybe (throwStd (errorToWai @'E.InvalidServiceKey)) pure -maybeInvalidUser :: Monad m => Maybe a -> (ExceptT Error m) a +maybeInvalidUser :: (Monad m) => Maybe a -> (ExceptT HttpError m) a maybeInvalidUser = maybe (throwStd (errorToWai @'E.InvalidUser)) pure -rangeChecked :: (KnownNat n, KnownNat m, Within a n m, Monad monad) => a -> (ExceptT Error monad) (Range n m a) +rangeChecked :: (KnownNat n, KnownNat m, Within a n m, Monad monad) => a -> (ExceptT HttpError monad) (Range n m a) rangeChecked = either (throwStd . invalidRange . fromString) pure . checkedEither badGatewayWith :: String -> Wai.Error @@ -919,5 +916,5 @@ serviceError :: RPC.ServiceError -> Wai.Error serviceError (RPC.ServiceUnavailableWith str) = badGatewayWith str serviceError RPC.ServiceBotConflict = tooManyBots -randServiceToken :: MonadIO m => m Public.ServiceToken +randServiceToken :: (MonadIO m) => m Public.ServiceToken randServiceToken = ServiceToken . Ascii.encodeBase64Url <$> liftIO (randBytes 18) diff --git a/services/brig/src/Brig/Provider/DB.hs b/services/brig/src/Brig/Provider/DB.hs index 77aefc29ea5..98d237c9565 100644 --- a/services/brig/src/Brig/Provider/DB.hs +++ b/services/brig/src/Brig/Provider/DB.hs @@ -17,7 +17,6 @@ module Brig.Provider.DB where -import Brig.Email (EmailKey, emailKeyOrig, emailKeyUniq) import Brig.Types.Instances () import Brig.Types.Provider.Tag import Cassandra as C @@ -35,6 +34,7 @@ import Wire.API.Provider import Wire.API.Provider.Service hiding (updateServiceTags) import Wire.API.Provider.Service.Tag import Wire.API.User +import Wire.UserKeyStore type RangedServiceTags = Range 0 3 (Set.Set ServiceTag) @@ -42,7 +42,7 @@ type RangedServiceTags = Range 0 3 (Set.Set ServiceTag) -- Providers insertAccount :: - MonadClient m => + (MonadClient m) => Name -> Password -> HttpsUrl -> @@ -57,7 +57,7 @@ insertAccount name pass url descr = do cql = "INSERT INTO provider (id, name, password, url, descr) VALUES (?, ?, ?, ?, ?)" updateAccountProfile :: - MonadClient m => + (MonadClient m) => ProviderId -> Maybe Name -> Maybe HttpsUrl -> @@ -79,7 +79,7 @@ updateAccountProfile p name url descr = retry x5 . batch $ do -- | Lookup the raw account data of a (possibly unverified) provider. lookupAccountData :: - MonadClient m => + (MonadClient m) => ProviderId -> m (Maybe (Name, Maybe Email, HttpsUrl, Text)) lookupAccountData p = retry x1 $ query1 cql $ params LocalQuorum (Identity p) @@ -88,7 +88,7 @@ lookupAccountData p = retry x1 $ query1 cql $ params LocalQuorum (Identity p) cql = "SELECT name, email, url, descr FROM provider WHERE id = ?" lookupAccount :: - MonadClient m => + (MonadClient m) => ProviderId -> m (Maybe Provider) lookupAccount p = (>>= mk) <$> lookupAccountData p @@ -98,13 +98,13 @@ lookupAccount p = (>>= mk) <$> lookupAccountData p mk (n, Just e, u, d) = Just $! Provider p n e u d lookupAccountProfile :: - MonadClient m => + (MonadClient m) => ProviderId -> m (Maybe ProviderProfile) lookupAccountProfile p = fmap ProviderProfile <$> lookupAccount p lookupPassword :: - MonadClient m => + (MonadClient m) => ProviderId -> m (Maybe Password) lookupPassword p = @@ -117,7 +117,7 @@ lookupPassword p = cql = "SELECT password FROM provider WHERE id = ?" deleteAccount :: - MonadClient m => + (MonadClient m) => ProviderId -> m () deleteAccount pid = retry x5 $ write cql $ params LocalQuorum (Identity pid) @@ -126,12 +126,12 @@ deleteAccount pid = retry x5 $ write cql $ params LocalQuorum (Identity pid) cql = "DELETE FROM provider WHERE id = ?" updateAccountPassword :: - MonadClient m => + (MonadClient m) => ProviderId -> PlainTextPassword6 -> m () updateAccountPassword pid pwd = do - p <- liftIO $ mkSafePassword pwd + p <- liftIO $ mkSafePasswordScrypt pwd retry x5 $ write cql $ params LocalQuorum (p, pid) where cql :: PrepQuery W (Password, ProviderId) () @@ -141,7 +141,7 @@ updateAccountPassword pid pwd = do -- Unique (Natural) Keys insertKey :: - MonadClient m => + (MonadClient m) => ProviderId -> Maybe EmailKey -> EmailKey -> @@ -163,7 +163,7 @@ insertKey p old new = retry x5 . batch $ do cqlEmail = {- `IF EXISTS`, but that requires benchmarking -} "UPDATE provider SET email = ? WHERE id = ?" lookupKey :: - MonadClient m => + (MonadClient m) => EmailKey -> m (Maybe ProviderId) lookupKey k = @@ -175,7 +175,7 @@ lookupKey k = cql :: PrepQuery R (Identity Text) (Identity ProviderId) cql = "SELECT provider FROM provider_keys WHERE key = ?" -deleteKey :: MonadClient m => EmailKey -> m () +deleteKey :: (MonadClient m) => EmailKey -> m () deleteKey k = retry x5 $ write cql $ params LocalQuorum (Identity (emailKeyUniq k)) where cql :: PrepQuery W (Identity Text) () @@ -185,7 +185,7 @@ deleteKey k = retry x5 $ write cql $ params LocalQuorum (Identity (emailKeyUniq -- Services insertService :: - MonadClient m => + (MonadClient m) => ProviderId -> Name -> Text -> @@ -230,7 +230,7 @@ insertService pid name summary descr url token key fprint assets tags = do \VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)" lookupService :: - MonadClient m => + (MonadClient m) => ProviderId -> ServiceId -> m (Maybe Service) @@ -252,7 +252,7 @@ lookupService pid sid = Service sid name (fromMaybe mempty summary) descr url toks keys assets (Set.fromList (fromSet tags)) enabled listServices :: - MonadClient m => + (MonadClient m) => ProviderId -> m [Service] listServices p = @@ -274,7 +274,7 @@ listServices p = in Service sid name (fromMaybe mempty summary) descr url toks keys assets tags' enabled updateService :: - MonadClient m => + (MonadClient m) => ProviderId -> ServiceId -> Name -> @@ -319,7 +319,7 @@ updateService pid sid svcName svcTags nameChange summary descr assets tagsChange -- NB: can take a significant amount of time if many teams were using the service deleteService :: - MonadClient m => + (MonadClient m) => ProviderId -> ServiceId -> Name -> @@ -346,7 +346,7 @@ deleteService pid sid name tags = do -- | Note: Consistency = One lookupServiceProfile :: - MonadClient m => + (MonadClient m) => ProviderId -> ServiceId -> m (Maybe ServiceProfile) @@ -366,7 +366,7 @@ lookupServiceProfile p s = -- | Note: Consistency = One listServiceProfiles :: - MonadClient m => + (MonadClient m) => ProviderId -> m [ServiceProfile] listServiceProfiles p = @@ -401,7 +401,7 @@ data ServiceConn = ServiceConn -- | Lookup the connection information of a service. lookupServiceConn :: - MonadClient m => + (MonadClient m) => ProviderId -> ServiceId -> m (Maybe ServiceConn) @@ -419,7 +419,7 @@ lookupServiceConn pid sid = -- | Update connection information of a service. updateServiceConn :: - MonadClient m => + (MonadClient m) => ProviderId -> ServiceId -> Maybe HttpsUrl -> @@ -453,7 +453,7 @@ updateServiceConn pid sid url tokens keys enabled = retry x5 . batch $ do -- Service "Indexes" (tag and prefix); contain only enabled services insertServiceIndexes :: - MonadClient m => + (MonadClient m) => ProviderId -> ServiceId -> Name -> @@ -467,7 +467,7 @@ insertServiceIndexes pid sid name tags = insertServiceTags pid sid name tags deleteServiceIndexes :: - MonadClient m => + (MonadClient m) => ProviderId -> ServiceId -> Name -> @@ -572,7 +572,7 @@ type IndexRow = (Name, ProviderId, ServiceId) -- | Note: Consistency = One paginateServiceTags :: - MonadClient m => + (MonadClient m) => QueryAnyTags 1 3 -> Maybe Text -> Int32 -> @@ -657,7 +657,7 @@ updateServicePrefix pid sid oldName newName = do insertServicePrefix pid sid newName paginateServiceNames :: - MonadClient m => + (MonadClient m) => Maybe (Range 1 128 Text) -> Int32 -> Maybe ProviderId -> @@ -713,13 +713,13 @@ filterPrefix prefix p = do more = allValid && hasMore p in p {hasMore = more, result = prefixed} -resolveRow :: MonadClient m => IndexRow -> m (Maybe ServiceProfile) +resolveRow :: (MonadClient m) => IndexRow -> m (Maybe ServiceProfile) resolveRow (_, pid, sid) = lookupServiceProfile pid sid -------------------------------------------------------------------------------- -- Service whitelist -insertServiceWhitelist :: MonadClient m => TeamId -> ProviderId -> ServiceId -> m () +insertServiceWhitelist :: (MonadClient m) => TeamId -> ProviderId -> ServiceId -> m () insertServiceWhitelist tid pid sid = retry x5 . batch $ do addPrepQuery insert1 (tid, pid, sid) @@ -739,7 +739,7 @@ insertServiceWhitelist tid pid sid = -- -- NB: Can take a significant amount of time if many teams were using the service -deleteServiceWhitelist :: MonadClient m => Maybe TeamId -> ProviderId -> ServiceId -> m () +deleteServiceWhitelist :: (MonadClient m) => Maybe TeamId -> ProviderId -> ServiceId -> m () deleteServiceWhitelist mbTid pid sid = case mbTid of Nothing -> do teams <- retry x5 $ query lookupRev $ params LocalQuorum (pid, sid) @@ -775,7 +775,7 @@ deleteServiceWhitelist mbTid pid sid = case mbTid of -- paginateServiceWhitelist :: - MonadClient m => + (MonadClient m) => -- | Team for which to list the services TeamId -> -- | Prefix @@ -817,7 +817,7 @@ paginateServiceWhitelist tid mbPrefix filterDisabled size = liftClient $ do | otherwise = id getServiceWhitelistStatus :: - MonadClient m => + (MonadClient m) => TeamId -> ProviderId -> ServiceId -> diff --git a/services/brig/src/Brig/Provider/Email.hs b/services/brig/src/Brig/Provider/Email.hs index fcf526b35a8..1b8f329c240 100644 --- a/services/brig/src/Brig/Provider/Email.hs +++ b/services/brig/src/Brig/Provider/Email.hs @@ -26,9 +26,7 @@ module Brig.Provider.Email where import Brig.App -import Brig.Email import Brig.Provider.Template -import Brig.Template import Control.Lens (view) import Data.ByteString.Conversion import Data.Code qualified as Code @@ -38,18 +36,23 @@ import Data.Text.Ascii qualified as Ascii import Data.Text.Encoding qualified as Text import Data.Text.Lazy qualified as LT import Imports +import Network.Mail.Mime +import Polysemy import Wire.API.Provider import Wire.API.User +import Wire.EmailSending +import Wire.EmailSubsystem.Interpreter (mkMimeAddress) +import Wire.EmailSubsystem.Template (TemplateBranding, renderHtmlWithBranding, renderTextWithBranding) ------------------------------------------------------------------------------- -- Activation Email -sendActivationMail :: Name -> Email -> Code.Key -> Code.Value -> Bool -> (AppT r) () +sendActivationMail :: (Member EmailSending r) => Name -> Email -> Code.Key -> Code.Value -> Bool -> (AppT r) () sendActivationMail name email key code update = do tpl <- selectTemplate update . snd <$> providerTemplates Nothing branding <- view templateBranding let mail = ActivationEmail email name key code - sendMail $ renderActivationMail mail tpl branding + liftSem $ sendMail $ renderActivationMail mail tpl branding where selectTemplate True = activationEmailUpdate selectTemplate False = activationEmail @@ -96,12 +99,12 @@ renderActivationUrl t (Code.Key k) (Code.Value v) branding = -------------------------------------------------------------------------------- -- Approval Request Email -sendApprovalRequestMail :: Name -> Email -> HttpsUrl -> Text -> Code.Key -> Code.Value -> (AppT r) () +sendApprovalRequestMail :: (Member EmailSending r) => Name -> Email -> HttpsUrl -> Text -> Code.Key -> Code.Value -> (AppT r) () sendApprovalRequestMail name email url descr key val = do tpl <- approvalRequestEmail . snd <$> providerTemplates Nothing branding <- view templateBranding let mail = ApprovalRequestEmail email name url descr key val - sendMail $ renderApprovalRequestMail mail tpl branding + liftSem $ sendMail $ renderApprovalRequestMail mail tpl branding data ApprovalRequestEmail = ApprovalRequestEmail { aprTo :: !Email, @@ -147,12 +150,12 @@ renderApprovalUrl t (Code.Key k) (Code.Value v) branding = -------------------------------------------------------------------------------- -- Approval Confirmation Email -sendApprovalConfirmMail :: Name -> Email -> (AppT r) () +sendApprovalConfirmMail :: (Member EmailSending r) => Name -> Email -> (AppT r) () sendApprovalConfirmMail name email = do tpl <- approvalConfirmEmail . snd <$> providerTemplates Nothing branding <- view templateBranding let mail = ApprovalConfirmEmail email name - sendMail $ renderApprovalConfirmMail mail tpl branding + liftSem $ sendMail $ renderApprovalConfirmMail mail tpl branding data ApprovalConfirmEmail = ApprovalConfirmEmail { apcTo :: !Email, @@ -183,12 +186,12 @@ renderApprovalConfirmMail ApprovalConfirmEmail {..} ApprovalConfirmEmailTemplate -------------------------------------------------------------------------------- -- Password Reset Email -sendPasswordResetMail :: Email -> Code.Key -> Code.Value -> (AppT r) () +sendPasswordResetMail :: (Member EmailSending r) => Email -> Code.Key -> Code.Value -> (AppT r) () sendPasswordResetMail to key code = do tpl <- passwordResetEmail . snd <$> providerTemplates Nothing branding <- view templateBranding let mail = PasswordResetEmail to key code - sendMail $ renderPwResetMail mail tpl branding + liftSem $ sendMail $ renderPwResetMail mail tpl branding data PasswordResetEmail = PasswordResetEmail { pwrTo :: !Email, diff --git a/services/brig/src/Brig/Provider/RPC.hs b/services/brig/src/Brig/Provider/RPC.hs index 12e17007518..f8abba06133 100644 --- a/services/brig/src/Brig/Provider/RPC.hs +++ b/services/brig/src/Brig/Provider/RPC.hs @@ -111,7 +111,7 @@ extReq scon ps = url = httpsUrl (sconBaseUrl scon) tok = List1.head (sconAuthTokens scon) -extHandleAll :: MonadCatch m => (SomeException -> m a) -> m a -> m a +extHandleAll :: (MonadCatch m) => (SomeException -> m a) -> m a -> m a extHandleAll f ma = catches ma @@ -137,7 +137,7 @@ extLogError scon e = -- Internal RPC -- | Set service connection information in galley. -setServiceConn :: ServiceConn -> (AppT r) () +setServiceConn :: ServiceConn -> AppT r () setServiceConn scon = do Log.debug $ remote "galley" diff --git a/services/brig/src/Brig/Provider/Template.hs b/services/brig/src/Brig/Provider/Template.hs index e8d56929300..951ff9add7e 100644 --- a/services/brig/src/Brig/Provider/Template.hs +++ b/services/brig/src/Brig/Provider/Template.hs @@ -26,8 +26,6 @@ module Brig.Provider.Template -- * Re-exports Template, - renderText, - renderHtml, ) where @@ -38,6 +36,7 @@ import Data.Misc (HttpsUrl) import Data.Text.Encoding (encodeUtf8) import Imports import Wire.API.User.Identity +import Wire.EmailSubsystem.Template data ProviderTemplates = ProviderTemplates { activationEmail :: !ActivationEmailTemplate, @@ -47,15 +46,6 @@ data ProviderTemplates = ProviderTemplates passwordResetEmail :: !PasswordResetEmailTemplate } -data ActivationEmailTemplate = ActivationEmailTemplate - { activationEmailUrl :: !Template, - activationEmailSubject :: !Template, - activationEmailBodyText :: !Template, - activationEmailBodyHtml :: !Template, - activationEmailSender :: !Email, - activationEmailSenderName :: !Text - } - data ApprovalRequestEmailTemplate = ApprovalRequestEmailTemplate { approvalRequestEmailUrl :: !Template, approvalRequestEmailSubject :: !Template, @@ -75,15 +65,6 @@ data ApprovalConfirmEmailTemplate = ApprovalConfirmEmailTemplate approvalConfirmEmailHomeUrl :: !HttpsUrl } -data PasswordResetEmailTemplate = PasswordResetEmailTemplate - { passwordResetEmailUrl :: !Template, - passwordResetEmailSubject :: !Template, - passwordResetEmailBodyText :: !Template, - passwordResetEmailBodyHtml :: !Template, - passwordResetEmailSender :: !Email, - passwordResetEmailSenderName :: !Text - } - -- TODO -- data NewServiceEmailTemplate = NewServiceEmailTemplate -- { newServiceEmailSubject :: !Template diff --git a/services/brig/src/Brig/Queue/Stomp.hs b/services/brig/src/Brig/Queue/Stomp.hs index 0ec44a75f24..d6d8c3abfca 100644 --- a/services/brig/src/Brig/Queue/Stomp.hs +++ b/services/brig/src/Brig/Queue/Stomp.hs @@ -180,7 +180,7 @@ listen b q callback = ------------------------------------------------------------------------------- -- Utilities -iconv :: FromJSON a => Text -> InBound a +iconv :: (FromJSON a) => Text -> InBound a iconv queue _ _ _ bs = case Aeson.eitherDecode (BL.fromStrict bs) of Right x -> pure x @@ -188,7 +188,7 @@ iconv queue _ _ _ bs = convertError $ "Error when parsing message from STOMP queue " <> unpack queue <> ": " <> e -oconv :: ToJSON a => OutBound a +oconv :: (ToJSON a) => OutBound a oconv = pure . BL.toStrict . Aeson.encode jsonType :: MIME.Type diff --git a/services/brig/src/Brig/Run.hs b/services/brig/src/Brig/Run.hs index 35f3fd36efa..5f713dd5edb 100644 --- a/services/brig/src/Brig/Run.hs +++ b/services/brig/src/Brig/Run.hs @@ -46,28 +46,23 @@ import Control.Monad.Catch (MonadCatch, finally) import Control.Monad.Random (randomRIO) import Data.Aeson qualified as Aeson import Data.ByteString.UTF8 qualified as UTF8 -import Data.Id (RequestId (..)) import Data.Metrics.AWS (gaugeTokenRemaing) import Data.Metrics.Servant qualified as Metrics import Data.Proxy (Proxy (Proxy)) import Data.Text (unpack) -import Data.Text.Encoding -import Data.UUID as UUID -import Data.UUID.V4 as UUID import Imports hiding (head) import Network.HTTP.Media qualified as HTTPMedia import Network.HTTP.Types qualified as HTTP import Network.Wai qualified as Wai import Network.Wai.Middleware.Gunzip qualified as GZip import Network.Wai.Middleware.Gzip qualified as GZip -import Network.Wai.Utilities (lookupRequestId) +import Network.Wai.Utilities.Request import Network.Wai.Utilities.Server import Network.Wai.Utilities.Server qualified as Server import Polysemy (Member) import Servant (Context ((:.)), (:<|>) (..)) import Servant qualified -import System.Logger (Logger, msg, val, (.=), (~~)) -import System.Logger qualified as Log +import System.Logger (msg, val, (.=), (~~)) import System.Logger.Class (MonadLogger, err) import Util.Options import Wire.API.Routes.API @@ -78,6 +73,7 @@ import Wire.API.Routes.Version.Wai import Wire.API.User (AccountStatus (PendingInvitation)) import Wire.DeleteQueue import Wire.Sem.Paging qualified as P +import Wire.UserStore -- FUTUREWORK: If any of these async threads die, we will have no clue about it -- and brig could start misbehaving. We should ensure that brig dies whenever a @@ -113,36 +109,41 @@ run o = do closeEnv e where endpoint' = brig o - server e = defaultServer (unpack $ endpoint' ^. host) (endpoint' ^. port) (e ^. applog) (e ^. metrics) + server e = defaultServer (unpack $ endpoint' ^. host) (endpoint' ^. port) (e ^. applog) mkApp :: Opts -> IO (Wai.Application, Env) mkApp o = do e <- newEnv o - pure (middleware e $ \reqId -> servantApp (e & requestId .~ reqId), e) + pure (middleware e $ servantApp e, e) where - middleware :: Env -> (RequestId -> Wai.Application) -> Wai.Application + middleware :: Env -> Wai.Middleware middleware e = -- this rewrites the request, so it must be at the top (i.e. applied last) versionMiddleware (e ^. disabledVersions) + -- this also rewrites the request + . requestIdMiddleware (e ^. applog) defaultRequestIdHeaderName . Metrics.servantPrometheusMiddleware (Proxy @ServantCombinedAPI) . GZip.gunzip . GZip.gzip GZip.def - . catchErrors (e ^. applog) [Right $ e ^. metrics] - . lookupRequestIdMiddleware (e ^. applog) + . catchErrors (e ^. applog) defaultRequestIdHeaderName -- the servant API wraps the one defined using wai-routing servantApp :: Env -> Wai.Application - servantApp e = + servantApp e0 req cont = do + let rid = getRequestId defaultRequestIdHeaderName req + let e = requestId .~ rid $ e0 let localDomain = view (settings . federationDomain) e - in Servant.serveWithContext - (Proxy @ServantCombinedAPI) - (customFormatters :. localDomain :. Servant.EmptyContext) - ( docsAPI - :<|> hoistServerWithDomain @BrigAPI (toServantHandler e) servantSitemap - :<|> hoistServerWithDomain @IAPI.API (toServantHandler e) IAPI.servantSitemap - :<|> hoistServerWithDomain @FederationAPI (toServantHandler e) federationSitemap - :<|> hoistServerWithDomain @VersionAPI (toServantHandler e) versionAPI - ) + Servant.serveWithContext + (Proxy @ServantCombinedAPI) + (customFormatters :. localDomain :. Servant.EmptyContext) + ( docsAPI + :<|> hoistServerWithDomain @BrigAPI (toServantHandler e) servantSitemap + :<|> hoistServerWithDomain @IAPI.API (toServantHandler e) IAPI.servantSitemap + :<|> hoistServerWithDomain @FederationAPI (toServantHandler e) federationSitemap + :<|> hoistServerWithDomain @VersionAPI (toServantHandler e) versionAPI + ) + req + cont type ServantCombinedAPI = ( DocsAPI @@ -152,20 +153,6 @@ type ServantCombinedAPI = :<|> VersionAPI ) -lookupRequestIdMiddleware :: Logger -> (RequestId -> Wai.Application) -> Wai.Application -lookupRequestIdMiddleware logger mkapp req cont = do - case lookupRequestId req of - Just rid -> do - mkapp (RequestId rid) req cont - Nothing -> do - localRid <- RequestId . encodeUtf8 . UUID.toText <$> UUID.nextRandom - Log.info logger $ - "request-id" .= localRid - ~~ "method" .= Wai.requestMethod req - ~~ "path" .= Wai.rawPathInfo req - ~~ msg (val "generated a new request id for local request") - mkapp localRid req cont - customFormatters :: Servant.ErrorFormatters customFormatters = Servant.defaultErrorFormatters @@ -194,7 +181,8 @@ pendingActivationCleanup :: forall r p. ( P.Paging p, Member (UserPendingActivationStore p) r, - Member DeleteQueue r + Member DeleteQueue r, + Member UserStore r ) => AppT r () pendingActivationCleanup = do @@ -203,7 +191,7 @@ pendingActivationCleanup = do forExpirationsPaged $ \exps -> do uids <- for exps $ \(UserPendingActivation uid expiresAt) -> do - isPendingInvitation <- (Just PendingInvitation ==) <$> wrapClient (API.lookupStatus uid) + isPendingInvitation <- (Just PendingInvitation ==) <$> liftSem (lookupStatus uid) pure ( expiresAt < now, isPendingInvitation, @@ -256,10 +244,9 @@ pendingActivationCleanup = do collectAuthMetrics :: forall r. AppT r () collectAuthMetrics = do - m <- view metrics env <- view (awsEnv . amazonkaEnv) liftIO $ forever $ do mbRemaining <- readAuthExpiration env - gaugeTokenRemaing m mbRemaining + gaugeTokenRemaing mbRemaining threadDelay 1_000_000 diff --git a/services/brig/src/Brig/Team/API.hs b/services/brig/src/Brig/Team/API.hs index 46ce343f9e4..900506d6bd7 100644 --- a/services/brig/src/Brig/Team/API.hs +++ b/services/brig/src/Brig/Team/API.hs @@ -32,15 +32,11 @@ import Brig.API.User (createUserInviteViaScim, fetchUserIdentity) import Brig.API.User qualified as API import Brig.API.Util (logEmail, logInvitationCode) import Brig.App -import Brig.Data.UserKey -import Brig.Data.UserKey qualified as Data import Brig.Effects.BlacklistStore (BlacklistStore) import Brig.Effects.BlacklistStore qualified as BlacklistStore import Brig.Effects.ConnectionStore (ConnectionStore) import Brig.Effects.UserPendingActivationStore (UserPendingActivationStore) -import Brig.Email qualified as Email import Brig.Options (setMaxTeamSize, setTeamInvitationTimeout) -import Brig.Phone qualified as Phone import Brig.Team.DB qualified as DB import Brig.Team.Email import Brig.Team.Util (ensurePermissionToAddUser, ensurePermissions) @@ -80,15 +76,23 @@ import Wire.API.Team.Role import Wire.API.Team.Role qualified as Public import Wire.API.User hiding (fromEmail) import Wire.API.User qualified as Public +import Wire.API.User.Identity qualified as Email +import Wire.EmailSending (EmailSending) +import Wire.Error import Wire.GalleyAPIAccess (GalleyAPIAccess, ShowOrHideInvitationUrl (..)) import Wire.GalleyAPIAccess qualified as GalleyAPIAccess import Wire.NotificationSubsystem import Wire.Sem.Concurrency import Wire.Sem.Paging.Cassandra (InternalPaging) +import Wire.UserKeyStore +import Wire.UserSubsystem servantAPI :: ( Member BlacklistStore r, - Member GalleyAPIAccess r + Member GalleyAPIAccess r, + Member UserKeyStore r, + Member UserSubsystem r, + Member EmailSending r ) => ServerT TeamsAPI (Handler r) servantAPI = @@ -100,7 +104,7 @@ servantAPI = :<|> Named @"head-team-invitations" headInvitationByEmail :<|> Named @"get-team-size" teamSizePublic -teamSizePublic :: Member GalleyAPIAccess r => UserId -> TeamId -> (Handler r) TeamSize +teamSizePublic :: (Member GalleyAPIAccess r) => UserId -> TeamId -> (Handler r) TeamSize teamSizePublic uid tid = do ensurePermissions uid tid [AddTeamMember] -- limit this to team admins to reduce risk of involuntary DOS attacks teamSize tid @@ -115,7 +119,10 @@ getInvitationCode t r = do createInvitationPublicH :: ( Member BlacklistStore r, - Member GalleyAPIAccess r + Member GalleyAPIAccess r, + Member UserKeyStore r, + Member UserSubsystem r, + Member EmailSending r ) => UserId -> TeamId -> @@ -137,7 +144,10 @@ data CreateInvitationInviter = CreateInvitationInviter createInvitationPublic :: ( Member BlacklistStore r, - Member GalleyAPIAccess r + Member GalleyAPIAccess r, + Member UserKeyStore r, + Member UserSubsystem r, + Member EmailSending r ) => UserId -> TeamId -> @@ -165,8 +175,10 @@ createInvitationPublic uid tid body = do createInvitationViaScim :: ( Member BlacklistStore r, Member GalleyAPIAccess r, + Member UserKeyStore r, Member (UserPendingActivationStore p) r, - Member TinyLog r + Member TinyLog r, + Member EmailSending r ) => TeamId -> NewUserScimInvitation -> @@ -214,7 +226,9 @@ logInvitationRequest context action = createInvitation' :: ( Member BlacklistStore r, - Member GalleyAPIAccess r + Member GalleyAPIAccess r, + Member UserKeyStore r, + Member EmailSending r ) => TeamId -> Maybe UserId -> @@ -229,25 +243,14 @@ createInvitation' tid mUid inviteeRole mbInviterUid fromEmail body = do -- Validate e-mail inviteeEmail <- either (const $ throwStd (errorToWai @'E.InvalidEmail)) pure (Email.validateEmail (irInviteeEmail body)) - let uke = userEmailKey inviteeEmail + let uke = mkEmailKey inviteeEmail blacklistedEm <- lift $ liftSem $ BlacklistStore.exists uke when blacklistedEm $ throwStd blacklistedEmail - emailTaken <- lift $ isJust <$> wrapClient (Data.lookupKey uke) + emailTaken <- lift $ liftSem $ isJust <$> lookupKey uke when emailTaken $ throwStd emailExists - -- Validate phone - inviteePhone <- for (irInviteePhone body) $ \p -> do - validatedPhone <- maybe (throwStd (errorToWai @'E.InvalidPhone)) pure =<< lift (wrapClient $ Phone.validatePhone p) - let ukp = userPhoneKey validatedPhone - blacklistedPh <- lift $ liftSem $ BlacklistStore.exists ukp - when blacklistedPh $ - throwStd (errorToWai @'E.BlacklistedPhone) - phoneTaken <- lift $ isJust <$> wrapClient (Data.lookupKey ukp) - when phoneTaken $ - throwStd phoneExists - pure validatedPhone maxSize <- setMaxTeamSize <$> view settings pending <- lift $ wrapClient $ DB.countInvitations tid when (fromIntegral pending >= maxSize) $ @@ -272,23 +275,23 @@ createInvitation' tid mUid inviteeRole mbInviterUid fromEmail body = do mbInviterUid inviteeEmail inviteeName - inviteePhone + Nothing -- ignore phone timeout (newInv, code) <$ sendInvitationMail inviteeEmail tid fromEmail code locale -deleteInvitation :: Member GalleyAPIAccess r => UserId -> TeamId -> InvitationId -> (Handler r) () +deleteInvitation :: (Member GalleyAPIAccess r) => UserId -> TeamId -> InvitationId -> (Handler r) () deleteInvitation uid tid iid = do ensurePermissions uid tid [AddTeamMember] lift $ wrapClient $ DB.deleteInvitation tid iid -listInvitations :: Member GalleyAPIAccess r => UserId -> TeamId -> Maybe InvitationId -> Maybe (Range 1 500 Int32) -> (Handler r) Public.InvitationList +listInvitations :: (Member GalleyAPIAccess r) => UserId -> TeamId -> Maybe InvitationId -> Maybe (Range 1 500 Int32) -> (Handler r) Public.InvitationList listInvitations uid tid start mSize = do ensurePermissions uid tid [AddTeamMember] showInvitationUrl <- lift $ liftSem $ GalleyAPIAccess.getExposeInvitationURLsToTeamAdmin tid rs <- lift $ wrapClient $ DB.lookupInvitations showInvitationUrl tid start (fromMaybe (unsafeRange 100) mSize) pure $! Public.InvitationList (DB.resultList rs) (DB.resultHasMore rs) -getInvitation :: Member GalleyAPIAccess r => UserId -> TeamId -> InvitationId -> (Handler r) (Maybe Public.Invitation) +getInvitation :: (Member GalleyAPIAccess r) => UserId -> TeamId -> InvitationId -> (Handler r) (Maybe Public.Invitation) getInvitation uid tid iid = do ensurePermissions uid tid [AddTeamMember] showInvitationUrl <- lift $ liftSem $ GalleyAPIAccess.getExposeInvitationURLsToTeamAdmin tid diff --git a/services/brig/src/Brig/Team/DB.hs b/services/brig/src/Brig/Team/DB.hs index ec22f1f6d81..a31875142c1 100644 --- a/services/brig/src/Brig/Team/DB.hs +++ b/services/brig/src/Brig/Team/DB.hs @@ -41,7 +41,6 @@ import Brig.App as App import Brig.Data.Types as T import Brig.Options import Brig.Team.Template -import Brig.Template (renderTextWithBranding) import Cassandra as C import Control.Lens (view) import Data.Conduit (runConduit, (.|)) @@ -62,6 +61,7 @@ import UnliftIO.Async (pooledMapConcurrentlyN_) import Wire.API.Team.Invitation hiding (HeadInvitationByEmailResult (..)) import Wire.API.Team.Role import Wire.API.User +import Wire.EmailSubsystem.Template (renderTextWithBranding) import Wire.GalleyAPIAccess (ShowOrHideInvitationUrl (..)) mkInvitationCode :: IO InvitationCode @@ -148,7 +148,7 @@ lookupInvitationByCode showUrl i = Just InvitationInfo {..} -> lookupInvitation showUrl iiTeam iiInvId _ -> pure Nothing -lookupInvitationCode :: MonadClient m => TeamId -> InvitationId -> m (Maybe InvitationCode) +lookupInvitationCode :: (MonadClient m) => TeamId -> InvitationId -> m (Maybe InvitationCode) lookupInvitationCode t r = fmap runIdentity <$> retry x1 (query1 cqlInvitationCode (params LocalQuorum (t, r))) @@ -156,7 +156,7 @@ lookupInvitationCode t r = cqlInvitationCode :: PrepQuery R (TeamId, InvitationId) (Identity InvitationCode) cqlInvitationCode = "SELECT code FROM team_invitation WHERE team = ? AND id = ?" -lookupInvitationCodeEmail :: MonadClient m => TeamId -> InvitationId -> m (Maybe (InvitationCode, Email)) +lookupInvitationCodeEmail :: (MonadClient m) => TeamId -> InvitationId -> m (Maybe (InvitationCode, Email)) lookupInvitationCodeEmail t r = retry x1 (query1 cqlInvitationCodeEmail (params LocalQuorum (t, r))) where cqlInvitationCodeEmail :: PrepQuery R (TeamId, InvitationId) (InvitationCode, Email) @@ -190,7 +190,7 @@ lookupInvitations showUrl team start (fromRange -> size) = do cqlSelectFrom :: PrepQuery R (TeamId, InvitationId) (TeamId, Maybe Role, InvitationId, UTCTimeMillis, Maybe UserId, Email, Maybe Name, Maybe Phone, InvitationCode) cqlSelectFrom = "SELECT team, role, id, created_at, created_by, email, name, phone, code FROM team_invitation WHERE team = ? AND id > ? ORDER BY id ASC" -deleteInvitation :: MonadClient m => TeamId -> InvitationId -> m () +deleteInvitation :: (MonadClient m) => TeamId -> InvitationId -> m () deleteInvitation t i = do codeEmail <- lookupInvitationCodeEmail t i case codeEmail of @@ -220,7 +220,7 @@ deleteInvitations t = cqlSelect :: PrepQuery R (Identity TeamId) (Identity InvitationId) cqlSelect = "SELECT id FROM team_invitation WHERE team = ? ORDER BY id ASC" -lookupInvitationInfo :: MonadClient m => InvitationCode -> m (Maybe InvitationInfo) +lookupInvitationInfo :: (MonadClient m) => InvitationCode -> m (Maybe InvitationInfo) lookupInvitationInfo ic@(InvitationCode c) | c == mempty = pure Nothing | otherwise = @@ -262,7 +262,7 @@ lookupInvitationInfoByEmail email = do cqlInvitationEmail :: PrepQuery R (Identity Email) (TeamId, InvitationId, InvitationCode) cqlInvitationEmail = "SELECT team, invitation, code FROM team_invitation_email WHERE email = ?" -countInvitations :: MonadClient m => TeamId -> m Int64 +countInvitations :: (MonadClient m) => TeamId -> m Int64 countInvitations t = maybe 0 runIdentity <$> retry x1 (query1 cqlSelect (params LocalQuorum (Identity t))) @@ -311,7 +311,7 @@ mkInviteUrl ShowInvitationUrl team (InvitationCode c) = do replace "code" = toText c replace x = x - parseHttpsUrl :: Log.MonadLogger m => Text -> m (Maybe (URIRef Absolute)) + parseHttpsUrl :: (Log.MonadLogger m) => Text -> m (Maybe (URIRef Absolute)) parseHttpsUrl url = either (\e -> logError url e >> pure Nothing) (pure . Just) $ parseURI laxURIParserOptions (encodeUtf8 url) diff --git a/services/brig/src/Brig/Team/Email.hs b/services/brig/src/Brig/Team/Email.hs index a58429f5c5f..07b38e1a57b 100644 --- a/services/brig/src/Brig/Team/Email.hs +++ b/services/brig/src/Brig/Team/Email.hs @@ -28,40 +28,41 @@ module Brig.Team.Email where import Brig.App -import Brig.Email -import Brig.Email qualified as Email import Brig.Team.Template -import Brig.Template import Control.Lens (view) import Data.Id (TeamId, idToText) import Data.Text.Ascii qualified as Ascii import Data.Text.Lazy (toStrict) import Imports +import Network.Mail.Mime +import Polysemy import Wire.API.User +import Wire.EmailSending +import Wire.EmailSubsystem.Template (TemplateBranding, renderHtmlWithBranding, renderTextWithBranding) ------------------------------------------------------------------------------- -- Invitation Email -sendInvitationMail :: Email -> TeamId -> Email -> InvitationCode -> Maybe Locale -> (AppT r) () +sendInvitationMail :: (Member EmailSending r) => Email -> TeamId -> Email -> InvitationCode -> Maybe Locale -> (AppT r) () sendInvitationMail to tid from code loc = do tpl <- invitationEmail . snd <$> teamTemplates loc branding <- view templateBranding let mail = InvitationEmail to tid code from - Email.sendMail $ renderInvitationEmail mail tpl branding + liftSem $ sendMail $ renderInvitationEmail mail tpl branding -sendCreatorWelcomeMail :: Email -> TeamId -> Text -> Maybe Locale -> (AppT r) () +sendCreatorWelcomeMail :: (Member EmailSending r) => Email -> TeamId -> Text -> Maybe Locale -> (AppT r) () sendCreatorWelcomeMail to tid teamName loc = do tpl <- creatorWelcomeEmail . snd <$> teamTemplates loc branding <- view templateBranding let mail = CreatorWelcomeEmail to tid teamName - Email.sendMail $ renderCreatorWelcomeMail mail tpl branding + liftSem $ sendMail $ renderCreatorWelcomeMail mail tpl branding -sendMemberWelcomeMail :: Email -> TeamId -> Text -> Maybe Locale -> (AppT r) () +sendMemberWelcomeMail :: (Member EmailSending r) => Email -> TeamId -> Text -> Maybe Locale -> (AppT r) () sendMemberWelcomeMail to tid teamName loc = do tpl <- memberWelcomeEmail . snd <$> teamTemplates loc branding <- view templateBranding let mail = MemberWelcomeEmail to tid teamName - Email.sendMail $ renderMemberWelcomeMail mail tpl branding + liftSem $ sendMail $ renderMemberWelcomeMail mail tpl branding ------------------------------------------------------------------------------- -- Invitation Email diff --git a/services/brig/src/Brig/Team/Template.hs b/services/brig/src/Brig/Team/Template.hs index 568707df45e..32f6f803ad4 100644 --- a/services/brig/src/Brig/Team/Template.hs +++ b/services/brig/src/Brig/Team/Template.hs @@ -24,8 +24,6 @@ module Brig.Team.Template -- * Re-exports Template, - renderText, - renderHtml, ) where diff --git a/services/brig/src/Brig/Team/Util.hs b/services/brig/src/Brig/Team/Util.hs index bf7a3d0da85..6ab5eab896d 100644 --- a/services/brig/src/Brig/Team/Util.hs +++ b/services/brig/src/Brig/Team/Util.hs @@ -30,18 +30,19 @@ import Polysemy (Member) import Wire.API.Team.Member import Wire.API.Team.Permission import Wire.API.User (User (userTeam)) +import Wire.Error import Wire.GalleyAPIAccess (GalleyAPIAccess) import Wire.GalleyAPIAccess qualified as GalleyAPIAccess -- | If the user is in a team, it has to have these permissions. If not, it is a personal -- user with account validation and thus given the permission implicitly. (Used for -- `SearchContactcs`.) -ensurePermissionsOrPersonalUser :: (Member GalleyAPIAccess r, IsPerm perm) => UserId -> [perm] -> ExceptT Error (AppT r) () +ensurePermissionsOrPersonalUser :: (Member GalleyAPIAccess r, IsPerm perm) => UserId -> [perm] -> ExceptT HttpError (AppT r) () ensurePermissionsOrPersonalUser u perms = do mbUser <- lift $ wrapHttp $ Data.lookupUser NoPendingInvitations u maybe (pure ()) (\tid -> ensurePermissions u tid perms) (userTeam =<< mbUser :: Maybe TeamId) -ensurePermissions :: (Member GalleyAPIAccess r, IsPerm perm) => UserId -> TeamId -> [perm] -> ExceptT Error (AppT r) () +ensurePermissions :: (Member GalleyAPIAccess r, IsPerm perm) => UserId -> TeamId -> [perm] -> ExceptT HttpError (AppT r) () ensurePermissions u t perms = do m <- lift $ liftSem $ GalleyAPIAccess.getTeamMember u t unless (check m) $ @@ -54,7 +55,7 @@ ensurePermissions u t perms = do -- | Privilege escalation detection (make sure no `RoleMember` user creates a `RoleOwner`). -- -- There is some code duplication with 'Galley.API.Teams.ensureNotElevated'. -ensurePermissionToAddUser :: Member GalleyAPIAccess r => UserId -> TeamId -> Permissions -> ExceptT Error (AppT r) () +ensurePermissionToAddUser :: (Member GalleyAPIAccess r) => UserId -> TeamId -> Permissions -> ExceptT HttpError (AppT r) () ensurePermissionToAddUser u t inviteePerms = do minviter <- lift $ liftSem $ GalleyAPIAccess.getTeamMember u t unless (check minviter) $ diff --git a/services/brig/src/Brig/Template.hs b/services/brig/src/Brig/Template.hs index d66ba6edbfb..906f395d8ef 100644 --- a/services/brig/src/Brig/Template.hs +++ b/services/brig/src/Brig/Template.hs @@ -21,18 +21,12 @@ module Brig.Template ( -- * Reading templates Localised, - forLocale, readLocalesDir, readTemplateWithDefault, readTextWithDefault, -- * Rendering templates - renderText, - renderHtml, - renderTextWithBranding, - renderHtmlWithBranding, genTemplateBranding, - TemplateBranding, -- * Re-exports Template, @@ -46,23 +40,15 @@ import Data.ByteString qualified as BS import Data.Map.Strict qualified as Map import Data.Text (pack, unpack) import Data.Text.Encoding qualified as T -import Data.Text.Lazy qualified as Lazy import Data.Text.Template (Template, template) -import Data.Text.Template qualified as Template -import HTMLEntities.Text qualified as HTML import Imports hiding (readFile) import System.IO.Error (isDoesNotExistError) import Wire.API.User +import Wire.EmailSubsystem.Template (Localised (Localised)) -- | See 'genTemplateBranding'. type TemplateBranding = Text -> Text --- | Localised templates. -data Localised a = Localised - { locDefault :: !(Locale, a), - locOther :: !(Map Locale a) - } - readLocalesDir :: -- | Default locale. Locale -> @@ -92,26 +78,6 @@ readLocalesDir defLocale base typ load = do fromMaybe (error ("Invalid locale: " ++ show l)) $ parseLocale (pack l) --- | Lookup a localised item from a 'Localised' structure. -forLocale :: - -- | 'Just' the preferred locale or 'Nothing' for - -- the default locale. - Maybe Locale -> - -- | The 'Localised' structure. - Localised a -> - -- | Pair of the effectively chosen locale and the - -- associated value. - (Locale, a) -forLocale pref t = case pref of - Just l -> fromMaybe (locDefault t) (select l) - Nothing -> locDefault t - where - select l = - let l' = l {lCountry = Nothing} - loc = Map.lookup l (locOther t) - lan = Map.lookup l' (locOther t) - in (l,) <$> loc <|> (l',) <$> lan - readTemplateWithDefault :: FilePath -> Locale -> @@ -143,24 +109,6 @@ readText f = (readFile f) (\_ -> error $ "Missing file: '" ++ f) --- | Uses a replace and a branding function, to replaces all placeholders from the --- given template to produce a Text. To be used on plain text templates -renderTextWithBranding :: Template -> (Text -> Text) -> TemplateBranding -> Lazy.Text -renderTextWithBranding tpl replace branding = renderText tpl (replace . branding) - --- | Uses a replace and a branding function to replace all placeholders from the --- given template to produce a Text. To be used on HTML templates -renderHtmlWithBranding :: Template -> (Text -> Text) -> TemplateBranding -> Lazy.Text -renderHtmlWithBranding tpl replace branding = renderHtml tpl (replace . branding) - --- TODO: Do not export this function -renderText :: Template -> (Text -> Text) -> Lazy.Text -renderText = Template.render - --- TODO: Do not export this function -renderHtml :: Template -> (Text -> Text) -> Lazy.Text -renderHtml tpl replace = renderText tpl (HTML.text . replace) - readWithDefault :: (String -> IO a) -> FilePath -> diff --git a/services/brig/src/Brig/User/API/Handle.hs b/services/brig/src/Brig/User/API/Handle.hs index f39fa56a7b0..bfa3407059a 100644 --- a/services/brig/src/Brig/User/API/Handle.hs +++ b/services/brig/src/Brig/User/API/Handle.hs @@ -42,13 +42,14 @@ import Wire.API.User import Wire.API.User qualified as Public import Wire.API.User.Search import Wire.API.User.Search qualified as Public +import Wire.UserStore (UserStore) import Wire.UserSubsystem getHandleInfo :: - (Member UserSubsystem r) => + (Member UserSubsystem r, Member UserStore r) => UserId -> Qualified Handle -> - (Handler r) (Maybe Public.UserProfile) + Handler r (Maybe Public.UserProfile) getHandleInfo self handle = do lself <- qualifyLocal self foldQualified @@ -57,7 +58,7 @@ getHandleInfo self handle = do getRemoteHandleInfo handle -getRemoteHandleInfo :: Remote Handle -> (Handler r) (Maybe Public.UserProfile) +getRemoteHandleInfo :: Remote Handle -> Handler r (Maybe Public.UserProfile) getRemoteHandleInfo handle = do lift . Log.info $ Log.msg (Log.val "getHandleInfo - remote lookup") @@ -65,13 +66,13 @@ getRemoteHandleInfo handle = do Federation.getUserHandleInfo handle !>> fedError getLocalHandleInfo :: - (Member UserSubsystem r) => + (Member UserSubsystem r, Member UserStore r) => Local UserId -> Handle -> - (Handler r) (Maybe Public.UserProfile) + Handler r (Maybe Public.UserProfile) getLocalHandleInfo self handle = do lift . Log.info $ Log.msg $ Log.val "getHandleInfo - local lookup" - maybeOwnerId <- lift . wrapClient $ API.lookupHandle handle + maybeOwnerId <- lift . liftSem $ API.lookupHandle handle case maybeOwnerId of Nothing -> pure Nothing Just ownerId -> do diff --git a/services/brig/src/Brig/User/API/Search.hs b/services/brig/src/Brig/User/API/Search.hs index 2d77a5e9119..afb00c1efd6 100644 --- a/services/brig/src/Brig/User/API/Search.hs +++ b/services/brig/src/Brig/User/API/Search.hs @@ -40,7 +40,7 @@ import Brig.User.Search.SearchIndex qualified as Q import Brig.User.Search.TeamUserSearch qualified as Q import Control.Lens (view) import Data.Domain (Domain) -import Data.Handle (parseHandle) +import Data.Handle qualified as Handle import Data.Id import Data.Range import Imports @@ -59,6 +59,7 @@ import Wire.API.User.Search import Wire.API.User.Search qualified as Public import Wire.GalleyAPIAccess (GalleyAPIAccess) import Wire.GalleyAPIAccess qualified as GalleyAPIAccess +import Wire.UserStore (UserStore) import Wire.UserSubsystem -- FUTUREWORK: Consider augmenting 'SearchResult' with full user profiles @@ -66,6 +67,7 @@ import Wire.UserSubsystem search :: ( Member GalleyAPIAccess r, Member FederationConfigStore r, + Member UserStore r, Member UserSubsystem r ) => UserId -> @@ -116,7 +118,8 @@ searchRemotely domain mTid searchTerm = do searchLocally :: forall r. ( Member GalleyAPIAccess r, - Member UserSubsystem r + Member UserSubsystem r, + Member UserStore r ) => UserId -> Text -> @@ -165,14 +168,14 @@ searchLocally searcherId searchTerm maybeMaxResults = do exactHandleSearch :: (Handler r) (Maybe Contact) exactHandleSearch = do lsearcherId <- qualifyLocal searcherId - case parseHandle searchTerm of + case Handle.parseHandle searchTerm of Nothing -> pure Nothing Just handle -> do HandleAPI.contactFromProfile <$$> HandleAPI.getLocalHandleInfo lsearcherId handle teamUserSearch :: - Member GalleyAPIAccess r => + (Member GalleyAPIAccess r) => UserId -> TeamId -> Maybe Text -> diff --git a/services/brig/src/Brig/User/Auth.hs b/services/brig/src/Brig/User/Auth.hs index 481a8b8cafa..ba4f765436a 100644 --- a/services/brig/src/Brig/User/Auth.hs +++ b/services/brig/src/Brig/User/Auth.hs @@ -18,7 +18,6 @@ -- | High-level user authentication and access control. module Brig.User.Auth ( Access, - sendLoginCode, login, logout, renewAccess, @@ -27,7 +26,6 @@ module Brig.User.Auth verifyCode, -- * Internal - lookupLoginCode, ssoLogin, legalHoldLogin, @@ -40,27 +38,19 @@ import Brig.API.Types import Brig.API.User (changeSingleAccountStatus) import Brig.App import Brig.Budget -import Brig.Code qualified as Code import Brig.Data.Activation qualified as Data import Brig.Data.Client -import Brig.Data.LoginCode qualified as Data import Brig.Data.User qualified as Data -import Brig.Data.UserKey -import Brig.Data.UserKey qualified as Data import Brig.Effects.ConnectionStore (ConnectionStore) -import Brig.Email import Brig.Options qualified as Opt -import Brig.Phone import Brig.Types.Intra import Brig.User.Auth.Cookie -import Brig.User.Handle -import Brig.User.Phone import Brig.ZAuth qualified as ZAuth import Cassandra import Control.Error hiding (bool) import Control.Lens (to, view) -import Control.Monad.Except import Data.ByteString.Conversion (toByteString) +import Data.Code qualified as Code import Data.Handle (Handle) import Data.Id import Data.List.NonEmpty qualified as NE @@ -86,47 +76,14 @@ import Wire.API.User.Auth.Sso import Wire.GalleyAPIAccess (GalleyAPIAccess) import Wire.GalleyAPIAccess qualified as GalleyAPIAccess import Wire.NotificationSubsystem +import Wire.PasswordStore (PasswordStore) import Wire.Sem.Paging.Cassandra (InternalPaging) - -sendLoginCode :: - (Member TinyLog r) => - Phone -> - Bool -> - Bool -> - ExceptT SendLoginCodeError (AppT r) PendingLoginCode -sendLoginCode phone call force = do - pk <- - maybe - (throwE $ SendLoginInvalidPhone phone) - (pure . userPhoneKey) - =<< lift (wrapHttpClient $ validatePhone phone) - user <- lift $ wrapHttpClient $ Data.lookupKey pk - case user of - Nothing -> throwE $ SendLoginInvalidPhone phone - Just u -> do - lift . liftSem . Log.debug $ field "user" (toByteString u) . field "action" (val "User.sendLoginCode") - pw <- lift $ wrapClient $ Data.lookupPassword u - unless (isNothing pw || force) $ - throwE SendLoginPasswordExists - lift $ wrapHttpClient $ do - l <- Data.lookupLocale u - c <- Data.createLoginCode u - void . forPhoneKey pk $ \ph -> - if call - then sendLoginCall ph (pendingLoginCode c) l - else sendLoginSms ph (pendingLoginCode c) l - pure c - -lookupLoginCode :: - Member TinyLog r => - Phone -> - AppT r (Maybe PendingLoginCode) -lookupLoginCode phone = - wrapClient (Data.lookupKey (userPhoneKey phone)) >>= \case - Nothing -> pure Nothing - Just u -> do - liftSem $ Log.debug $ field "user" (toByteString u) . field "action" (val "User.lookupLoginCode") - wrapHttpClient $ Data.lookupLoginCode u +import Wire.UserKeyStore +import Wire.UserStore +import Wire.VerificationCode qualified as VerificationCode +import Wire.VerificationCodeGen qualified as VerificationCodeGen +import Wire.VerificationCodeSubsystem (VerificationCodeSubsystem) +import Wire.VerificationCodeSubsystem qualified as VerificationCodeSubsystem login :: forall r. @@ -136,22 +93,25 @@ login :: Member NotificationSubsystem r, Member (Input (Local ())) r, Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r + Member (ConnectionStore InternalPaging) r, + Member PasswordStore r, + Member UserKeyStore r, + Member UserStore r, + Member VerificationCodeSubsystem r ) => Login -> CookieType -> ExceptT LoginError (AppT r) (Access ZAuth.User) login (PasswordLogin (PasswordLoginData li pw label code)) typ = do - uid <- wrapHttpClientE $ resolveLoginId li + uid <- resolveLoginId li lift . liftSem . Log.debug $ field "user" (toByteString uid) . field "action" (val "User.login") wrapHttpClientE $ checkRetryLimit uid - wrapHttpClientE $ - Data.authenticate uid pw `catchE` \case - AuthInvalidUser -> loginFailed uid - AuthInvalidCredentials -> loginFailed uid - AuthSuspended -> throwE LoginSuspended - AuthEphemeral -> throwE LoginEphemeral - AuthPendingInvitation -> throwE LoginPendingActivation + Data.authenticate uid pw `catchE` \case + AuthInvalidUser -> wrapHttpClientE $ loginFailed uid + AuthInvalidCredentials -> wrapHttpClientE $ loginFailed uid + AuthSuspended -> throwE LoginSuspended + AuthEphemeral -> throwE LoginEphemeral + AuthPendingInvitation -> throwE LoginPendingActivation verifyLoginCode code uid newAccess @ZAuth.User @ZAuth.Access uid Nothing typ label where @@ -162,19 +122,13 @@ login (PasswordLogin (PasswordLoginData li pw label code)) typ = do VerificationCodeNoPendingCode -> wrapHttpClientE $ loginFailedWith LoginCodeInvalid uid VerificationCodeRequired -> wrapHttpClientE $ loginFailedWith LoginCodeRequired uid VerificationCodeNoEmail -> wrapHttpClientE $ loginFailed uid -login (SmsLogin (SmsLoginData phone code label)) typ = do - uid <- wrapHttpClientE $ resolveLoginId (LoginByPhone phone) - lift . liftSem . Log.debug $ field "user" (toByteString uid) . field "action" (val "User.login") - wrapHttpClientE $ checkRetryLimit uid - ok <- wrapHttpClientE $ Data.verifyLoginCode uid code - unless ok $ - wrapHttpClientE $ - loginFailed uid - newAccess @ZAuth.User @ZAuth.Access uid Nothing typ label +login (SmsLogin _) _ = do + -- sms login not supported + throwE LoginFailed verifyCode :: forall r. - Member GalleyAPIAccess r => + (Member GalleyAPIAccess r, Member VerificationCodeSubsystem r) => Maybe Code.Value -> VerificationAction -> UserId -> @@ -188,8 +142,9 @@ verifyCode mbCode action uid = do when (featureEnabled && not isSsoUser) $ do case (mbCode, mbEmail) of (Just code, Just email) -> do - key <- Code.mkKey $ Code.ForEmail email - codeValid <- isJust <$> wrapHttpClientE (Code.verify key (Code.scopeFromAction action) code) + let key = VerificationCodeGen.mkKey email + scope = VerificationCode.scopeFromAction action + codeValid <- isJust <$> lift (liftSem $ VerificationCodeSubsystem.verifyCode key scope code) unless codeValid $ throwE VerificationCodeNoPendingCode (Nothing, _) -> throwE VerificationCodeRequired (_, Nothing) -> throwE VerificationCodeNoEmail @@ -214,7 +169,7 @@ checkRetryLimit :: (MonadClient m, MonadReader Env m) => UserId -> ExceptT Login checkRetryLimit = withRetryLimit checkBudget withRetryLimit :: - MonadReader Env m => + (MonadReader Env m) => (BudgetKey -> Budget -> ExceptT LoginError m (Budgeted ())) -> UserId -> ExceptT LoginError m () @@ -264,7 +219,7 @@ renewAccess uts at mcid = do pure $ Access at' ck' revokeAccess :: - (Member TinyLog r) => + (Member TinyLog r, Member PasswordStore r) => UserId -> PlainTextPassword6 -> [CookieId] -> @@ -272,7 +227,7 @@ revokeAccess :: ExceptT AuthError (AppT r) () revokeAccess u pw cc ll = do lift . liftSem $ Log.debug $ field "user" (toByteString u) . field "action" (val "User.revokeAccess") - wrapHttpClientE $ unlessM (Data.isSamlUser u) $ Data.authenticate u pw + unlessM (lift . wrapHttpClient $ Data.isSamlUser u) $ Data.authenticate u pw lift $ wrapHttpClient $ revokeCookies u cc ll -------------------------------------------------------------------------------- @@ -299,7 +254,7 @@ catchSuspendInactiveUser uid errval = do lift $ runExceptT (changeSingleAccountStatus uid Suspended) >>= explicitlyIgnoreErrors throwE errval where - explicitlyIgnoreErrors :: Monad m => Either AccountStatusError () -> m () + explicitlyIgnoreErrors :: (Monad m) => Either AccountStatusError () -> m () explicitlyIgnoreErrors = \case Left InvalidAccountStatus -> pure () Left AccountNotFound -> pure () @@ -329,37 +284,35 @@ newAccess uid cid ct cl = do t <- lift $ newAccessToken @u @a ck Nothing pure $ Access t (Just ck) -resolveLoginId :: (MonadClient m, MonadReader Env m) => LoginId -> ExceptT LoginError m UserId +resolveLoginId :: (Member UserKeyStore r, Member UserStore r) => LoginId -> ExceptT LoginError (AppT r) UserId resolveLoginId li = do - usr <- validateLoginId li >>= lift . either lookupKey lookupHandle + usr <- wrapClientE (validateLoginId li) >>= lift . either (liftSem . lookupKey) (liftSem . lookupHandle) case usr of Nothing -> do - pending <- lift $ isPendingActivation li + pending <- wrapClientE $ isPendingActivation li throwE $ if pending then LoginPendingActivation else LoginFailed Just uid -> pure uid -validateLoginId :: (MonadClient m, MonadReader Env m) => LoginId -> ExceptT LoginError m (Either UserKey Handle) +validateLoginId :: (MonadReader Env m) => LoginId -> ExceptT LoginError m (Either EmailKey Handle) validateLoginId (LoginByEmail email) = either (const $ throwE LoginFailed) - (pure . Left . userEmailKey) + (pure . Left . mkEmailKey) (validateEmail email) -validateLoginId (LoginByPhone phone) = - maybe - (throwE LoginFailed) - (pure . Left . userPhoneKey) - =<< lift (validatePhone phone) +validateLoginId (LoginByPhone _) = do + -- phone logins are not supported + throwE LoginFailed validateLoginId (LoginByHandle h) = pure (Right h) isPendingActivation :: (MonadClient m, MonadReader Env m) => LoginId -> m Bool isPendingActivation ident = case ident of (LoginByHandle _) -> pure False - (LoginByEmail e) -> checkKey (userEmailKey e) - (LoginByPhone p) -> checkKey (userPhoneKey p) + (LoginByEmail e) -> checkKey (mkEmailKey e) + (LoginByPhone _) -> pure False where checkKey k = do usr <- (>>= fst) <$> Data.lookupActivationCode k @@ -375,9 +328,7 @@ isPendingActivation ident = case ident of Ephemeral -> False PendingInvitation -> True in statusAdmitsPending && case i of - Just (EmailIdentity e) -> userEmailKey e /= k - Just (PhoneIdentity p) -> userPhoneKey p /= k - Just (FullIdentity e p) -> userEmailKey e /= k && userPhoneKey p /= k + Just (EmailIdentity e) -> mkEmailKey e /= k Just SSOIdentity {} -> False -- sso-created users are activated immediately. Nothing -> True @@ -396,7 +347,7 @@ validateTokens uts at = do where -- FUTUREWORK: There is surely a better way to do this getFirstSuccessOrFirstFail :: - Monad m => + (Monad m) => List1 (Either ZAuth.Failure (UserId, Cookie (ZAuth.Token u))) -> ExceptT ZAuth.Failure m (UserId, Cookie (ZAuth.Token u)) getFirstSuccessOrFirstFail tks = case (lefts $ NE.toList $ List1.toNonEmpty tks, rights $ NE.toList $ List1.toNonEmpty tks) of @@ -473,7 +424,7 @@ legalHoldLogin (LegalHoldLogin uid pw label) typ = do !>> LegalHoldLoginError assertLegalHoldEnabled :: - Member GalleyAPIAccess r => + (Member GalleyAPIAccess r) => TeamId -> ExceptT LegalHoldLoginError (AppT r) () assertLegalHoldEnabled tid = do @@ -482,6 +433,6 @@ assertLegalHoldEnabled tid = do FeatureStatusDisabled -> throwE LegalHoldLoginLegalHoldNotEnabled FeatureStatusEnabled -> pure () -checkClientId :: MonadClient m => UserId -> ClientId -> ExceptT ZAuth.Failure m () +checkClientId :: (MonadClient m) => UserId -> ClientId -> ExceptT ZAuth.Failure m () checkClientId uid cid = lookupClient uid cid >>= maybe (throwE ZAuth.Invalid) (const (pure ())) diff --git a/services/brig/src/Brig/User/Auth/Cookie.hs b/services/brig/src/Brig/User/Auth/Cookie.hs index 1bd569bc352..1be8ff2c778 100644 --- a/services/brig/src/Brig/User/Auth/Cookie.hs +++ b/services/brig/src/Brig/User/Auth/Cookie.hs @@ -43,7 +43,6 @@ where import Brig.App import Brig.Options hiding (user) import Brig.User.Auth.Cookie.Limit -import Brig.User.Auth.DB.Cookie qualified as DB import Brig.ZAuth qualified as ZAuth import Cassandra import Control.Error @@ -52,17 +51,18 @@ import Control.Monad.Except import Data.ByteString.Conversion import Data.Id import Data.List qualified as List -import Data.Metrics qualified as Metrics import Data.Proxy import Data.RetryAfter import Data.Time.Clock import Imports import Network.Wai (Response) import Network.Wai.Utilities.Response (addHeader) +import Prometheus qualified as Prom import System.Logger.Class (field, msg, val, (~~)) import System.Logger.Class qualified as Log import Web.Cookie qualified as WebCookie import Wire.API.User.Auth +import Wire.SessionStore qualified as Store -------------------------------------------------------------------------------- -- Basic Cookie Management @@ -94,7 +94,7 @@ newCookie uid cid typ label = do cookieSucc = Nothing, cookieValue = tok } - DB.insertCookie uid c Nothing + adhocSessionStoreInterpreter $ Store.insertCookie uid (toUnitCookie c) Nothing pure c -- | Renew the given cookie with a fresh token, if its age @@ -104,7 +104,8 @@ nextCookie :: MonadReader Env m, Log.MonadLogger m, ZAuth.MonadZAuth m, - MonadClient m + MonadClient m, + Prom.MonadMonitor m ) => Cookie (ZAuth.Token u) -> Maybe ClientId -> @@ -132,7 +133,7 @@ nextCookie c mNewCid = runMaybeT $ do ck <- hoistMaybe $ cookieSucc c let uid = ZAuth.userTokenOf (cookieValue c) lift $ trackSuperseded uid (cookieId c) - cs <- lift $ DB.listCookies uid + cs <- lift $ adhocSessionStoreInterpreter $ Store.listCookies uid c' <- hoistMaybe $ List.find (\x -> cookieId x == ck && cookieType x == PersistentCookie) cs @@ -160,7 +161,7 @@ renewCookie old mcid = do -- an ever growing chain of superseded cookies. let old' = old {cookieSucc = Just (cookieId new)} ttl <- setUserCookieRenewAge <$> view settings - DB.insertCookie uid old' (Just (DB.TTL (fromIntegral ttl))) + adhocSessionStoreInterpreter $ Store.insertCookie uid (toUnitCookie old') (Just (Store.TTL (fromIntegral ttl))) pure new -- | Whether a user has not renewed any of her cookies for longer than @@ -204,29 +205,29 @@ newAccessToken c mt = do -- | Lookup the stored cookie associated with a user token, -- if one exists. -lookupCookie :: (ZAuth.UserTokenLike u, MonadClient m) => ZAuth.Token u -> m (Maybe (Cookie (ZAuth.Token u))) +lookupCookie :: (ZAuth.UserTokenLike u, MonadClient m, MonadReader Env m) => ZAuth.Token u -> m (Maybe (Cookie (ZAuth.Token u))) lookupCookie t = do let user = ZAuth.userTokenOf t let rand = ZAuth.userTokenRand t let expi = ZAuth.tokenExpiresUTC t - fmap setToken <$> DB.lookupCookie user expi (CookieId rand) + adhocSessionStoreInterpreter $ fmap setToken <$> Store.lookupCookie user expi (CookieId rand) where setToken c = c {cookieValue = t} -listCookies :: MonadClient m => UserId -> [CookieLabel] -> m [Cookie ()] -listCookies u [] = DB.listCookies u -listCookies u ll = filter byLabel <$> DB.listCookies u +listCookies :: (MonadClient m, MonadReader Env m) => UserId -> [CookieLabel] -> m [Cookie ()] +listCookies u [] = adhocSessionStoreInterpreter $ Store.listCookies u +listCookies u ll = filter byLabel <$> adhocSessionStoreInterpreter (Store.listCookies u) where byLabel c = maybe False (`elem` ll) (cookieLabel c) -revokeAllCookies :: MonadClient m => UserId -> m () +revokeAllCookies :: (MonadClient m, MonadReader Env m) => UserId -> m () revokeAllCookies u = revokeCookies u [] [] -revokeCookies :: MonadClient m => UserId -> [CookieId] -> [CookieLabel] -> m () -revokeCookies u [] [] = DB.deleteAllCookies u +revokeCookies :: (MonadClient m, MonadReader Env m) => UserId -> [CookieId] -> [CookieLabel] -> m () +revokeCookies u [] [] = adhocSessionStoreInterpreter $ Store.deleteAllCookies u revokeCookies u ids labels = do - cc <- filter matching <$> DB.listCookies u - DB.deleteCookies u cc + cc <- filter matching <$> adhocSessionStoreInterpreter (Store.listCookies u) + adhocSessionStoreInterpreter $ Store.deleteCookies u cc where matching c = cookieId c `elem` ids @@ -247,7 +248,7 @@ newCookieLimited :: Maybe CookieLabel -> m (Either RetryAfter (Cookie (ZAuth.Token t))) newCookieLimited u c typ label = do - cs <- filter ((typ ==) . cookieType) <$> DB.listCookies u + cs <- filter ((typ ==) . cookieType) <$> adhocSessionStoreInterpreter (Store.listCookies u) now <- liftIO =<< view currentTime lim <- CookieLimit . setUserCookieLimit <$> view settings thr <- setUserCookieThrottle <$> view settings @@ -291,11 +292,20 @@ toWebCookie c = do -------------------------------------------------------------------------------- -- Tracking -trackSuperseded :: (MonadReader Env m, MonadIO m, Log.MonadLogger m) => UserId -> CookieId -> m () +trackSuperseded :: (MonadIO m, Log.MonadLogger m, Prom.MonadMonitor m) => UserId -> CookieId -> m () trackSuperseded u c = do - m <- view metrics - Metrics.counterIncr (Metrics.path "user.auth.cookie.superseded") m + Prom.incCounter cookieSupersededCounter Log.warn $ msg (val "Superseded cookie used") ~~ field "user" (toByteString u) ~~ field "cookie" (cookieIdNum c) + +{-# NOINLINE cookieSupersededCounter #-} +cookieSupersededCounter :: Prom.Counter +cookieSupersededCounter = + Prom.unsafeRegister $ + Prom.counter + Prom.Info + { Prom.metricName = "user.auth.cookie.superseded", + Prom.metricHelp = "Number of times user's cookie got superseded" + } diff --git a/services/brig/src/Brig/User/Auth/DB/Instances.hs b/services/brig/src/Brig/User/Auth/DB/Instances.hs deleted file mode 100644 index 5cd536e4fba..00000000000 --- a/services/brig/src/Brig/User/Auth/DB/Instances.hs +++ /dev/null @@ -1,53 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - --- 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 Brig.User.Auth.DB.Instances - ( - ) -where - -import Cassandra.CQL -import Data.Id () -import Data.Misc () -import Data.Range () -import Data.Text.Ascii () -import Imports -import Wire.API.User.Auth - -deriving instance Cql CookieLabel - -deriving instance Cql LoginCode - -instance Cql CookieId where - ctype = Tagged BigIntColumn - toCql = CqlBigInt . fromIntegral . cookieIdNum - - fromCql (CqlBigInt i) = pure (CookieId (fromIntegral i)) - fromCql _ = Left "fromCql: invalid cookie id" - -instance Cql CookieType where - ctype = Tagged IntColumn - - toCql SessionCookie = CqlInt 0 - toCql PersistentCookie = CqlInt 1 - - fromCql (CqlInt 0) = pure SessionCookie - fromCql (CqlInt 1) = pure PersistentCookie - fromCql _ = Left "fromCql: invalid cookie type" diff --git a/services/brig/src/Brig/User/EJPD.hs b/services/brig/src/Brig/User/EJPD.hs index e04538621c0..880fc7d4618 100644 --- a/services/brig/src/Brig/User/EJPD.hs +++ b/services/brig/src/Brig/User/EJPD.hs @@ -32,46 +32,50 @@ import Control.Lens (view, (^.)) import Data.Aeson qualified as A import Data.ByteString.Conversion import Data.Handle (Handle) -import Data.Id (UserId) +import Data.Qualified import Data.Set qualified as Set import Data.Text qualified as T import Imports hiding (head) import Network.HTTP.Types.Method -import Polysemy (Member) +import Polysemy import Servant.OpenApi.Internal.Orphans () -import Wire.API.Connection (Relation, RelationWithHistory (..), relationDropHistory) +import Wire.API.Connection import Wire.API.Push.Token qualified as PushTok -import Wire.API.Routes.Internal.Brig.EJPD (EJPDRequestBody (EJPDRequestBody), EJPDResponseBody (EJPDResponseBody), EJPDResponseItem (EJPDResponseItem)) +import Wire.API.Routes.Internal.Brig.EJPD import Wire.API.Team.Member qualified as Team import Wire.API.User import Wire.GalleyAPIAccess (GalleyAPIAccess) import Wire.GalleyAPIAccess qualified as GalleyAPIAccess import Wire.NotificationSubsystem import Wire.Rpc +import Wire.UserStore (UserStore) +-- FUTUREWORK(mangoiv): this uses 'UserStore' and should hence go to 'UserSubSystem' ejpdRequest :: forall r. ( Member GalleyAPIAccess r, Member NotificationSubsystem r, + Member UserStore r, Member Rpc r ) => Maybe Bool -> EJPDRequestBody -> (Handler r) EJPDResponseBody ejpdRequest (fromMaybe False -> includeContacts) (EJPDRequestBody handles) = do - ExceptT $ Right . EJPDResponseBody . catMaybes <$> forM handles go1 + ExceptT $ Right . EJPDResponseBody . catMaybes <$> forM handles responseItemForHandle where -- find uid given handle - go1 :: Handle -> (AppT r) (Maybe EJPDResponseItem) - go1 handle = do - mbUid <- wrapClient $ lookupHandle handle + responseItemForHandle :: Handle -> AppT r (Maybe EJPDResponseItemRoot) + responseItemForHandle hdl = do + mbUid <- liftSem $ lookupHandle hdl mbUsr <- maybe (pure Nothing) (wrapClient . lookupUser NoPendingInvitations) mbUid - maybe (pure Nothing) (fmap Just . go2 includeContacts) mbUsr + maybe (pure Nothing) (fmap Just . responseItemForExistingUser includeContacts) mbUsr -- construct response item given uid - go2 :: Bool -> User -> (AppT r) EJPDResponseItem - go2 reallyIncludeContacts target = do + responseItemForExistingUser :: Bool -> User -> (AppT r) EJPDResponseItemRoot + responseItemForExistingUser reallyIncludeContacts target = do let uid = userId target + luid <- qualifyLocal uid ptoks <- PushTok.tokenText . view PushTok.token <$$> liftSem (getPushTokens uid) @@ -79,15 +83,17 @@ ejpdRequest (fromMaybe False -> includeContacts) (EJPDRequestBody handles) = do mbContacts <- if reallyIncludeContacts then do - contacts :: [(UserId, RelationWithHistory)] <- - wrapClient $ Conn.lookupContactListWithRelation uid + contacts <- + wrapClient $ -- FUTUREWORK: use polysemy effect, not wrapClient + Conn.lookupContactListWithRelation uid - contactsFull :: [Maybe (Relation, EJPDResponseItem)] <- - forM contacts $ \(uid', relationDropHistory -> rel) -> do - mbUsr <- wrapClient $ lookupUser NoPendingInvitations uid' - maybe (pure Nothing) (fmap (Just . (rel,)) . go2 False) mbUsr + localContacts <- + catMaybes <$> do + forM contacts $ \(uid', relationDropHistory -> rel) -> do + mbUsr <- wrapClient $ lookupUser NoPendingInvitations uid' -- FUTUREWORK: use polysemy effect, not wrapClient + maybe (pure Nothing) (fmap (Just . EJPDContactFound rel . toEJPDResponseItemLeaf) . responseItemForExistingUser False) mbUsr - pure . Just . Set.fromList . catMaybes $ contactsFull + pure . Just . Set.fromList $ localContacts else do pure Nothing @@ -97,18 +103,24 @@ ejpdRequest (fromMaybe False -> includeContacts) (EJPDRequestBody handles) = do memberList <- liftSem $ GalleyAPIAccess.getTeamMembers tid let members = (view Team.userId <$> (memberList ^. Team.teamMembers)) \\ [uid] - contactsFull :: [Maybe EJPDResponseItem] <- + contactsFull <- forM members $ \uid' -> do mbUsr <- wrapClient $ lookupUser NoPendingInvitations uid' - maybe (pure Nothing) (fmap Just . go2 False) mbUsr + maybe (pure Nothing) (fmap Just . responseItemForExistingUser False) mbUsr + + let listType = Team.toNewListType (memberList ^. Team.teamMemberListType) - pure . Just . (,Team.toNewListType (memberList ^. Team.teamMemberListType)) . Set.fromList . catMaybes $ contactsFull + pure . Just $ + EJPDTeamContacts + (Set.fromList $ toEJPDResponseItemLeaf <$> catMaybes contactsFull) + listType _ -> do pure Nothing - mbConversations <- do - -- FUTUREWORK(fisx) - pure Nothing + mbConversations <- + if reallyIncludeContacts + then liftSem $ Just . Set.fromList <$> GalleyAPIAccess.getEJPDConvInfo uid + else pure Nothing mbAssets <- do urls <- forM (userAssets target) $ \(asset :: Asset) -> do @@ -129,15 +141,16 @@ ejpdRequest (fromMaybe False -> includeContacts) (EJPDRequestBody handles) = do something -> Just (Set.fromList something) pure $ - EJPDResponseItem - uid - (userTeam target) - (userDisplayName target) - (userHandle target) - (userEmail target) - (userPhone target) - (Set.fromList ptoks) - mbContacts - mbTeamContacts - mbConversations - mbAssets + EJPDResponseItemRoot + { ejpdResponseRootUserId = tUntagged luid, + ejpdResponseRootTeamId = userTeam target, + ejpdResponseRootName = userDisplayName target, + ejpdResponseRootHandle = userHandle target, + ejpdResponseRootEmail = userEmail target, + ejpdResponseRootPhone = Nothing, + ejpdResponseRootPushTokens = Set.fromList ptoks, + ejpdResponseRootContacts = mbContacts, + ejpdResponseRootTeamContacts = mbTeamContacts, + ejpdResponseRootConversations = mbConversations, + ejpdResponseRootAssets = mbAssets + } diff --git a/services/brig/src/Brig/User/Email.hs b/services/brig/src/Brig/User/Email.hs deleted file mode 100644 index 0a4a0a92c11..00000000000 --- a/services/brig/src/Brig/User/Email.hs +++ /dev/null @@ -1,438 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} - --- 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 Brig.User.Email - ( sendActivationMail, - sendVerificationMail, - sendTeamActivationMail, - sendPasswordResetMail, - sendDeletionEmail, - sendNewClientEmail, - sendLoginVerificationMail, - sendCreateScimTokenVerificationMail, - sendTeamDeletionVerificationMail, - - -- * Re-exports - validateEmail, - ) -where - -import Brig.App -import Brig.Email -import Brig.Email qualified as Email -import Brig.Locale (formatDateTime, timeLocale) -import Brig.Template -import Brig.Types.Activation (ActivationPair) -import Brig.User.Template -import Control.Lens (view) -import Data.Code qualified as Code -import Data.Json.Util (fromUTCTimeMillis) -import Data.Range -import Data.Text.Ascii qualified as Ascii -import Data.Text.Lazy (toStrict) -import Imports -import Wire.API.User -import Wire.API.User.Activation -import Wire.API.User.Client -import Wire.API.User.Password - -sendVerificationMail :: - ( MonadIO m, - MonadReader Env m - ) => - Email -> - ActivationPair -> - Maybe Locale -> - m () -sendVerificationMail to pair loc = do - tpl <- verificationEmail . snd <$> userTemplates loc - branding <- view templateBranding - let mail = VerificationEmail to pair - Email.sendMail $ renderVerificationMail mail tpl branding - -sendLoginVerificationMail :: - ( MonadReader Env m, - MonadIO m - ) => - Email -> - Code.Value -> - Maybe Locale -> - m () -sendLoginVerificationMail email code mbLocale = do - tpl <- verificationLoginEmail . snd <$> userTemplates mbLocale - branding <- view templateBranding - Email.sendMail $ renderSecondFactorVerificationEmail tpl email code branding - -sendCreateScimTokenVerificationMail :: - ( MonadIO m, - MonadReader Env m - ) => - Email -> - Code.Value -> - Maybe Locale -> - m () -sendCreateScimTokenVerificationMail email code mbLocale = do - tpl <- verificationScimTokenEmail . snd <$> userTemplates mbLocale - branding <- view templateBranding - Email.sendMail $ renderSecondFactorVerificationEmail tpl email code branding - -sendTeamDeletionVerificationMail :: - ( MonadIO m, - MonadReader Env m - ) => - Email -> - Code.Value -> - Maybe Locale -> - m () -sendTeamDeletionVerificationMail email code mbLocale = do - tpl <- verificationTeamDeletionEmail . snd <$> userTemplates mbLocale - branding <- view templateBranding - Email.sendMail $ renderSecondFactorVerificationEmail tpl email code branding - -sendActivationMail :: - ( MonadIO m, - MonadReader Env m - ) => - Email -> - Name -> - ActivationPair -> - Maybe Locale -> - Maybe UserIdentity -> - m () -sendActivationMail to name pair loc ident = do - tpl <- selectTemplate . snd <$> userTemplates loc - branding <- view templateBranding - let mail = ActivationEmail to name pair - Email.sendMail $ renderActivationMail mail tpl branding - where - selectTemplate = - if isNothing ident - then activationEmail - else activationEmailUpdate - -sendPasswordResetMail :: - ( MonadIO m, - MonadReader Env m - ) => - Email -> - PasswordResetPair -> - Maybe Locale -> - m () -sendPasswordResetMail to pair loc = do - tpl <- passwordResetEmail . snd <$> userTemplates loc - branding <- view templateBranding - let mail = PasswordResetEmail to pair - Email.sendMail $ renderPwResetMail mail tpl branding - -sendDeletionEmail :: - ( MonadIO m, - MonadReader Env m - ) => - Name -> - Email -> - Code.Key -> - Code.Value -> - Locale -> - m () -sendDeletionEmail name email key code locale = do - tpl <- deletionEmail . snd <$> userTemplates (Just locale) - branding <- view templateBranding - Email.sendMail $ renderDeletionEmail tpl (DeletionEmail email name key code) branding - -sendNewClientEmail :: - ( MonadIO m, - MonadReader Env m - ) => - Name -> - Email -> - Client -> - Locale -> - m () -sendNewClientEmail name email client locale = do - tpl <- newClientEmail . snd <$> userTemplates (Just locale) - branding <- view templateBranding - Email.sendMail $ renderNewClientEmail tpl (NewClientEmail locale email name client) branding - -sendTeamActivationMail :: - ( MonadIO m, - MonadReader Env m - ) => - Email -> - Name -> - ActivationPair -> - Maybe Locale -> - Text -> - m () -sendTeamActivationMail to name pair loc team = do - tpl <- teamActivationEmail . snd <$> userTemplates loc - let mail = TeamActivationEmail to name team pair - branding <- view templateBranding - Email.sendMail $ renderTeamActivationMail mail tpl branding - -------------------------------------------------------------------------------- --- New Client Email - -data NewClientEmail = NewClientEmail - { nclLocale :: !Locale, - nclTo :: !Email, - nclName :: !Name, - nclClient :: !Client - } - -renderNewClientEmail :: NewClientEmailTemplate -> NewClientEmail -> TemplateBranding -> Mail -renderNewClientEmail NewClientEmailTemplate {..} NewClientEmail {..} branding = - (emptyMail from) - { mailTo = [to], - mailHeaders = - [ ("Subject", toStrict subj), - ("X-Zeta-Purpose", "NewDevice") - ], - mailParts = [[plainPart txt, htmlPart html]] - } - where - from = Address (Just newClientEmailSenderName) (fromEmail newClientEmailSender) - to = mkMimeAddress nclName nclTo - txt = renderTextWithBranding newClientEmailBodyText replace branding - html = renderHtmlWithBranding newClientEmailBodyHtml replace branding - subj = renderTextWithBranding newClientEmailSubject replace branding - replace "name" = fromName nclName - replace "label" = fromMaybe "N/A" (clientLabel nclClient) - replace "model" = fromMaybe "N/A" (clientModel nclClient) - replace "date" = - formatDateTime - "%A %e %B %Y, %H:%M - %Z" - (timeLocale nclLocale) - (fromUTCTimeMillis $ clientTime nclClient) - replace x = x - -------------------------------------------------------------------------------- --- Deletion Email - -data DeletionEmail = DeletionEmail - { delTo :: !Email, - delName :: !Name, - delKey :: !Code.Key, - delCode :: !Code.Value - } - -renderDeletionEmail :: DeletionEmailTemplate -> DeletionEmail -> TemplateBranding -> Mail -renderDeletionEmail DeletionEmailTemplate {..} DeletionEmail {..} branding = - (emptyMail from) - { mailTo = [to], - mailHeaders = - [ ("Subject", toStrict subj), - ("X-Zeta-Purpose", "Delete"), - ("X-Zeta-Key", key), - ("X-Zeta-Code", code) - ], - mailParts = [[plainPart txt, htmlPart html]] - } - where - from = Address (Just deletionEmailSenderName) (fromEmail deletionEmailSender) - to = mkMimeAddress delName delTo - txt = renderTextWithBranding deletionEmailBodyText replace1 branding - html = renderHtmlWithBranding deletionEmailBodyHtml replace1 branding - subj = renderTextWithBranding deletionEmailSubject replace1 branding - key = Ascii.toText (fromRange (Code.asciiKey delKey)) - code = Ascii.toText (fromRange (Code.asciiValue delCode)) - replace1 "url" = toStrict (renderTextWithBranding deletionEmailUrl replace2 branding) - replace1 "email" = fromEmail delTo - replace1 "name" = fromName delName - replace1 x = x - replace2 "key" = key - replace2 "code" = code - replace2 x = x - -------------------------------------------------------------------------------- --- Verification Email - -data VerificationEmail = VerificationEmail - { vfTo :: !Email, - vfPair :: !ActivationPair - } - -renderVerificationMail :: VerificationEmail -> VerificationEmailTemplate -> TemplateBranding -> Mail -renderVerificationMail VerificationEmail {..} VerificationEmailTemplate {..} branding = - (emptyMail from) - { mailTo = [to], - -- To make automated processing possible, the activation code is also added to - -- headers. {#RefActivationEmailHeaders} - mailHeaders = - [ ("Subject", toStrict subj), - ("X-Zeta-Purpose", "Verification"), - ("X-Zeta-Code", Ascii.toText code) - ], - mailParts = [[plainPart txt, htmlPart html]] - } - where - (ActivationKey _, ActivationCode code) = vfPair - from = Address (Just verificationEmailSenderName) (fromEmail verificationEmailSender) - to = Address Nothing (fromEmail vfTo) - txt = renderTextWithBranding verificationEmailBodyText replace branding - html = renderHtmlWithBranding verificationEmailBodyHtml replace branding - subj = renderTextWithBranding verificationEmailSubject replace branding - replace "code" = Ascii.toText code - replace "email" = fromEmail vfTo - replace x = x - -------------------------------------------------------------------------------- --- Activation Email - -data ActivationEmail = ActivationEmail - { acmTo :: !Email, - acmName :: !Name, - acmPair :: !ActivationPair - } - -renderActivationMail :: ActivationEmail -> ActivationEmailTemplate -> TemplateBranding -> Mail -renderActivationMail ActivationEmail {..} ActivationEmailTemplate {..} branding = - (emptyMail from) - { mailTo = [to], - -- To make automated processing possible, the activation code is also added to - -- headers. {#RefActivationEmailHeaders} - mailHeaders = - [ ("Subject", toStrict subj), - ("X-Zeta-Purpose", "Activation"), - ("X-Zeta-Key", Ascii.toText key), - ("X-Zeta-Code", Ascii.toText code) - ], - mailParts = [[plainPart txt, htmlPart html]] - } - where - (ActivationKey key, ActivationCode code) = acmPair - from = Address (Just activationEmailSenderName) (fromEmail activationEmailSender) - to = mkMimeAddress acmName acmTo - txt = renderTextWithBranding activationEmailBodyText replace branding - html = renderHtmlWithBranding activationEmailBodyHtml replace branding - subj = renderTextWithBranding activationEmailSubject replace branding - replace "url" = renderActivationUrl activationEmailUrl acmPair branding - replace "email" = fromEmail acmTo - replace "name" = fromName acmName - replace x = x - -renderActivationUrl :: Template -> ActivationPair -> TemplateBranding -> Text -renderActivationUrl t (ActivationKey k, ActivationCode c) branding = - toStrict $ renderTextWithBranding t replace branding - where - replace "key" = Ascii.toText k - replace "code" = Ascii.toText c - replace x = x - -------------------------------------------------------------------------------- --- Team Activation Email - -data TeamActivationEmail = TeamActivationEmail - { tacmTo :: !Email, - tacmName :: !Name, - tacmTeamName :: !Text, - tacmPair :: !ActivationPair - } - -renderTeamActivationMail :: TeamActivationEmail -> TeamActivationEmailTemplate -> TemplateBranding -> Mail -renderTeamActivationMail TeamActivationEmail {..} TeamActivationEmailTemplate {..} branding = - (emptyMail from) - { mailTo = [to], - mailHeaders = - [ ("Subject", toStrict subj), - ("X-Zeta-Purpose", "Activation"), - ("X-Zeta-Key", Ascii.toText key), - ("X-Zeta-Code", Ascii.toText code) - ], - mailParts = [[plainPart txt, htmlPart html]] - } - where - (ActivationKey key, ActivationCode code) = tacmPair - from = Address (Just teamActivationEmailSenderName) (fromEmail teamActivationEmailSender) - to = mkMimeAddress tacmName tacmTo - txt = renderTextWithBranding teamActivationEmailBodyText replace branding - html = renderHtmlWithBranding teamActivationEmailBodyHtml replace branding - subj = renderTextWithBranding teamActivationEmailSubject replace branding - replace "url" = renderActivationUrl teamActivationEmailUrl tacmPair branding - replace "email" = fromEmail tacmTo - replace "name" = fromName tacmName - replace "team" = tacmTeamName - replace x = x - -------------------------------------------------------------------------------- --- Password Reset Email - -data PasswordResetEmail = PasswordResetEmail - { pwrTo :: !Email, - pwrPair :: !PasswordResetPair - } - -renderPwResetMail :: PasswordResetEmail -> PasswordResetEmailTemplate -> TemplateBranding -> Mail -renderPwResetMail PasswordResetEmail {..} PasswordResetEmailTemplate {..} branding = - (emptyMail from) - { mailTo = [to], - mailHeaders = - [ ("Subject", toStrict subj), - ("X-Zeta-Purpose", "PasswordReset"), - ("X-Zeta-Key", Ascii.toText key), - ("X-Zeta-Code", Ascii.toText code) - ], - mailParts = [[plainPart txt, htmlPart html]] - } - where - (PasswordResetKey key, PasswordResetCode code) = pwrPair - from = Address (Just passwordResetEmailSenderName) (fromEmail passwordResetEmailSender) - to = Address Nothing (fromEmail pwrTo) - txt = renderTextWithBranding passwordResetEmailBodyText replace branding - html = renderHtmlWithBranding passwordResetEmailBodyHtml replace branding - subj = renderTextWithBranding passwordResetEmailSubject replace branding - replace "url" = renderPwResetUrl passwordResetEmailUrl pwrPair branding - replace x = x - -renderPwResetUrl :: Template -> PasswordResetPair -> TemplateBranding -> Text -renderPwResetUrl t (PasswordResetKey k, PasswordResetCode c) branding = - toStrict $ renderTextWithBranding t replace branding - where - replace "key" = Ascii.toText k - replace "code" = Ascii.toText c - replace x = x - -------------------------------------------------------------------------------- --- Second Factor Verification Code Email - -renderSecondFactorVerificationEmail :: - SecondFactorVerificationEmailTemplate -> - Email -> - Code.Value -> - TemplateBranding -> - Mail -renderSecondFactorVerificationEmail SecondFactorVerificationEmailTemplate {..} email codeValue branding = - (emptyMail from) - { mailTo = [to], - mailHeaders = - [ ("Subject", toStrict subj), - ("X-Zeta-Purpose", "SecondFactorVerification"), - ("X-Zeta-Code", code) - ], - mailParts = [[plainPart txt, htmlPart html]] - } - where - from = Address (Just sndFactorVerificationEmailSenderName) (fromEmail sndFactorVerificationEmailSender) - to = Address Nothing (fromEmail email) - txt = renderTextWithBranding sndFactorVerificationEmailBodyText replace branding - html = renderHtmlWithBranding sndFactorVerificationEmailBodyHtml replace branding - subj = renderTextWithBranding sndFactorVerificationEmailSubject replace branding - code = Ascii.toText (fromRange (Code.asciiValue codeValue)) - replace "email" = fromEmail email - replace "code" = code - replace x = x diff --git a/services/brig/src/Brig/User/Handle.hs b/services/brig/src/Brig/User/Handle.hs deleted file mode 100644 index fd62c770c3c..00000000000 --- a/services/brig/src/Brig/User/Handle.hs +++ /dev/null @@ -1,100 +0,0 @@ --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - --- | Ownership of unique user handles. -module Brig.User.Handle - ( claimHandle, - freeHandle, - lookupHandle, - glimpseHandle, - ) -where - -import Brig.App -import Brig.CanonicalInterpreter (runBrigToIO) -import Brig.Data.User qualified as User -import Brig.Unique -import Cassandra -import Data.Handle (Handle, fromHandle) -import Data.Id -import Imports - --- | Claim a new handle for an existing 'User'. -claimHandle :: (MonadClient m, MonadReader Env m) => UserId -> Maybe Handle -> Handle -> m Bool -claimHandle uid oldHandle newHandle = - isJust <$> do - owner <- lookupHandle newHandle - case owner of - Just uid' | uid /= uid' -> pure Nothing - _ -> do - env <- ask - let key = "@" <> fromHandle newHandle - withClaim uid key (30 # Minute) $ - runBrigToIO env $ - do - -- Record ownership - wrapClient $ retry x5 $ write handleInsert (params LocalQuorum (newHandle, uid)) - -- Update profile - result <- wrapClient $ User.updateHandle uid newHandle - -- Free old handle (if it changed) - for_ (mfilter (/= newHandle) oldHandle) $ - wrapClient . freeHandle uid - pure result - --- | Free a 'Handle', making it available to be claimed again. -freeHandle :: MonadClient m => UserId -> Handle -> m () -freeHandle uid h = do - mbHandleUid <- lookupHandle h - case mbHandleUid of - Just handleUid | handleUid == uid -> do - retry x5 $ write handleDelete (params LocalQuorum (Identity h)) - let key = "@" <> fromHandle h - deleteClaim uid key (30 # Minute) - _ -> pure () -- this shouldn't happen, the call side should always check that `h` and `uid` belong to the same account. - --- | Lookup the current owner of a 'Handle'. -lookupHandle :: MonadClient m => Handle -> m (Maybe UserId) -lookupHandle = lookupHandleWithPolicy LocalQuorum - --- | A weaker version of 'lookupHandle' that trades availability --- (and potentially speed) for the possibility of returning stale data. -glimpseHandle :: MonadClient m => Handle -> m (Maybe UserId) -glimpseHandle = lookupHandleWithPolicy One - -{-# INLINE lookupHandleWithPolicy #-} - --- | Sending an empty 'Handle' here causes C* to throw "Key may not be empty" --- error. --- --- FUTUREWORK: This should ideally be tackled by hiding constructor for 'Handle' --- and only allowing it to be parsed. -lookupHandleWithPolicy :: MonadClient m => Consistency -> Handle -> m (Maybe UserId) -lookupHandleWithPolicy policy h = do - (runIdentity =<<) - <$> retry x1 (query1 handleSelect (params policy (Identity h))) - --------------------------------------------------------------------------------- --- Queries - -handleInsert :: PrepQuery W (Handle, UserId) () -handleInsert = "INSERT INTO user_handle (handle, user) VALUES (?, ?)" - -handleSelect :: PrepQuery R (Identity Handle) (Identity (Maybe UserId)) -handleSelect = "SELECT user FROM user_handle WHERE handle = ?" - -handleDelete :: PrepQuery W (Identity Handle) () -handleDelete = "DELETE FROM user_handle WHERE handle = ?" diff --git a/services/brig/src/Brig/User/Handle/Blacklist.hs b/services/brig/src/Brig/User/Handle/Blacklist.hs deleted file mode 100644 index 2f51a8cfa01..00000000000 --- a/services/brig/src/Brig/User/Handle/Blacklist.hs +++ /dev/null @@ -1,71 +0,0 @@ --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module Brig.User.Handle.Blacklist - ( isBlacklistedHandle, - ) -where - -import Data.Handle (Handle (Handle)) -import Data.HashSet qualified as HashSet -import Imports - --- | A blacklisted handle cannot be chosen by a (regular) user. -isBlacklistedHandle :: Handle -> Bool -isBlacklistedHandle = (`HashSet.member` blacklist) - -blacklist :: HashSet Handle -blacklist = - HashSet.fromList $ - map - Handle - [ "account", - "admin", - "administrator", - "all", - "android", - "anna", - "avs", - "backend", - "bot", - "cs", - "design", - "dev", - "developer", - "development", - "everyone", - "help", - "helpdesk", - "hr", - "info", - "ios", - "legal", - "management", - "news", - "otto", - "payment", - "product", - "purchase", - "qa", - "support", - "team", - "user", - "web", - "wire", - "wirebot", - "wireteam" - ] diff --git a/services/brig/src/Brig/User/Phone.hs b/services/brig/src/Brig/User/Phone.hs deleted file mode 100644 index f12541ae0aa..00000000000 --- a/services/brig/src/Brig/User/Phone.hs +++ /dev/null @@ -1,270 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} - --- 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 Brig.User.Phone - ( ActivationSms (..), - sendActivationSms, - PasswordResetSms (..), - sendPasswordResetSms, - LoginSms (..), - sendLoginSms, - ActivationCall (..), - sendActivationCall, - LoginCall (..), - sendLoginCall, - DeletionSms (..), - sendDeletionSms, - - -- * Re-exports - validatePhone, - ) -where - -import Brig.App -import Brig.Phone -import Brig.Template -import Brig.Types.Activation -import Brig.Types.User -import Brig.User.Template -import Cassandra (MonadClient) -import Control.Lens (view) -import Control.Monad.Catch -import Data.Code qualified as Code -import Data.Range -import Data.Text qualified as Text -import Data.Text.Ascii qualified as Ascii -import Data.Text.Lazy (toStrict) -import Imports -import Ropes.Nexmo qualified as Nexmo -import System.Logger.Class qualified as Log -import Wire.API.User -import Wire.API.User.Activation -import Wire.API.User.Auth -import Wire.API.User.Password - -sendActivationSms :: - ( MonadClient m, - MonadReader Env m, - MonadCatch m, - Log.MonadLogger m - ) => - Phone -> - ActivationPair -> - Maybe Locale -> - m () -sendActivationSms to (_, c) loc = do - branding <- view templateBranding - (loc', tpl) <- userTemplates loc - sendSms loc' $ renderActivationSms (ActivationSms to c) (activationSms tpl) branding - -sendPasswordResetSms :: - ( MonadClient m, - MonadReader Env m, - MonadCatch m, - Log.MonadLogger m - ) => - Phone -> - PasswordResetPair -> - Maybe Locale -> - m () -sendPasswordResetSms to (_, c) loc = do - branding <- view templateBranding - (loc', tpl) <- userTemplates loc - sendSms loc' $ renderPasswordResetSms (PasswordResetSms to c) (passwordResetSms tpl) branding - -sendLoginSms :: - ( MonadClient m, - MonadReader Env m, - MonadCatch m, - Log.MonadLogger m - ) => - Phone -> - LoginCode -> - Maybe Locale -> - m () -sendLoginSms to code loc = do - branding <- view templateBranding - (loc', tpl) <- userTemplates loc - sendSms loc' $ renderLoginSms (LoginSms to code) (loginSms tpl) branding - -sendDeletionSms :: - ( MonadClient m, - MonadReader Env m, - MonadCatch m, - Log.MonadLogger m - ) => - Phone -> - Code.Key -> - Code.Value -> - Locale -> - m () -sendDeletionSms to key code loc = do - branding <- view templateBranding - (loc', tpl) <- userTemplates (Just loc) - sendSms loc' $ renderDeletionSms (DeletionSms to key code) (deletionSms tpl) branding - -sendActivationCall :: - ( MonadClient m, - MonadReader Env m, - Log.MonadLogger m - ) => - Phone -> - ActivationPair -> - Maybe Locale -> - m () -sendActivationCall to (_, c) loc = do - branding <- view templateBranding - (loc', tpl) <- userTemplates loc - sendCall $ renderActivationCall (ActivationCall to c) (activationCall tpl) loc' branding - -sendLoginCall :: - ( MonadClient m, - MonadReader Env m, - Log.MonadLogger m - ) => - Phone -> - LoginCode -> - Maybe Locale -> - m () -sendLoginCall to c loc = do - branding <- view templateBranding - (loc', tpl) <- userTemplates loc - sendCall $ renderLoginCall (LoginCall to c) (loginCall tpl) loc' branding - -------------------------------------------------------------------------------- --- Activation SMS - -data ActivationSms = ActivationSms - { actSmsTo :: !Phone, - actSmsCode :: !ActivationCode - } - -renderActivationSms :: ActivationSms -> ActivationSmsTemplate -> TemplateBranding -> SMSMessage -renderActivationSms ActivationSms {..} (ActivationSmsTemplate url t from) branding = - SMSMessage from (fromPhone actSmsTo) (toStrict $ renderTextWithBranding t replace branding) - where - replace "code" = codeText - replace "url" = renderSmsActivationUrl url codeText - replace x = x - codeText = Ascii.toText (fromActivationCode actSmsCode) - -------------------------------------------------------------------------------- --- Password Reset SMS - -data PasswordResetSms = PasswordResetSms - { pwrSmsTo :: !Phone, - pwrSmsCode :: !PasswordResetCode - } - -renderPasswordResetSms :: PasswordResetSms -> PasswordResetSmsTemplate -> TemplateBranding -> SMSMessage -renderPasswordResetSms PasswordResetSms {..} (PasswordResetSmsTemplate t from) branding = - SMSMessage from (fromPhone pwrSmsTo) (toStrict $ renderTextWithBranding t replace branding) - where - replace "code" = Ascii.toText (fromPasswordResetCode pwrSmsCode) - replace x = x - -------------------------------------------------------------------------------- --- Login SMS - -data LoginSms = LoginSms - { loginSmsTo :: !Phone, - loginSmsCode :: !LoginCode - } - -renderLoginSms :: LoginSms -> LoginSmsTemplate -> TemplateBranding -> SMSMessage -renderLoginSms LoginSms {..} (LoginSmsTemplate url t from) branding = - SMSMessage from (fromPhone loginSmsTo) (toStrict $ renderTextWithBranding t replace branding) - where - replace "code" = fromLoginCode loginSmsCode - replace "url" = renderSmsActivationUrl url (fromLoginCode loginSmsCode) - replace x = x - -------------------------------------------------------------------------------- --- Deletion SMS - -data DeletionSms = DeletionSms - { delSmsTo :: !Phone, - delSmsKey :: !Code.Key, - delSmsCode :: !Code.Value - } - -renderDeletionSms :: DeletionSms -> DeletionSmsTemplate -> TemplateBranding -> SMSMessage -renderDeletionSms DeletionSms {..} (DeletionSmsTemplate url txt from) branding = - SMSMessage from (fromPhone delSmsTo) (toStrict $ renderTextWithBranding txt replace1 branding) - where - replace1 "code" = Ascii.toText (fromRange (Code.asciiValue delSmsCode)) - replace1 "url" = toStrict (renderText url replace2) - replace1 x = x - replace2 "key" = Ascii.toText (fromRange (Code.asciiKey delSmsKey)) - replace2 "code" = Ascii.toText (fromRange (Code.asciiValue delSmsCode)) - replace2 x = x - -------------------------------------------------------------------------------- --- Activation Call - -data ActivationCall = ActivationCall - { actCallTo :: !Phone, - actCallCode :: !ActivationCode - } - -renderActivationCall :: ActivationCall -> ActivationCallTemplate -> Locale -> TemplateBranding -> Nexmo.Call -renderActivationCall ActivationCall {..} (ActivationCallTemplate t) loc branding = - Nexmo.Call - Nothing - (fromPhone actCallTo) - (toStrict $ renderTextWithBranding t replace branding) - (Just . Text.toLower $ locToText loc) - (Just 1) - where - replace "code" = toPinPrompt $ Ascii.toText (fromActivationCode actCallCode) - replace x = x - -------------------------------------------------------------------------------- --- Login Call - -data LoginCall = LoginCall - { loginCallTo :: !Phone, - loginCallCode :: !LoginCode - } - -renderLoginCall :: LoginCall -> LoginCallTemplate -> Locale -> TemplateBranding -> Nexmo.Call -renderLoginCall LoginCall {..} (LoginCallTemplate t) loc branding = - Nexmo.Call - Nothing - (fromPhone loginCallTo) - (toStrict $ renderTextWithBranding t replace branding) - (Just . Text.toLower $ locToText loc) - (Just 1) - where - replace "code" = toPinPrompt $ fromLoginCode loginCallCode - replace x = x - --- Common Prompt rendering - -toPinPrompt :: Text -> Text -toPinPrompt = Text.intercalate "" . Text.chunksOf 1 - --- Common URL rendering - -renderSmsActivationUrl :: Template -> Text -> Text -renderSmsActivationUrl t c = - toStrict $ renderText t replace - where - replace "code" = c - replace x = x diff --git a/services/brig/src/Brig/User/Search/Index.hs b/services/brig/src/Brig/User/Search/Index.hs index 9df5255ce84..24be42ce4ed 100644 --- a/services/brig/src/Brig/User/Search/Index.hs +++ b/services/brig/src/Brig/User/Search/Index.hs @@ -78,19 +78,19 @@ import Data.Credentials import Data.Handle (Handle) import Data.Id import Data.Map qualified as Map -import Data.Metrics import Data.Text qualified as T import Data.Text qualified as Text import Data.Text.Encoding import Data.Text.Encoding.Error import Data.Text.Lazy qualified as LT -import Data.Text.Lazy.Builder.Int (decimal) import Data.Text.Lens hiding (text) import Data.UUID qualified as UUID import Database.Bloodhound qualified as ES import Imports hiding (log, searchable) import Network.HTTP.Client hiding (host, path, port) import Network.HTTP.Types (StdMethod (POST), hContentType, statusCode) +import Prometheus (MonadMonitor) +import Prometheus qualified as Prom import SAML2.WebSSO.Types qualified as SAML import System.Logger qualified as Log import System.Logger.Class (Logger, MonadLogger (..), field, info, msg, val, (+++), (~~)) @@ -106,8 +106,7 @@ import Wire.API.User.Search (Sso (..)) -- IndexIO Monad data IndexEnv = IndexEnv - { idxMetrics :: Metrics, - idxLogger :: Logger, + { idxLogger :: Logger, idxElastic :: ES.BHEnv, idxRequest :: Maybe RequestId, idxName :: ES.IndexName, @@ -129,13 +128,14 @@ newtype IndexIO a = IndexIO (ReaderT IndexEnv IO a) MonadReader IndexEnv, MonadThrow, MonadCatch, - MonadMask + MonadMask, + MonadMonitor ) -runIndexIO :: MonadIO m => IndexEnv -> IndexIO a -> m a +runIndexIO :: (MonadIO m) => IndexEnv -> IndexIO a -> m a runIndexIO e (IndexIO m) = liftIO $ runReaderT m e -class MonadIO m => MonadIndexIO m where +class (MonadIO m) => MonadIndexIO m where liftIndexIO :: IndexIO a -> m a instance MonadIndexIO IndexIO where @@ -178,10 +178,9 @@ reindex u = do ixu <- lookupIndexUser u updateIndex (maybe (IndexDeleteUser u) (IndexUpdateUser IndexUpdateIfNewerVersion) ixu) -updateIndex :: MonadIndexIO m => IndexUpdate -> m () +updateIndex :: (MonadIndexIO m) => IndexUpdate -> m () updateIndex (IndexUpdateUser updateType iu) = liftIndexIO $ do - m <- asks idxMetrics - counterIncr (path "user.index.update.count") m + Prom.incCounter indexUpdateCounter info $ field "user" (Bytes.toByteString (view iuUserId iu)) . msg (val "Indexing user") @@ -191,20 +190,18 @@ updateIndex (IndexUpdateUser updateType iu) = liftIndexIO $ do where indexDoc :: (MonadIndexIO m, MonadThrow m) => ES.IndexName -> ES.BH m () indexDoc idx = do - m <- lift . liftIndexIO $ asks idxMetrics r <- ES.indexDocument idx mappingName versioning (indexToDoc iu) docId unless (ES.isSuccess r || ES.isVersionConflict r) $ do - counterIncr (path "user.index.update.err") m + liftIO $ Prom.incCounter indexUpdateErrorCounter ES.parseEsResponse r >>= throwM . IndexUpdateError . either id id - counterIncr (path "user.index.update.ok") m + liftIO $ Prom.incCounter indexUpdateSuccessCounter versioning = ES.defaultIndexDocumentSettings { ES.idsVersionControl = indexUpdateToVersionControl updateType (ES.ExternalDocVersion (docVersion (_iuVersion iu))) } docId = ES.DocId (view (iuUserId . re _TextId) iu) updateIndex (IndexUpdateUsers updateType ius) = liftIndexIO $ do - m <- asks idxMetrics - counterIncr (path "user.index.update.bulk.count") m + Prom.incCounter indexBulkUpdateCounter info $ field "num_users" (length ius) . msg (val "Bulk indexing users") @@ -226,20 +223,17 @@ updateIndex (IndexUpdateUsers updateType ius) = liftIndexIO $ do } (ES.bhManager bhe) unless (ES.isSuccess res) $ do - counterIncr (path "user.index.update.bulk.err") m + Prom.incCounter indexBulkUpdateErrorCounter ES.parseEsResponse res >>= throwM . IndexUpdateError . either id id - counterIncr (path "user.index.update.bulk.ok") m + Prom.incCounter indexBulkUpdateSuccessCounter for_ (statuses res) $ \(s, f) -> - counterAdd - (fromIntegral f) - (path ("user.index.update.bulk.status." <> review builder (decimal s))) - m + Prom.withLabel indexBulkUpdateResponseCounter (Text.pack $ show s) $ (void . flip Prom.addCounter (fromIntegral f)) where mkAuthHeaders = do creds <- asks idxCredentials pure $ maybe [] ((: []) . mkBasicAuthHeader) creds - encodeJSONToString :: ToJSON a => a -> Builder + encodeJSONToString :: (ToJSON a) => a -> Builder encodeJSONToString = fromEncoding . toEncoding bulkEncode iu = bulkMeta (view (iuUserId . re _TextId) iu) (docVersion (_iuVersion iu)) @@ -261,7 +255,7 @@ updateIndex (IndexUpdateUsers updateType ius) = liftIndexIO $ do . toListOf (key "items" . values . key "index" . key "status" . _Integral) . responseBody updateIndex (IndexDeleteUser u) = liftIndexIO $ do - counterIncr (path "user.index.delete.count") =<< asks idxMetrics + Prom.incCounter indexDeleteCounter info $ field "user" (Bytes.toByteString u) . msg (val "(Soft) deleting user from index") @@ -302,25 +296,25 @@ updateSearchVisibilityInbound status = liftIndexIO $ do -------------------------------------------------------------------------------- -- Administrative -refreshIndex :: MonadIndexIO m => m () +refreshIndex :: (MonadIndexIO m) => m () refreshIndex = liftIndexIO $ do idx <- asks idxName void $ ES.refreshIndex idx createIndexIfNotPresent :: - MonadIndexIO m => + (MonadIndexIO m) => CreateIndexSettings -> m () createIndexIfNotPresent = createIndex' False createIndex :: - MonadIndexIO m => + (MonadIndexIO m) => CreateIndexSettings -> m () createIndex = createIndex' True createIndex' :: - MonadIndexIO m => + (MonadIndexIO m) => -- | Fail if index alredy exists Bool -> CreateIndexSettings -> @@ -374,7 +368,7 @@ analysisSettings = ] in ES.Analysis analyzerDef mempty filterDef mempty -updateMapping :: MonadIndexIO m => m () +updateMapping :: (MonadIndexIO m) => m () updateMapping = liftIndexIO $ do idx <- asks idxName ex <- ES.indexExists idx @@ -388,7 +382,7 @@ updateMapping = liftIndexIO $ do ES.putMapping idx (ES.MappingName "user") indexMapping resetIndex :: - MonadIndexIO m => + (MonadIndexIO m) => CreateIndexSettings -> m () resetIndex ciSettings = liftIndexIO $ do @@ -439,7 +433,7 @@ indexUpdateToVersionControl :: IndexDocUpdateType -> (ES.ExternalDocVersion -> E indexUpdateToVersionControl IndexUpdateIfNewerVersion = ES.ExternalGT indexUpdateToVersionControl IndexUpdateIfSameOrNewerVersion = ES.ExternalGTE -traceES :: MonadIndexIO m => ByteString -> IndexIO ES.Reply -> m ES.Reply +traceES :: (MonadIndexIO m) => ByteString -> IndexIO ES.Reply -> m ES.Reply traceES descr act = liftIndexIO $ do info (msg descr) r <- act @@ -816,7 +810,7 @@ type ReindexRow = teamInReindexRow :: ReindexRow -> Maybe TeamId teamInReindexRow (_f1, f2, _f3, _f4, _f5, _f6, _f7, _f8, _f9, _f10, _f11, _f12, _f13, _f14, _f15, _f16, _f17, _f18, _f19, _f20, _f21, _f22) = f2 -reindexRowToIndexUser :: forall m. MonadThrow m => ReindexRow -> SearchVisibilityInbound -> m IndexUser +reindexRowToIndexUser :: forall m. (MonadThrow m) => ReindexRow -> SearchVisibilityInbound -> m IndexUser reindexRowToIndexUser ( u, mteam, @@ -972,3 +966,87 @@ instance Show ParseException where ++ m instance Exception ParseException + +--------------------------------------------------------------------------------- +-- Metrics + +{-# NOINLINE indexUpdateCounter #-} +indexUpdateCounter :: Prom.Counter +indexUpdateCounter = + Prom.unsafeRegister $ + Prom.counter + Prom.Info + { Prom.metricName = "user.index.update.count", + Prom.metricHelp = "Number of updates on user index" + } + +{-# NOINLINE indexUpdateErrorCounter #-} +indexUpdateErrorCounter :: Prom.Counter +indexUpdateErrorCounter = + Prom.unsafeRegister $ + Prom.counter + Prom.Info + { Prom.metricName = "user.index.update.err", + Prom.metricHelp = "Number of errors during user index update" + } + +{-# NOINLINE indexUpdateSuccessCounter #-} +indexUpdateSuccessCounter :: Prom.Counter +indexUpdateSuccessCounter = + Prom.unsafeRegister $ + Prom.counter + Prom.Info + { Prom.metricName = "user.index.update.ok", + Prom.metricHelp = "Number of successful user index updates" + } + +{-# NOINLINE indexBulkUpdateCounter #-} +indexBulkUpdateCounter :: Prom.Counter +indexBulkUpdateCounter = + Prom.unsafeRegister $ + Prom.counter + Prom.Info + { Prom.metricName = "user.index.update.bulk.count", + Prom.metricHelp = "Number of bulk updates on user index" + } + +{-# NOINLINE indexBulkUpdateErrorCounter #-} +indexBulkUpdateErrorCounter :: Prom.Counter +indexBulkUpdateErrorCounter = + Prom.unsafeRegister $ + Prom.counter + Prom.Info + { Prom.metricName = "user.index.update.bulk.err", + Prom.metricHelp = "Number of errors during bulk updates on user index" + } + +{-# NOINLINE indexBulkUpdateSuccessCounter #-} +indexBulkUpdateSuccessCounter :: Prom.Counter +indexBulkUpdateSuccessCounter = + Prom.unsafeRegister $ + Prom.counter + Prom.Info + { Prom.metricName = "user.index.update.bulk.ok", + Prom.metricHelp = "Number of successful bulk updates on user index" + } + +{-# NOINLINE indexBulkUpdateResponseCounter #-} +indexBulkUpdateResponseCounter :: Prom.Vector Prom.Label1 Prom.Counter +indexBulkUpdateResponseCounter = + Prom.unsafeRegister $ + Prom.vector ("status") $ + Prom.counter + Prom.Info + { Prom.metricName = "user.index.update.bulk.response", + Prom.metricHelp = "Number of successful bulk updates on user index" + } + +{-# NOINLINE indexDeleteCounter #-} +indexDeleteCounter :: Prom.Counter +indexDeleteCounter = + Prom.unsafeRegister $ + Prom.counter + Prom.Info + { Prom.metricName = "user.index.delete.count", + Prom.metricHelp = "Number of deletes on user index" + } diff --git a/services/brig/src/Brig/User/Search/SearchIndex.hs b/services/brig/src/Brig/User/Search/SearchIndex.hs index d9803fff6b5..82b76637976 100644 --- a/services/brig/src/Brig/User/Search/SearchIndex.hs +++ b/services/brig/src/Brig/User/Search/SearchIndex.hs @@ -29,7 +29,6 @@ import Brig.Types.Search import Brig.User.Search.Index import Control.Lens hiding (setting, (#), (.=)) import Control.Monad.Catch (MonadThrow, throwM) -import Control.Monad.Except import Data.Domain (Domain) import Data.Handle (Handle (fromHandle)) import Data.Id @@ -91,7 +90,7 @@ queryIndex (IndexQuery q f _) s = do searchHasMore = Nothing } -userDocToContact :: MonadThrow m => Domain -> UserDoc -> m Contact +userDocToContact :: (MonadThrow m) => Domain -> UserDoc -> m Contact userDocToContact localDomain UserDoc {..} = do let contactQualifiedId = Qualified udId localDomain contactName <- maybe (throwM $ IndexError "Name not found") (pure . fromName) udName @@ -149,8 +148,9 @@ mkUserQuery :: SearchSetting -> ES.Query -> IndexQuery Contact mkUserQuery setting q = IndexQuery q - ( ES.Filter . ES.QueryBoolQuery $ - boolQuery + ( ES.Filter + . ES.QueryBoolQuery + $ boolQuery { ES.boolQueryMustNotMatch = maybeToList $ matchSelf setting, ES.boolQueryMustMatch = [ restrictSearchSpace setting, diff --git a/services/brig/src/Brig/User/Search/TeamSize.hs b/services/brig/src/Brig/User/Search/TeamSize.hs index 1fd23bbf1c3..dce653ab03b 100644 --- a/services/brig/src/Brig/User/Search/TeamSize.hs +++ b/services/brig/src/Brig/User/Search/TeamSize.hs @@ -29,7 +29,7 @@ import Data.Id import Database.Bloodhound qualified as ES import Imports hiding (log, searchable) -teamSize :: MonadIndexIO m => TeamId -> m TeamSize +teamSize :: (MonadIndexIO m) => TeamId -> m TeamSize teamSize t = liftIndexIO $ do indexName <- asks idxName countResEither <- ES.countByIndex indexName (ES.CountQuery query) diff --git a/services/brig/src/Brig/User/Template.hs b/services/brig/src/Brig/User/Template.hs index 0acc0fe5c40..0667a4b2cd2 100644 --- a/services/brig/src/Brig/User/Template.hs +++ b/services/brig/src/Brig/User/Template.hs @@ -34,126 +34,13 @@ module Brig.User.Template -- * Re-exports Template, - renderText, - renderHtml, ) where import Brig.Options qualified as Opt import Brig.Template import Imports -import Wire.API.User.Identity - -data UserTemplates = UserTemplates - { activationSms :: !ActivationSmsTemplate, - activationCall :: !ActivationCallTemplate, - verificationEmail :: !VerificationEmailTemplate, - activationEmail :: !ActivationEmailTemplate, - activationEmailUpdate :: !ActivationEmailTemplate, - teamActivationEmail :: !TeamActivationEmailTemplate, - passwordResetSms :: !PasswordResetSmsTemplate, - passwordResetEmail :: !PasswordResetEmailTemplate, - loginSms :: !LoginSmsTemplate, - loginCall :: !LoginCallTemplate, - deletionSms :: !DeletionSmsTemplate, - deletionEmail :: !DeletionEmailTemplate, - newClientEmail :: !NewClientEmailTemplate, - verificationLoginEmail :: !SecondFactorVerificationEmailTemplate, - verificationScimTokenEmail :: !SecondFactorVerificationEmailTemplate, - verificationTeamDeletionEmail :: !SecondFactorVerificationEmailTemplate - } - -data ActivationSmsTemplate = ActivationSmsTemplate - { activationSmslUrl :: !Template, - activationSmsText :: !Template, - activationSmsSender :: !Text - } - -data ActivationCallTemplate = ActivationCallTemplate - { activationCallText :: !Template - } - -data VerificationEmailTemplate = VerificationEmailTemplate - { verificationEmailUrl :: !Template, - verificationEmailSubject :: !Template, - verificationEmailBodyText :: !Template, - verificationEmailBodyHtml :: !Template, - verificationEmailSender :: !Email, - verificationEmailSenderName :: !Text - } - -data ActivationEmailTemplate = ActivationEmailTemplate - { activationEmailUrl :: !Template, - activationEmailSubject :: !Template, - activationEmailBodyText :: !Template, - activationEmailBodyHtml :: !Template, - activationEmailSender :: !Email, - activationEmailSenderName :: !Text - } - -data TeamActivationEmailTemplate = TeamActivationEmailTemplate - { teamActivationEmailUrl :: !Template, - teamActivationEmailSubject :: !Template, - teamActivationEmailBodyText :: !Template, - teamActivationEmailBodyHtml :: !Template, - teamActivationEmailSender :: !Email, - teamActivationEmailSenderName :: !Text - } - -data DeletionEmailTemplate = DeletionEmailTemplate - { deletionEmailUrl :: !Template, - deletionEmailSubject :: !Template, - deletionEmailBodyText :: !Template, - deletionEmailBodyHtml :: !Template, - deletionEmailSender :: !Email, - deletionEmailSenderName :: !Text - } - -data PasswordResetEmailTemplate = PasswordResetEmailTemplate - { passwordResetEmailUrl :: !Template, - passwordResetEmailSubject :: !Template, - passwordResetEmailBodyText :: !Template, - passwordResetEmailBodyHtml :: !Template, - passwordResetEmailSender :: !Email, - passwordResetEmailSenderName :: !Text - } - -data PasswordResetSmsTemplate = PasswordResetSmsTemplate - { passwordResetSmsText :: !Template, - passwordResetSmsSender :: !Text - } - -data LoginSmsTemplate = LoginSmsTemplate - { loginSmsUrl :: !Template, - loginSmsText :: !Template, - loginSmsSender :: !Text - } - -data LoginCallTemplate = LoginCallTemplate - { loginCallText :: !Template - } - -data DeletionSmsTemplate = DeletionSmsTemplate - { deletionSmsUrl :: !Template, - deletionSmsText :: !Template, - deletionSmsSender :: !Text - } - -data NewClientEmailTemplate = NewClientEmailTemplate - { newClientEmailSubject :: !Template, - newClientEmailBodyText :: !Template, - newClientEmailBodyHtml :: !Template, - newClientEmailSender :: !Email, - newClientEmailSenderName :: !Text - } - -data SecondFactorVerificationEmailTemplate = SecondFactorVerificationEmailTemplate - { sndFactorVerificationEmailSubject :: !Template, - sndFactorVerificationEmailBodyText :: !Template, - sndFactorVerificationEmailBodyHtml :: !Template, - sndFactorVerificationEmailSender :: !Email, - sndFactorVerificationEmailSenderName :: !Text - } +import Wire.EmailSubsystem.Template loadUserTemplates :: Opt.Opts -> IO (Localised UserTemplates) loadUserTemplates o = readLocalesDir defLocale templateDir "user" $ \fp -> diff --git a/services/brig/src/Brig/ZAuth.hs b/services/brig/src/Brig/ZAuth.hs index 14e714bd331..9eaf2cba30a 100644 --- a/services/brig/src/Brig/ZAuth.hs +++ b/services/brig/src/Brig/ZAuth.hs @@ -110,13 +110,13 @@ import Wire.API.User.Auth qualified as Auth newtype ZAuth a = ZAuth {unZAuth :: ReaderT Env IO a} deriving (Functor, Applicative, Monad, MonadIO, MonadReader Env) -class MonadIO m => MonadZAuth m where +class (MonadIO m) => MonadZAuth m where liftZAuth :: ZAuth a -> m a instance MonadZAuth ZAuth where liftZAuth = id -runZAuth :: MonadIO m => Env -> ZAuth a -> m a +runZAuth :: (MonadIO m) => Env -> ZAuth a -> m a runZAuth e za = liftIO $ runReaderT (unZAuth za) e data Settings = Settings @@ -217,7 +217,7 @@ makeLenses ''Env localSettings :: (Settings -> Settings) -> ZAuth a -> ZAuth a localSettings f za = ZAuth (local (over settings f) (unZAuth za)) -readKeys :: Read k => FilePath -> IO (Maybe (NonEmpty k)) +readKeys :: (Read k) => FilePath -> IO (Maybe (NonEmpty k)) readKeys fp = nonEmpty . map read . filter (not . null) . lines <$> readFile fp mkEnv :: NonEmpty SecretKey -> NonEmpty PublicKey -> Settings -> IO Env @@ -227,7 +227,7 @@ mkEnv sk pk sets = do pure $! Env zc zv sets class (UserTokenLike u, AccessTokenLike a) => TokenPair u a where - newAccessToken :: MonadZAuth m => Token u -> m (Token a) + newAccessToken :: (MonadZAuth m) => Token u -> m (Token a) instance TokenPair User Access where newAccessToken = newAccessToken' @@ -238,7 +238,7 @@ instance TokenPair LegalHoldUser LegalHoldAccess where class (FromByteString (Token a), ToByteString a) => AccessTokenLike a where accessTokenOf :: Token a -> UserId accessTokenClient :: Token a -> Maybe ClientId - renewAccessToken :: MonadZAuth m => Maybe ClientId -> Token a -> m (Token a) + renewAccessToken :: (MonadZAuth m) => Maybe ClientId -> Token a -> m (Token a) settingsTTL :: Proxy a -> Lens' Settings Integer instance AccessTokenLike Access where @@ -257,9 +257,9 @@ class (FromByteString (Token u), ToByteString u) => UserTokenLike u where userTokenOf :: Token u -> UserId userTokenClient :: Token u -> Maybe ClientId mkSomeToken :: Token u -> Auth.SomeUserToken - mkUserToken :: MonadZAuth m => UserId -> Maybe ClientId -> Word32 -> UTCTime -> m (Token u) + mkUserToken :: (MonadZAuth m) => UserId -> Maybe ClientId -> Word32 -> UTCTime -> m (Token u) userTokenRand :: Token u -> Word32 - newUserToken :: MonadZAuth m => UserId -> Maybe ClientId -> m (Token u) + newUserToken :: (MonadZAuth m) => UserId -> Maybe ClientId -> m (Token u) newSessionToken :: (MonadThrow m, MonadZAuth m) => UserId -> Maybe ClientId -> m (Token u) userTTL :: Proxy u -> Lens' Settings Integer zauthType :: Type -- see libs/zauth/src/Token.hs @@ -286,14 +286,14 @@ instance UserTokenLike LegalHoldUser where userTTL _ = legalHoldUserTokenTimeout . legalHoldUserTokenTimeoutSeconds zauthType = LU -mkUserToken' :: MonadZAuth m => UserId -> Maybe ClientId -> Word32 -> UTCTime -> m (Token User) +mkUserToken' :: (MonadZAuth m) => UserId -> Maybe ClientId -> Word32 -> UTCTime -> m (Token User) mkUserToken' u cid r t = liftZAuth $ do z <- ask liftIO $ ZC.runCreate (z ^. private) (z ^. settings . keyIndex) $ ZC.newToken (utcTimeToPOSIXSeconds t) U Nothing (mkUser (toUUID u) (fmap clientToText cid) r) -newUserToken' :: MonadZAuth m => UserId -> Maybe ClientId -> m (Token User) +newUserToken' :: (MonadZAuth m) => UserId -> Maybe ClientId -> m (Token User) newUserToken' u c = liftZAuth $ do z <- ask r <- liftIO randomValue @@ -302,7 +302,7 @@ newUserToken' u c = liftZAuth $ do let UserTokenTimeout ttl = z ^. settings . userTokenTimeout in ZC.userToken ttl (toUUID u) (fmap clientToText c) r -newSessionToken' :: MonadZAuth m => UserId -> Maybe ClientId -> m (Token User) +newSessionToken' :: (MonadZAuth m) => UserId -> Maybe ClientId -> m (Token User) newSessionToken' u c = liftZAuth $ do z <- ask r <- liftIO randomValue @@ -311,7 +311,7 @@ newSessionToken' u c = liftZAuth $ do let SessionTokenTimeout ttl = z ^. settings . sessionTokenTimeout in ZC.sessionToken ttl (toUUID u) (fmap clientToText c) r -newAccessToken' :: MonadZAuth m => Token User -> m (Token Access) +newAccessToken' :: (MonadZAuth m) => Token User -> m (Token Access) newAccessToken' xt = liftZAuth $ do z <- ask liftIO $ @@ -319,7 +319,7 @@ newAccessToken' xt = liftZAuth $ do let AccessTokenTimeout ttl = z ^. settings . accessTokenTimeout in ZC.accessToken1 ttl (xt ^. body . user) (xt ^. body . client) -renewAccessToken' :: MonadZAuth m => Maybe ClientId -> Token Access -> m (Token Access) +renewAccessToken' :: (MonadZAuth m) => Maybe ClientId -> Token Access -> m (Token Access) renewAccessToken' mcid old = liftZAuth $ do z <- ask liftIO $ @@ -333,14 +333,14 @@ renewAccessToken' mcid old = liftZAuth $ do $ (old ^. body) ) -newBotToken :: MonadZAuth m => ProviderId -> BotId -> ConvId -> m (Token Bot) +newBotToken :: (MonadZAuth m) => ProviderId -> BotId -> ConvId -> m (Token Bot) newBotToken pid bid cid = liftZAuth $ do z <- ask liftIO $ ZC.runCreate (z ^. private) (z ^. settings . keyIndex) $ ZC.botToken (toUUID pid) (toUUID (botUserId bid)) (toUUID cid) -newProviderToken :: MonadZAuth m => ProviderId -> m (Token Provider) +newProviderToken :: (MonadZAuth m) => ProviderId -> m (Token Provider) newProviderToken pid = liftZAuth $ do z <- ask liftIO $ @@ -355,7 +355,7 @@ newProviderToken pid = liftZAuth $ do -- Possibly some duplication could be removed. -- See https://github.com/wireapp/wire-server/pull/761/files#r318612423 mkLegalHoldUserToken :: - MonadZAuth m => + (MonadZAuth m) => UserId -> Maybe ClientId -> Word32 -> @@ -371,7 +371,7 @@ mkLegalHoldUserToken u c r t = liftZAuth $ do Nothing (mkLegalHoldUser (toUUID u) (fmap clientToText c) r) -newLegalHoldUserToken :: MonadZAuth m => UserId -> Maybe ClientId -> m (Token LegalHoldUser) +newLegalHoldUserToken :: (MonadZAuth m) => UserId -> Maybe ClientId -> m (Token LegalHoldUser) newLegalHoldUserToken u c = liftZAuth $ do z <- ask r <- liftIO randomValue @@ -380,7 +380,7 @@ newLegalHoldUserToken u c = liftZAuth $ do let LegalHoldUserTokenTimeout ttl = z ^. settings . legalHoldUserTokenTimeout in ZC.legalHoldUserToken ttl (toUUID u) (fmap clientToText c) r -newLegalHoldAccessToken :: MonadZAuth m => Token LegalHoldUser -> m (Token LegalHoldAccess) +newLegalHoldAccessToken :: (MonadZAuth m) => Token LegalHoldUser -> m (Token LegalHoldAccess) newLegalHoldAccessToken xt = liftZAuth $ do z <- ask liftIO $ @@ -392,7 +392,7 @@ newLegalHoldAccessToken xt = liftZAuth $ do (xt ^. body . legalHoldUser . client) renewLegalHoldAccessToken :: - MonadZAuth m => + (MonadZAuth m) => Maybe ClientId -> Token LegalHoldAccess -> m (Token LegalHoldAccess) diff --git a/services/brig/test/integration/API/Calling.hs b/services/brig/test/integration/API/Calling.hs index c8008d01cb6..442dcfca55b 100644 --- a/services/brig/test/integration/API/Calling.hs +++ b/services/brig/test/integration/API/Calling.hs @@ -125,7 +125,7 @@ testSFTUnavailable b opts domain = do (cfg ^. rtcConfSftServersAll) modifyAndAssert :: - HasCallStack => + (HasCallStack) => Brig -> UserId -> (UserId -> Brig -> Http RTCConfiguration) -> @@ -212,7 +212,7 @@ testCallsConfigV2SRV b opts = do ] ) -assertConfiguration :: HasCallStack => RTCConfiguration -> NonEmpty TurnURI -> Http () +assertConfiguration :: (HasCallStack) => RTCConfiguration -> NonEmpty TurnURI -> Http () assertConfiguration cfg expected = do let actual = concatMap (toList . view iceURLs) $ toList $ cfg ^. rtcConfIceServers liftIO $ assertEqual "Expected adverstised TURN servers to match actual ones" (sort $ toList expected) (sort actual) @@ -220,10 +220,10 @@ assertConfiguration cfg expected = do getTurnConfigurationV1 :: UserId -> Brig -> Http RTCConfiguration getTurnConfigurationV1 = getAndValidateTurnConfiguration "" -getTurnConfigurationV2 :: HasCallStack => UserId -> Brig -> ((MonadHttp m, MonadIO m, MonadCatch m) => m RTCConfiguration) +getTurnConfigurationV2 :: (HasCallStack) => UserId -> Brig -> ((MonadHttp m, MonadIO m, MonadCatch m) => m RTCConfiguration) getTurnConfigurationV2 = getAndValidateTurnConfiguration "v2" -getTurnConfiguration :: ByteString -> UserId -> Brig -> (MonadHttp m => m (Response (Maybe LB.ByteString))) +getTurnConfiguration :: ByteString -> UserId -> Brig -> ((MonadHttp m) => m (Response (Maybe LB.ByteString))) getTurnConfiguration suffix u b = get ( b @@ -232,7 +232,7 @@ getTurnConfiguration suffix u b = . zConn "conn" ) -getAndValidateTurnConfiguration :: HasCallStack => ByteString -> UserId -> Brig -> ((MonadIO m, MonadHttp m, MonadCatch m) => m RTCConfiguration) +getAndValidateTurnConfiguration :: (HasCallStack) => ByteString -> UserId -> Brig -> ((MonadIO m, MonadHttp m, MonadCatch m) => m RTCConfiguration) getAndValidateTurnConfiguration suffix u b = responseJsonError =<< (getTurnConfiguration suffix u b Int -> UserId -> Brig -> Http RTCConfiguration +getAndValidateTurnConfigurationLimit :: (HasCallStack) => Int -> UserId -> Brig -> Http RTCConfiguration getAndValidateTurnConfigurationLimit limit u b = responseJsonError =<< (getTurnConfigurationV2Limit limit u b Domain -> Either Handle Name -> Maybe (Qualified UserId) -> FederatedUserSearchPolicy -> WaiTest.Session () + let expectSearch :: (HasCallStack) => Domain -> Either Handle Name -> Maybe (Qualified UserId) -> FederatedUserSearchPolicy -> WaiTest.Session () expectSearch domain handleOrName mExpectedUser expectedSearchPolicy = do let squery = either fromHandle fromName handleOrName searchResponse <- @@ -264,7 +264,7 @@ testGetUserByHandleNotFound opts = do maybeProfile <- withSettingsOverrides (allowFullSearch domain opts) $ do runWaiTestFedClient domain $ createWaiTestFedClient @"get-user-by-handle" @'Brig $ - Handle hdl + fromJust (parseHandle hdl) liftIO $ assertEqual "should not return any UserProfile" Nothing maybeProfile diff --git a/services/brig/test/integration/API/Internal.hs b/services/brig/test/integration/API/Internal.hs index b4d730fcd94..f3b65f6b37c 100644 --- a/services/brig/test/integration/API/Internal.hs +++ b/services/brig/test/integration/API/Internal.hs @@ -27,7 +27,7 @@ import API.Internal.Util import API.MLS.Util import Bilge import Bilge.Assert -import Brig.Data.User (lookupFeatureConferenceCalling, lookupStatus, userExists) +import Brig.Data.User (lookupFeatureConferenceCalling, userExists) import Brig.Options qualified as Opt import Cassandra qualified as C import Cassandra qualified as Cass @@ -222,3 +222,11 @@ testWritetimeRepresentation _ _mgr db brig _brigep _galley = do q2 :: C.PrepQuery C.R (Identity UserId) (Identity (Writetime ())) q2 = "SELECT WRITETIME(status) from user where id = ?" + +lookupStatus :: UserId -> C.Client (Maybe AccountStatus) +lookupStatus u = + (runIdentity =<<) + <$> C.retry C.x1 (C.query1 statusSelect (C.params C.LocalQuorum (Identity u))) + where + statusSelect :: C.PrepQuery C.R (Identity UserId) (Identity (Maybe AccountStatus)) + statusSelect = "SELECT status FROM user WHERE id = ?" diff --git a/services/brig/test/integration/API/MLS/Util.hs b/services/brig/test/integration/API/MLS/Util.hs index c2725fd0a3d..445ca6875fb 100644 --- a/services/brig/test/integration/API/MLS/Util.hs +++ b/services/brig/test/integration/API/MLS/Util.hs @@ -57,8 +57,8 @@ cliCmd tmp qcid cmnds = ["--store", tmp (show qcid <> ".db")] <> cmnds initStore :: - HasCallStack => - MonadIO m => + (HasCallStack) => + (MonadIO m) => FilePath -> ClientIdentity -> m () @@ -67,8 +67,8 @@ initStore tmp qcid = do cliCmd tmp qcid ["init", show qcid] generateKeyPackage :: - HasCallStack => - MonadIO m => + (HasCallStack) => + (MonadIO m) => FilePath -> ClientIdentity -> Maybe Timeout -> @@ -84,7 +84,7 @@ generateKeyPackage tmp qcid lifetime = do pure (kp, ref) uploadKeyPackages :: - HasCallStack => + (HasCallStack) => Brig -> FilePath -> KeyingInfo -> @@ -119,7 +119,7 @@ uploadKeyPackages brig tmp KeyingInfo {..} u c n = do !!! const (case kiSetKey of SetKey -> 201; DontSetKey -> 400) === statusCode -getKeyPackageCount :: HasCallStack => Brig -> Qualified UserId -> ClientId -> Http KeyPackageCount +getKeyPackageCount :: (HasCallStack) => Brig -> Qualified UserId -> ClientId -> Http KeyPackageCount getKeyPackageCount brig u c = responseJsonError =<< get @@ -130,7 +130,7 @@ getKeyPackageCount brig u c = ByteString -> IO a +decodeMLSError :: (ParseMLS a) => ByteString -> IO a decodeMLSError s = case decodeMLS' s of Left e -> assertFailure ("Could not parse MLS object: " <> Text.unpack e) Right x -> pure x diff --git a/services/brig/test/integration/API/OAuth.hs b/services/brig/test/integration/API/OAuth.hs index cd08aae8317..3b3eba50b38 100644 --- a/services/brig/test/integration/API/OAuth.hs +++ b/services/brig/test/integration/API/OAuth.hs @@ -472,7 +472,7 @@ testRefreshTokenMaxActiveTokens opts db brig = tokens <- C.runClient db (lookupOAuthRefreshTokens uid) liftIO $ assertBool testMsg $ [rid3, rid] `hasSameElems` (refreshTokenId <$> tokens) where - extractRefreshTokenId :: MonadIO m => JWK -> OAuthRefreshToken -> m OAuthRefreshTokenId + extractRefreshTokenId :: (MonadIO m) => JWK -> OAuthRefreshToken -> m OAuthRefreshTokenId extractRefreshTokenId jwk rt = do fromMaybe (error "invalid sub") . hcsSub <$> liftIO (verifyRefreshToken jwk (unOAuthToken rt)) @@ -732,10 +732,10 @@ verifyRefreshToken jwk jwt = fromRight (error "invalid jwt or jwk") <$> runJOSE (verifyClaims (defaultJWTValidationSettings (const True)) jwk jwt :: JOSE JWTError IO ClaimsSet) -authHeader :: ToHttpApiData a => a -> Request -> Request +authHeader :: (ToHttpApiData a) => a -> Request -> Request authHeader = bearer "Authorization" -bearer :: ToHttpApiData a => HeaderName -> a -> Request -> Request +bearer :: (ToHttpApiData a) => HeaderName -> a -> Request -> Request bearer name = header name . toHeader . Bearer newOAuthClientRequestBody :: Text -> Text -> OAuthClientConfig @@ -845,7 +845,7 @@ mkUrl = fromMaybe (error "invalid url") . fromByteString revokeOAuthRefreshToken :: (MonadHttp m) => Brig -> OAuthRevokeRefreshTokenRequest -> m ResponseLBS revokeOAuthRefreshToken brig req = post (brig . paths ["oauth", "revoke"] . json req) -instance ToHttpApiData a => ToHttpApiData (Bearer a) where +instance (ToHttpApiData a) => ToHttpApiData (Bearer a) where toHeader = (<>) "Bearer " . toHeader . unBearer toUrlPiece = T.decodeUtf8 . toHeader diff --git a/services/brig/test/integration/API/Provider.hs b/services/brig/test/integration/API/Provider.hs index 538453d1aed..0d2aad8a5db 100644 --- a/services/brig/test/integration/API/Provider.hs +++ b/services/brig/test/integration/API/Provider.hs @@ -27,7 +27,6 @@ where import API.Team.Util qualified as Team import Bilge hiding (accept, head, timeout) import Bilge.Assert -import Brig.Code qualified as Code import Cassandra qualified as DB import Control.Arrow ((&&&)) import Control.Concurrent.Async qualified as Async @@ -40,8 +39,9 @@ import Data.ByteString qualified as BS import Data.ByteString.Char8 qualified as C8 import Data.ByteString.Conversion import Data.ByteString.Lazy.Char8 qualified as LC8 +import Data.Code qualified as Code import Data.Domain -import Data.Handle (Handle (Handle)) +import Data.Handle (parseHandle) import Data.HashMap.Strict qualified as HashMap import Data.Id import Data.Json.Util (toBase64Text) @@ -100,6 +100,9 @@ import Wire.API.User as User hiding (EmailUpdate, PasswordChange, mkName) import Wire.API.User.Auth (CookieType (..)) import Wire.API.User.Client import Wire.API.User.Client.Prekey +import Wire.VerificationCode qualified as Code +import Wire.VerificationCodeGen +import Wire.VerificationCodeStore.Cassandra qualified as VerificationCodeStore tests :: Domain -> Config -> Manager -> DB.ClientState -> Brig -> Cannon -> Galley -> Nginz -> IO TestTree tests dom conf p db b c g n = do @@ -263,7 +266,7 @@ testPasswordResetProvider db brig = do resetPw :: PlainTextPassword6 -> Email -> Http ResponseLBS resetPw newPw email = do -- Get the code directly from the DB - gen <- Code.mkGen (Code.ForEmail email) + let gen = mkVerificationCodeGen email Just vcode <- lookupCode db gen Code.PasswordReset let passwordResetData = CompletePasswordReset @@ -281,7 +284,7 @@ testPasswordResetAfterEmailUpdateProvider db brig = do initiateEmailUpdateProvider brig pid (EmailUpdate newEmail) !!! const 202 === statusCode initiatePasswordResetProvider brig (PasswordReset origEmail) !!! const 201 === statusCode -- Get password reset code directly from the DB - genOrig <- Code.mkGen (Code.ForEmail origEmail) + let genOrig = mkVerificationCodeGen origEmail Just vcodePw <- lookupCode db genOrig Code.PasswordReset let passwordResetData = CompletePasswordReset @@ -289,7 +292,7 @@ testPasswordResetAfterEmailUpdateProvider db brig = do (Code.codeValue vcodePw) (plainTextPassword6Unsafe "doesnotmatter") -- Activate the new email - genNew <- Code.mkGen (Code.ForEmail newEmail) + let genNew = mkVerificationCodeGen newEmail Just vcodeEm <- lookupCode db genNew Code.IdentityVerification activateProvider brig (Code.codeKey vcodeEm) (Code.codeValue vcodeEm) !!! const 200 === statusCode @@ -465,7 +468,7 @@ testListServices config db brig = do -- This is how we're going to call our /services endpoint. Every time we -- would call it twice (with tags and without) and assert that results -- match. - let search :: HasCallStack => Name -> Http ServiceProfilePage + let search :: (HasCallStack) => Name -> Http ServiceProfilePage search name = do r1 <- searchServices brig 20 uid (Just name) Nothing r2 <- searchServices brig 20 uid (Just name) (Just (match1 SocialTag)) @@ -480,7 +483,7 @@ testListServices config db brig = do pure r1 -- This function searches for a prefix and check that the results match -- our known list of services - let searchAndCheck :: HasCallStack => Name -> Http [ServiceProfile] + let searchAndCheck :: (HasCallStack) => Name -> Http [ServiceProfile] searchAndCheck name = do result <- search name assertServiceDetails ("name " <> show name) (select name services) result @@ -923,7 +926,7 @@ testSearchWhitelist config db brig galley = do -- endpoint. Every time we call it twice (with filter_disabled=false and -- without) and assert that results match – which should always be the -- case since in this test we won't have any disabled services. - let search :: HasCallStack => Maybe Text -> Http ServiceProfilePage + let search :: (HasCallStack) => Maybe Text -> Http ServiceProfilePage search mbName = do r1 <- searchServiceWhitelist brig 20 uid tid mbName r2 <- searchServiceWhitelistAll brig 20 uid tid mbName @@ -950,7 +953,7 @@ testSearchWhitelist config db brig galley = do liftIO $ assertEqual "has more" True (serviceProfilePageHasMore page) -- This function searches for a prefix and check that the results match -- our known list of services - let searchAndCheck :: HasCallStack => Name -> Http [ServiceProfile] + let searchAndCheck :: (HasCallStack) => Name -> Http [ServiceProfile] searchAndCheck (Name name) = do result <- search (Just name) assertServiceDetails ("name " <> show name) (select name services) result @@ -1646,8 +1649,8 @@ getUserClients brig bid uid = -------------------------------------------------------------------------------- -- DB Operations -lookupCode :: MonadIO m => DB.ClientState -> Code.Gen -> Code.Scope -> m (Maybe Code.Code) -lookupCode db gen = liftIO . DB.runClient db . Code.lookup (Code.genKey gen) +lookupCode :: (MonadIO m) => DB.ClientState -> VerificationCodeGen -> Code.Scope -> m (Maybe Code.Code) +lookupCode db gen = liftIO . DB.runClient db . VerificationCodeStore.lookupCodeImpl gen.genKey -------------------------------------------------------------------------------- -- Utilities @@ -1675,7 +1678,7 @@ testRegisterProvider db' brig = do case db' of Just db -> do -- Activate email - gen <- Code.mkGen (Code.ForEmail email) + let gen = mkVerificationCodeGen email Just vcode <- lookupCode db gen Code.IdentityVerification activateProvider brig (Code.codeKey vcode) (Code.codeValue vcode) !!! const 200 === statusCode @@ -1710,10 +1713,10 @@ testRegisterProvider db' brig = do assertEqual "description" defProviderDescr (providerDescr p) assertEqual "profile" (ProviderProfile p) pp -randomProvider :: HasCallStack => DB.ClientState -> Brig -> Http Provider +randomProvider :: (HasCallStack) => DB.ClientState -> Brig -> Http Provider randomProvider db brig = do email <- randomEmail - gen <- Code.mkGen (Code.ForEmail email) + let gen = mkVerificationCodeGen email -- Register let new = defNewProvider email _rs <- @@ -1729,7 +1732,7 @@ randomProvider db brig = do let Just prv = responseJsonMaybe _rs pure prv -addGetService :: HasCallStack => Brig -> ProviderId -> NewService -> Http Service +addGetService :: (HasCallStack) => Brig -> ProviderId -> NewService -> Http Service addGetService brig pid new = do _rs <- addService brig pid new Brig -> ProviderId -> ServiceId -> Http () +enableService :: (HasCallStack) => Brig -> ProviderId -> ServiceId -> Http () enableService brig pid sid = do let upd = (mkUpdateServiceConn defProviderPassword) @@ -1747,7 +1750,7 @@ enableService brig pid sid = do updateServiceConn brig pid sid upd !!! const 200 === statusCode -disableService :: HasCallStack => Brig -> ProviderId -> ServiceId -> Http () +disableService :: (HasCallStack) => Brig -> ProviderId -> ServiceId -> Http () disableService brig pid sid = do let upd = (mkUpdateServiceConn defProviderPassword) @@ -1757,7 +1760,7 @@ disableService brig pid sid = do !!! const 200 === statusCode whitelistServiceNginz :: - HasCallStack => + (HasCallStack) => Nginz -> -- | Team owner User -> @@ -1787,7 +1790,7 @@ updateServiceWhitelistNginz nginz user tid upd = do . body (RequestBodyLBS (encode upd)) whitelistService :: - HasCallStack => + (HasCallStack) => Brig -> -- | Team owner UserId -> @@ -1803,7 +1806,7 @@ whitelistService brig uid tid pid sid = const 200 === statusCode dewhitelistService :: - HasCallStack => + (HasCallStack) => Brig -> -- | Team owner UserId -> @@ -1818,7 +1821,7 @@ dewhitelistService brig uid tid pid sid = -- TODO: allow both 200 and 204 here and use it in 'testWhitelistEvents' const 200 === statusCode -defNewService :: MonadIO m => Config -> m NewService +defNewService :: (MonadIO m) => Config -> m NewService defNewService config = liftIO $ do key <- readServiceKey (publicKey config) pure @@ -1879,32 +1882,32 @@ defServiceAssets = -- TODO: defServiceToken :: ServiceToken -readServiceKey :: MonadIO m => FilePath -> m ServiceKeyPEM +readServiceKey :: (MonadIO m) => FilePath -> m ServiceKeyPEM readServiceKey fp = liftIO $ do bs <- BS.readFile fp let Right [k] = pemParseBS bs pure (ServiceKeyPEM k) -randServiceKey :: MonadIO m => m ServiceKeyPEM +randServiceKey :: (MonadIO m) => m ServiceKeyPEM randServiceKey = liftIO $ do kp <- generateRSAKey' 4096 65537 Right [k] <- pemParseBS . C8.pack <$> writePublicKey kp pure (ServiceKeyPEM k) -waitFor :: MonadIO m => Timeout -> (a -> Bool) -> m a -> m a +waitFor :: (MonadIO m) => Timeout -> (a -> Bool) -> m a -> m a waitFor t f ma = do a <- ma if - | f a -> pure a - | t <= 0 -> liftIO $ throwM TimedOut - | otherwise -> do - liftIO $ threadDelay (1 # Second) - waitFor (t - 1 # Second) f ma + | f a -> pure a + | t <= 0 -> liftIO $ throwM TimedOut + | otherwise -> do + liftIO $ threadDelay (1 # Second) + waitFor (t - 1 # Second) f ma withFreePortAnyAddr :: (MonadMask m, MonadIO m) => ((Warp.Port, Socket) -> m a) -> m a withFreePortAnyAddr = bracket openFreePortAnyAddr (liftIO . Socket.close . snd) -openFreePortAnyAddr :: MonadIO m => m (Warp.Port, Socket) +openFreePortAnyAddr :: (MonadIO m) => m (Warp.Port, Socket) openFreePortAnyAddr = liftIO $ bindRandomPortTCP "*" -- | Run a test case with an external service application. @@ -2145,7 +2148,7 @@ mkMessage fromc rcps = ] where mk (u, c, m) = (text u, HashMap.singleton (text c) m) - text :: ToByteString a => a -> Text + text :: (ToByteString a) => a -> Text text = fromJust . fromByteString . toByteString' -- | A list of 20 services, all having names that begin with the given prefix. @@ -2233,7 +2236,7 @@ testAddRemoveBotUtil localDomain pid sid cid u1 u2 h sref buf brig galley cannon -- Check that the preferred locale defaults to the locale of the -- user who requsted the bot. liftIO $ assertEqual "locale" (userLocale u1) (testBotLocale bot) - liftIO $ assertEqual "handle" (Just (Handle h)) u1Handle + liftIO $ assertEqual "handle" (Just (fromJust $ parseHandle h)) u1Handle -- Check that the bot has access to the conversation getBotConv galley bid cid !!! const 200 === statusCode -- Check that the bot user exists and can be identified as a bot @@ -2322,7 +2325,7 @@ testMessageBotUtil quid uc cid pid sid sref buf brig galley cannon = do wsAssertMemberLeave ws qcid (tUntagged lbuid) [tUntagged lbuid] prepareBotUsersTeam :: - HasCallStack => + (HasCallStack) => Brig -> Galley -> ServiceRef -> @@ -2352,7 +2355,7 @@ testWhitelistNginz config db brig nginz = withTestService config db brig defServ whitelistServiceNginz nginz adminUser tid pid sid addBotConv :: - HasCallStack => + (HasCallStack) => Domain -> Brig -> WS.Cannon -> @@ -2389,7 +2392,7 @@ addBotConv localDomain brig cannon uid1 uid2 cid pid sid buf = do -- | Given some endpoint that can search for services by name prefix, check -- that it doesn't break when service name changes. searchAndAssertNameChange :: - HasCallStack => + (HasCallStack) => Brig -> -- | Service provider ProviderId -> @@ -2455,7 +2458,7 @@ assertServiceDetails testName expected page = liftIO $ do -- | Call the endpoint that searches through all services. searchServices :: - HasCallStack => + (HasCallStack) => Brig -> Int -> UserId -> @@ -2478,7 +2481,7 @@ searchServices brig size uid mbStart mbTags = case (mbStart, mbTags) of -- | Call the endpoint that searches through whitelisted services. searchServiceWhitelist :: - HasCallStack => + (HasCallStack) => Brig -> Int -> UserId -> @@ -2494,7 +2497,7 @@ searchServiceWhitelist brig size uid tid mbStart = -- | Call the endpoint that searches through whitelisted services, and don't -- filter out disabled services. searchServiceWhitelistAll :: - HasCallStack => + (HasCallStack) => Brig -> Int -> UserId -> diff --git a/services/brig/test/integration/API/RichInfo/Util.hs b/services/brig/test/integration/API/RichInfo/Util.hs index 896f90735b8..5dae93d4168 100644 --- a/services/brig/test/integration/API/RichInfo/Util.hs +++ b/services/brig/test/integration/API/RichInfo/Util.hs @@ -29,7 +29,7 @@ import Util import Wire.API.User.RichInfo getRichInfo :: - HasCallStack => + (HasCallStack) => Brig -> -- | The user who is performing the query UserId -> @@ -44,16 +44,16 @@ getRichInfo brig self uid = do . zUser self ) if - | statusCode r == 200 -> Right <$> responseJsonError r - | statusCode r `elem` [403, 404] -> pure . Left . statusCode $ r - | otherwise -> - error $ - "expected status code 200, 403, or 404, got: " <> show (statusCode r) + | statusCode r == 200 -> Right <$> responseJsonError r + | statusCode r `elem` [403, 404] -> pure . Left . statusCode $ r + | otherwise -> + error $ + "expected status code 200, 403, or 404, got: " <> show (statusCode r) -- | This contacts an internal end-point. Note the asymmetry between this and the external -- GET end-point in the body: here we need to wrap the 'RichInfo' in a 'RichInfoUpdate'. putRichInfo :: - HasCallStack => + (HasCallStack) => Brig -> -- | The user whose rich info is being updated UserId -> diff --git a/services/brig/test/integration/API/Search.hs b/services/brig/test/integration/API/Search.hs index 6ffe569c113..54111e832f5 100644 --- a/services/brig/test/integration/API/Search.hs +++ b/services/brig/test/integration/API/Search.hs @@ -151,7 +151,7 @@ tests opts mgr galley brig = do type TestConstraints m = (MonadFail m, MonadCatch m, MonadIO m, MonadHttp m) -testSearchWithUnvalidatedEmail :: TestConstraints m => Brig -> m () +testSearchWithUnvalidatedEmail :: (TestConstraints m) => Brig -> m () testSearchWithUnvalidatedEmail brig = do (tid, owner, user : _) <- createPopulatedBindingTeamWithNamesAndHandles brig 1 let uid = userId user @@ -180,18 +180,18 @@ testSearchWithUnvalidatedEmail brig = do assertBool "unvalidated email should be null" (isNothing . Search.teamContactEmailUnvalidated $ tc) ) where - searchAndCheckResult :: TestConstraints m => Brig -> TeamId -> UserId -> UserId -> (Search.TeamContact -> Assertion) -> m () + searchAndCheckResult :: (TestConstraints m) => Brig -> TeamId -> UserId -> UserId -> (Search.TeamContact -> Assertion) -> m () searchAndCheckResult b tid ownerId userToSearchFor assertion = executeTeamUserSearch b tid ownerId Nothing Nothing Nothing Nothing >>= checkResult userToSearchFor assertion . searchResults - checkResult :: TestConstraints m => UserId -> (Search.TeamContact -> Assertion) -> [Search.TeamContact] -> m () + checkResult :: (TestConstraints m) => UserId -> (Search.TeamContact -> Assertion) -> [Search.TeamContact] -> m () checkResult userToSearchFor assertion results = liftIO $ do let mbTeamContact = find ((==) userToSearchFor . Search.teamContactUserId) results case mbTeamContact of Nothing -> fail "no team contact found" Just teamContact -> assertion teamContact -testSearchByName :: TestConstraints m => Brig -> m () +testSearchByName :: (TestConstraints m) => Brig -> m () testSearchByName brig = do u1 <- randomUser brig u2 <- randomUser brig @@ -206,7 +206,7 @@ testSearchByName brig = do assertCan'tFind brig uid1 quid1 (fromName (userDisplayName u1)) assertCan'tFind brig uid2 quid2 (fromName (userDisplayName u2)) -testSearchByLastOrMiddleName :: TestConstraints m => Brig -> m () +testSearchByLastOrMiddleName :: (TestConstraints m) => Brig -> m () testSearchByLastOrMiddleName brig = do searcher <- userId <$> randomUser brig firstName <- randomHandle @@ -220,7 +220,7 @@ testSearchByLastOrMiddleName brig = do assertCanFind brig searcher searched lastName assertCanFind brig searcher searched (firstName <> " " <> lastName) -testSearchNonAsciiNames :: TestConstraints m => Brig -> m () +testSearchNonAsciiNames :: (TestConstraints m) => Brig -> m () testSearchNonAsciiNames brig = do searcher <- userId <$> randomUser brig suffix <- randomHandle @@ -231,7 +231,7 @@ testSearchNonAsciiNames brig = do -- This is pathetic transliteration, but it is what we have. assertCanFind brig searcher searched ("saktimana" <> suffix) -testSearchCJK :: TestConstraints m => Brig -> m () +testSearchCJK :: (TestConstraints m) => Brig -> m () testSearchCJK brig = do searcher <- randomUser brig user <- createUser' True "藤崎詩織" brig @@ -248,7 +248,7 @@ testSearchCJK brig = do assertCanFind brig (User.userId searcher) user''.userQualifiedId "ジョン" assertCanFind brig (User.userId searcher) user''.userQualifiedId "じょん" -testSearchWithUmlaut :: TestConstraints m => Brig -> m () +testSearchWithUmlaut :: (TestConstraints m) => Brig -> m () testSearchWithUmlaut brig = do searcher <- randomUser brig user <- createUser' True "Özi Müller" brig @@ -256,7 +256,7 @@ testSearchWithUmlaut brig = do assertCanFind brig (User.userId searcher) user.userQualifiedId "ozi muller" assertCanFind brig (User.userId searcher) user.userQualifiedId "Özi Müller" -testSearchByHandle :: TestConstraints m => Brig -> m () +testSearchByHandle :: (TestConstraints m) => Brig -> m () testSearchByHandle brig = do u1 <- randomUserWithHandle brig u2 <- randomUser brig @@ -266,7 +266,7 @@ testSearchByHandle brig = do Just h = fromHandle <$> userHandle u1 assertCanFind brig uid2 quid1 h -testSearchEmpty :: TestConstraints m => Brig -> m () +testSearchEmpty :: (TestConstraints m) => Brig -> m () testSearchEmpty brig = do -- This user exists just in case empty string starts matching everything _someUser <- randomUserWithHandle brig @@ -275,7 +275,7 @@ testSearchEmpty brig = do res <- searchResults <$> executeSearch brig (userId searcher) "" liftIO $ assertEqual "nothing should be returned" [] res -testSearchSize :: TestConstraints m => Brig -> Bool -> m () +testSearchSize :: (TestConstraints m) => Brig -> Bool -> m () testSearchSize brig exactHandleInTeam = do (handleMatch, searchTerm) <- if exactHandleInTeam @@ -304,7 +304,7 @@ testSearchSize brig exactHandleInTeam = do Nothing (find ((userQualifiedId handleMatch ==) . contactQualifiedId) (tail res)) -testSearchNoMatch :: TestConstraints m => Brig -> m () +testSearchNoMatch :: (TestConstraints m) => Brig -> m () testSearchNoMatch brig = do u1 <- randomUser brig _ <- randomUser brig @@ -314,7 +314,7 @@ testSearchNoMatch brig = do result <- searchResults <$> executeSearch brig uid1 "nomatch" liftIO $ assertEqual "Expected 0 results" 0 (length result) -testSearchNoExtraResults :: TestConstraints m => Brig -> m () +testSearchNoExtraResults :: (TestConstraints m) => Brig -> m () testSearchNoExtraResults brig = do u1 <- randomUser brig u2 <- randomUser brig @@ -355,7 +355,7 @@ testReindex brig = do -- See also the "cassandra writetime hypothesis": -- https://wearezeta.atlassian.net/browse/BE-523 -- https://github.com/wireapp/wire-server/pull/1798#issuecomment-933174913 -_testOrderName :: TestConstraints m => Brig -> m () +_testOrderName :: (TestConstraints m) => Brig -> m () _testOrderName brig = do searcher <- userId <$> randomUser brig Name searchedWord <- randomNameWithMaxLen 122 @@ -372,7 +372,7 @@ _testOrderName brig = do expectedOrder resultUIds -testOrderHandle :: TestConstraints m => Brig -> m () +testOrderHandle :: (TestConstraints m) => Brig -> m () testOrderHandle brig = do searcher <- userId <$> randomUser brig searchedWord <- randomHandle @@ -390,7 +390,7 @@ testOrderHandle brig = do expectedOrder resultUIds -testSearchTeamMemberAsNonMemberDisplayName :: TestConstraints m => Manager -> Brig -> Galley -> FeatureStatus -> m () +testSearchTeamMemberAsNonMemberDisplayName :: (TestConstraints m) => Manager -> Brig -> Galley -> FeatureStatus -> m () testSearchTeamMemberAsNonMemberDisplayName mgr brig galley inboundVisibility = do nonTeamMember <- randomUser brig (tid, _, [teamMember, teamBTargetReindexedAfter]) <- createPopulatedBindingTeamWithNamesAndHandles brig 2 @@ -401,7 +401,7 @@ testSearchTeamMemberAsNonMemberDisplayName mgr brig galley inboundVisibility = d assertCan'tFind brig (userId nonTeamMember) (userQualifiedId teamMember) (fromName (userDisplayName teamMember)) assertCan'tFind brig (userId nonTeamMember) (userQualifiedId teamBTargetReindexedAfter) (fromName (userDisplayName teamBTargetReindexedAfter)) -testSearchTeamMemberAsNonMemberExactHandle :: TestConstraints m => Manager -> Brig -> Galley -> FeatureStatus -> m () +testSearchTeamMemberAsNonMemberExactHandle :: (TestConstraints m) => Manager -> Brig -> Galley -> FeatureStatus -> m () testSearchTeamMemberAsNonMemberExactHandle mgr brig galley inboundVisibility = do nonTeamMember <- randomUser brig (tid, _, [teamMember, teamMemberReindexedAfter]) <- createPopulatedBindingTeamWithNamesAndHandles brig 2 @@ -415,7 +415,7 @@ testSearchTeamMemberAsNonMemberExactHandle mgr brig galley inboundVisibility = d assertCanFind brig (userId nonTeamMember) (userQualifiedId teamMember) (fromHandle teamMemberHandle) assertCanFind brig (userId nonTeamMember) (userQualifiedId teamMemberReindexedAfter) (fromHandle teamMemberReindexedAfterHandle) -testSearchTeamMemberAsOtherMemberDisplayName :: TestConstraints m => Manager -> Brig -> Galley -> FeatureStatus -> m () +testSearchTeamMemberAsOtherMemberDisplayName :: (TestConstraints m) => Manager -> Brig -> Galley -> FeatureStatus -> m () testSearchTeamMemberAsOtherMemberDisplayName mgr brig galley inboundVisibility = do (_, _, [teamBSearcher]) <- createPopulatedBindingTeamWithNamesAndHandles brig 1 (tidA, _, [teamATarget, teamATargetReindexedAfter]) <- createPopulatedBindingTeamWithNamesAndHandles brig 2 @@ -433,7 +433,7 @@ testSearchTeamMemberAsOtherMemberDisplayName mgr brig galley inboundVisibility = FeatureStatusEnabled -> assertCanFind FeatureStatusDisabled -> assertCan'tFind -testSearchTeamMemberAsOtherMemberExactHandle :: TestConstraints m => Manager -> Brig -> Galley -> FeatureStatus -> m () +testSearchTeamMemberAsOtherMemberExactHandle :: (TestConstraints m) => Manager -> Brig -> Galley -> FeatureStatus -> m () testSearchTeamMemberAsOtherMemberExactHandle mgr brig galley inboundVisibility = do (_, _, [teamASearcher]) <- createPopulatedBindingTeamWithNamesAndHandles brig 1 (tidA, _, [teamATarget, teamATargetReindexedAfter]) <- createPopulatedBindingTeamWithNamesAndHandles brig 2 @@ -444,21 +444,21 @@ testSearchTeamMemberAsOtherMemberExactHandle mgr brig galley inboundVisibility = assertCanFind brig (userId teamASearcher) (userQualifiedId teamATarget) (fromHandle teamATargetHandle) assertCanFind brig (userId teamASearcher) (userQualifiedId teamATargetReindexedAfter) (fromHandle (fromJust (userHandle teamATargetReindexedAfter'))) -testSearchTeamMemberAsSameMember :: TestConstraints m => Manager -> Brig -> Galley -> FeatureStatus -> m () +testSearchTeamMemberAsSameMember :: (TestConstraints m) => Manager -> Brig -> Galley -> FeatureStatus -> m () testSearchTeamMemberAsSameMember mgr brig galley inboundVisibility = do (tid, _, [teamASearcher, teamATarget]) <- createPopulatedBindingTeam brig 2 circumventSettingsOverride mgr $ setTeamSearchVisibilityInboundAvailable galley tid inboundVisibility refreshIndex brig assertCanFind brig (userId teamASearcher) (userQualifiedId teamATarget) (fromName (userDisplayName teamATarget)) -testSeachNonMemberAsTeamMember :: TestConstraints m => Brig -> m () +testSeachNonMemberAsTeamMember :: (TestConstraints m) => Brig -> m () testSeachNonMemberAsTeamMember brig = do nonTeamMember <- randomUser brig (_, _, [teamMember]) <- createPopulatedBindingTeam brig 1 refreshIndex brig assertCanFind brig (userId teamMember) (userQualifiedId nonTeamMember) (fromName (userDisplayName nonTeamMember)) -testSearchOrderingAsTeamMemberExactMatch :: TestConstraints m => Brig -> m () +testSearchOrderingAsTeamMemberExactMatch :: (TestConstraints m) => Brig -> m () testSearchOrderingAsTeamMemberExactMatch brig = do searchedName <- randomName mapM_ (\(_ :: Int) -> createUser' True (fromName searchedName) brig) [0 .. 99] @@ -471,7 +471,7 @@ testSearchOrderingAsTeamMemberExactMatch brig = do Nothing -> assertFailure "team mate not found in search" Just teamSearcheeIndex -> assertEqual "teammate is not the first result" 0 teamSearcheeIndex -testSearchOrderingAsTeamMemberPrefixMatch :: TestConstraints m => Brig -> m () +testSearchOrderingAsTeamMemberPrefixMatch :: (TestConstraints m) => Brig -> m () testSearchOrderingAsTeamMemberPrefixMatch brig = do searchedName <- randomNameWithMaxLen 122 -- 6 characters for "suffix" mapM_ (\(i :: Int) -> createUser' True (fromName searchedName <> Text.pack (show i)) brig) [0 .. 99] @@ -484,7 +484,7 @@ testSearchOrderingAsTeamMemberPrefixMatch brig = do Nothing -> assertFailure "team mate not found in search" Just teamSearcheeIndex -> assertEqual "teammate is not the first result" 0 teamSearcheeIndex -testSearchOrderingAsTeamMemberWorseNameMatch :: TestConstraints m => Brig -> m () +testSearchOrderingAsTeamMemberWorseNameMatch :: (TestConstraints m) => Brig -> m () testSearchOrderingAsTeamMemberWorseNameMatch brig = do searchedTerm <- randomHandle _ <- createUser' True searchedTerm brig @@ -497,7 +497,7 @@ testSearchOrderingAsTeamMemberWorseNameMatch brig = do Nothing -> assertFailure "team mate not found in search" Just teamSearcheeIndex -> assertEqual "teammate is not the first result" 0 teamSearcheeIndex -testSearchOrderingAsTeamMemberWorseHandleMatch :: TestConstraints m => Brig -> m () +testSearchOrderingAsTeamMemberWorseHandleMatch :: (TestConstraints m) => Brig -> m () testSearchOrderingAsTeamMemberWorseHandleMatch brig = do searchedTerm <- randomHandle nonTeamSearchee <- createUser' True searchedTerm brig @@ -514,7 +514,7 @@ testSearchOrderingAsTeamMemberWorseHandleMatch brig = do Nothing -> assertFailure "team mate not found in search" Just teamSearcheeIndex -> assertEqual "teammate is not the second result" 1 teamSearcheeIndex -testSearchSameTeamOnly :: TestConstraints m => Brig -> Opt.Opts -> m () +testSearchSameTeamOnly :: (TestConstraints m) => Brig -> Opt.Opts -> m () testSearchSameTeamOnly brig opts = do nonTeamMember' <- randomUser brig nonTeamMember <- setRandomHandle brig nonTeamMember' @@ -557,7 +557,7 @@ testSearchNonMemberOutboundOnlyByHandle brig ((_, _, teamAMember), (_, _, _), no let teamMemberAHandle = fromMaybe (error "nonTeamMember must have a handle") (userHandle nonTeamMember) assertCanFind brig (userId teamAMember) (userQualifiedId nonTeamMember) (fromHandle teamMemberAHandle) -testSearchWithDomain :: TestConstraints m => Brig -> m () +testSearchWithDomain :: (TestConstraints m) => Brig -> m () testSearchWithDomain brig = do searcher <- randomUser brig searchee <- randomUser brig @@ -571,7 +571,7 @@ testSearchWithDomain brig = do -- | WARNING: this test only tests that brig will indeed make a call to federator -- (i.e. does the correct if/else branching based on the domain), -- it does not test any of the federation API details. This needs to be tested separately. -testSearchOtherDomain :: TestConstraints m => Opt.Opts -> Brig -> m () +testSearchOtherDomain :: (TestConstraints m) => Opt.Opts -> Brig -> m () testSearchOtherDomain opts brig = do user <- randomUser brig -- We cannot assert on a real federated request here, so we make a request to @@ -732,7 +732,7 @@ testWithBothIndices opts mgr name f = do test mgr "old-index" $ withOldIndex opts f ] -testWithBothIndicesAndOpts :: Opt.Opts -> Manager -> TestName -> (HasCallStack => Opt.Opts -> Http ()) -> TestTree +testWithBothIndicesAndOpts :: Opt.Opts -> Manager -> TestName -> ((HasCallStack) => Opt.Opts -> Http ()) -> TestTree testWithBothIndicesAndOpts opts mgr name f = testGroup name diff --git a/services/brig/test/integration/API/Search/Util.hs b/services/brig/test/integration/API/Search/Util.hs index 3141b4be83f..9f8c83b34e0 100644 --- a/services/brig/test/integration/API/Search/Util.hs +++ b/services/brig/test/integration/API/Search/Util.hs @@ -49,7 +49,7 @@ executeSearch' brig self q maybeDomain maybeSize = do Brig -> UserId -> Text -> Maybe Domain -> Maybe Int -> m ResponseLBS +searchRequest :: (MonadHttp m) => Brig -> UserId -> Text -> Maybe Domain -> Maybe Int -> m ResponseLBS searchRequest brig self q maybeDomain maybeSize = do get ( brig diff --git a/services/brig/test/integration/API/Settings.hs b/services/brig/test/integration/API/Settings.hs index f600817a0e8..1d350b08868 100644 --- a/services/brig/test/integration/API/Settings.hs +++ b/services/brig/test/integration/API/Settings.hs @@ -98,7 +98,7 @@ expectEmailVisible EmailVisibleToSelf = \case DifferentTeam -> False NoTeam -> False -jsonField :: FromJSON a => Key -> Value -> Maybe a +jsonField :: (FromJSON a) => Key -> Value -> Maybe a jsonField f u = u ^? key f >>= maybeFromJSON testUsersEmailVisibleIffExpected :: Opts -> Brig -> Galley -> ViewingUserIs -> EmailVisibilityConfig -> Http () diff --git a/services/brig/test/integration/API/Team.hs b/services/brig/test/integration/API/Team.hs index 350fb894d66..6eafdb1ed9c 100644 --- a/services/brig/test/integration/API/Team.hs +++ b/services/brig/test/integration/API/Team.hs @@ -35,10 +35,12 @@ import Control.Monad.Catch (MonadCatch) import Data.Aeson import Data.ByteString.Conversion import Data.ByteString.Lazy (toStrict) +import Data.Default (def) import Data.Either.Extra (eitherToMaybe) import Data.Id import Data.Json.Util (UTCTimeMillis, toUTCTimeMillis) import Data.LegalHold (UserLegalHoldStatus (UserLegalHoldDisabled)) +import Data.String.Conversions (cs) import Data.Text qualified as Text import Data.Text.Ascii qualified as Ascii import Data.Text.Encoding (encodeUtf8) @@ -98,7 +100,6 @@ tests conf m n b c g aws = do test m "post /teams/:tid/invitations - roles" $ testInvitationRoles b g, test m "post /register - 201 accepted" $ testInvitationEmailAccepted b g, test m "post /register - 201 accepted (with domain blocking customer extension)" $ testInvitationEmailAcceptedInBlockedDomain conf b g, - test m "post /register - 201 extended accepted" $ testInvitationEmailAndPhoneAccepted b g, test m "post /register user & team - 201 accepted" $ testCreateTeam b g aws, test m "post /register user & team - 201 preverified" $ testCreateTeamPreverified b g aws, test m "post /register - 400 no passwordless" $ testTeamNoPassword b, @@ -151,7 +152,7 @@ testTeamSize brig req = do SearchUtil.refreshIndex brig assertSize tid owner expectedSize where - assertSize :: HasCallStack => TeamId -> UserId -> Natural -> Http () + assertSize :: (HasCallStack) => TeamId -> UserId -> Natural -> Http () assertSize tid uid expectedSize = void $ get (req tid uid) ReceivedRequest -> MockT IO Wai.Response -invitationUrlGalleyMock featureStatus tid inviter (ReceivedRequest mth pth _body) +invitationUrlGalleyMock featureStatus tid inviter (ReceivedRequest mth pth body_) | mth == "GET" && pth == ["i", "teams", Text.pack (show tid), "features", "exposeInvitationURLsToTeamAdmin"] = pure . Wai.responseLBS HTTP.status200 mempty $ @@ -284,7 +285,18 @@ invitationUrlGalleyMock featureStatus tid inviter (ReceivedRequest mth pth _body && pth == ["i", "teams", Text.pack (show tid), "members", Text.pack (show inviter)] = pure . Wai.responseLBS HTTP.status200 mempty $ encode (mkTeamMember inviter fullPermissions Nothing UserLegalHoldDisabled) - | otherwise = pure $ Wai.responseLBS HTTP.status500 mempty "Unexpected request to mocked galley" + | mth == "GET" + && pth == ["i", "feature-configs"] = + pure $ Wai.responseLBS HTTP.status200 mempty (encode (def @AllFeatureConfigs)) + | otherwise = + let errBody = + encode . object $ + [ "msg" .= ("unexpecUnexpected request to mocked galley" :: Text), + "method" .= show mth, + "path" .= pth, + "body" .= (cs @_ @Text body_) + ] + in pure $ Wai.responseLBS HTTP.status500 mempty errBody -- FUTUREWORK: This test should be rewritten to be free of mocks once Galley is -- inlined into Brig. @@ -382,7 +394,7 @@ registerInvite brig tid inv invemail = do pure invitee -- | Admins can invite external partners, but not owners. -testInvitationRoles :: HasCallStack => Brig -> Galley -> Http () +testInvitationRoles :: (HasCallStack) => Brig -> Galley -> Http () testInvitationRoles brig galley = do (owner, tid) <- createUserWithTeam brig -- owner creates a member alice. @@ -432,29 +444,10 @@ testInvitationEmailAcceptedInBlockedDomain opts brig galley = do replacementBrigApp = withDomainsBlockedForRegistration opts [emailDomain inviteeEmail] void $ createAndVerifyInvitation' (Just replacementBrigApp) (accept (irInviteeEmail invite)) invite brig galley -testInvitationEmailAndPhoneAccepted :: Brig -> Galley -> Http () -testInvitationEmailAndPhoneAccepted brig galley = do - inviteeEmail <- randomEmail - inviteePhone <- randomPhone - -- Prepare the extended invitation - let stdInvite = stdInvitationRequest inviteeEmail - inviteeName = Name "Invited Member" - extInvite = stdInvite {irInviteePhone = Just inviteePhone, irInviteeName = Just inviteeName} - -- Register the same (pre verified) phone number - let phoneReq = RequestBodyLBS . encode $ object ["phone" .= fromPhone inviteePhone] - post (brig . path "/activate/send" . contentJson . body phoneReq) !!! (const 200 === statusCode) - Just (_, phoneCode) <- getActivationCode brig (Right inviteePhone) - -- Register the user with the extra supplied information - (profile, invitation) <- createAndVerifyInvitation (extAccept inviteeEmail inviteeName inviteePhone phoneCode) extInvite brig galley - liftIO $ assertEqual "Wrong name in profile" (Just inviteeName) (userDisplayName . selfUser <$> profile) - liftIO $ assertEqual "Wrong name in invitation" (Just inviteeName) (inInviteeName invitation) - liftIO $ assertEqual "Wrong phone number in profile" (Just inviteePhone) ((userPhone . selfUser) =<< profile) - liftIO $ assertEqual "Wrong phone number in invitation" (Just inviteePhone) (inInviteePhone invitation) - -- | FUTUREWORK: this is an alternative helper to 'createPopulatedBindingTeam'. it has been -- added concurrently, and the two should probably be consolidated. createAndVerifyInvitation :: - HasCallStack => + (HasCallStack) => (InvitationCode -> RequestBody) -> InvitationRequest -> Brig -> @@ -717,7 +710,7 @@ testInvitationTooManyMembers brig galley (TeamSizeLimit limit) = do const 403 === statusCode const (Just "too-many-team-members") === fmap Error.label . responseJsonMaybe -testInvitationPaging :: HasCallStack => Opt.Opts -> Brig -> Http () +testInvitationPaging :: (HasCallStack) => Opt.Opts -> Brig -> Http () testInvitationPaging opts brig = do before <- liftIO $ toUTCTimeMillis . addUTCTime (-1) <$> getCurrentTime (uid, tid) <- createUserWithTeam brig @@ -731,7 +724,7 @@ testInvitationPaging opts brig = do postInvitation brig tid uid (invite email) !!! const 201 === statusCode pure email after1ms <- liftIO $ toUTCTimeMillis . addUTCTime 1 <$> getCurrentTime - let getPages :: HasCallStack => Int -> Maybe InvitationId -> Int -> Http [[Invitation]] + let getPages :: (HasCallStack) => Int -> Maybe InvitationId -> Int -> Http [[Invitation]] getPages count start step = do let range = queryRange (toByteString' <$> start) (Just step) r <- @@ -742,7 +735,7 @@ testInvitationPaging opts brig = do if more then (invs :) <$> getPages (count + step) (fmap inInvitation . listToMaybe . reverse $ invs) step else pure [invs] - let checkSize :: HasCallStack => Int -> [Int] -> Http () + let checkSize :: (HasCallStack) => Int -> [Int] -> Http () checkSize pageSize expectedSizes = getPages 0 Nothing pageSize >>= \invss -> liftIO $ do assertEqual "page sizes" expectedSizes (take (length expectedSizes) (map length invss)) diff --git a/services/brig/test/integration/API/Team/Util.hs b/services/brig/test/integration/API/Team/Util.hs index 7fff7162fa9..61ab960962f 100644 --- a/services/brig/test/integration/API/Team/Util.hs +++ b/services/brig/test/integration/API/Team/Util.hs @@ -203,7 +203,7 @@ inviteAndRegisterUser u tid brig = do liftIO $ assertEqual "Team ID in self profile and team table do not match" selfTeam (Just tid) pure invitee -updatePermissions :: HasCallStack => UserId -> TeamId -> (UserId, Permissions) -> Galley -> Http () +updatePermissions :: (HasCallStack) => UserId -> TeamId -> (UserId, Permissions) -> Galley -> Http () updatePermissions from tid (to, perm) galley = put ( galley @@ -217,10 +217,10 @@ updatePermissions from tid (to, perm) galley = where changeMember = Member.mkNewTeamMember to perm Nothing -createTeamConv :: HasCallStack => Galley -> TeamId -> UserId -> [UserId] -> Maybe Milliseconds -> Http ConvId +createTeamConv :: (HasCallStack) => Galley -> TeamId -> UserId -> [UserId] -> Maybe Milliseconds -> Http ConvId createTeamConv = createTeamConvWithRole roleNameWireAdmin -createTeamConvWithRole :: HasCallStack => RoleName -> Galley -> TeamId -> UserId -> [UserId] -> Maybe Milliseconds -> Http ConvId +createTeamConvWithRole :: (HasCallStack) => RoleName -> Galley -> TeamId -> UserId -> [UserId] -> Maybe Milliseconds -> Http ConvId createTeamConvWithRole role g tid u us mtimer = do let tinfo = Just $ ConvTeamInfo tid let conv = @@ -250,7 +250,7 @@ createTeamConvWithRole role g tid u us mtimer = do fromByteString $ getHeader' "Location" r -deleteTeamConv :: HasCallStack => Galley -> TeamId -> ConvId -> UserId -> Http () +deleteTeamConv :: (HasCallStack) => Galley -> TeamId -> ConvId -> UserId -> Http () deleteTeamConv g tid cid u = do delete ( g @@ -261,7 +261,7 @@ deleteTeamConv g tid cid u = do !!! const 200 === statusCode -deleteTeam :: HasCallStack => Galley -> TeamId -> UserId -> Http () +deleteTeam :: (HasCallStack) => Galley -> TeamId -> UserId -> Http () deleteTeam g tid u = do delete ( g @@ -276,7 +276,7 @@ deleteTeam g tid u = do newTeam :: BindingNewTeam newTeam = BindingNewTeam $ newNewTeam (unsafeRange "teamName") DefaultIcon -putLegalHoldEnabled :: HasCallStack => TeamId -> FeatureStatus -> Galley -> Http () +putLegalHoldEnabled :: (HasCallStack) => TeamId -> FeatureStatus -> Galley -> Http () putLegalHoldEnabled tid enabled g = do void . put $ g @@ -285,7 +285,7 @@ putLegalHoldEnabled tid enabled g = do . lbytes (encode (Public.WithStatusNoLock enabled Public.LegalholdConfig Public.FeatureTTLUnlimited)) . expect2xx -putLHWhitelistTeam :: HasCallStack => Galley -> TeamId -> Http ResponseLBS +putLHWhitelistTeam :: (HasCallStack) => Galley -> TeamId -> Http ResponseLBS putLHWhitelistTeam galley tid = do put ( galley @@ -420,7 +420,7 @@ getInvitationCode brig t ref = do let lbs = fromMaybe "" $ responseBody r pure $ fromByteString (maybe (error "No code?") T.encodeUtf8 (lbs ^? key "code" . _String)) -assertNoInvitationCode :: HasCallStack => Brig -> TeamId -> InvitationId -> (MonadIO m, MonadHttp m, MonadCatch m) => m () +assertNoInvitationCode :: (HasCallStack) => Brig -> TeamId -> InvitationId -> (MonadIO m, MonadHttp m, MonadCatch m) => m () assertNoInvitationCode brig t i = get ( brig @@ -457,7 +457,7 @@ setTeamTeamSearchVisibilityAvailable galley tid status = !!! do const 200 === statusCode -setTeamSearchVisibility :: HasCallStack => Galley -> TeamId -> TeamSearchVisibility -> Http () +setTeamSearchVisibility :: (HasCallStack) => Galley -> TeamId -> TeamSearchVisibility -> Http () setTeamSearchVisibility galley tid typ = put ( galley diff --git a/services/brig/test/integration/API/TeamUserSearch.hs b/services/brig/test/integration/API/TeamUserSearch.hs index 84e2a8a3701..b70f59a4b17 100644 --- a/services/brig/test/integration/API/TeamUserSearch.hs +++ b/services/brig/test/integration/API/TeamUserSearch.hs @@ -53,7 +53,7 @@ tests opts mgr _galley brig = do where testWithNewIndex name f = test mgr name $ withSettingsOverrides opts f -testSearchByEmail :: TestConstraints m => Brig -> m (TeamId, UserId, User) -> Bool -> m () +testSearchByEmail :: (HasCallStack, TestConstraints m) => Brig -> m (TeamId, UserId, User) -> Bool -> m () testSearchByEmail brig mkSearcherAndSearchee canFind = do (tid, searcher, searchee) <- mkSearcherAndSearchee eml <- randomEmail @@ -63,14 +63,14 @@ testSearchByEmail brig mkSearcherAndSearchee canFind = do let check = if canFind then assertTeamUserSearchCanFind else assertTeamUserSearchCannotFind check brig tid searcher (userId searchee) (fromEmail eml) -testSearchByEmailSameTeam :: TestConstraints m => Brig -> m () +testSearchByEmailSameTeam :: (HasCallStack, TestConstraints m) => Brig -> m () testSearchByEmailSameTeam brig = do let mkSearcherAndSearchee = do (tid, userId -> ownerId, [u1]) <- createPopulatedBindingTeamWithNamesAndHandles brig 1 pure (tid, ownerId, u1) testSearchByEmail brig mkSearcherAndSearchee True -assertTeamUserSearchCanFind :: TestConstraints m => Brig -> TeamId -> UserId -> UserId -> Text -> m () +assertTeamUserSearchCanFind :: (TestConstraints m) => Brig -> TeamId -> UserId -> UserId -> Text -> m () assertTeamUserSearchCanFind brig teamid self expected q = do r <- searchResults <$> executeTeamUserSearch brig teamid self (Just q) Nothing Nothing Nothing liftIO $ do @@ -79,14 +79,14 @@ assertTeamUserSearchCanFind brig teamid self expected q = do assertBool ("User not in results for query: " <> show q) $ expected `elem` map teamContactUserId r -assertTeamUserSearchCannotFind :: TestConstraints m => Brig -> TeamId -> UserId -> UserId -> Text -> m () +assertTeamUserSearchCannotFind :: (TestConstraints m) => Brig -> TeamId -> UserId -> UserId -> Text -> m () assertTeamUserSearchCannotFind brig teamid self expected q = do r <- searchResults <$> executeTeamUserSearch brig teamid self (Just q) Nothing Nothing Nothing liftIO $ do assertBool ("User shouldn't be present in results for query: " <> show q) $ expected `notElem` map teamContactUserId r -testEmptyQuerySorted :: TestConstraints m => Brig -> m () +testEmptyQuerySorted :: (TestConstraints m) => Brig -> m () testEmptyQuerySorted brig = do (tid, userId -> ownerId, users) <- createPopulatedBindingTeamWithNamesAndHandles brig 4 refreshIndex brig @@ -99,7 +99,7 @@ testEmptyQuerySorted brig = do (sort (fmap teamContactUserId r)) liftIO $ assertEqual "sorted team contacts" (sortOn Down creationDates) creationDates -testSort :: TestConstraints m => Brig -> m () +testSort :: (TestConstraints m) => Brig -> m () testSort brig = do (tid, userId -> ownerId, usersImplicitOrder) <- createPopulatedBindingTeamWithNamesAndHandles brig 4 -- Shuffle here to guard against false positives in this test. @@ -131,7 +131,7 @@ testSort brig = do -- Creating test users for these cases is hard, so we skip it. -- This test checks that the search query at least succeeds and returns the users of the team (without testing correct order). -testSortCallSucceeds :: TestConstraints m => Brig -> m () +testSortCallSucceeds :: (TestConstraints m) => Brig -> m () testSortCallSucceeds brig = do (tid, userId -> ownerId, users) <- createPopulatedBindingTeamWithNamesAndHandles brig 4 refreshIndex brig @@ -140,7 +140,7 @@ testSortCallSucceeds brig = do r <- searchResults <$> executeTeamUserSearch brig tid ownerId Nothing Nothing (Just tuSortBy) (Just SortOrderAsc) liftIO $ assertEqual ("length of users sorted by " <> cs (toByteString tuSortBy)) n (length r) -testEmptyQuerySortedWithPagination :: TestConstraints m => Brig -> m () +testEmptyQuerySortedWithPagination :: (TestConstraints m) => Brig -> m () testEmptyQuerySortedWithPagination brig = do (tid, userId -> ownerId, _) <- createPopulatedBindingTeamWithNamesAndHandles brig 20 refreshIndex brig diff --git a/services/brig/test/integration/API/User/Account.hs b/services/brig/test/integration/API/User/Account.hs index 494ffecdc6e..8e46b4437dd 100644 --- a/services/brig/test/integration/API/User/Account.hs +++ b/services/brig/test/integration/API/User/Account.hs @@ -31,7 +31,6 @@ import Brig.AWS qualified as AWS import Brig.AWS.Types import Brig.Options qualified as Opt import Brig.Types.Activation -import Brig.Types.Common import Brig.Types.Intra import Control.Arrow ((&&&)) import Control.Exception (throw) @@ -51,7 +50,6 @@ import Data.Json.Util (fromUTCTimeMillis) import Data.LegalHold import Data.List.NonEmpty qualified as NonEmpty import Data.List1 (singleton) -import Data.List1 qualified as List1 import Data.Misc (plainTextPassword6Unsafe) import Data.Proxy import Data.Qualified @@ -86,7 +84,6 @@ import Wire.API.Asset hiding (Asset) import Wire.API.Asset qualified as Asset import Wire.API.Connection import Wire.API.Conversation -import Wire.API.Internal.Notification import Wire.API.Routes.MultiTablePaging import Wire.API.Team.Feature (ExposeInvitationURLsToTeamAdminConfig (..), FeatureStatus (..), FeatureTTL' (..), LockStatus (LockStatusLocked), withStatus) import Wire.API.Team.Invitation (Invitation (inInvitation)) @@ -104,7 +101,7 @@ tests _ at opts p b c ch g aws userJournalWatcher = [ test p "post /register - 201 (with preverified)" $ testCreateUserWithPreverified opts b userJournalWatcher, test p "testCreateUserWithInvalidVerificationCode - post /register - 400 (with preverified)" $ testCreateUserWithInvalidVerificationCode b, test p "post /register - 201" $ testCreateUser b g, - test p "post /register - 201 + no email" $ testCreateUserNoEmailNoPassword b, + test p "post /register - 400 + no email" $ testCreateUserNoEmailNoPassword b, test p "post /register - 201 anonymous" $ testCreateUserAnon b g, test p "testCreateUserEmptyName - post /register - 400 empty name" $ testCreateUserEmptyName b, test p "testCreateUserLongName - post /register - 400 name too long" $ testCreateUserLongName b, @@ -132,22 +129,17 @@ tests _ at opts p b c ch g aws userJournalWatcher = test p "post /list-users - 200" $ testMultipleUsers opts b, test p "put /self - 200" $ testUserUpdate b c userJournalWatcher, test p "put /access/self/email - 2xx" $ testEmailUpdate b userJournalWatcher, - test p "put /self/phone - 202" $ testPhoneUpdate b, - test p "put /self/phone - 403" $ testPhoneUpdateBlacklisted b, - test p "put /self/phone - 409" $ testPhoneUpdateConflict b, + test p "put /self/phone - 400" $ testPhoneUpdate b, test p "head /self/password - 200/404" $ testPasswordSet b, test p "put /self/password - 400" $ testPasswordSetInvalidPasswordLength b, test p "put /self/password - 200" $ testPasswordChange b, test p "put /self/locale - 200" $ testUserLocaleUpdate b userJournalWatcher, test p "post /activate/send - 200" $ testSendActivationCode opts b, test p "post /activate/send - 400 invalid input" $ testSendActivationCodeInvalidEmailOrPhone b, - test p "post /activate/send - 403 prefix excluded" $ testSendActivationCodePrefixExcluded b, - test p "post /i/users/phone-prefix" $ testInternalPhonePrefixes b, test p "put /i/users/:uid/status (suspend)" $ testSuspendUser b, - test p "get /i/users?:(email|phone) - 200" $ testGetByIdentity b, + test p "get /i/users?:email - 200" $ testGetByIdentity b, -- "get /i/users?:ids=...&includePendingInvitations=..." is tested in 'testCreateUserNoIdP', 'testCreateUserTimeout' -- in spar's integration tests, module "Test.Spar.Scim.UserSpec" - test p "delete/phone-email" $ testEmailPhoneDelete b c, test p "delete/by-password" $ testDeleteUserByPassword b c userJournalWatcher, test p "delete/with-legalhold" $ testDeleteUserWithLegalHold b c userJournalWatcher, test p "delete/by-code" $ testDeleteUserByCode b, @@ -185,7 +177,10 @@ testCreateUserWithInvalidVerificationCode brig = do "phone" .= fromPhone p, "phone_code" .= code ] - postUserRegister' regPhone brig !!! const 404 === statusCode + postUserRegister' regPhone brig !!! do + const 400 === statusCode + const (Just "invalid-phone") === fmap Wai.label . responseJsonMaybe + -- Attempt to register (pre verified) user with email e <- randomEmail let Object regEmail = @@ -247,29 +242,10 @@ testCreateUserWithPreverified opts brig userJournalWatcher = do p <- randomPhone let phoneReq = RequestBodyLBS . encode $ object ["phone" .= fromPhone p] post (brig . path "/activate/send" . contentJson . body phoneReq) - !!! (const 200 === statusCode) - getActivationCode brig (Right p) >>= \case - Nothing -> liftIO $ assertFailure "missing activation key/code" - Just (_, c) -> do - let Object reg = - object - [ "name" .= Name "Alice", - "phone" .= fromPhone p, - "phone_code" .= c - ] - if Opt.setRestrictUserCreation (Opt.optSettings opts) == Just True - then do - postUserRegister' reg brig !!! const 403 === statusCode - else do - usr <- postUserRegister reg brig - let uid = userId usr - let domain = Opt.setFederationDomain $ Opt.optSettings opts - get (brig . path "/self" . zUser uid) !!! do - const 200 === statusCode - const (Just p) === (userPhone <=< responseJsonMaybe) - -- check /self returns the qualified_id field in the response - const (Just (Qualified uid domain)) === (fmap userQualifiedId . responseJsonMaybe) - Util.assertUserActivateJournaled userJournalWatcher usr "user activate" + !!! do + const 400 === statusCode + const (Just "invalid-phone") === fmap Wai.label . responseJsonMaybe + -- Register (pre verified) user with email e <- randomEmail let emailReq = RequestBodyLBS . encode $ object ["email" .= fromEmail e] @@ -422,16 +398,11 @@ testCreateUserNoEmailNoPassword brig = do [ "name" .= ("Alice" :: Text), "phone" .= fromPhone p ] - rs <- - post (brig . path "/i/users" . contentJson . body newUser) - responseJsonMaybe rs - e <- randomEmail - Just code <- do - sendLoginCode brig p LoginCodeSMS False !!! const 200 === statusCode - getPhoneLoginCode brig p - initiateEmailUpdateLogin brig e (SmsLogin (SmsLoginData p code Nothing)) uid - !!! (const 202 === statusCode) + post + (brig . path "/i/users" . contentJson . body newUser) + !!! do + const 400 === statusCode + (const (Just "invalid-phone") === fmap Error.label . responseJsonMaybe) -- The testCreateUserConflict test conforms to the following testing standards: -- @@ -570,11 +541,11 @@ testActivateWithExpiry _ brig timeout = do awaitExpiry (round timeout + 5) kc activate brig kc !!! const 404 === statusCode where - actualBody :: HasCallStack => ResponseLBS -> Maybe (Maybe UserIdentity, Bool) + actualBody :: (HasCallStack) => ResponseLBS -> Maybe (Maybe UserIdentity, Bool) actualBody rs = do a <- responseJsonMaybe rs Just (Just (activatedIdentity a), activatedFirst a) - awaitExpiry :: HasCallStack => Int -> ActivationPair -> Http () + awaitExpiry :: (HasCallStack) => Int -> ActivationPair -> Http () awaitExpiry n kc = do liftIO $ threadDelay 1000000 r <- activate brig kc @@ -739,7 +710,7 @@ testMultipleUsersUnqualified brig = do Set.fromList . map (field "name" &&& field "email") <$> responseJsonMaybe r - field :: FromJSON a => Key -> Value -> Maybe a + field :: (FromJSON a) => Key -> Value -> Maybe a field f u = u ^? key f >>= maybeFromJSON testMultipleUsersV3 :: Brig -> Http () @@ -771,7 +742,7 @@ testMultipleUsersV3 brig = do Set.fromList . map (field "name" &&& field "email") <$> responseJsonMaybe r - field :: FromJSON a => Key -> Value -> Maybe a + field :: (FromJSON a) => Key -> Value -> Maybe a field f u = u ^? key f >>= maybeFromJSON testMultipleUsers :: Opt.Opts -> Brig -> Http () @@ -846,7 +817,7 @@ testCreateUserAnonExpiry :: Brig -> Http () testCreateUserAnonExpiry b = do u1 <- randomUser b alice <- randomUser b - bob <- createAnonUserExpiry (Just 2) "bob" b + bob <- createAnonUserExpiry (Just 5 {- 2 was flaky, so it's 5 now; make sure to re-align with 'awaitExpiry' below! -}) "bob" b liftIO $ assertBool "expiry not set on regular creation" (isNothing (userExpire alice)) ensureExpiry (fromUTCTimeMillis <$> userExpire bob) "bob/register" resAlice <- getProfile (userId u1) (userId alice) @@ -856,12 +827,13 @@ testCreateUserAnonExpiry b = do liftIO $ assertBool "Regular user should not have any expiry" (null $ expire resAlice) ensureExpiry (expire resBob) "bob/public" ensureExpiry (expire selfBob) "bob/self" - awaitExpiry 5 (userId u1) (userId bob) + awaitExpiry 10 (userId u1) (userId bob) resBob' <- getProfile (userId u1) (userId bob) liftIO $ assertBool "Bob must be in deleted state" (fromMaybe False $ deleted resBob') where getProfile :: UserId -> UserId -> Http ResponseLBS getProfile zusr uid = get (apiVersion "v1" . b . zUser zusr . paths ["users", toByteString' uid]) UserId -> UserId -> Http () awaitExpiry n zusr uid = do -- after expiration, a profile lookup should trigger garbage collection of ephemeral users @@ -869,6 +841,7 @@ testCreateUserAnonExpiry b = do when (statusCode r == 200 && isNothing (deleted r) && n > 0) $ do liftIO $ threadDelay 1000000 awaitExpiry (n - 1) zusr uid + ensureExpiry :: Maybe UTCTime -> String -> Http () ensureExpiry expiry s = do now <- liftIO getCurrentTime @@ -880,14 +853,17 @@ testCreateUserAnonExpiry b = do maxExp = 60 * 60 * 24 * 10 :: Integer -- 10 days liftIO $ assertBool "expiry must be in the future" (diff >= fromIntegral minExp) liftIO $ assertBool "expiry must be less than 10 days" (diff < fromIntegral maxExp) + expire :: ResponseLBS -> Maybe UTCTime expire r = field "expires_at" =<< responseJsonMaybe r + deleted :: ResponseLBS -> Maybe Bool deleted r = field "deleted" =<< responseJsonMaybe r - field :: FromJSON a => Key -> Value -> Maybe a + + field :: (FromJSON a) => Key -> Value -> Maybe a field f u = u ^? key f >>= maybeFromJSON -testUserUpdate :: HasCallStack => Brig -> Cannon -> UserJournalWatcher -> Http () +testUserUpdate :: (HasCallStack) => Brig -> Cannon -> UserJournalWatcher -> Http () testUserUpdate brig cannon userJournalWatcher = do aliceUser <- randomUser brig Util.assertUserActivateJournaled userJournalWatcher aliceUser "user create alice" @@ -990,37 +966,6 @@ testPhoneUpdate brig = do -- check new phone get (brig . path "/self" . zUser uid) !!! do const 200 === statusCode - const (Just phn) === (userPhone <=< responseJsonMaybe) - -testPhoneUpdateBlacklisted :: Brig -> Http () -testPhoneUpdateBlacklisted brig = do - uid <- userId <$> randomUser brig - phn <- randomPhone - let prefix = mkPrefix $ T.take 5 (fromPhone phn) - - insertPrefix brig prefix - let phoneUpdate = RequestBodyLBS . encode $ PhoneUpdate phn - put (brig . path "/self/phone" . contentJson . zUser uid . zConn "c" . body phoneUpdate) - !!! (const 403 === statusCode) - - -- check that phone is not updated - get (brig . path "/self" . zUser uid) !!! do - const 200 === statusCode - const (Right Nothing) === fmap userPhone . responseJsonEither - - -- cleanup to avoid other tests failing sporadically - deletePrefix brig (phonePrefix prefix) - -testPhoneUpdateConflict :: Brig -> Http () -testPhoneUpdateConflict brig = do - uid1 <- userId <$> randomUser brig - phn <- randomPhone - updatePhone brig uid1 phn - - uid2 <- userId <$> randomUser brig - let phoneUpdate = RequestBodyLBS . encode $ PhoneUpdate phn - put (brig . path "/self/phone" . contentJson . zUser uid2 . zConn "c" . body phoneUpdate) - !!! (const 409 === statusCode) testCreateAccountPendingActivationKey :: Opt.Opts -> Brig -> Http () testCreateAccountPendingActivationKey (Opt.setRestrictUserCreation . Opt.optSettings -> Just True) _ = pure () @@ -1030,23 +975,9 @@ testCreateAccountPendingActivationKey _ brig = do -- update phone let phoneUpdate = RequestBodyLBS . encode $ PhoneUpdate phn put (brig . path "/self/phone" . contentJson . zUser uid . zConn "c" . body phoneUpdate) - !!! (const 202 === statusCode) - -- create a new user with that phone/code - act <- getActivationCode brig (Right phn) - case act of - Nothing -> liftIO $ assertFailure "missing activation key/code" - Just kc@(_, c) -> do - let p = - RequestBodyLBS . encode $ - object - [ "name" .= ("foo" :: Text), - "phone" .= phn, - "phone_code" .= c - ] - post (brig . path "/register" . contentJson . body p) - !!! const 201 === statusCode - -- try to activate already active phone - activate brig kc !!! const 409 === statusCode + !!! do + const 400 === statusCode + const (Just "invalid-phone") === fmap Error.label . responseJsonMaybe testUserLocaleUpdate :: Brig -> UserJournalWatcher -> Http () testUserLocaleUpdate brig userJournalWatcher = do @@ -1057,6 +988,10 @@ testUserLocaleUpdate brig userJournalWatcher = do let locEN = fromMaybe (error "Failed to parse locale") $ parseLocale "en-US" put (brig . path "/self/locale" . contentJson . zUser uid . zConn "c" . locale locEN) !!! const 200 === statusCode + get (brig . path "/self" . contentJson . zUser uid . zConn "c") + !!! do + const 200 === statusCode + const (Just locEN) === (Just . userLocale . selfUser <=< responseJsonMaybe) Util.assertLocaleUpdateJournaled userJournalWatcher uid locEN "user update" -- update locale info with locale NOT supported in templates let locPT = fromMaybe (error "Failed to parse locale") $ parseLocale "pt-PT" @@ -1096,15 +1031,12 @@ testSuspendUser brig = do testGetByIdentity :: Brig -> Http () testGetByIdentity brig = do - p <- randomPhone e <- randomEmail let emailBs = T.encodeUtf8 $ fromEmail e - phoneBs = T.encodeUtf8 $ fromPhone p newUser = RequestBodyLBS . encode $ object [ "name" .= ("Alice" :: Text), - "phone" .= fromPhone p, "email" .= fromEmail e ] rs <- @@ -1114,20 +1046,17 @@ testGetByIdentity brig = do get (brig . zUser uid . path "i/users" . queryItem "email" emailBs) !!! do const 200 === statusCode const (Just [uid]) === getUids - get (brig . zUser uid . path "i/users" . queryItem "phone" phoneBs) !!! do - const 200 === statusCode - const (Just [uid]) === getUids where getUids r = fmap (userId . accountUser) <$> responseJsonMaybe r testPasswordSet :: Brig -> Http () testPasswordSet brig = do - p <- randomPhone + e <- randomEmail let newUser = RequestBodyLBS . encode $ object [ "name" .= ("Alice" :: Text), - "phone" .= fromPhone p + "email" .= fromEmail e ] rs <- post (brig . path "/i/users" . contentJson . body newUser) @@ -1151,12 +1080,12 @@ testPasswordSet brig = do testPasswordSetInvalidPasswordLength :: Brig -> Http () testPasswordSetInvalidPasswordLength brig = do - p <- randomPhone + e <- randomEmail let newUser = RequestBodyLBS . encode $ object [ "name" .= ("Alice" :: Text), - "phone" .= fromPhone p + "email" .= fromEmail e ] rs <- post (brig . path "/i/users" . contentJson . body newUser) @@ -1212,7 +1141,7 @@ testPasswordChange brig = do testSendActivationCode :: Opt.Opts -> Brig -> Http () testSendActivationCode opts brig = do -- Code for phone pre-verification - requestActivationCode brig 200 . Right =<< randomPhone + requestActivationCode brig 400 . Right =<< randomPhone -- Code for email pre-verification requestActivationCode brig 200 . Left =<< randomEmail -- Standard email registration flow @@ -1234,113 +1163,6 @@ testSendActivationCodeInvalidEmailOrPhone brig = do -- Code for email pre-verification requestActivationCode brig 400 (Left invalidEmail) -testSendActivationCodePrefixExcluded :: Brig -> Http () -testSendActivationCodePrefixExcluded brig = do - p <- randomPhone - let prefix = mkPrefix $ T.take 5 (fromPhone p) - -- expect activation to fail after it was excluded - insertPrefix brig prefix - requestActivationCode brig 403 (Right p) - -- expect activation to work again after removing block - deletePrefix brig (phonePrefix prefix) - requestActivationCode brig 200 (Right p) - -testInternalPhonePrefixes :: Brig -> Http () -testInternalPhonePrefixes brig = do - -- prefix1 is a prefix of prefix2 - let prefix1 = mkPrefix "+5678" - prefix2 = mkPrefix "+56789" - insertPrefix brig prefix1 - insertPrefix brig prefix2 - -- test getting prefixs - res <- getPrefixes prefix1 - liftIO $ assertEqual "prefix match prefix" res [prefix1] - -- we expect both prefixes returned when searching for the longer one - res2 <- getPrefixes prefix2 - liftIO $ assertEqual "prefix match phone number" res2 [prefix1, prefix2] - deletePrefix brig (phonePrefix prefix1) - deletePrefix brig (phonePrefix prefix2) - getPrefix (phonePrefix prefix1) !!! const 404 === statusCode - where - getPrefixes :: ExcludedPrefix -> Http [ExcludedPrefix] - getPrefixes prefix = responseJsonError =<< getPrefix (phonePrefix prefix) - getPrefix :: PhonePrefix -> Http ResponseLBS - getPrefix prefix = get (brig . paths ["/i/users/phone-prefixes", toByteString' prefix]) - -mkPrefix :: Text -> ExcludedPrefix -mkPrefix t = ExcludedPrefix (PhonePrefix t) "comment" - -insertPrefix :: Brig -> ExcludedPrefix -> Http () -insertPrefix brig prefix = do - let payload = body $ RequestBodyLBS (encode prefix) - post (brig . path "/i/users/phone-prefixes" . contentJson . payload) !!! const 200 === statusCode - -deletePrefix :: Brig -> PhonePrefix -> Http () -deletePrefix brig prefix = delete (brig . paths ["/i/users/phone-prefixes", toByteString' prefix]) !!! const 200 === statusCode - -testEmailPhoneDelete :: Brig -> Cannon -> Http () -testEmailPhoneDelete brig cannon = do - user <- randomUser brig - let uid = userId user - let Just email = userEmail user - (cky, tok) <- do - rsp <- - login brig (emailLogin email defPassword Nothing) PersistentCookie - liftIO $ assertFailure "missing activation key/code" - Just kc -> activate brig kc !!! const 200 === statusCode - -- Remove the email - WS.bracketR cannon uid $ \ws -> do - delete (brig . path "/self/email" . zUser uid . zConn "c") - !!! (const 200 === statusCode) - void . liftIO . WS.assertMatch (5 # Second) ws $ \n -> do - let j = Object $ List1.head (ntfPayload n) - let etype = j ^? key "type" . _String - let euser = j ^? key "user" . key "id" . _String - let eemail = j ^? key "user" . key "email" . _String - etype @?= Just "user.identity-remove" - euser @?= Just (UUID.toText (toUUID uid)) - eemail @?= Just (fromEmail email) - get (brig . path "/self" . zUser uid) !!! do - const 200 === statusCode - const Nothing === (userEmail <=< responseJsonMaybe) - -- Cannot remove the only remaining identity - delete (brig . path "/self/phone" . zUser uid . zConn "c") - !!! const 403 === statusCode - -- Add back a new email address - eml <- randomEmail - initiateEmailUpdateCreds brig eml (cky, tok) uid !!! (const 202 === statusCode) - act' <- getActivationCode brig (Left eml) - case act' of - Nothing -> liftIO $ assertFailure "missing activation key/code" - Just kc -> activate brig kc !!! const 200 === statusCode - -- Remove the phone number - WS.bracketR cannon uid $ \ws -> do - delete (brig . path "/self/phone" . zUser uid . zConn "c") - !!! const 200 === statusCode - void . liftIO . WS.assertMatch (5 # Second) ws $ \n -> do - let j = Object $ List1.head (ntfPayload n) - let etype = j ^? key "type" . _String - let euser = j ^? key "user" . key "id" . _String - let ephone = j ^? key "user" . key "phone" . _String - etype @?= Just "user.identity-remove" - euser @?= Just (UUID.toText (toUUID uid)) - ephone @?= Just (fromPhone phone) - get (brig . path "/self" . zUser uid) !!! do - const 200 === statusCode - const Nothing === (userPhone <=< responseJsonMaybe) - testDeleteUserByPassword :: Brig -> Cannon -> UserJournalWatcher -> Http () testDeleteUserByPassword brig cannon userJournalWatcher = do u <- randomUser brig @@ -1471,7 +1293,7 @@ testUpdateSSOId brig galley = do . Bilge.json (UserSSOId (mkSampleUref "1" "1")) ) !!! const 404 === statusCode - let go :: HasCallStack => User -> UserSSOId -> Http () + let go :: (HasCallStack) => User -> UserSSOId -> Http () go user ssoid = do let uid = userId user put @@ -1481,11 +1303,10 @@ testUpdateSSOId brig galley = do ) !!! const 200 === statusCode profile :: SelfProfile <- responseJsonError =<< get (brig . path "/self" . zUser uid) - let Just (SSOIdentity ssoid' mEmail mPhone) = userIdentity . selfUser $ profile + let Just (SSOIdentity ssoid' mEmail) = userIdentity . selfUser $ profile liftIO $ do assertEqual "updateSSOId/ssoid" ssoid ssoid' assertEqual "updateSSOId/email" (userEmail user) mEmail - assertEqual "updateSSOId/phone" (userPhone user) mPhone (owner, teamid) <- createUserWithTeam brig let mkMember :: Bool -> Bool -> Http User mkMember hasEmail hasPhone = do @@ -1499,11 +1320,9 @@ testUpdateSSOId brig galley = do ssoids2 = [UserSSOId (mkSampleUref "2" "1"), UserSSOId (mkSampleUref "2" "2")] users <- sequence - [ mkMember True False, - mkMember True True - -- the following two could be implemented by creating the user implicitly via SSO login. - -- , mkMember False False - -- , mkMember False True + [ mkMember True False + -- the following two could be implemented by creating the user implicitly via SSO login. + -- , mkMember False False ] zipWithM_ go users ssoids1 zipWithM_ go users ssoids2 @@ -1669,7 +1488,7 @@ testDeleteUserWithNoUser brig = do !!! do const 404 === statusCode -testDeleteUserWithNotDeletedUser :: HasCallStack => Brig -> Cannon -> UserJournalWatcher -> Http () +testDeleteUserWithNotDeletedUser :: (HasCallStack) => Brig -> Cannon -> UserJournalWatcher -> Http () testDeleteUserWithNotDeletedUser brig cannon userJournalWatcher = do u <- randomUser brig Util.assertUserActivateJournaled userJournalWatcher u "user activate testDeleteUserWithNotDeletedUser" @@ -1702,7 +1521,7 @@ testDeleteUserWithDanglingProperty brig cannon userJournalWatcher = do const 200 === statusCode const (Just objectProp) === responseJsonMaybe - execAndAssertUserDeletion brig cannon u (Handle hdl) [] userJournalWatcher $ \uid' -> do + execAndAssertUserDeletion brig cannon u (fromJust (parseHandle hdl)) [] userJournalWatcher $ \uid' -> do deleteUserInternal uid' brig !!! do const 202 === statusCode @@ -1727,7 +1546,7 @@ setHandleAndDeleteUser brig cannon u others userJournalWatcher execDelete = do put (brig . path "/self/handle" . contentJson . zUser uid . zConn "c" . body update) !!! const 200 === statusCode - execAndAssertUserDeletion brig cannon u (Handle hdl) others userJournalWatcher execDelete + execAndAssertUserDeletion brig cannon u (fromJust (parseHandle hdl)) others userJournalWatcher execDelete execAndAssertUserDeletion :: Brig -> Cannon -> User -> Handle -> [UserId] -> UserJournalWatcher -> (UserId -> HttpT IO ()) -> Http () execAndAssertUserDeletion brig cannon u hdl others userJournalWatcher execDelete = do diff --git a/services/brig/test/integration/API/User/Auth.hs b/services/brig/test/integration/API/User/Auth.hs index 8a23e8cbb27..966481ef84d 100644 --- a/services/brig/test/integration/API/User/Auth.hs +++ b/services/brig/test/integration/API/User/Auth.hs @@ -28,9 +28,7 @@ import API.Team.Util import Bilge hiding (body) import Bilge qualified as Http import Bilge.Assert hiding (assert) -import Brig.Code qualified as Code import Brig.Options qualified as Opts -import Brig.User.Auth.Cookie (revokeAllCookies) import Brig.ZAuth (ZAuth, runZAuth) import Brig.ZAuth qualified as ZAuth import Cassandra hiding (Value) @@ -42,7 +40,7 @@ import Data.Aeson as Aeson hiding (json) import Data.ByteString qualified as BS import Data.ByteString.Conversion import Data.ByteString.Lazy qualified as Lazy -import Data.Handle (Handle (Handle)) +import Data.Handle (parseHandle) import Data.Id import Data.Misc (PlainTextPassword6, plainTextPassword6, plainTextPassword6Unsafe) import Data.Proxy @@ -62,7 +60,7 @@ import Test.Tasty.HUnit qualified as HUnit import UnliftIO.Async hiding (wait) import Util import Wire.API.Conversation (Conversation (..)) -import Wire.API.Password (Password, mkSafePassword) +import Wire.API.Password (Password, mkSafePasswordScrypt) import Wire.API.User as Public import Wire.API.User.Auth as Auth import Wire.API.User.Auth.LegalHold @@ -76,7 +74,7 @@ import Wire.API.User.Client -- with this are failing then assumption that -- 'whitelist-teams-and-implicit-consent' is set in all test environments is no -- longer correct. -onlyIfLhWhitelisted :: MonadIO m => m () -> m () +onlyIfLhWhitelisted :: (MonadIO m) => m () -> m () onlyIfLhWhitelisted action = do let isGalleyLegalholdFeatureWhitelist = True if isGalleyLegalholdFeatureWhitelist @@ -191,23 +189,29 @@ testLoginWith6CharPassword brig db = do -- we need to write this directly to the db, to be able to test this writeDirectlyToDB :: UserId -> PlainTextPassword6 -> Http () writeDirectlyToDB uid pw = - liftIO (runClient db (updatePassword uid pw >> revokeAllCookies uid)) + liftIO (runClient db (updatePassword uid pw >> deleteAllCookies uid)) - updatePassword :: MonadClient m => UserId -> PlainTextPassword6 -> m () + updatePassword :: (MonadClient m) => UserId -> PlainTextPassword6 -> m () updatePassword u t = do - p <- liftIO $ mkSafePassword t + p <- liftIO $ mkSafePasswordScrypt t retry x5 $ write userPasswordUpdate (params LocalQuorum (p, u)) userPasswordUpdate :: PrepQuery W (Password, UserId) () userPasswordUpdate = {- `IF EXISTS`, but that requires benchmarking -} "UPDATE user SET password = ? WHERE id = ?" + deleteAllCookies :: (MonadClient m) => UserId -> m () + deleteAllCookies u = retry x5 (write cql (params LocalQuorum (Identity u))) + where + cql :: PrepQuery W (Identity UserId) () + cql = "DELETE FROM user_cookies WHERE user = ?" + -------------------------------------------------------------------------------- -- ZAuth test environment for generating arbitrary tokens. -randomAccessToken :: forall u a. ZAuth.TokenPair u a => ZAuth (ZAuth.Token a) +randomAccessToken :: forall u a. (ZAuth.TokenPair u a) => ZAuth (ZAuth.Token a) randomAccessToken = randomUserToken @u >>= ZAuth.newAccessToken -randomUserToken :: ZAuth.UserTokenLike u => ZAuth (ZAuth.Token u) +randomUserToken :: (ZAuth.UserTokenLike u) => ZAuth (ZAuth.Token u) randomUserToken = do r <- Id <$> liftIO UUID.nextRandom ZAuth.newUserToken r Nothing @@ -302,7 +306,7 @@ testNginzMultipleCookies :: Opts.Opts -> Brig -> Nginz -> Http () testNginzMultipleCookies o b n = do u <- randomUser b let Just email = userEmail u - dologin :: HasCallStack => Http ResponseLBS + dologin :: (HasCallStack) => Http ResponseLBS dologin = login n (defEmailLogin email) PersistentCookie c {cookie_value = "ThisIsNotAZauthCookie"}) . decodeCookie <$> dologin badCookie1 <- (\c -> c {cookie_value = "SKsjKQbiqxuEugGMWVbq02fNEA7QFdNmTiSa1Y0YMgaEP5tWl3nYHWlIrM5F8Tt7Cfn2Of738C7oeiY8xzPHAB==.v=1.k=1.d=1.t=u.l=.u=13da31b4-c6bb-4561-8fed-07e728fa6cc5.r=f844b420"}) . decodeCookie <$> dologin @@ -362,15 +366,11 @@ testPhoneLogin brig = do [ "name" .= ("Alice" :: Text), "phone" .= fromPhone p ] + -- phone logins are not supported anymore post (brig . path "/i/users" . contentJson . Http.body newUser) - !!! const 201 === statusCode - sendLoginCode brig p LoginCodeSMS False !!! const 200 === statusCode - code <- getPhoneLoginCode brig p - case code of - Nothing -> liftIO $ assertFailure "missing login code" - Just c -> - login brig (SmsLogin (SmsLoginData p c Nothing)) PersistentCookie - !!! const 200 === statusCode + !!! do + const 400 === statusCode + const (Just "invalid-phone") === errorLabel testHandleLogin :: Brig -> Http () testHandleLogin brig = do @@ -379,7 +379,7 @@ testHandleLogin brig = do let update = RequestBodyLBS . encode $ HandleUpdate hdl put (brig . path "/self/handle" . contentJson . zUser usr . zConn "c" . Http.body update) !!! const 200 === statusCode - let l = PasswordLogin (PasswordLoginData (LoginByHandle (Handle hdl)) defPassword Nothing Nothing) + let l = PasswordLogin (PasswordLoginData (LoginByHandle (fromJust $ parseHandle hdl)) defPassword Nothing Nothing) login brig l PersistentCookie !!! const 200 === statusCode -- | Check that local part after @+@ is ignored by equality on email addresses if the domain is @@ -403,24 +403,9 @@ testSendLoginCode brig = do "password" .= ("topsecretdefaultpassword" :: Text) ] post (brig . path "/i/users" . contentJson . Http.body newUser) - !!! const 201 === statusCode - -- Unless forcing it, SMS/voice code login is not permitted if - -- the user has a password. - sendLoginCode brig p LoginCodeSMS False !!! do - const 403 === statusCode - const (Just "password-exists") === errorLabel - rsp1 <- - sendLoginCode brig p LoginCodeSMS True - responseJsonMaybe rsp1 - liftIO $ assertEqual "timeout" (Just (Code.Timeout 600)) _timeout - -- Retry with a voice call - rsp2 <- - sendLoginCode brig p LoginCodeVoice True - responseJsonMaybe rsp2 - liftIO $ assertEqual "timeout" (Just (Code.Timeout 600)) _timeout + !!! do + const 400 === statusCode + const (Just "invalid-phone") === errorLabel -- The testLoginFailure test conforms to the following testing standards: -- @@ -478,7 +463,7 @@ testThrottleLogins conf b = do -- successfully log in again. Furthermore, the test asserts that another -- unrelated user can successfully log-in in parallel to the failed attempts of -- the aforementioned user. -testLimitRetries :: HasCallStack => Opts.Opts -> Brig -> Http () +testLimitRetries :: (HasCallStack) => Opts.Opts -> Brig -> Http () testLimitRetries conf brig = do let Just opts = Opts.setLimitFailedLogins . Opts.optSettings $ conf unless (Opts.timeout opts <= 30) $ @@ -535,7 +520,7 @@ testRegularUserLegalHoldLogin brig = do legalHoldLogin brig (LegalHoldLogin uid (Just defPassword) Nothing) PersistentCookie !!! do const 403 === statusCode -testTeamUserLegalHoldLogin :: HasCallStack => Brig -> Galley -> Http () +testTeamUserLegalHoldLogin :: (HasCallStack) => Brig -> Galley -> Http () testTeamUserLegalHoldLogin brig galley = do -- create team user Alice (alice, tid) <- createUserWithTeam brig @@ -652,7 +637,7 @@ testNoUserSsoLogin brig = do -- The testInvalidCookie test conforms to the following testing standards: -- -- Test that invalid and expired tokens do not work. -testInvalidCookie :: forall u. ZAuth.UserTokenLike u => ZAuth.Env -> Brig -> Http () +testInvalidCookie :: forall u. (ZAuth.UserTokenLike u) => ZAuth.Env -> Brig -> Http () testInvalidCookie z b = do -- Syntactically invalid post (unversioned . b . path "/access" . cookieRaw "zuid" "xxx") !!! do @@ -682,7 +667,7 @@ testInvalidToken z b = do const 403 === statusCode const (Just "Invalid access token") =~= responseBody -testMissingCookie :: forall u a. ZAuth.TokenPair u a => ZAuth.Env -> Brig -> Http () +testMissingCookie :: forall u a. (ZAuth.TokenPair u a) => ZAuth.Env -> Brig -> Http () testMissingCookie z b = do -- Missing cookie, i.e. token refresh mandates a cookie. post (unversioned . b . path "/access") @@ -698,7 +683,7 @@ testMissingCookie z b = do const (Just "Missing cookie") =~= responseBody const (Just "invalid-credentials") =~= responseBody -testUnknownCookie :: forall u. ZAuth.UserTokenLike u => ZAuth.Env -> Brig -> Http () +testUnknownCookie :: forall u. (ZAuth.UserTokenLike u) => ZAuth.Env -> Brig -> Http () testUnknownCookie z b = do -- Valid cookie but unknown to the server. t <- toByteString' <$> runZAuth z (randomUserToken @u) @@ -1064,7 +1049,7 @@ testNewSessionCookie config b = do const 200 === statusCode const Nothing === getHeader "Set-Cookie" -testSuspendInactiveUsers :: HasCallStack => Opts.Opts -> Brig -> CookieType -> String -> Http () +testSuspendInactiveUsers :: (HasCallStack) => Opts.Opts -> Brig -> CookieType -> String -> Http () testSuspendInactiveUsers config brig cookieType endPoint = do -- (context information: cookies are stored by user, not by device; so if there is a -- cookie that is old, it means none of the devices of the user has used it for a request.) @@ -1278,10 +1263,10 @@ getCookieId c = (CookieId . ZAuth.userTokenRand @u) (fromByteString (cookie_value c)) -listCookies :: HasCallStack => Brig -> UserId -> Http [Auth.Cookie ()] +listCookies :: (HasCallStack) => Brig -> UserId -> Http [Auth.Cookie ()] listCookies b u = listCookiesWithLabel b u [] -listCookiesWithLabel :: HasCallStack => Brig -> UserId -> [CookieLabel] -> Http [Auth.Cookie ()] +listCookiesWithLabel :: (HasCallStack) => Brig -> UserId -> [CookieLabel] -> Http [Auth.Cookie ()] listCookiesWithLabel b u l = do rs <- get @@ -1299,7 +1284,7 @@ listCookiesWithLabel b u l = do -- | Check that the cookie returned after login is sane. -- -- Doesn't check everything, just some basic properties. -assertSanePersistentCookie :: forall u. ZAuth.UserTokenLike u => Http.Cookie -> Assertion +assertSanePersistentCookie :: forall u. (ZAuth.UserTokenLike u) => Http.Cookie -> Assertion assertSanePersistentCookie ck = do assertBool "type" (cookie_persistent ck) assertBool "http-only" (cookie_http_only ck) @@ -1312,7 +1297,7 @@ assertSanePersistentCookie ck = do -- | Check that the access token returned after login is sane. assertSaneAccessToken :: - ZAuth.AccessTokenLike a => + (ZAuth.AccessTokenLike a) => -- | Some moment in time before the user was created UTCTime -> UserId -> @@ -1334,5 +1319,5 @@ remJson p l ids = "ids" .= ids ] -wait :: MonadIO m => m () +wait :: (MonadIO m) => m () wait = liftIO $ threadDelay 1000000 diff --git a/services/brig/test/integration/API/User/Client.hs b/services/brig/test/integration/API/User/Client.hs index b7bbd4c2cd1..fef7075b728 100644 --- a/services/brig/test/integration/API/User/Client.hs +++ b/services/brig/test/integration/API/User/Client.hs @@ -30,7 +30,6 @@ import API.User.Util import API.User.Util qualified as Util import Bilge hiding (accept, head, timeout) import Bilge.Assert -import Brig.Code qualified as Code import Brig.Options qualified as Opt import Brig.Options qualified as Opts import Cassandra qualified as DB @@ -41,6 +40,7 @@ import Data.Aeson qualified as A import Data.Aeson.KeyMap qualified as M import Data.Aeson.Lens import Data.ByteString.Conversion +import Data.Code qualified as Code import Data.Coerce (coerce) import Data.Default import Data.Domain (Domain (..)) @@ -83,6 +83,8 @@ import Wire.API.User.Client.DPoPAccessToken import Wire.API.User.Client.Prekey import Wire.API.UserMap (QualifiedUserMap (..), UserMap (..), WrappedQualifiedUserMap) import Wire.API.Wrapped (Wrapped (..)) +import Wire.VerificationCode qualified as Code +import Wire.VerificationCodeGen tests :: ConnectionLimit -> Opt.Timeout -> Opt.Opts -> Manager -> DB.ClientState -> Nginz -> Brig -> Cannon -> Galley -> TestTree tests _cl _at opts p db n b c g = @@ -151,7 +153,7 @@ testAddGetClientVerificationCode db brig galley = do Util.setTeamFeatureLockStatus @Public.SndFactorPasswordChallengeConfig galley tid Public.LockStatusUnlocked Util.setTeamSndFactorPasswordChallenge galley tid Public.FeatureStatusEnabled Util.generateVerificationCode brig (Public.SendVerificationCode Public.Login email) - k <- Code.mkKey (Code.ForEmail email) + let k = mkKey email codeValue <- Code.codeValue <$$> lookupCode db k Code.AccountLogin checkLoginSucceeds $ PasswordLogin $ @@ -207,8 +209,8 @@ testAddGetClientCodeExpired db opts brig galley = do Util.setTeamFeatureLockStatus @Public.SndFactorPasswordChallengeConfig galley tid Public.LockStatusUnlocked Util.setTeamSndFactorPasswordChallenge galley tid Public.FeatureStatusEnabled Util.generateVerificationCode brig (Public.SendVerificationCode Public.Login email) - k <- Code.mkKey (Code.ForEmail email) - codeValue <- Code.codeValue <$$> lookupCode db k Code.AccountLogin + let k = mkKey email + codeValue <- (.codeValue) <$$> lookupCode db k Code.AccountLogin checkLoginSucceeds $ PasswordLogin $ PasswordLoginData (LoginByEmail email) defPassword (Just defCookieLabel) codeValue @@ -1165,7 +1167,7 @@ testUpdateClient opts brig = do const (Just "label") === (clientLabel <=< responseJsonMaybe) -- update supported client capabilities work - let checkUpdate :: HasCallStack => Maybe [ClientCapability] -> Bool -> [ClientCapability] -> Http () + let checkUpdate :: (HasCallStack) => Maybe [ClientCapability] -> Bool -> [ClientCapability] -> Http () checkUpdate capsIn respStatusOk capsOut = do let update'' = defUpdateClient {updateClientCapabilities = Set.fromList <$> capsIn} put @@ -1193,13 +1195,13 @@ testUpdateClient opts brig = do -- update supported client capabilities don't break prekeys or label do - let checkClientLabel :: HasCallStack => Http () + let checkClientLabel :: (HasCallStack) => Http () checkClientLabel = do getClient brig uid (clientId c) !!! do const 200 === statusCode const (Just label) === (clientLabel <=< responseJsonMaybe) - flushClientPrekey :: HasCallStack => Http (Maybe ClientPrekey) + flushClientPrekey :: (HasCallStack) => Http (Maybe ClientPrekey) flushClientPrekey = do responseJsonMaybe <$> ( get @@ -1208,7 +1210,7 @@ testUpdateClient opts brig = do === statusCode ) - checkClientPrekeys :: HasCallStack => Prekey -> Http () + checkClientPrekeys :: (HasCallStack) => Prekey -> Http () checkClientPrekeys expectedPrekey = do flushClientPrekey >>= \case Nothing -> error "unexpected." @@ -1285,7 +1287,7 @@ testMissingClient brig = do -- brig) have registered it. Add second temporary client, check -- again. (NB: temp clients replace each other, there can always be -- at most one per account.) -testAddMultipleTemporary :: HasCallStack => Brig -> Galley -> Cannon -> Http () +testAddMultipleTemporary :: (HasCallStack) => Brig -> Galley -> Cannon -> Http () testAddMultipleTemporary brig galley cannon = do uid <- userId <$> randomUser brig let clt1 = diff --git a/services/brig/test/integration/API/User/Connection.hs b/services/brig/test/integration/API/User/Connection.hs index 7dbb61f7bcb..e9023104eb9 100644 --- a/services/brig/test/integration/API/User/Connection.hs +++ b/services/brig/test/integration/API/User/Connection.hs @@ -366,7 +366,6 @@ testBlockConnection brig = do -- Initiate a new connection (A -> B) postConnection brig uid1 uid2 !!! const 201 === statusCode -- Even connected users cannot see each other's email - -- (or phone number for that matter). assertEmailVisibility brig u2 u1 False assertEmailVisibility brig u1 u2 False -- B blocks A @@ -413,7 +412,6 @@ testBlockConnectionQualified brig = do -- Initiate a new connection (A -> B) postConnectionQualified brig uid1 quid2 !!! const 201 === statusCode -- Even connected users cannot see each other's email - -- (or phone number for that matter). assertEmailVisibility brig u2 u1 False assertEmailVisibility brig u1 u2 False -- B blocks A diff --git a/services/brig/test/integration/API/User/Handles.hs b/services/brig/test/integration/API/User/Handles.hs index 88164a3e600..db34f2f9277 100644 --- a/services/brig/test/integration/API/User/Handles.hs +++ b/services/brig/test/integration/API/User/Handles.hs @@ -32,7 +32,7 @@ import Control.Monad.Catch (MonadCatch) import Data.Aeson import Data.Aeson.Lens import Data.ByteString.Conversion -import Data.Handle (Handle (Handle)) +import Data.Handle (parseHandle) import Data.Id import Data.List1 qualified as List1 import Data.Qualified (Qualified (..)) @@ -151,7 +151,7 @@ testHandleRace brig = do void . flip mapConcurrently us $ \u -> put (brig . path "/self/handle" . contentJson . zUser u . zConn "c" . body update) ps <- forM us $ \u -> responseJsonMaybe <$> get (brig . path "/self" . zUser u) - let owners = catMaybes $ filter (maybe False ((== Just (Handle hdl)) . userHandle)) ps + let owners = catMaybes $ filter (maybe False ((== Just (fromJust (parseHandle hdl))) . userHandle)) ps liftIO $ assertBool "More than one owner of a handle" (length owners <= 1) testHandleQuery :: Opt.Opts -> Brig -> Http () @@ -168,14 +168,14 @@ testHandleQuery opts brig = do -- Query the updated profile get (brig . path "/self" . zUser uid) !!! do const 200 === statusCode - const (Just (Handle hdl)) === (userHandle <=< responseJsonMaybe) + const (Just (fromJust $ parseHandle hdl)) === (userHandle <=< responseJsonMaybe) -- Query for the handle availability (must be taken) Bilge.head (brig . paths ["users", "handles", toByteString' hdl] . zUser uid) !!! const 200 === statusCode -- Query user profiles by handles get (apiVersion "v1" . brig . path "/users" . queryItem "handles" (toByteString' hdl) . zUser uid) !!! do const 200 === statusCode - const (Just (Handle hdl)) === (profileHandle <=< listToMaybe <=< responseJsonMaybe) + const (Just (fromJust $ parseHandle hdl)) === (profileHandle <=< listToMaybe <=< responseJsonMaybe) -- Bulk availability check hdl2 <- randomHandle hdl3 <- randomHandle diff --git a/services/brig/test/integration/API/User/PasswordReset.hs b/services/brig/test/integration/API/User/PasswordReset.hs index 55f19b34c28..b478af41749 100644 --- a/services/brig/test/integration/API/User/PasswordReset.hs +++ b/services/brig/test/integration/API/User/PasswordReset.hs @@ -46,16 +46,16 @@ tests :: Cannon -> Galley -> TestTree -tests cs _cl _at _conf p b _c _g = +tests _cs _cl _at _conf p b _c _g = testGroup "password-reset" - [ test p "post /password-reset[/complete] - 201[/200]" $ testPasswordReset b cs, - test p "post /password-reset after put /access/self/email - 400" $ testPasswordResetAfterEmailUpdate b cs, - test p "post /password-reset/complete - password too short - 400" $ testPasswordResetInvalidPasswordLength b cs + [ test p "post /password-reset[/complete] - 201[/200]" $ testPasswordReset b, + test p "post /password-reset after put /access/self/email - 400" $ testPasswordResetAfterEmailUpdate b, + test p "post /password-reset/complete - password too short - 400" $ testPasswordResetInvalidPasswordLength b ] -testPasswordReset :: Brig -> DB.ClientState -> Http () -testPasswordReset brig cs = do +testPasswordReset :: Brig -> Http () +testPasswordReset brig = do u <- randomUser brig let Just email = userEmail u let uid = userId u @@ -63,7 +63,12 @@ testPasswordReset brig cs = do let newpw = plainTextPassword8Unsafe "newsecret" do initiatePasswordReset brig email !!! const 201 === statusCode - passwordResetData <- preparePasswordReset brig cs email uid newpw + -- even though a password reset is now in progress + -- we expect a successful response from a subsequent request to not leak any information + -- about the requested email + initiatePasswordReset brig email !!! const 201 === statusCode + + passwordResetData <- preparePasswordReset brig email uid newpw completePasswordReset brig passwordResetData !!! const 200 === statusCode -- try login login brig (defEmailLogin email) PersistentCookie @@ -76,33 +81,33 @@ testPasswordReset brig cs = do -- reset password again to the same new password, get 400 "must be different" do initiatePasswordReset brig email !!! const 201 === statusCode - passwordResetData <- preparePasswordReset brig cs email uid newpw + passwordResetData <- preparePasswordReset brig email uid newpw completePasswordReset brig passwordResetData !!! const 409 === statusCode -testPasswordResetAfterEmailUpdate :: Brig -> DB.ClientState -> Http () -testPasswordResetAfterEmailUpdate brig cs = do +testPasswordResetAfterEmailUpdate :: Brig -> Http () +testPasswordResetAfterEmailUpdate brig = do u <- randomUser brig let uid = userId u let Just email = userEmail u eml <- randomEmail initiateEmailUpdateLogin brig eml (emailLogin email defPassword Nothing) uid !!! const 202 === statusCode initiatePasswordReset brig email !!! const 201 === statusCode - passwordResetData <- preparePasswordReset brig cs email uid (plainTextPassword8Unsafe "newsecret") + passwordResetData <- preparePasswordReset brig email uid (plainTextPassword8Unsafe "newsecret") -- activate new email activateEmail brig eml checkEmail brig uid eml -- attempting to complete password reset should fail completePasswordReset brig passwordResetData !!! const 400 === statusCode -testPasswordResetInvalidPasswordLength :: Brig -> DB.ClientState -> Http () -testPasswordResetInvalidPasswordLength brig cs = do +testPasswordResetInvalidPasswordLength :: Brig -> Http () +testPasswordResetInvalidPasswordLength brig = do u <- randomUser brig let Just email = userEmail u let uid = userId u -- for convenience, we create a valid password first that we replace with an invalid one in the JSON later let newpw = plainTextPassword8Unsafe "newsecret" initiatePasswordReset brig email !!! const 201 === statusCode - passwordResetData <- preparePasswordReset brig cs email uid newpw + passwordResetData <- preparePasswordReset brig email uid newpw let shortPassword = String "123456" let reqBody = toJSON passwordResetData & addJsonKey "password" shortPassword postCompletePasswordReset reqBody !!! const 400 === statusCode @@ -111,7 +116,7 @@ testPasswordResetInvalidPasswordLength brig cs = do addJsonKey key val (Object xs) = KeyMap.insert key val xs addJsonKey _ _ _ = error "invalid JSON object" - postCompletePasswordReset :: Object -> MonadHttp m => m ResponseLBS + postCompletePasswordReset :: Object -> (MonadHttp m) => m ResponseLBS postCompletePasswordReset bdy = post ( brig diff --git a/services/brig/test/integration/API/User/Property.hs b/services/brig/test/integration/API/User/Property.hs index fd16f35793f..071ea2d356d 100644 --- a/services/brig/test/integration/API/User/Property.hs +++ b/services/brig/test/integration/API/User/Property.hs @@ -149,7 +149,7 @@ testPropertyLimits opts brig = do const 403 === statusCode const (Just "too-many-properties") === fmap Error.label . responseJsonMaybe -testSizeLimits :: HasCallStack => Opt.Opts -> Brig -> Http () +testSizeLimits :: (HasCallStack) => Opt.Opts -> Brig -> Http () testSizeLimits opts brig = do let maxKeyLen = fromIntegral $ fromMaybe defMaxKeyLen . setPropertyMaxKeyLen $ optSettings opts maxValueLen = fromIntegral $ fromMaybe defMaxValueLen . setPropertyMaxValueLen $ optSettings opts diff --git a/services/brig/test/integration/API/User/RichInfo.hs b/services/brig/test/integration/API/User/RichInfo.hs index 49d4957246b..cad0d8053b6 100644 --- a/services/brig/test/integration/API/User/RichInfo.hs +++ b/services/brig/test/integration/API/User/RichInfo.hs @@ -114,7 +114,7 @@ testDedupeDuplicateFieldNames brig = do ri <- getRichInfo brig owner owner liftIO $ assertEqual "duplicate rich info fields" (Right deduped) ri -testRichInfoSizeLimit :: HasCallStack => Brig -> Opt.Opts -> Http () +testRichInfoSizeLimit :: (HasCallStack) => Brig -> Opt.Opts -> Http () testRichInfoSizeLimit brig conf = do let maxSize :: Int = setRichInfoLimit $ optSettings conf (owner, _) <- createUserWithTeam brig diff --git a/services/brig/test/integration/API/User/Util.hs b/services/brig/test/integration/API/User/Util.hs index dfd26fb1c26..d862c73ddd1 100644 --- a/services/brig/test/integration/API/User/Util.hs +++ b/services/brig/test/integration/API/User/Util.hs @@ -23,9 +23,6 @@ module API.User.Util where import Bilge hiding (accept, timeout) import Bilge.Assert -import Brig.Code qualified as Code -import Brig.Effects.CodeStore -import Brig.Effects.CodeStore.Cassandra import Brig.Options (Opts) import Brig.Types.Team.LegalHold (LegalHoldClientRequest (..)) import Brig.ZAuth (Token) @@ -39,8 +36,9 @@ import Data.ByteString.Builder (toLazyByteString) import Data.ByteString.Char8 (pack) import Data.ByteString.Conversion import Data.ByteString.Lazy qualified as LB +import Data.Code qualified as Code import Data.Domain -import Data.Handle (Handle (Handle)) +import Data.Handle (parseHandle) import Data.Id import Data.Kind import Data.List1 qualified as List1 @@ -55,7 +53,6 @@ import Federation.Util (withTempMockFederator) import Federator.MockServer (FederatedRequest (..)) import GHC.TypeLits (KnownSymbol) import Imports -import Polysemy import Test.Tasty.Cannon qualified as WS import Test.Tasty.HUnit import Util @@ -79,6 +76,8 @@ import Wire.API.User.Client.DPoPAccessToken (Proof) import Wire.API.User.Client.Prekey import Wire.API.User.Handle import Wire.API.User.Password +import Wire.VerificationCode qualified as Code +import Wire.VerificationCodeStore.Cassandra qualified as VerificationCodeStore newtype ConnectionLimit = ConnectionLimit Int64 @@ -120,7 +119,7 @@ setRandomHandle brig user = do ) !!! const 200 === statusCode - pure user {userHandle = Just (Handle h)} + pure user {userHandle = Just . fromJust . parseHandle $ h} -- Note: This actually _will_ send out an email, so we ensure that the email -- used here has a domain 'simulator.amazonses.com'. @@ -136,33 +135,13 @@ registerUser name brig = do ] post (brig . path "/register" . contentJson . body p) -createRandomPhoneUser :: (MonadCatch m, MonadIO m, MonadHttp m, HasCallStack) => Brig -> m (UserId, Phone) -createRandomPhoneUser brig = do - usr <- randomUser brig - let uid = userId usr - phn <- liftIO randomPhone - -- update phone - let phoneUpdate = RequestBodyLBS . encode $ PhoneUpdate phn - put (brig . path "/self/phone" . contentJson . zUser uid . zConn "c" . body phoneUpdate) - !!! (const 202 === statusCode) - -- activate - act <- getActivationCode brig (Right phn) - case act of - Nothing -> liftIO $ assertFailure "missing activation key/code" - Just kc -> activate brig kc !!! const 200 === statusCode - -- check new phone - get (brig . path "/self" . zUser uid) !!! do - const 200 === statusCode - const (Just phn) === (userPhone <=< responseJsonMaybe) - pure (uid, phn) - -initiatePasswordReset :: Brig -> Email -> MonadHttp m => m ResponseLBS +initiatePasswordReset :: Brig -> Email -> (MonadHttp m) => m ResponseLBS initiatePasswordReset brig email = post ( brig . path "/password-reset" . contentJson - . body (RequestBodyLBS . encode $ NewPasswordReset (Left email)) + . body (RequestBodyLBS . encode $ NewPasswordReset email) ) activateEmail :: (MonadCatch m, MonadIO m, MonadHttp m, HasCallStack) => Brig -> Email -> m () @@ -190,7 +169,7 @@ initiateEmailUpdateLogin brig email loginCreds uid = do pure (decodeCookie rsp, decodeToken rsp) initiateEmailUpdateCreds brig email (cky, tok) uid -initiateEmailUpdateCreds :: Brig -> Email -> (Bilge.Cookie, Brig.ZAuth.Token ZAuth.Access) -> UserId -> MonadHttp m => m ResponseLBS +initiateEmailUpdateCreds :: Brig -> Email -> (Bilge.Cookie, Brig.ZAuth.Token ZAuth.Access) -> UserId -> (MonadHttp m) => m ResponseLBS initiateEmailUpdateCreds brig email (cky, tok) uid = do put $ unversioned @@ -201,31 +180,29 @@ initiateEmailUpdateCreds brig email (cky, tok) uid = do . zUser uid . Bilge.json (EmailUpdate email) -initiateEmailUpdateNoSend :: Brig -> Email -> UserId -> MonadHttp m => m ResponseLBS +initiateEmailUpdateNoSend :: (MonadHttp m, MonadIO m, MonadCatch m) => Brig -> Email -> UserId -> m ResponseLBS initiateEmailUpdateNoSend brig email uid = let emailUpdate = RequestBodyLBS . encode $ EmailUpdate email in put (brig . path "/i/self/email" . contentJson . zUser uid . body emailUpdate) + Brig -> - DB.ClientState -> Email -> UserId -> PlainTextPassword8 -> m CompletePasswordReset -preparePasswordReset brig cState email uid newpw = do +preparePasswordReset brig email uid newpw = do let qry = queryItem "email" (toByteString' email) r <- get $ brig . path "/i/users/password-reset-code" . qry let lbs = fromMaybe "" $ responseBody r let Just pwcode = PasswordResetCode . Ascii.unsafeFromText <$> (lbs ^? key "code" . _String) - ident <- PasswordResetIdentityKey <$> runSem (mkPasswordResetKey uid) + let ident = PasswordResetIdentityKey (mkPasswordResetKey uid) let complete = CompletePasswordReset ident pwcode newpw pure complete - where - runSem = liftIO . runFinal @IO . interpretClientToIO cState . codeStoreToCassandra @DB.Client -completePasswordReset :: Brig -> CompletePasswordReset -> MonadHttp m => m ResponseLBS +completePasswordReset :: Brig -> CompletePasswordReset -> (MonadHttp m) => m ResponseLBS completePasswordReset brig passwordResetData = post ( brig @@ -238,7 +215,7 @@ removeBlacklist :: Brig -> Email -> (MonadIO m, MonadHttp m) => m () removeBlacklist brig email = void $ delete (brig . path "/i/users/blacklist" . queryItem "email" (toByteString' email)) -getClient :: Brig -> UserId -> ClientId -> MonadHttp m => m ResponseLBS +getClient :: Brig -> UserId -> ClientId -> (MonadHttp m) => m ResponseLBS getClient brig u c = get $ brig @@ -259,14 +236,14 @@ putClient brig uid c keys = . zUser uid . json (UpdateClient [] Nothing Nothing Nothing keys) -getClientCapabilities :: Brig -> UserId -> ClientId -> MonadHttp m => m ResponseLBS +getClientCapabilities :: Brig -> UserId -> ClientId -> (MonadHttp m) => m ResponseLBS getClientCapabilities brig u c = get $ brig . paths ["clients", toByteString' c, "capabilities"] . zUser u -getUserClientsUnqualified :: Brig -> UserId -> MonadHttp m => m ResponseLBS +getUserClientsUnqualified :: Brig -> UserId -> (MonadHttp m) => m ResponseLBS getUserClientsUnqualified brig uid = get $ apiVersion "v1" @@ -274,14 +251,14 @@ getUserClientsUnqualified brig uid = . paths ["users", toByteString' uid, "clients"] . zUser uid -getUserClientsQualified :: Brig -> UserId -> Domain -> UserId -> MonadHttp m => m ResponseLBS +getUserClientsQualified :: Brig -> UserId -> Domain -> UserId -> (MonadHttp m) => m ResponseLBS getUserClientsQualified brig zusr domain uid = get $ brig . paths ["users", toByteString' domain, toByteString' uid, "clients"] . zUser zusr -deleteClient :: Brig -> UserId -> ClientId -> Maybe Text -> MonadHttp m => m ResponseLBS +deleteClient :: Brig -> UserId -> ClientId -> Maybe Text -> (MonadHttp m) => m ResponseLBS deleteClient brig u c pw = delete $ brig @@ -295,7 +272,7 @@ deleteClient brig u c pw = RequestBodyLBS . encode . object . maybeToList $ fmap ("password" .=) pw -listConnections :: HasCallStack => Brig -> UserId -> MonadHttp m => m ResponseLBS +listConnections :: (HasCallStack) => Brig -> UserId -> (MonadHttp m) => m ResponseLBS listConnections brig u = get $ apiVersion "v1" @@ -320,14 +297,14 @@ listAllConnections brig u size state = ] ) -getConnectionQualified :: MonadHttp m => Brig -> UserId -> Qualified UserId -> m ResponseLBS +getConnectionQualified :: (MonadHttp m) => Brig -> UserId -> Qualified UserId -> m ResponseLBS getConnectionQualified brig from (Qualified toUser toDomain) = get $ brig . paths ["connections", toByteString' toDomain, toByteString' toUser] . zUser from -setProperty :: Brig -> UserId -> ByteString -> Value -> MonadHttp m => m ResponseLBS +setProperty :: Brig -> UserId -> ByteString -> Value -> (MonadHttp m) => m ResponseLBS setProperty brig u k v = put $ brig @@ -337,14 +314,14 @@ setProperty brig u k v = . contentJson . body (RequestBodyLBS $ encode v) -getProperty :: Brig -> UserId -> ByteString -> MonadHttp m => m ResponseLBS +getProperty :: Brig -> UserId -> ByteString -> (MonadHttp m) => m ResponseLBS getProperty brig u k = get $ brig . paths ["/properties", k] . zUser u -deleteProperty :: Brig -> UserId -> ByteString -> MonadHttp m => m ResponseLBS +deleteProperty :: Brig -> UserId -> ByteString -> (MonadHttp m) => m ResponseLBS deleteProperty brig u k = delete $ brig @@ -381,7 +358,7 @@ assertConnectionQualified brig u1 qu2 rel = const (Right rel) === fmap ucStatus . responseJsonEither receiveConnectionAction :: - HasCallStack => + (HasCallStack) => Brig -> FedClient 'Brig -> UserId -> @@ -399,7 +376,7 @@ receiveConnectionAction brig fedBrigClient uid1 quid2 action expectedReaction ex assertConnectionQualified brig uid1 quid2 expectedRel sendConnectionAction :: - HasCallStack => + (HasCallStack) => Brig -> Opts -> UserId -> @@ -426,7 +403,7 @@ sendConnectionAction brig opts uid1 quid2 reaction expectedRel = do assertConnectionQualified brig uid1 quid2 expectedRel sendConnectionUpdateAction :: - HasCallStack => + (HasCallStack) => Brig -> Opts -> UserId -> @@ -472,7 +449,7 @@ uploadAsset c usr sts dat = do === statusCode downloadAsset :: - MonadHttp m => + (MonadHttp m) => CargoHold -> UserId -> Qualified AssetKey -> @@ -485,7 +462,7 @@ downloadAsset c usr ast = . zConn "conn" ) -requestLegalHoldDevice :: Brig -> UserId -> UserId -> LastPrekey -> MonadHttp m => m ResponseLBS +requestLegalHoldDevice :: Brig -> UserId -> UserId -> LastPrekey -> (MonadHttp m) => m ResponseLBS requestLegalHoldDevice brig requesterId targetUserId lastPrekey' = post $ brig @@ -497,7 +474,7 @@ requestLegalHoldDevice brig requesterId targetUserId lastPrekey' = RequestBodyLBS . encode $ LegalHoldClientRequest requesterId lastPrekey' -deleteLegalHoldDevice :: Brig -> UserId -> MonadHttp m => m ResponseLBS +deleteLegalHoldDevice :: Brig -> UserId -> (MonadHttp m) => m ResponseLBS deleteLegalHoldDevice brig uid = delete $ brig @@ -558,11 +535,11 @@ setTeamFeatureLockStatus :: setTeamFeatureLockStatus galley tid status = put (galley . paths ["i", "teams", toByteString' tid, "features", Public.featureNameBS @cfg, toByteString' status]) !!! const 200 === statusCode -lookupCode :: MonadIO m => DB.ClientState -> Code.Key -> Code.Scope -> m (Maybe Code.Code) -lookupCode db k = liftIO . DB.runClient db . Code.lookup k +lookupCode :: (MonadIO m) => DB.ClientState -> Code.Key -> Code.Scope -> m (Maybe Code.Code) +lookupCode db k = liftIO . DB.runClient db . VerificationCodeStore.lookupCodeImpl k getNonce :: - MonadHttp m => + (MonadHttp m) => Brig -> UserId -> ClientId -> @@ -570,7 +547,7 @@ getNonce :: getNonce = nonce get headNonce :: - MonadHttp m => + (MonadHttp m) => Brig -> UserId -> ClientId -> @@ -586,7 +563,7 @@ nonce m brig uid cid = ) headNonceNginz :: - MonadHttp m => + (MonadHttp m) => Nginz -> ZAuth.Token ZAuth.Access -> ClientId -> diff --git a/services/brig/test/integration/API/UserPendingActivation.hs b/services/brig/test/integration/API/UserPendingActivation.hs index db47762b6e4..81f6e995c51 100644 --- a/services/brig/test/integration/API/UserPendingActivation.hs +++ b/services/brig/test/integration/API/UserPendingActivation.hs @@ -118,18 +118,18 @@ createUserStep spar' brig' tok tid scimUser email = do Just inviteeCode <- getInvitationCode brig' tid (inInvitation inv) pure (scimStoredUser, inv, inviteeCode) -assertUserExist :: HasCallStack => String -> ClientState -> UserId -> Bool -> HttpT IO () +assertUserExist :: (HasCallStack) => String -> ClientState -> UserId -> Bool -> HttpT IO () assertUserExist msg db' uid shouldExist = liftIO $ do exists <- aFewTimes 12 (runClient db' (userExists uid)) (== shouldExist) assertEqual msg shouldExist exists -waitUserExpiration :: MonadUnliftIO m => Opts -> m () +waitUserExpiration :: (MonadUnliftIO m) => Opts -> m () waitUserExpiration opts' = do let timeoutSecs = round @Double . realToFrac . setTeamInvitationTimeout . optSettings $ opts' Control.Exception.assert (timeoutSecs < 30) $ do threadDelay $ (timeoutSecs + 3) * 1_000_000 -userExists :: MonadClient m => UserId -> m Bool +userExists :: (MonadClient m) => UserId -> m Bool userExists uid = do x <- retry x1 (query1 usersSelect (params LocalQuorum (Identity uid))) pure $ @@ -156,8 +156,9 @@ createUserWithTeamDisableSSO brg gly = do e <- randomEmail n <- UUID.toString <$> liftIO UUID.nextRandom let p = - RequestBodyLBS . Aeson.encode $ - object + RequestBodyLBS + . Aeson.encode + $ object [ "name" .= n, "email" .= fromEmail e, "password" .= defPassword, @@ -209,7 +210,7 @@ randomScimUserWithSubjectAndRichInfo richInfo = do ) _ -> error "randomScimUserWithSubject: impossible" pure - ( (Scim.User.empty userSchemas ("scimuser_" <> suffix) (ScimUserExtra richInfo)) + ( (Scim.User.empty @SparTag userSchemas ("scimuser_" <> suffix) (ScimUserExtra richInfo)) { Scim.User.displayName = Just ("ScimUser" <> suffix), Scim.User.externalId = Just externalId, Scim.User.emails = emails, @@ -218,7 +219,7 @@ randomScimUserWithSubjectAndRichInfo richInfo = do subj ) -randomScimEmail :: MonadRandom m => m Email.Email +randomScimEmail :: (MonadRandom m) => m Email.Email randomScimEmail = do let typ :: Maybe Text = Nothing -- TODO: where should we catch users with more than one @@ -230,7 +231,7 @@ randomScimEmail = do pure . Email.EmailAddress2 $ Email.unsafeEmailAddress localpart domainpart pure Email.Email {..} -randomScimPhone :: MonadRandom m => m Phone.Phone +randomScimPhone :: (MonadRandom m) => m Phone.Phone randomScimPhone = do let typ :: Maybe Text = Nothing value :: Maybe Text <- do @@ -242,7 +243,7 @@ randomScimPhone = do -- | Create a user. createUser :: - HasCallStack => + (HasCallStack) => Spar -> ScimToken -> Scim.User.User SparTag -> @@ -329,7 +330,7 @@ createToken_ spar userid payload = do -- | Create a SCIM token. createToken :: - HasCallStack => + (HasCallStack) => Spar -> UserId -> CreateScimToken -> diff --git a/services/brig/test/integration/Federation/End2end.hs b/services/brig/test/integration/Federation/End2end.hs index cf1beffc23c..a19f1bc328b 100644 --- a/services/brig/test/integration/Federation/End2end.hs +++ b/services/brig/test/integration/Federation/End2end.hs @@ -191,7 +191,7 @@ testClaimMultiPrekeyBundleSuccess brig1 brig2 = do mkClients = Set.fromList . map prekeyClient mkClientMap :: [ClientPrekey] -> Map ClientId (Maybe Prekey) mkClientMap = Map.fromList . map (prekeyClient &&& Just . prekeyData) - qmap :: Ord a => [(Qualified a, b)] -> Map Domain (Map a b) + qmap :: (Ord a) => [(Qualified a, b)] -> Map Domain (Map a b) qmap = fmap Map.fromList . indexQualified . map (sequenceAOf _1) c1 <- generateClientPrekeys brig1 prekeys1 c2 <- generateClientPrekeys brig2 prekeys2 @@ -593,7 +593,7 @@ claimRemoteKeyPackages brig1 brig2 = do @?= Set.fromList [(bob, c) | c <- bobClients] testRemoteTypingIndicator :: - HasCallStack => + (HasCallStack) => Brig -> Brig -> Galley -> diff --git a/services/brig/test/integration/Federation/Util.hs b/services/brig/test/integration/Federation/Util.hs index 4a1376e8686..ace4d04fbbe 100644 --- a/services/brig/test/integration/Federation/Util.hs +++ b/services/brig/test/integration/Federation/Util.hs @@ -117,7 +117,7 @@ connectUsersEnd2End brig1 brig2 quid1 quid2 = do putConnectionQualified brig2 (qUnqualified quid2) quid1 Accepted !!! const 200 === statusCode -sendCommitBundle :: HasCallStack => FilePath -> FilePath -> Maybe FilePath -> Galley -> UserId -> ClientId -> ByteString -> Http () +sendCommitBundle :: (HasCallStack) => FilePath -> FilePath -> Maybe FilePath -> Galley -> UserId -> ClientId -> ByteString -> Http () sendCommitBundle tmp subGroupStateFn welcomeFn galley uid cid commit = do subGroupStateRaw <- liftIO $ BS.readFile $ tmp subGroupStateFn subGroupState <- either (liftIO . assertFailure . T.unpack) pure . decodeMLS' $ subGroupStateRaw diff --git a/services/brig/test/integration/SMTP.hs b/services/brig/test/integration/SMTP.hs index 6acc1288230..4911ffbcebc 100644 --- a/services/brig/test/integration/SMTP.hs +++ b/services/brig/test/integration/SMTP.hs @@ -1,11 +1,8 @@ {-# OPTIONS_GHC -Wno-deferred-out-of-scope-variables #-} --- Disabling to stop warnings on HasCallStack -{-# OPTIONS_GHC -Wno-redundant-constraints #-} module SMTP where import Bilge qualified -import Brig.SMTP import Control.Exception import Data.Bifunctor import Data.ByteString qualified as B @@ -20,11 +17,15 @@ import Network.Mail.Mime import Network.Mail.Postie qualified as Postie import Network.Socket import Pipes.Prelude qualified +import Polysemy import System.Logger qualified as Logger import Test.Tasty import Test.Tasty.HUnit import Util +import Wire.EmailSending +import Wire.EmailSending.SMTP +-- FUTUREWORK: Move all these tests to unit tests for the emailViaSMTPInterpreter tests :: Bilge.Manager -> Logger.Logger -> TestTree tests m lg = testGroup @@ -47,7 +48,7 @@ testSendMail lg = do withMailServer sock (mailStoringApp receivedMailRef) $ do conPool <- initSMTP lg "localhost" (Just port) Nothing Plain - sendMail lg conPool someTestMail + _ <- runM . emailViaSMTPInterpreter lg conPool $ sendMail someTestMail mbMail <- retryWhileN 3 isJust $ do readIORef receivedMailRef @@ -84,7 +85,7 @@ testSendMailNoReceiver lg = do caughtException <- handle @SomeException (const (pure True)) - (sendMail' @Second 1 lg conPool (emptyMail (Address Nothing "foo@example.com")) >> pure False) + (sendMailWithDuration @Second 1 lg conPool (emptyMail (Address Nothing "foo@example.com")) >> pure False) caughtException @? "Expected exception due to missing mail receiver." testSendMailTransactionFailed :: Logger.Logger -> Bilge.Http () @@ -98,7 +99,7 @@ testSendMailTransactionFailed lg = do caughtException <- handle @SomeException (const (pure True)) - (sendMail lg conPool someTestMail >> pure False) + (runM . emailViaSMTPInterpreter lg conPool $ sendMail someTestMail >> pure False) caughtException @? "Expected exception due to missing mail receiver." testSendMailFailingConnectionOnStartup :: Logger.Logger -> Bilge.Http () @@ -127,7 +128,7 @@ testSendMailFailingConnectionOnSend lg = do liftIO $ handle @SomeException (const (pure True)) - (sendMail lg conPool someTestMail >> pure False) + (runM . emailViaSMTPInterpreter lg conPool $ sendMail someTestMail >> pure False) liftIO $ caughtException @? "Expected exception (SMTP server unreachable.)" mbMail <- liftIO $ readIORef receivedMailRef liftIO $ isNothing mbMail @? "No mail expected (if there is one, the test setup is broken.)" @@ -143,7 +144,7 @@ testSendMailTimeout lg = do conPool <- initSMTP lg "localhost" (Just port) Nothing Plain handle @SMTPPoolException (\e -> pure (Just e)) - (sendMail' (500 :: Millisecond) lg conPool someTestMail >> pure Nothing) + (sendMailWithDuration (500 :: Millisecond) lg conPool someTestMail >> pure Nothing) liftIO $ isJust mbException @? "Expected exception (SMTP server action timed out.)" liftIO $ mbException @?= Just SMTPConnectionTimeout @@ -224,10 +225,10 @@ delayingApp delay = $> Postie.Accepted ) -everDelayingTCPServer :: HasCallStack => Socket -> IO a -> IO a +everDelayingTCPServer :: Socket -> IO a -> IO a everDelayingTCPServer sock action = listen sock 1024 >> action -withRandomPortAndSocket :: MonadIO m => ((PortNumber, Socket) -> IO a) -> m a +withRandomPortAndSocket :: (MonadIO m) => ((PortNumber, Socket) -> IO a) -> m a withRandomPortAndSocket action = liftIO $ bracket diff --git a/services/brig/test/integration/Util.hs b/services/brig/test/integration/Util.hs index e39db21d288..f2aae1e00de 100644 --- a/services/brig/test/integration/Util.hs +++ b/services/brig/test/integration/Util.hs @@ -27,7 +27,6 @@ import Bilge.Assert import Brig.AWS.Types import Brig.App (applog, fsWatcher, sftEnv, turnEnv) import Brig.Calling as Calling -import Brig.Code qualified as Code import Brig.Options qualified as Opt import Brig.Run qualified as Run import Brig.Types.Activation @@ -50,6 +49,7 @@ import Data.ByteString.Builder (toLazyByteString) import Data.ByteString.Char8 (pack) import Data.ByteString.Char8 qualified as B8 import Data.ByteString.Conversion +import Data.Code qualified as Code import Data.Default import Data.Domain (Domain (..), domainText, mkDomain) import Data.Handle (Handle (..)) @@ -84,6 +84,7 @@ import Network.Wai qualified as Wai import Network.Wai.Handler.Warp qualified as Warp import Network.Wai.Test (Session) import Network.Wai.Test qualified as WaiTest +import Network.Wai.Utilities.Error qualified as Wai import OpenSSL.BN (randIntegerZeroToNMinusOne) import Servant.Client (ClientError (FailureResponse)) import Servant.Client qualified as Servant @@ -195,16 +196,17 @@ runFedClient (FedClient mgr ep) domain = Right res -> pure res Left err -> assertFailure $ "Servant client failed with: " <> show err - makeClientRequest :: Domain -> Servant.BaseUrl -> Servant.Request -> HTTP.Request - makeClientRequest originDomain burl req = - let req' = Servant.defaultMakeClientRequest burl req - in req' - { HTTP.requestHeaders = - HTTP.requestHeaders req' - <> [ (originDomainHeaderName, toByteString' originDomain), - (versionHeader, toByteString' (versionInt (maxBound :: Version))) - ] - } + makeClientRequest :: Domain -> Servant.BaseUrl -> Servant.Request -> IO HTTP.Request + makeClientRequest originDomain burl req = do + req' <- Servant.defaultMakeClientRequest burl req + pure + req' + { HTTP.requestHeaders = + HTTP.requestHeaders req' + <> [ (originDomainHeaderName, toByteString' originDomain), + (versionHeader, toByteString' (versionInt (maxBound :: Version))) + ] + } instance ToJSON SESBounceType where toJSON BounceUndetermined = String "Undetermined" @@ -272,7 +274,7 @@ localAndRemoteUserWithConvId brig shouldBeLocal = do fakeRemoteUser :: (HasCallStack, MonadIO m) => m (Qualified UserId) fakeRemoteUser = Qualified <$> randomId <*> pure (Domain "far-away.example.com") -randomClient :: MonadIO m => m ClientId +randomClient :: (MonadIO m) => m ClientId randomClient = liftIO $ generate arbitrary randomUser :: @@ -309,28 +311,28 @@ createUser' hasPwd name brig = do Text -> Email -> Brig -> Http User +createUserWithEmail :: (HasCallStack) => Text -> Email -> Brig -> Http User createUserWithEmail name email brig = do r <- postUserWithEmail True True name (Just email) False Nothing Nothing brig Text -> Brig -> Http User +createUserUntrustedEmail :: (HasCallStack) => Text -> Brig -> Http User createUserUntrustedEmail name brig = do email <- randomUntrustedEmail createUserWithEmail name email brig -createAnonUser :: HasCallStack => Text -> Brig -> Http User +createAnonUser :: (HasCallStack) => Text -> Brig -> Http User createAnonUser = createAnonUserExpiry Nothing -createAnonUserExpiry :: HasCallStack => Maybe Integer -> Text -> Brig -> Http User +createAnonUserExpiry :: (HasCallStack) => Maybe Integer -> Text -> Brig -> Http User createAnonUserExpiry expires name brig = do let p = RequestBodyLBS . encode $ object ["name" .= name, "expires_in" .= expires] r <- post (brig . path "/register" . contentJson . body p) Brig -> Int -> Either Email Phone -> Http () +requestActivationCode :: (HasCallStack) => Brig -> Int -> Either Email Phone -> Http () requestActivationCode brig expectedStatus ep = post (brig . path "/activate/send" . contentJson . body (RequestBodyLBS . encode $ bdy ep)) !!! const expectedStatus === statusCode @@ -357,7 +359,7 @@ getPhoneLoginCode brig p = do let lbs = fromMaybe "" $ responseBody r pure (LoginCode <$> (lbs ^? key "code" . _String)) -assertUpdateNotification :: HasCallStack => WS.WebSocket -> UserId -> UserUpdate -> IO () +assertUpdateNotification :: (HasCallStack) => WS.WebSocket -> UserId -> UserUpdate -> IO () assertUpdateNotification ws uid upd = WS.assertMatch (5 # Second) ws $ \n -> do let j = Object $ List1.head (ntfPayload n) j ^? key "type" . _String @?= Just "user.update" @@ -446,7 +448,7 @@ postUserRegister payload brig = do rs <- postUserRegister' payload brig Object -> Brig -> m ResponseLBS +postUserRegister' :: (MonadHttp m) => Object -> Brig -> m ResponseLBS postUserRegister' payload brig = do post (brig . path "/register" . contentJson . body (RequestBodyLBS $ encode payload)) @@ -465,7 +467,7 @@ deleteUserInternal u brig = brig . paths ["/i/users", toByteString' u] -activate :: Brig -> ActivationPair -> MonadHttp m => m ResponseLBS +activate :: Brig -> ActivationPair -> (MonadHttp m) => m ResponseLBS activate brig (k, c) = get $ brig @@ -488,7 +490,7 @@ getUser brig zusr usr = -- | NB: you can also use nginz as the first argument here. The type aliases are compatible, -- and so are the end-points. This is important in tests where the cookie must come from the -- nginz domain, so it can be passed back to it. -login :: Brig -> Login -> CookieType -> MonadHttp m => m ResponseLBS +login :: Brig -> Login -> CookieType -> (MonadHttp m) => m ResponseLBS login b l t = let js = RequestBodyLBS (encode l) in post $ @@ -519,10 +521,10 @@ legalHoldLogin b l t = . (if t == PersistentCookie then queryItem "persist" "true" else id) . body js -decodeCookie :: HasCallStack => Response a -> Bilge.Cookie +decodeCookie :: (HasCallStack) => Response a -> Bilge.Cookie decodeCookie = fromMaybe (error "missing zuid cookie") . getCookie "zuid" -decodeToken :: HasCallStack => Response (Maybe LByteString) -> ZAuth.Token ZAuth.Access +decodeToken :: (HasCallStack) => Response (Maybe LByteString) -> ZAuth.Token ZAuth.Access decodeToken = decodeToken' decodeToken' :: (HasCallStack, ZAuth.AccessTokenLike a) => Response (Maybe LByteString) -> ZAuth.Token a @@ -543,14 +545,15 @@ sendLoginCode b p typ force = . body js where js = - RequestBodyLBS . encode $ - object + RequestBodyLBS + . encode + $ object [ "phone" .= fromPhone p, "voice_call" .= (typ == LoginCodeVoice), "force" .= force ] -postConnection :: Brig -> UserId -> UserId -> MonadHttp m => m ResponseLBS +postConnection :: Brig -> UserId -> UserId -> (MonadHttp m) => m ResponseLBS postConnection brig from to = post $ apiVersion "v1" @@ -562,10 +565,11 @@ postConnection brig from to = . zConn "conn" where payload = - RequestBodyLBS . encode $ - ConnectionRequest to (unsafeRange "some conv name") + RequestBodyLBS + . encode + $ ConnectionRequest to (unsafeRange "some conv name") -postConnectionQualified :: MonadHttp m => Brig -> UserId -> Qualified UserId -> m ResponseLBS +postConnectionQualified :: (MonadHttp m) => Brig -> UserId -> Qualified UserId -> m ResponseLBS postConnectionQualified brig from (Qualified toUser toDomain) = post $ brig @@ -574,7 +578,7 @@ postConnectionQualified brig from (Qualified toUser toDomain) = . zUser from . zConn "conn" -putConnection :: Brig -> UserId -> UserId -> Relation -> MonadHttp m => m ResponseLBS +putConnection :: Brig -> UserId -> UserId -> Relation -> (MonadHttp m) => m ResponseLBS putConnection brig from to r = put $ apiVersion "v1" @@ -587,7 +591,7 @@ putConnection brig from to r = where payload = RequestBodyLBS . encode $ object ["status" .= r] -putConnectionQualified :: Brig -> UserId -> Qualified UserId -> Relation -> MonadHttp m => m ResponseLBS +putConnectionQualified :: Brig -> UserId -> Qualified UserId -> Relation -> (MonadHttp m) => m ResponseLBS putConnectionQualified brig from (Qualified to toDomain) r = put $ brig @@ -721,14 +725,14 @@ getTeamMember u tid galley = . expect2xx ) -getConversationQualified :: MonadHttp m => Galley -> UserId -> Qualified ConvId -> m ResponseLBS +getConversationQualified :: (MonadHttp m) => Galley -> UserId -> Qualified ConvId -> m ResponseLBS getConversationQualified galley usr cnv = get $ galley . paths ["conversations", toByteString' (qDomain cnv), toByteString' (qUnqualified cnv)] . zAuthAccess usr "conn" -createMLSConversation :: MonadHttp m => Galley -> UserId -> ClientId -> m ResponseLBS +createMLSConversation :: (MonadHttp m) => Galley -> UserId -> ClientId -> m ResponseLBS createMLSConversation galley zusr c = do let conv = NewConv @@ -769,7 +773,7 @@ createMLSSubConversation galley zusr qcnv sconv = ] . zUser zusr -createConversation :: MonadHttp m => Galley -> UserId -> [Qualified UserId] -> m ResponseLBS +createConversation :: (MonadHttp m) => Galley -> UserId -> [Qualified UserId] -> m ResponseLBS createConversation galley zusr usersToAdd = do let conv = NewConv @@ -790,7 +794,7 @@ createConversation galley zusr usersToAdd = do . zConn "conn" . json conv -listConvIdsFirstPage :: MonadHttp m => Galley -> UserId -> m ResponseLBS +listConvIdsFirstPage :: (MonadHttp m) => Galley -> UserId -> m ResponseLBS listConvIdsFirstPage galley zusr = do let req = GetMultiTablePageRequest (toRange (Proxy @1000)) Nothing :: GetPaginatedConversationIds post $ @@ -801,7 +805,7 @@ listConvIdsFirstPage galley zusr = do . json req listConvs :: - MonadHttp m => + (MonadHttp m) => Galley -> UserId -> Range 1 1000 [Qualified ConvId] -> @@ -826,16 +830,17 @@ isMember g usr cnv = do Nothing -> pure False Just m -> pure (tUntagged usr == memId m) -getStatus :: HasCallStack => Brig -> UserId -> (MonadIO m, MonadHttp m) => m WU.AccountStatus +getStatus :: (HasCallStack) => Brig -> UserId -> (MonadIO m, MonadHttp m) => m WU.AccountStatus getStatus brig u = - (^?! key "status" . (_JSON @Value @WU.AccountStatus)) . (responseJsonUnsafe @Value) + (^?! key "status" . (_JSON @Value @WU.AccountStatus)) + . (responseJsonUnsafe @Value) <$> get ( brig . paths ["i", "users", toByteString' u, "status"] . expect2xx ) -chkStatus :: HasCallStack => Brig -> UserId -> WU.AccountStatus -> (MonadIO m, MonadHttp m, MonadCatch m) => m () +chkStatus :: (HasCallStack) => Brig -> UserId -> WU.AccountStatus -> (MonadIO m, MonadHttp m, MonadCatch m) => m () chkStatus brig u s = get (brig . paths ["i", "users", toByteString' u, "status"]) !!! do const 200 === statusCode @@ -861,7 +866,7 @@ queryRange start size = maybe id (queryItem "size" . pack . show) size . maybe id (queryItem "start") start -maybeFromJSON :: FromJSON a => Value -> Maybe a +maybeFromJSON :: (FromJSON a) => Value -> Maybe a maybeFromJSON v = case fromJSON v of Success a -> Just a _ -> Nothing @@ -878,7 +883,7 @@ zClient = header "Z-Client" . toByteString' zConn :: ByteString -> Request -> Request zConn = header "Z-Connection" -mkEmailRandomLocalSuffix :: MonadIO m => Text -> m Email +mkEmailRandomLocalSuffix :: (MonadIO m) => Text -> m Email mkEmailRandomLocalSuffix e = do uid <- liftIO UUID.nextRandom case parseEmail e of @@ -887,21 +892,21 @@ mkEmailRandomLocalSuffix e = do -- | Generate emails that are in the trusted whitelist of domains whose @+@ suffices count for email -- disambiguation. See also: 'Brig.Email.mkEmailKey'. -randomEmail :: MonadIO m => m Email +randomEmail :: (MonadIO m) => m Email randomEmail = mkSimulatorEmail "success" -- | To test the behavior of email addresses with untrusted domains (two emails are equal even if -- their local part after @+@ differs), we need to generate them. -randomUntrustedEmail :: MonadIO m => m Email +randomUntrustedEmail :: (MonadIO m) => m Email randomUntrustedEmail = do -- NOTE: local part cannot be longer than 64 octets rd <- liftIO (randomIO :: IO Integer) pure $ Email (Text.pack $ show rd) "zinfra.io" -mkSimulatorEmail :: MonadIO m => Text -> m Email +mkSimulatorEmail :: (MonadIO m) => Text -> m Email mkSimulatorEmail loc = mkEmailRandomLocalSuffix (loc <> "@simulator.amazonses.com") -randomPhone :: MonadIO m => m Phone +randomPhone :: (MonadIO m) => m Phone randomPhone = liftIO $ do nrs <- map show <$> replicateM 14 (randomRIO (0, 9) :: IO Int) let phone = parsePhone . Text.pack $ "+0" ++ concat nrs @@ -910,25 +915,19 @@ randomPhone = liftIO $ do randomActivationCode :: (HasCallStack, MonadIO m) => m ActivationCode randomActivationCode = liftIO $ - ActivationCode . Ascii.unsafeFromText . T.pack . printf "%06d" + ActivationCode + . Ascii.unsafeFromText + . T.pack + . printf "%06d" <$> randIntegerZeroToNMinusOne 1000000 -updatePhone :: HasCallStack => Brig -> UserId -> Phone -> Http () +updatePhone :: (HasCallStack) => Brig -> UserId -> Phone -> Http () updatePhone brig uid phn = do -- update phone let phoneUpdate = RequestBodyLBS . encode $ PhoneUpdate phn - failMsg = "updatePhone (PUT /self/phone): failed to update to " <> show phn <> " - might be a flaky test tracked in https://wearezeta.atlassian.net/browse/BE-526" put (brig . path "/self/phone" . contentJson . zUser uid . zConn "c" . body phoneUpdate) !!! do - const 202 === statusCode - assertTrue failMsg ((== 202) . statusCode) - -- activate - act <- getActivationCode brig (Right phn) - case act of - Nothing -> liftIO $ assertFailure "missing activation key/code" - Just kc -> - activate brig kc !!! do - const 200 === statusCode - const (Just False) === fmap activatedFirst . responseJsonMaybe + const 400 === statusCode + const (Just "invalid-phone") === fmap Wai.label . responseJsonMaybe defEmailLogin :: Email -> Login defEmailLogin e = emailLogin e defPassword (Just defCookieLabel) @@ -1015,12 +1014,12 @@ defCookieLabel = CookieLabel "auth" randomBytes :: Int -> IO ByteString randomBytes n = BS.pack <$> replicateM n randomIO -randomHandle :: MonadIO m => m Text +randomHandle :: (MonadIO m) => m Text randomHandle = liftIO $ do nrs <- replicateM 21 (randomRIO (97, 122)) -- a-z pure (Text.pack (map chr nrs)) -randomName :: MonadIO m => m Name +randomName :: (MonadIO m) => m Name randomName = randomNameWithMaxLen 128 -- | For testing purposes we restrict ourselves to code points in the @@ -1032,7 +1031,7 @@ randomName = randomNameWithMaxLen 128 -- the standard tokenizer considers as word boundaries (or which are -- simply unassigned code points), yielding no tokens to match and thus -- no results in search queries. -randomNameWithMaxLen :: MonadIO m => Word -> m Name +randomNameWithMaxLen :: (MonadIO m) => Word -> m Name randomNameWithMaxLen maxLen = liftIO $ do len <- randomRIO (2, maxLen) chars <- fill len [] @@ -1130,7 +1129,7 @@ assertOne xs = liftIO . assertFailure $ "Expected exactly one element, found " < newtype MockT m a = MockT {unMock :: ReaderT (IORef MockState) m a} deriving newtype (Functor, Applicative, Monad, MonadReader (IORef MockState), MonadIO) -instance MonadIO m => MonadState MockState (MockT m) where +instance (MonadIO m) => MonadState MockState (MockT m) where get = readIORef =<< ask put x = do ref <- ask @@ -1162,7 +1161,7 @@ getReceivedRequest r = runMockT :: IORef MockState -> MockT m a -> m a runMockT ref mock = runReaderT (unMock mock) ref -startMockService :: MonadIO m => IORef MockState -> ExceptT String m () +startMockService :: (MonadIO m) => IORef MockState -> ExceptT String m () startMockService ref = ExceptT . liftIO $ do (sPort, sock) <- Warp.openFreePort serverStarted <- newEmptyMVar @@ -1185,7 +1184,7 @@ startMockService ref = ExceptT . liftIO $ do initState :: MockState initState = MockState [] (error "server not started") (error "server not started") (error "No mock response provided") -stopMockedService :: MonadIO m => IORef MockState -> m () +stopMockedService :: (MonadIO m) => IORef MockState -> m () stopMockedService ref = liftIO $ Async.cancel . serverThread <=< readIORef $ ref @@ -1214,8 +1213,10 @@ assertRight = \case withMockedGalley :: (MonadIO m, MonadMask m) => Opt.Opts -> (ReceivedRequest -> MockT IO Wai.Response) -> Session a -> m (a, [ReceivedRequest]) withMockedGalley opts handler action = - assertRight <=< runExceptT $ - withTempMockedService initState handler $ \st -> lift $ do + assertRight + <=< runExceptT + $ withTempMockedService initState handler + $ \st -> lift $ do let opts' = opts { Opt.galley = Endpoint "127.0.0.1" (fromIntegral (serverPort st)) @@ -1230,8 +1231,10 @@ withMockedFederatorAndGalley :: Session a -> IO (a, [Mock.FederatedRequest], [ReceivedRequest]) withMockedFederatorAndGalley opts _domain fedResp galleyHandler action = do - result <- assertRight <=< runExceptT $ - withTempMockedService initState galleyHandler $ \galleyMockState -> + result <- assertRight + <=< runExceptT + $ withTempMockedService initState galleyHandler + $ \galleyMockState -> Mock.withTempMockFederator def {Mock.handler = (\r -> pure ("application" // "json", r)) <=< fedResp} $ \fedMockPort -> do @@ -1338,7 +1341,7 @@ runWaiTestFedClient :: runWaiTestFedClient domain action = runReaderT (unWaiTestFedClient action) domain -spawn :: HasCallStack => CreateProcess -> Maybe ByteString -> IO ByteString +spawn :: (HasCallStack) => CreateProcess -> Maybe ByteString -> IO ByteString spawn cp minput = do (mout, ex) <- withCreateProcess cp diff --git a/services/brig/test/integration/Util/AWS.hs b/services/brig/test/integration/Util/AWS.hs index b7cb46fb0f5..ace8a3f23d1 100644 --- a/services/brig/test/integration/Util/AWS.hs +++ b/services/brig/test/integration/Util/AWS.hs @@ -119,7 +119,7 @@ userDeleteMatcher uid ev = assertEventType :: String -> PU.UserEvent'EventType -> PU.UserEvent -> IO () assertEventType l et ev = assertEqual (l <> "eventType") et (ev ^. PU.eventType) -assertUserId :: HasCallStack => String -> UserId -> PU.UserEvent -> IO () +assertUserId :: (HasCallStack) => String -> UserId -> PU.UserEvent -> IO () assertUserId l uid ev = assertEqual (l <> "userId") uid (decodeIdFromBS (ev ^. PU.userId)) assertTeamId :: String -> Maybe TeamId -> PU.UserEvent -> IO () diff --git a/services/brig/test/resources/nexmo-credentials.yaml b/services/brig/test/resources/nexmo-credentials.yaml deleted file mode 100644 index 1f83517f2ee..00000000000 --- a/services/brig/test/resources/nexmo-credentials.yaml +++ /dev/null @@ -1,2 +0,0 @@ -key: "dummy" -secret: "dummy" diff --git a/services/brig/test/resources/rabbitmq-ca.pem b/services/brig/test/resources/rabbitmq-ca.pem new file mode 120000 index 00000000000..ca91c2c31bd --- /dev/null +++ b/services/brig/test/resources/rabbitmq-ca.pem @@ -0,0 +1 @@ +../../../../deploy/dockerephemeral/rabbitmq-config/certificates/ca.pem \ No newline at end of file diff --git a/services/brig/test/unit/Test/Brig/Calling.hs b/services/brig/test/unit/Test/Brig/Calling.hs index 007a2041743..3b22294d16c 100644 --- a/services/brig/test/unit/Test/Brig/Calling.hs +++ b/services/brig/test/unit/Test/Brig/Calling.hs @@ -64,7 +64,7 @@ newFakeDNSEnv :: (Domain -> SrvResponse) -> IO FakeDNSEnv newFakeDNSEnv lookupSrvFn = FakeDNSEnv lookupSrvFn <$> newIORef [] -runFakeDNSLookup :: Member (Embed IO) r => FakeDNSEnv -> Sem (DNSLookup ': r) a -> Sem r a +runFakeDNSLookup :: (Member (Embed IO) r) => FakeDNSEnv -> Sem (DNSLookup ': r) a -> Sem r a runFakeDNSLookup FakeDNSEnv {..} = interpret $ \(LookupSRV domain) -> do modifyIORef' fakeLookupSrvCalls (++ [domain]) @@ -296,7 +296,7 @@ testSFTStaticDeprecatedEndpoint = do . ignoreLogs . interpretSFTInMemory mempty . throwErrorInIO @_ @NoTurnServers - $ newConfig env (Discovered turnUri) Nothing Nothing Nothing HideAllSFTServers CallsConfigDeprecated + $ newConfig env (Discovered turnUri) Nothing Nothing Nothing HideAllSFTServers CallsConfigDeprecated True assertEqual "when SFT static URL is disabled, sft_servers should be empty." Set.empty @@ -323,7 +323,7 @@ testSFTStaticV2NoStaticUrl = do . ignoreLogs . interpretSFTInMemory mempty . throwErrorInIO @_ @NoTurnServers - $ newConfig env (Discovered turnUri) Nothing (Just sftEnv) (Just . unsafeRange $ 2) ListAllSFTServers (CallsConfigV2 Nothing) + $ newConfig env (Discovered turnUri) Nothing (Just sftEnv) (Just . unsafeRange $ 2) ListAllSFTServers (CallsConfigV2 Nothing) True assertEqual "when SFT static URL is disabled, sft_servers_all should be from SFT environment" (Just . fmap ((^. sftURL) . sftServerFromSrvTarget . srvTarget) . toList $ servers) @@ -339,7 +339,7 @@ testSFTStaticV2StaticUrlError = do . ignoreLogs . interpretSFTInMemory mempty -- an empty lookup map, meaning there was an error . throwErrorInIO @_ @NoTurnServers - $ newConfig env (Discovered turnUri) (Just staticUrl) Nothing (Just . unsafeRange $ 2) ListAllSFTServers (CallsConfigV2 Nothing) + $ newConfig env (Discovered turnUri) (Just staticUrl) Nothing (Just . unsafeRange $ 2) ListAllSFTServers (CallsConfigV2 Nothing) True assertEqual "when SFT static URL is enabled (and setSftListAllServers is enabled), but returns error, sft_servers_all should be omitted" Nothing @@ -358,7 +358,7 @@ testSFTStaticV2StaticUrlList = do . ignoreLogs . interpretSFTInMemory (Map.singleton staticUrl (SFTGetResponse $ Right servers)) . throwErrorInIO @_ @NoTurnServers - $ newConfig env (Discovered turnUri) (Just staticUrl) Nothing (Just . unsafeRange $ 3) ListAllSFTServers (CallsConfigV2 Nothing) + $ newConfig env (Discovered turnUri) (Just staticUrl) Nothing (Just . unsafeRange $ 3) ListAllSFTServers (CallsConfigV2 Nothing) True assertEqual "when SFT static URL and setSftListAllServers are enabled, sft_servers_all should be from /sft_servers_all.json" ((^. sftURL) <$$> Just servers) @@ -376,7 +376,7 @@ testSFTStaticV2ListAllServersDisabled = do . ignoreLogs . interpretSFTInMemory (Map.singleton staticUrl (SFTGetResponse . Right $ servers)) . throwErrorInIO @_ @NoTurnServers - $ newConfig env (Discovered turnUri) (Just staticUrl) Nothing (Just . unsafeRange $ 3) HideAllSFTServers (CallsConfigV2 Nothing) + $ newConfig env (Discovered turnUri) (Just staticUrl) Nothing (Just . unsafeRange $ 3) HideAllSFTServers (CallsConfigV2 Nothing) True assertEqual "when SFT static URL is enabled and setSftListAllServers is \"disabled\" then sft_servers_all is missing" Nothing diff --git a/services/brig/test/unit/Test/Brig/Effects/Delay.hs b/services/brig/test/unit/Test/Brig/Effects/Delay.hs index 55109f712e3..9b11ad5bfec 100644 --- a/services/brig/test/unit/Test/Brig/Effects/Delay.hs +++ b/services/brig/test/unit/Test/Brig/Effects/Delay.hs @@ -21,7 +21,7 @@ import Wire.Sem.Delay -- > delay 100 -- > takeMVar tick -- This blocks until doStuff is done -- > assertStuffDone -runDelayWithTick :: Member (Embed IO) r => MVar () -> TVar [Int] -> Sem (Delay ': r) a -> Sem r a +runDelayWithTick :: (Member (Embed IO) r) => MVar () -> TVar [Int] -> Sem (Delay ': r) a -> Sem r a runDelayWithTick tick calls = interpret $ \case Delay i -> do atomically $ modifyTVar calls (<> [i]) diff --git a/services/cannon/cannon.cabal b/services/cannon/cannon.cabal index 992758164de..d0af6581163 100644 --- a/services/cannon/cannon.cabal +++ b/services/cannon/cannon.cabal @@ -97,6 +97,7 @@ library , lens-family-core >=1.1 , metrics-wai >=0.4 , mwc-random >=0.13 + , prometheus-client , retry >=0.7 , safe-exceptions , servant-conduit @@ -107,7 +108,6 @@ library , types-common >=0.16 , unix , unliftio - , uuid , vector >=0.10 , wai >=3.0 , wai-extra >=3.0 @@ -166,9 +166,8 @@ executable cannon ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path - -threaded -rtsopts -with-rtsopts=-N -with-rtsopts=-T - -with-rtsopts=-M1g -with-rtsopts=-ki4k -Wredundant-constraints - -Wunused-packages + -threaded -rtsopts "-with-rtsopts=-N -T -M1g -ki4k" + -Wredundant-constraints -Wunused-packages build-depends: base diff --git a/services/cannon/default.nix b/services/cannon/default.nix index dce615c2001..9278d2c1c94 100644 --- a/services/cannon/default.nix +++ b/services/cannon/default.nix @@ -26,6 +26,7 @@ , lib , metrics-wai , mwc-random +, prometheus-client , QuickCheck , random , retry @@ -77,6 +78,7 @@ mkDerivation { lens-family-core metrics-wai mwc-random + prometheus-client retry safe-exceptions servant-conduit @@ -87,7 +89,6 @@ mkDerivation { types-common unix unliftio - uuid vector wai wai-extra diff --git a/services/cannon/src/Cannon/App.hs b/services/cannon/src/Cannon/App.hs index 83a6a86e44f..842d38135a3 100644 --- a/services/cannon/src/Cannon/App.hs +++ b/services/cannon/src/Cannon/App.hs @@ -46,11 +46,11 @@ data State = State !Int !Timeout -- | The lifetime of a websocket. newtype TTL = TTL Word64 -counter :: Functor f => LensLike' f State Int +counter :: (Functor f) => LensLike' f State Int counter f (State c p) = (\x -> State x p) `fmap` f c {-# INLINE counter #-} -pingFreq :: Functor f => LensLike' f State Timeout +pingFreq :: (Functor f) => LensLike' f State Timeout pingFreq f (State c p) = (\x -> State c x) `fmap` f p {-# INLINE pingFreq #-} @@ -107,16 +107,16 @@ writeLoop ws clock (TTL ttl) st = loop loop = do s <- readIORef st if - | s ^. counter == 0 -> do - set counter st succ - threadDelay $ s ^. pingFreq - keepAlive - | s ^. counter < 3 -> do - set counter st succ - send (connection ws) ping - threadDelay $ (10 # Second) `min` (s ^. pingFreq) - keepAlive - | otherwise -> pure () + | s ^. counter == 0 -> do + set counter st succ + threadDelay $ s ^. pingFreq + keepAlive + | s ^. counter < 3 -> do + set counter st succ + send (connection ws) ping + threadDelay $ (10 # Second) `min` (s ^. pingFreq) + keepAlive + | otherwise -> pure () keepAlive = do time <- getTime clock unless (time > ttl) loop @@ -161,7 +161,7 @@ rejectOnError p x = do _ -> pure () throwM x -ioErrors :: MonadLogger m => Key -> [Handler m ()] +ioErrors :: (MonadLogger m) => Key -> [Handler m ()] ioErrors k = let f s = Logger.err $ client (key2bytes k) . msg s in [ Handler $ \(x :: HandshakeException) -> f (show x), diff --git a/services/cannon/src/Cannon/Dict.hs b/services/cannon/src/Cannon/Dict.hs index 066a91ccefe..902a3f31040 100644 --- a/services/cannon/src/Cannon/Dict.hs +++ b/services/cannon/src/Cannon/Dict.hs @@ -39,10 +39,10 @@ newtype Dict a b = Dict { _map :: Vector (IORef (SizedHashMap a b)) } -size :: MonadIO m => Dict a b -> m Int +size :: (MonadIO m) => Dict a b -> m Int size d = liftIO $ sum <$> mapM (fmap SHM.size . readIORef) (_map d) -empty :: MonadIO m => Int -> m (Dict a b) +empty :: (MonadIO m) => Int -> m (Dict a b) empty w = liftIO $ if w > 0 && w < 8192 @@ -70,7 +70,7 @@ removeIf f k d = liftIO . atomicModifyIORef' (getSlice k d) $ \m -> lookup :: (Hashable a, MonadIO m) => a -> Dict a b -> m (Maybe b) lookup k = liftIO . fmap (SHM.lookup k) . readIORef . getSlice k -toList :: MonadIO m => Dict a b -> m [(a, b)] +toList :: (MonadIO m) => Dict a b -> m [(a, b)] toList = fmap (mconcat . V.toList) . V.mapM (fmap SHM.toList . readIORef) @@ -80,11 +80,11 @@ toList = -- Internal mutDict :: - MonadIO m => + (MonadIO m) => (SizedHashMap a b -> SizedHashMap a b) -> IORef (SizedHashMap a b) -> m () mutDict f d = liftIO . atomicModifyIORef' d $ \m -> (f m, ()) -getSlice :: Hashable a => a -> Dict a b -> IORef (SizedHashMap a b) +getSlice :: (Hashable a) => a -> Dict a b -> IORef (SizedHashMap a b) getSlice k (Dict m) = m ! (hash k `mod` V.length m) diff --git a/services/cannon/src/Cannon/Run.hs b/services/cannon/src/Cannon/Run.hs index 01eeefc167d..ba8256cb62b 100644 --- a/services/cannon/src/Cannon/Run.hs +++ b/services/cannon/src/Cannon/Run.hs @@ -27,7 +27,7 @@ import Cannon.API.Public import Cannon.App (maxPingInterval) import Cannon.Dict qualified as D import Cannon.Options -import Cannon.Types (Cannon, applog, clients, env, mkEnv, monitor, runCannon', runCannonToServant) +import Cannon.Types (Cannon, applog, clients, env, mkEnv, runCannon', runCannonToServant) import Cannon.WS hiding (env) import Control.Concurrent import Control.Concurrent.Async qualified as Async @@ -35,8 +35,6 @@ import Control.Exception qualified as E import Control.Exception.Safe (catchAny) import Control.Lens ((^.)) import Control.Monad.Catch (MonadCatch, finally) -import Data.Metrics.Middleware (gaugeSet, path) -import Data.Metrics.Middleware qualified as Middleware import Data.Metrics.Servant import Data.Proxy import Data.Text (pack, strip) @@ -47,6 +45,7 @@ import Network.Wai qualified as Wai import Network.Wai.Handler.Warp hiding (run) import Network.Wai.Middleware.Gzip qualified as Gzip import Network.Wai.Utilities.Server +import Prometheus qualified as Prom import Servant import System.IO.Strict qualified as Strict import System.Logger.Class qualified as LC @@ -68,23 +67,23 @@ run o = do when (o ^. drainOpts . gracePeriodSeconds == 0) $ error "drainOpts.gracePeriodSeconds must not be set to 0." ext <- loadExternal - m <- Middleware.metrics g <- L.mkLogger (o ^. logLevel) (o ^. logNetStrings) (o ^. logFormat) e <- - mkEnv m ext o g + mkEnv ext o g <$> D.empty 128 <*> newManager defaultManagerSettings {managerConnCount = 128} <*> createSystemRandom <*> mkClock refreshMetricsThread <- Async.async $ runCannon' e refreshMetrics - s <- newSettings $ Server (o ^. cannon . host) (o ^. cannon . port) (applog e) m (Just idleTimeout) + s <- newSettings $ Server (o ^. cannon . host) (o ^. cannon . port) (applog e) (Just idleTimeout) let middleware :: Wai.Middleware middleware = versionMiddleware (foldMap expandVersionExp (o ^. disabledAPIVersions)) + . requestIdMiddleware g defaultRequestIdHeaderName . servantPrometheusMiddleware (Proxy @CombinedAPI) . Gzip.gzip Gzip.def - . catchErrors g [Right m] + . catchErrors g defaultRequestIdHeaderName app :: Application app = middleware (serve (Proxy @CombinedAPI) server) server :: Servant.Server CombinedAPI @@ -132,11 +131,11 @@ instance Exception SignalledToExit refreshMetrics :: Cannon () refreshMetrics = do - m <- monitor c <- clients safeForever $ do s <- D.size c - gaugeSet (fromIntegral s) (path "net.websocket.clients") m + Prom.setGauge websocketClientsGauge (fromIntegral s) + -- gaugeSet (fromIntegral s) (path "") m liftIO $ threadDelay 1000000 where safeForever :: (MonadIO m, LC.MonadLogger m, MonadCatch m) => m () -> m () @@ -145,3 +144,13 @@ refreshMetrics = do action `catchAny` \exc -> do LC.err $ "error" LC..= show exc LC.~~ LC.msg (LC.val "refreshMetrics failed") liftIO $ threadDelay 60000000 -- pause to keep worst-case noise in logs manageable + +{-# NOINLINE websocketClientsGauge #-} +websocketClientsGauge :: Prom.Gauge +websocketClientsGauge = + Prom.unsafeRegister $ + Prom.gauge + Prom.Info + { Prom.metricName = "net.websocket.clients", + Prom.metricHelp = "Number of connected websocket clients" + } diff --git a/services/cannon/src/Cannon/Types.hs b/services/cannon/src/Cannon/Types.hs index 9dc29f2e2e8..e085a0d9f20 100644 --- a/services/cannon/src/Cannon/Types.hs +++ b/services/cannon/src/Cannon/Types.hs @@ -19,7 +19,6 @@ module Cannon.Types ( Env, - mon, opts, applog, dict, @@ -32,13 +31,12 @@ module Cannon.Types runCannon', options, clients, - monitor, wsenv, runCannonToServant, ) where -import Bilge (Manager, RequestId (..), requestIdName) +import Bilge (Manager, RequestId (..)) import Bilge.RPC (HasRequestId (..)) import Cannon.Dict (Dict) import Cannon.Options @@ -47,14 +45,13 @@ import Cannon.WS qualified as WS import Control.Concurrent.Async (mapConcurrently) import Control.Lens ((^.)) import Control.Monad.Catch -import Data.Metrics.Middleware import Data.Text.Encoding -import Data.UUID as UUID -import Data.UUID.V4 as UUID import Imports import Network.Wai +import Network.Wai.Utilities.Request qualified as Wai +import Network.Wai.Utilities.Server +import Prometheus import Servant qualified -import System.Logger qualified as Log import System.Logger qualified as Logger import System.Logger.Class hiding (info) import System.Random.MWC (GenIO) @@ -63,8 +60,7 @@ import System.Random.MWC (GenIO) -- Cannon monad data Env = Env - { mon :: !Metrics, - opts :: !Opts, + { opts :: !Opts, applog :: !Logger, dict :: !(Dict Key Websocket), reqId :: !RequestId, @@ -81,10 +77,11 @@ newtype Cannon a = Cannon MonadIO, MonadThrow, MonadCatch, - MonadMask + MonadMask, + MonadMonitor ) -mapConcurrentlyCannon :: Traversable t => (a -> Cannon b) -> t a -> Cannon (t b) +mapConcurrentlyCannon :: (Traversable t) => (a -> Cannon b) -> t a -> Cannon (t b) mapConcurrentlyCannon action inputs = Cannon $ ask >>= \e -> @@ -100,7 +97,6 @@ instance HasRequestId Cannon where getRequestId = Cannon $ asks reqId mkEnv :: - Metrics -> ByteString -> Opts -> Logger -> @@ -109,40 +105,25 @@ mkEnv :: GenIO -> Clock -> Env -mkEnv m external o l d p g t = - Env m o l d (RequestId "N/A") $ +mkEnv external o l d p g t = + Env o l d (RequestId "N/A") $ WS.env external (o ^. cannon . port) (encodeUtf8 $ o ^. gundeck . host) (o ^. gundeck . port) l p d g t (o ^. drainOpts) runCannon :: Env -> Cannon a -> Request -> IO a runCannon e c r = do - rid <- lookupReqId e.applog r - let e' = e {reqId = rid} + let rid = Wai.getRequestId defaultRequestIdHeaderName r + e' = e {reqId = rid} runCannon' e' c runCannon' :: Env -> Cannon a -> IO a runCannon' e c = runReaderT (unCannon c) e -lookupReqId :: Logger -> Request -> IO RequestId -lookupReqId l r = case lookup requestIdName (requestHeaders r) of - Just rid -> pure $ RequestId rid - Nothing -> do - localRid <- RequestId . UUID.toASCIIBytes <$> UUID.nextRandom - Log.info l $ - "request-id" .= localRid - ~~ "method" .= requestMethod r - ~~ "path" .= rawPathInfo r - ~~ msg (val "generated a new request id for local request") - pure localRid - options :: Cannon Opts options = Cannon $ asks opts clients :: Cannon (Dict Key Websocket) clients = Cannon $ asks dict -monitor :: Cannon Metrics -monitor = Cannon $ asks mon - wsenv :: Cannon WS.Env wsenv = Cannon $ do e <- asks env diff --git a/services/cannon/src/Cannon/WS.hs b/services/cannon/src/Cannon/WS.hs index 6837457b636..2b9a816df20 100644 --- a/services/cannon/src/Cannon/WS.hs +++ b/services/cannon/src/Cannon/WS.hs @@ -194,7 +194,7 @@ env :: Env env leh lp gh gp = Env leh lp (host gh . port gp $ empty) (RequestId "N/A") -runWS :: MonadIO m => Env -> WS a -> m a +runWS :: (MonadIO m) => Env -> WS a -> m a runWS e m = liftIO $ runReaderT (_conn m) e registerLocal :: Key -> Websocket -> WS () diff --git a/services/cargohold/cargohold.cabal b/services/cargohold/cargohold.cabal index f3c5ad95c44..2a8a5b2ba93 100644 --- a/services/cargohold/cargohold.cabal +++ b/services/cargohold/cargohold.cabal @@ -115,6 +115,7 @@ library , metrics-core , metrics-wai >=0.4 , mime >=0.4 + , prometheus-client , resourcet >=1.1 , retry >=0.5 , servant diff --git a/services/cargohold/default.nix b/services/cargohold/default.nix index 58b2e770a30..32c9e73b371 100644 --- a/services/cargohold/default.nix +++ b/services/cargohold/default.nix @@ -43,6 +43,7 @@ , mmorph , mtl , optparse-applicative +, prometheus-client , resourcet , retry , safe @@ -108,6 +109,7 @@ mkDerivation { metrics-core metrics-wai mime + prometheus-client resourcet retry servant diff --git a/services/cargohold/src/CargoHold/API/Public.hs b/services/cargohold/src/CargoHold/API/Public.hs index 794e4ae0318..607e8947087 100644 --- a/services/cargohold/src/CargoHold/API/Public.hs +++ b/services/cargohold/src/CargoHold/API/Public.hs @@ -60,11 +60,11 @@ servantSitemap = :<|> legacyAPI :<|> mainAPI where - userAPI :: forall tag. tag ~ 'UserPrincipalTag => ServerT (BaseAPIv3 tag) Handler + userAPI :: forall tag. (tag ~ 'UserPrincipalTag) => ServerT (BaseAPIv3 tag) Handler userAPI = uploadAssetV3 @tag :<|> downloadAssetV3 @tag :<|> deleteAssetV3 @tag - botAPI :: forall tag. tag ~ 'BotPrincipalTag => ServerT (BaseAPIv3 tag) Handler + botAPI :: forall tag. (tag ~ 'BotPrincipalTag) => ServerT (BaseAPIv3 tag) Handler botAPI = uploadAssetV3 @tag :<|> downloadAssetV3 @tag :<|> deleteAssetV3 @tag - providerAPI :: forall tag. tag ~ 'ProviderPrincipalTag => ServerT (BaseAPIv3 tag) Handler + providerAPI :: forall tag. (tag ~ 'ProviderPrincipalTag) => ServerT (BaseAPIv3 tag) Handler providerAPI = uploadAssetV3 @tag :<|> downloadAssetV3 @tag :<|> deleteAssetV3 @tag legacyAPI = legacyDownloadPlain :<|> legacyDownloadPlain :<|> legacyDownloadOtr qualifiedAPI :: ServerT QualifiedAPI Handler @@ -121,7 +121,7 @@ instance HasLocation 'ProviderPrincipalTag where assetKeyToText (tUnqualified key) ] -class HasLocation tag => MakePrincipal (tag :: PrincipalTag) (id :: Type) | id -> tag, tag -> id where +class (HasLocation tag) => MakePrincipal (tag :: PrincipalTag) (id :: Type) | id -> tag, tag -> id where mkPrincipal :: id -> V3.Principal instance MakePrincipal 'UserPrincipalTag (Local UserId) where @@ -135,7 +135,7 @@ instance MakePrincipal 'ProviderPrincipalTag ProviderId where mkAssetLocation :: forall (tag :: PrincipalTag). - HasLocation tag => + (HasLocation tag) => Local AssetKey -> AssetLocation Relative mkAssetLocation key = @@ -155,7 +155,7 @@ mkAssetLocation key = uploadAssetV3 :: forall tag id. - MakePrincipal tag id => + (MakePrincipal tag id) => id -> AssetSource -> Handler (Asset, AssetLocation Relative) @@ -174,7 +174,7 @@ uploadAssetV3 pid req = do pure (fmap tUntagged asset, mkAssetLocation @tag (asset ^. assetKey)) downloadAssetV3 :: - MakePrincipal tag id => + (MakePrincipal tag id) => id -> AssetKey -> Maybe AssetToken -> @@ -206,7 +206,7 @@ downloadAssetV4 usr qkey tok1 tok2 mbHostHeader = ) qkey -deleteAssetV3 :: MakePrincipal tag id => id -> AssetKey -> Handler () +deleteAssetV3 :: (MakePrincipal tag id) => id -> AssetKey -> Handler () deleteAssetV3 usr = V3.delete (mkPrincipal usr) deleteAssetV4 :: Local UserId -> Qualified AssetKey -> Handler () diff --git a/services/cargohold/src/CargoHold/API/V3.hs b/services/cargohold/src/CargoHold/API/V3.hs index 4b4c58f374a..fcb9105c7d5 100644 --- a/services/cargohold/src/CargoHold/API/V3.hs +++ b/services/cargohold/src/CargoHold/API/V3.hs @@ -105,7 +105,7 @@ updateToken own key tok = do let m' = m {S3.v3AssetToken = tok} S3.updateMetadataV3 key m' -randToken :: MonadIO m => m V3.AssetToken +randToken :: (MonadIO m) => m V3.AssetToken randToken = liftIO $ V3.AssetToken . Ascii.encodeBase64Url <$> getRandomBytes 16 download :: V3.Principal -> V3.AssetKey -> Maybe V3.AssetToken -> Maybe Text -> Handler (Maybe URI) diff --git a/services/cargohold/src/CargoHold/AWS.hs b/services/cargohold/src/CargoHold/AWS.hs index 38b8ecc260f..587937d7aa2 100644 --- a/services/cargohold/src/CargoHold/AWS.hs +++ b/services/cargohold/src/CargoHold/AWS.hs @@ -142,7 +142,7 @@ mkEnv lgr s3End s3AddrStyle s3Download bucket cfOpts mgr = do -- they are still revealed on debug level. mapLevel AWS.Error = Logger.Debug -execute :: MonadIO m => Env -> Amazon a -> m a +execute :: (MonadIO m) => Env -> Amazon a -> m a execute e m = liftIO $ runResourceT (runReaderT (unAmazon m) e) data Error where @@ -246,7 +246,7 @@ execCatch env request = do pure Nothing Right r -> pure $ Just r -canRetry :: MonadIO m => Either AWS.Error a -> m Bool +canRetry :: (MonadIO m) => Either AWS.Error a -> m Bool canRetry (Right _) = pure False canRetry (Left e) = case e of AWS.TransportError (HttpExceptionRequest _ ResponseTimeout) -> pure True diff --git a/services/cargohold/src/CargoHold/App.hs b/services/cargohold/src/CargoHold/App.hs index 36af17c0051..85c31799667 100644 --- a/services/cargohold/src/CargoHold/App.hs +++ b/services/cargohold/src/CargoHold/App.hs @@ -29,7 +29,6 @@ module CargoHold.App multiIngress, httpManager, http2Manager, - metrics, appLogger, requestId, localUnit, @@ -62,8 +61,6 @@ import Control.Lens (Lens', makeLenses, non, view, (?~), (^.)) import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) import Control.Monad.Trans.Resource (ResourceT, runResourceT, transResourceT) import qualified Data.Map as Map -import Data.Metrics.Middleware (Metrics) -import qualified Data.Metrics.Middleware as Metrics import Data.Qualified import HTTP2.Client.Manager (Http2Manager, http2ManagerWithSSLCtx) import Imports hiding (log) @@ -72,6 +69,7 @@ import Network.HTTP.Client.OpenSSL import Network.Wai.Utilities (Error (..)) import OpenSSL.Session (SSLContext, SSLOption (..)) import qualified OpenSSL.Session as SSL +import Prometheus import qualified Servant.Client as Servant import System.Logger.Class hiding (settings) import qualified System.Logger.Extended as Log @@ -84,7 +82,6 @@ import qualified Wire.API.Routes.Internal.Brig as IBrig data Env = Env { _aws :: AWS.Env, - _metrics :: Metrics, _appLogger :: Logger, _httpManager :: Manager, _http2Manager :: Http2Manager, @@ -101,7 +98,6 @@ settings = options . Opt.settings newEnv :: Opts -> IO Env newEnv opts = do - metricsStorage <- Metrics.metrics logger <- Log.mkLogger (opts ^. Opt.logLevel) (opts ^. Opt.logNetStrings) (opts ^. Opt.logFormat) checkOpts opts logger httpMgr <- initHttpManager (opts ^. Opt.aws . Opt.s3Compatibility) @@ -109,7 +105,7 @@ newEnv opts = do awsEnv <- initAws (opts ^. Opt.aws) logger httpMgr multiIngressAWS <- initMultiIngressAWS logger httpMgr let localDomain = toLocalUnsafe (opts ^. Opt.settings . Opt.federationDomain) () - pure $ Env awsEnv metricsStorage logger httpMgr http2Mgr (RequestId "N/A") opts localDomain multiIngressAWS + pure $ Env awsEnv logger httpMgr http2Mgr (RequestId "N/A") opts localDomain multiIngressAWS where initMultiIngressAWS :: Logger -> Manager -> IO (Map String AWS.Env) initMultiIngressAWS logger httpMgr = @@ -205,7 +201,8 @@ newtype AppT m a = AppT (ReaderT Env m a) MonadThrow, MonadCatch, MonadMask, - MonadReader Env + MonadReader Env, + MonadMonitor ) type App = AppT IO @@ -236,7 +233,7 @@ instance HasRequestId (ExceptT e App) where runAppT :: Env -> AppT m a -> m a runAppT e (AppT a) = runReaderT a e -runAppResourceT :: MonadIO m => Env -> ResourceT App a -> m a +runAppResourceT :: (MonadIO m) => Env -> ResourceT App a -> m a runAppResourceT e rma = liftIO . runResourceT $ transResourceT (runAppT e) rma executeBrigInteral :: BrigInternalClient a -> App (Either Servant.ClientError a) diff --git a/services/cargohold/src/CargoHold/CloudFront.hs b/services/cargohold/src/CargoHold/CloudFront.hs index 9b379e9bcc2..0c8666c1567 100644 --- a/services/cargohold/src/CargoHold/CloudFront.hs +++ b/services/cargohold/src/CargoHold/CloudFront.hs @@ -56,7 +56,7 @@ data CloudFront = CloudFront _func :: ByteString -> IO ByteString } -initCloudFront :: MonadIO m => FilePath -> KeyPairId -> Word -> Domain -> m CloudFront +initCloudFront :: (MonadIO m) => FilePath -> KeyPairId -> Word -> Domain -> m CloudFront initCloudFront kfp kid ttl (Domain dom) = liftIO $ CloudFront baseUrl kid ttl <$> mkPOSIXClock <*> sha1Rsa kfp diff --git a/services/cargohold/src/CargoHold/Metrics.hs b/services/cargohold/src/CargoHold/Metrics.hs index aa21c396891..af9dab18a93 100644 --- a/services/cargohold/src/CargoHold/Metrics.hs +++ b/services/cargohold/src/CargoHold/Metrics.hs @@ -17,17 +17,32 @@ module CargoHold.Metrics where -import CargoHold.App (Env, metrics) -import Control.Lens (view) -import Data.Metrics.Middleware (counterAdd, counterIncr, path) import Imports +import qualified Prometheus as Prom -s3UploadOk :: (MonadReader Env m, MonadIO m) => m () -s3UploadOk = - counterIncr (path "net.s3.upload_ok") - =<< view metrics +s3UploadOk :: (Prom.MonadMonitor m) => m () +s3UploadOk = Prom.incCounter netS3UploadOk -s3UploadSize :: (MonadReader Env m, MonadIO m, Integral n) => n -> m () +{-# NOINLINE netS3UploadOk #-} +netS3UploadOk :: Prom.Counter +netS3UploadOk = + Prom.unsafeRegister $ + Prom.counter + Prom.Info + { Prom.metricName = "net.s3.upload_ok", + Prom.metricHelp = "Number of successful S3 Uploads" + } + +s3UploadSize :: (Prom.MonadMonitor m, Integral n) => n -> m () s3UploadSize n = - counterAdd (fromIntegral n) (path "net.s3.upload_size") - =<< view metrics + void $ Prom.addCounter netS3UploadSize (fromIntegral n) + +{-# NOINLINE netS3UploadSize #-} +netS3UploadSize :: Prom.Counter +netS3UploadSize = + Prom.unsafeRegister $ + Prom.counter + Prom.Info + { Prom.metricName = "net.s3.upload_size", + Prom.metricHelp = "Number of bytes uploaded successfully uploaded to S3" + } diff --git a/services/cargohold/src/CargoHold/Run.hs b/services/cargohold/src/CargoHold/Run.hs index 2a7165e162d..eeee6b32ab2 100644 --- a/services/cargohold/src/CargoHold/Run.hs +++ b/services/cargohold/src/CargoHold/Run.hs @@ -24,7 +24,6 @@ where import AWS.Util (readAuthExpiration) import qualified Amazonka as AWS -import Bilge.Request (requestIdName) import CargoHold.API.Federation import CargoHold.API.Public import CargoHold.AWS (amazonkaEnv) @@ -33,24 +32,19 @@ import CargoHold.Options hiding (aws) import Control.Exception (bracket) import Control.Lens ((.~), (^.)) import Control.Monad.Codensity -import Data.Id -import Data.Metrics (Metrics) import Data.Metrics.AWS (gaugeTokenRemaing) import Data.Metrics.Servant import Data.Proxy import Data.Text (unpack) -import Data.UUID as UUID -import Data.UUID.V4 as UUID import Imports import qualified Network.Wai as Wai import qualified Network.Wai.Middleware.Gzip as GZip +import Network.Wai.Utilities.Request import Network.Wai.Utilities.Server import qualified Network.Wai.Utilities.Server as Server import qualified Servant import Servant.API import Servant.Server hiding (Handler, runHandler) -import System.Logger (Logger, msg, val, (.=), (~~)) -import qualified System.Logger as Log import qualified UnliftIO.Async as Async import Util.Options import Wire.API.Routes.API @@ -64,7 +58,7 @@ type CombinedAPI = FederationAPI :<|> CargoholdAPI :<|> InternalAPI run :: Opts -> IO () run o = lowerCodensity $ do (app, e) <- mkApp o - void $ Codensity $ Async.withAsync (collectAuthMetrics (e ^. metrics) (e ^. aws . amazonkaEnv)) + void $ Codensity $ Async.withAsync (collectAuthMetrics (e ^. aws . amazonkaEnv)) liftIO $ do s <- Server.newSettings $ @@ -72,7 +66,6 @@ run o = lowerCodensity $ do (unpack $ o ^. cargohold . host) (o ^. cargohold . port) (e ^. appLogger) - (e ^. metrics) runSettingsWithShutdown s app Nothing mkApp :: Opts -> Codensity IO (Application, Env) @@ -83,13 +76,14 @@ mkApp o = Codensity $ \k -> middleware :: Env -> Wai.Middleware middleware e = versionMiddleware (foldMap expandVersionExp (o ^. settings . disabledAPIVersions)) + . requestIdMiddleware (e ^. appLogger) defaultRequestIdHeaderName . servantPrometheusMiddleware (Proxy @CombinedAPI) . GZip.gzip GZip.def - . catchErrors (e ^. appLogger) [Right $ e ^. metrics] + . catchErrors (e ^. appLogger) defaultRequestIdHeaderName servantApp :: Env -> Application servantApp e0 r cont = do - rid <- lookupReqId (e0 ^. appLogger) r - let e = requestId .~ rid $ e0 + let rid = getRequestId defaultRequestIdHeaderName r + e = requestId .~ rid $ e0 Servant.serveWithContext (Proxy @CombinedAPI) ((o ^. settings . federationDomain) :. Servant.EmptyContext) @@ -100,25 +94,13 @@ mkApp o = Codensity $ \k -> r cont - lookupReqId :: Logger -> Wai.Request -> IO RequestId - lookupReqId l r = case lookup requestIdName $ Wai.requestHeaders r of - Just rid -> pure $ RequestId rid - Nothing -> do - localRid <- RequestId . UUID.toASCIIBytes <$> UUID.nextRandom - Log.info l $ - "request-id" .= localRid - ~~ "method" .= Wai.requestMethod r - ~~ "path" .= Wai.rawPathInfo r - ~~ msg (val "generated a new request id for local request") - pure localRid - toServantHandler :: Env -> Handler a -> Servant.Handler a toServantHandler env = liftIO . runHandler env -collectAuthMetrics :: MonadIO m => Metrics -> AWS.Env -> m () -collectAuthMetrics m env = do +collectAuthMetrics :: (MonadIO m) => AWS.Env -> m () +collectAuthMetrics env = do liftIO $ forever $ do mbRemaining <- readAuthExpiration env - gaugeTokenRemaing m mbRemaining + gaugeTokenRemaing mbRemaining threadDelay 1_000_000 diff --git a/services/cargohold/src/CargoHold/S3.hs b/services/cargohold/src/CargoHold/S3.hs index 181b2f9255c..849b77dcda8 100644 --- a/services/cargohold/src/CargoHold/S3.hs +++ b/services/cargohold/src/CargoHold/S3.hs @@ -341,7 +341,7 @@ getAmzMetaToken h = V3.AssetToken . Ascii.unsafeFromText <$> lookupCI hAmzMetaToken h -parseAmzMeta :: FromByteString a => Text -> [(Text, Text)] -> Maybe a +parseAmzMeta :: (FromByteString a) => Text -> [(Text, Text)] -> Maybe a parseAmzMeta k h = lookupCI k h >>= fromByteString . encodeUtf8 ------------------------------------------------------------------------------- diff --git a/services/cargohold/test/integration/TestSetup.hs b/services/cargohold/test/integration/TestSetup.hs index ae8d4f7362d..93f361e34c3 100644 --- a/services/cargohold/test/integration/TestSetup.hs +++ b/services/cargohold/test/integration/TestSetup.hs @@ -175,17 +175,15 @@ runFederationClient action = do let base = BaseUrl Http (T.unpack cHost) (fromIntegral cPort) "/federation" let env = (mkClientEnv man base) - { makeClientRequest = \burl req -> - let req' = defaultMakeClientRequest burl req - in req' - { requestHeaders = - (originDomainHeaderName, toByteString' domain) - : requestHeaders req' - } + { makeClientRequest = \burl req -> do + req' <- defaultMakeClientRequest burl req + pure req' {requestHeaders = (originDomainHeaderName, toByteString' domain) : requestHeaders req'} } - r <- lift . lift $ - Codensity $ \k -> + r <- lift + . lift + $ Codensity + $ \k -> -- Servant's streaming client throws exceptions in IO for some reason catch (withClientM action env k) (k . Left) @@ -200,17 +198,19 @@ withFederationClient :: ReaderT TestSetup (ExceptT ClientError (Codensity IO)) a withFederationClient action = runExceptT (hoistFederation action) >>= \case Left err -> - liftIO . assertFailure $ - "Unexpected federation client error: " + liftIO + . assertFailure + $ "Unexpected federation client error: " <> displayException err Right x -> pure x withFederationError :: ReaderT TestSetup (ExceptT ClientError (Codensity IO)) a -> TestM Wai.Error withFederationError action = runExceptT (hoistFederation action) - >>= liftIO . \case - Left (FailureResponse _ resp) -> case Aeson.eitherDecode (responseBody resp) of - Left err -> assertFailure $ "Error while parsing error response: " <> err - Right e -> (Wai.code e @?= responseStatusCode resp) $> e - Left err -> assertFailure $ "Unexpected federation client error: " <> displayException err - Right _ -> assertFailure "Unexpected success" + >>= liftIO + . \case + Left (FailureResponse _ resp) -> case Aeson.eitherDecode (responseBody resp) of + Left err -> assertFailure $ "Error while parsing error response: " <> err + Right e -> (Wai.code e @?= responseStatusCode resp) $> e + Left err -> assertFailure $ "Unexpected federation client error: " <> displayException err + Right _ -> assertFailure "Unexpected success" diff --git a/services/federator/default.nix b/services/federator/default.nix index 423926f9509..9b687bbd39e 100644 --- a/services/federator/default.nix +++ b/services/federator/default.nix @@ -123,7 +123,6 @@ mkDerivation { types-common unix utf8-string - uuid wai wai-utilities warp diff --git a/services/federator/federator.cabal b/services/federator/federator.cabal index 4fa411b3be0..4c88186b527 100644 --- a/services/federator/federator.cabal +++ b/services/federator/federator.cabal @@ -35,7 +35,6 @@ extra-source-files: library -- cabal-fmt: expand src exposed-modules: - Federator.App Federator.Discovery Federator.Env Federator.Error @@ -43,6 +42,7 @@ library Federator.ExternalServer Federator.Health Federator.InternalServer + Federator.Interpreter Federator.Metrics Federator.MockServer Federator.Monitor @@ -148,7 +148,6 @@ library , types-common , unix , utf8-string - , uuid , wai , wai-utilities , warp @@ -206,8 +205,8 @@ executable federator ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path - -threaded -with-rtsopts=-N1 -with-rtsopts=-T -rtsopts - -Wredundant-constraints -Wunused-packages + -threaded "-with-rtsopts=-N -T" -rtsopts -Wredundant-constraints + -Wunused-packages build-depends: base @@ -326,7 +325,6 @@ test-suite federator-tests Test.Federator.Monitor Test.Federator.Options Test.Federator.Remote - Test.Federator.Response Test.Federator.Util Test.Federator.Validation diff --git a/services/federator/src/Federator/App.hs b/services/federator/src/Federator/App.hs deleted file mode 100644 index 30561b19923..00000000000 --- a/services/federator/src/Federator/App.hs +++ /dev/null @@ -1,93 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - --- 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 Federator.App - ( AppT, - runAppT, - embedApp, - ) -where - -import Bilge (MonadHttp (..), RequestId (unRequestId), withResponse) -import Bilge.RPC (HasRequestId (..)) -import Control.Lens (view) -import Control.Monad.Catch -import Control.Monad.Except -import Federator.Env (Env, applog, httpManager, requestId) -import Imports -import Polysemy -import Polysemy.Input -import System.Logger.Class as LC -import System.Logger.Extended qualified as Log - --- FUTUREWORK(federation): this code re-occurs in every service. introduce 'MkAppT' in types-common that --- takes 'Env' as one more argument. -newtype AppT m a = AppT - { unAppT :: ReaderT Env m a - } - deriving newtype - ( Functor, - Applicative, - Monad, - MonadIO, - MonadThrow, - MonadCatch, - MonadMask, - MonadReader Env - ) - -instance MonadIO m => LC.MonadLogger (AppT m) where - log l m = do - g <- view applog - r <- view requestId - Log.log g l $ field "request" (unRequestId r) ~~ m - -instance MonadIO m => LC.MonadLogger (ExceptT err (AppT m)) where - log l m = lift (LC.log l m) - -instance Monad m => HasRequestId (AppT m) where - getRequestId = view requestId - -instance MonadUnliftIO m => MonadUnliftIO (AppT m) where - withRunInIO inner = - AppT . ReaderT $ \r -> - withRunInIO $ \runner -> - inner (runner . flip runReaderT r . unAppT) - -instance MonadTrans AppT where - lift = AppT . lift - -instance MonadIO m => MonadHttp (AppT m) where - handleRequestWithCont req handler = do - manager <- view httpManager <$> ask - liftIO $ withResponse req manager handler - -runAppT :: forall m a. Env -> AppT m a -> m a -runAppT e (AppT ma) = runReaderT ma e - -embedApp :: - ( Member (Embed m) r, - Member (Input Env) r - ) => - AppT m a -> - Sem r a -embedApp (AppT action) = do - env <- input - embed $ runReaderT action env diff --git a/services/federator/src/Federator/Env.hs b/services/federator/src/Federator/Env.hs index 12f3670ef18..6d13f073ad1 100644 --- a/services/federator/src/Federator/Env.hs +++ b/services/federator/src/Federator/Env.hs @@ -21,9 +21,7 @@ module Federator.Env where -import Bilge (RequestId) import Control.Lens (makeLenses) -import Data.Metrics (Metrics) import Federator.Options (RunSettings) import HTTP2.Client.Manager import Imports @@ -41,9 +39,7 @@ data FederatorMetrics = FederatorMetrics } data Env = Env - { _metrics :: Metrics, - _applog :: LC.Logger, - _requestId :: RequestId, + { _applog :: LC.Logger, _dnsResolver :: Resolver, _runSettings :: RunSettings, _service :: Component -> Endpoint, diff --git a/services/federator/src/Federator/ExternalServer.hs b/services/federator/src/Federator/ExternalServer.hs index 4a2f83d4c5f..238fc493c35 100644 --- a/services/federator/src/Federator/ExternalServer.hs +++ b/services/federator/src/Federator/ExternalServer.hs @@ -24,25 +24,20 @@ module Federator.ExternalServer ) where -import Control.Monad.Codensity import Data.Bifunctor import Data.ByteString qualified as BS import Data.ByteString.Builder import Data.ByteString.Lazy qualified as LBS import Data.Domain -import Data.Id (RequestId (..)) -import Data.Metrics.Servant qualified as Metrics -import Data.Proxy (Proxy (Proxy)) import Data.Sequence qualified as Seq import Data.Text qualified as Text import Data.Text.Encoding qualified as Text -import Data.UUID as UUID -import Data.UUID.V4 as UUID import Data.X509 qualified as X509 import Federator.Discovery import Federator.Env import Federator.Error.ServerError import Federator.Health qualified as Health +import Federator.Interpreter import Federator.Metrics import Federator.RPC import Federator.Response @@ -57,18 +52,17 @@ import Polysemy.Error import Polysemy.Input import Polysemy.TinyLog (TinyLog) import Polysemy.TinyLog qualified as Log +import Servant qualified import Servant.API import Servant.API.Extended.Endpath +import Servant.API.Extended.RawM qualified as RawM import Servant.Client.Core -import Servant.Server (Tagged (..)) -import Servant.Server.Generic -import System.Logger (msg, val, (.=), (~~)) +import Servant.Server.Generic (AsServerT) import System.Logger.Message qualified as Log import Wire.API.Federation.Component import Wire.API.Federation.Domain import Wire.API.Routes.FederationDomainConfig import Wire.API.VersionInfo -import Wire.Sem.Logger (info) -- | Used to get PEM encoded certificate out of an HTTP header newtype CertHeader = CertHeader X509.Certificate @@ -92,14 +86,12 @@ data API mode = API :- "federation" :> Capture "component" Component :> Capture "rpc" RPC - :> Header "Wire-Origin-Request-Id" RequestId :> Header' '[Required, Strict] OriginDomainHeaderName Domain :> Header' '[Required, Strict] "X-SSL-Certificate" CertHeader :> Endpath - -- We need to use 'Raw' so we can stream request body regardless of - -- content-type and send a response with arbitrary content-type. Not - -- sure if this is the right approach. - :> Raw + -- We need to use 'RawM' so we can stream request body regardless of + -- content-type and send a response with arbitrary content-type. + :> RawM.RawM } deriving (Generic) @@ -111,18 +103,17 @@ server :: Member (Error ValidationError) r, Member (Error DiscoveryFailure) r, Member (Error ServerError) r, + Member (Error Servant.ServerError) r, Member (Input FederationDomainConfigs) r, Member Metrics r ) => Manager -> Word16 -> - (Sem r Wai.Response -> Codensity IO Wai.Response) -> - API AsServer -server mgr intPort interpreter = + API (AsServerT (Sem r)) +server mgr intPort = API { status = Health.status mgr "internal server" intPort, - externalRequest = \component rpc mReqId remoteDomain remoteCert -> - Tagged $ \req respond -> runCodensity (interpreter (callInward component rpc mReqId remoteDomain remoteCert req)) respond + externalRequest = callInward } -- FUTUREWORK(federation): Versioning of the federation API. @@ -139,22 +130,12 @@ callInward :: ) => Component -> RPC -> - Maybe RequestId -> Domain -> CertHeader -> Wai.Request -> - Sem r Wai.Response -callInward component (RPC rpc) mReqId originDomain (CertHeader cert) wreq = do - rid <- case mReqId of - Just r -> pure r - Nothing -> do - localRid <- liftIO $ RequestId . Text.encodeUtf8 . UUID.toText <$> UUID.nextRandom - info $ - "request-id" .= localRid - ~~ "method" .= Wai.requestMethod wreq - ~~ "path" .= Wai.rawPathInfo wreq - ~~ msg (val "generated a new request id for local request") - pure localRid + (Wai.Response -> IO Wai.ResponseReceived) -> + Sem r Wai.ResponseReceived +callInward component (RPC rpc) originDomain (CertHeader cert) wreq cont = do incomingCounterIncr originDomain -- only POST is supported when (Wai.requestMethod wreq /= HTTP.methodPost) $ @@ -169,7 +150,6 @@ callInward component (RPC rpc) mReqId originDomain (CertHeader cert) wreq = do . Log.field "originDomain" (domainText originDomain) . Log.field "component" (show component) . Log.field "rpc" rpc - . Log.field "request" rid validatedDomain <- validateDomain cert originDomain @@ -177,12 +157,11 @@ callInward component (RPC rpc) mReqId originDomain (CertHeader cert) wreq = do body <- embed $ Wai.lazyRequestBody wreq let headers = filter ((== versionHeader) . fst) (Wai.requestHeaders wreq) - resp <- serviceCall component path headers body rid validatedDomain + resp <- serviceCall component path headers body validatedDomain Log.debug $ Log.msg ("Inward Request response" :: ByteString) . Log.field "status" (show (responseStatusCode resp)) - . Log.field "request" rid - pure $ + embed . cont $ streamingResponseToWai resp { responseHeaders = @@ -192,8 +171,5 @@ callInward component (RPC rpc) mReqId originDomain (CertHeader cert) wreq = do } serveInward :: Env -> Int -> IO () -serveInward env = - serveServant - (Metrics.servantPrometheusMiddleware $ Proxy @(ToServantApi API)) - (server env._httpManager env._internalPort $ runFederator env) - env +serveInward env port = + serveServant @(ToServantApi API) env port $ toServant $ server env._httpManager env._internalPort diff --git a/services/federator/src/Federator/Health.hs b/services/federator/src/Federator/Health.hs index 857a3e56415..602faf7ddd0 100644 --- a/services/federator/src/Federator/Health.hs +++ b/services/federator/src/Federator/Health.hs @@ -5,9 +5,12 @@ import Data.ByteString.UTF8 qualified as UTF8 import Imports import Network.HTTP.Client import Network.HTTP.Types.Status qualified as HTTP +import Polysemy +import Polysemy.Error import Servant status :: + (Member (Embed IO) r, Member (Error ServerError) r) => Manager -> -- | Name of other service LByteString -> @@ -15,15 +18,15 @@ status :: Word16 -> -- | standalone flag, when specified only return status of current service Bool -> - Handler NoContent + Sem r NoContent status _ _ _ True = pure NoContent status mgr otherName otherPort False = do - req <- parseRequest $ "http://localhost:" <> show otherPort <> "/i/status?standalone" + req <- liftIO $ parseRequest $ "http://localhost:" <> show otherPort <> "/i/status?standalone" res <- liftIO $ httpNoBody req mgr if HTTP.statusIsSuccessful $ responseStatus res then pure NoContent else - throwError + throw Servant.err500 { Servant.errBody = otherName diff --git a/services/federator/src/Federator/InternalServer.hs b/services/federator/src/Federator/InternalServer.hs index ef6cbd0cce4..e7caef5fd45 100644 --- a/services/federator/src/Federator/InternalServer.hs +++ b/services/federator/src/Federator/InternalServer.hs @@ -20,19 +20,13 @@ module Federator.InternalServer where -import Control.Monad.Codensity import Data.Binary.Builder import Data.ByteString qualified as BS import Data.Domain -import Data.Id -import Data.Metrics.Servant qualified as Metrics -import Data.Proxy -import Data.Text.Encoding qualified as T -import Data.UUID as UUID -import Data.UUID.V4 as UUID import Federator.Env import Federator.Error.ServerError import Federator.Health qualified as Health +import Federator.Interpreter import Federator.Metrics (Metrics, outgoingCounterIncr) import Federator.RPC import Federator.Remote @@ -45,15 +39,15 @@ import Network.Wai qualified as Wai import Polysemy import Polysemy.Error import Polysemy.Input +import Polysemy.TinyLog +import Servant qualified import Servant.API import Servant.API.Extended.Endpath -import Servant.Server (Tagged (..)) +import Servant.API.Extended.RawM qualified as RawM import Servant.Server.Generic -import System.Logger (msg, val, (.=), (~~)) import System.Logger.Class qualified as Log import Wire.API.Federation.Component import Wire.API.Routes.FederationDomainConfig -import Wire.Sem.Logger (Logger, debug, info) data API mode = API { status :: @@ -67,15 +61,13 @@ data API mode = API internalRequest :: mode :- "rpc" - :> Header "Wire-Origin-Request-Id" RequestId :> Capture "domain" Domain :> Capture "component" Component :> Capture "rpc" RPC :> Endpath - -- We need to use 'Raw' so we can stream request body regardless of - -- content-type and send a response with arbitrary content-type. Not - -- sure if this is the right approach. - :> Raw + -- We need to use 'RawM' so we can stream request body regardless of + -- content-type and send a response with arbitrary content-type. + :> RawM.RawM } deriving (Generic) @@ -86,17 +78,16 @@ server :: Member (Error ServerError) r, Member (Input FederationDomainConfigs) r, Member Metrics r, - Member (Logger (Log.Msg -> Log.Msg)) r + Member (Logger (Log.Msg -> Log.Msg)) r, + Member (Error Servant.ServerError) r ) => Manager -> Word16 -> - (Sem r Wai.Response -> Codensity IO Wai.Response) -> - API AsServer -server mgr extPort interpreter = + API (AsServerT (Sem r)) +server mgr extPort = API { status = Health.status mgr "external server" extPort, - internalRequest = \mReqId remoteDomain component rpc -> - Tagged $ \req respond -> runCodensity (interpreter (callOutward mReqId remoteDomain component rpc req)) respond + internalRequest = callOutward } callOutward :: @@ -108,23 +99,13 @@ callOutward :: Member Metrics r, Member (Logger (Log.Msg -> Log.Msg)) r ) => - Maybe RequestId -> Domain -> Component -> RPC -> Wai.Request -> - Sem r Wai.Response -callOutward mReqId targetDomain component (RPC path) req = do - rid <- case mReqId of - Just r -> pure r - Nothing -> do - localRid <- liftIO $ RequestId . T.encodeUtf8 . UUID.toText <$> UUID.nextRandom - info $ - "request-id" .= localRid - ~~ "method" .= Wai.requestMethod req - ~~ "path" .= Wai.rawPathInfo req - ~~ msg (val "generated a new request id for local request") - pure localRid + (Wai.Response -> IO Wai.ResponseReceived) -> + Sem r Wai.ResponseReceived +callOutward targetDomain component (RPC path) req cont = do -- only POST is supported when (Wai.requestMethod req /= HTTP.methodPost) $ throw InvalidRoute @@ -142,17 +123,13 @@ callOutward mReqId targetDomain component (RPC path) req = do . Log.field "body" body resp <- discoverAndCall - rid targetDomain component path (Wai.requestHeaders req) (fromLazyByteString body) - pure $ streamingResponseToWai resp + embed . cont $ streamingResponseToWai resp serveOutward :: Env -> Int -> IO () -serveOutward env = - serveServant - (Metrics.servantPrometheusMiddleware $ Proxy @(ToServantApi API)) - (server env._httpManager env._externalPort $ runFederator env) - env +serveOutward env port = do + serveServant @(ToServantApi API) env port (toServant $ server env._httpManager env._internalPort) diff --git a/services/federator/src/Federator/Interpreter.hs b/services/federator/src/Federator/Interpreter.hs new file mode 100644 index 00000000000..2042ab1e043 --- /dev/null +++ b/services/federator/src/Federator/Interpreter.hs @@ -0,0 +1,190 @@ +module Federator.Interpreter + ( runWaiErrors, + serveServant, + ) +where + +import Control.Lens +import Control.Monad.Codensity +import Control.Monad.Except (ExceptT (..)) +import Data.Aeson (encode) +import Data.Id +import Data.Kind +import Data.Metrics.Servant qualified as Metrics +import Data.Text qualified as T +import Data.Text.Lazy qualified as LText +import Federator.Discovery +import Federator.Env +import Federator.Error +import Federator.Error.ServerError +import Federator.Metrics (Metrics, interpretMetrics) +import Federator.Options +import Federator.Remote +import Federator.Service +import Federator.Validation +import HTTP2.Client.Manager (Http2Manager) +import Imports +import Network.HTTP.Types qualified as HTTP +import Network.Wai qualified as Wai +import Network.Wai.Handler.Warp qualified as Warp +import Network.Wai.Utilities (getRequestId) +import Network.Wai.Utilities.Error qualified as Wai +import Network.Wai.Utilities.Server (federationRequestIdHeaderName, requestIdMiddleware) +import Network.Wai.Utilities.Server qualified as Wai +import Polysemy +import Polysemy.Embed +import Polysemy.Error +import Polysemy.Input +import Polysemy.Internal +import Polysemy.TinyLog +import Servant (ServerError (..), serve) +import Servant hiding (ServerError, respond, serve) +import Servant.Client (mkClientEnv) +import Servant.Client.Core +import Util.Options (Endpoint (..)) +import Wire.API.FederationUpdate qualified as FedUp (getFederationDomainConfigs) +import Wire.API.MakesFederatedCall (Component (Brig)) +import Wire.API.Routes.FederationDomainConfig qualified as FedUp (FederationDomainConfigs) +import Wire.Network.DNS.Effect +import Wire.Sem.Logger.TinyLog + +class ErrorEffects (ee :: [Type]) r where + type Row ee :: EffectRow + runWaiErrorsEither :: + Sem (Append (Row ee) r) (Either Wai.Error a) -> + Sem r (Either Wai.Error a) + +runWaiErrors :: + forall ee r a. + (ErrorEffects ee r, Member (Error Servant.ServerError) r) => + Sem (Append (Row ee) r) a -> + Sem r a +runWaiErrors action = do + x <- runWaiErrorsEither @ee . fmap Right $ action + case x of + Left e -> throw $ waiToServant e + Right a -> pure a + +instance ErrorEffects '[] r where + type Row '[] = '[] + runWaiErrorsEither = id + +instance + ( Member TinyLog (Append (Row ee) r), + AsWai e, + ErrorEffects ee r + ) => + ErrorEffects (e ': ee) r + where + type Row (e ': ee) = (Error e ': Row ee) + runWaiErrorsEither action = do + runWaiErrorsEither @ee $ runWaiErrorEither @e action + +runWaiErrorEither :: + (AsWai e, Member TinyLog r) => + Sem (Error e ': r) (Either Wai.Error a) -> + Sem r (Either Wai.Error a) +runWaiErrorEither = + fmap join + . runError + . flip catch logError + . mapError toWai + . raiseUnder + where + logError :: + ( Member (Error Wai.Error) r, + Member TinyLog r + ) => + Wai.Error -> + Sem r a + logError e = do + err $ Wai.logErrorMsg e + throw e + +serveServant :: + forall (api :: Type). + (HasServer api '[], Metrics.RoutesToPaths api) => + Env -> + Int -> + ServerT api (Sem AllEffects) -> + IO () +serveServant env port server = do + let hoistApp :: RequestId -> Server api + hoistApp rid = + hoistServerWithContext (Proxy @api) (Proxy @'[]) (runFederator env rid) server + Warp.run port + . requestIdMiddleware env._applog federationRequestIdHeaderName + . Wai.catchErrors (view applog env) federationRequestIdHeaderName + . Metrics.servantPrometheusMiddleware (Proxy @api) + $ app hoistApp + where + app :: (RequestId -> Server api) -> Wai.Application + app mkServerFromReqId req cont = do + let rid = getRequestId federationRequestIdHeaderName req + serve (Proxy @api) (mkServerFromReqId rid) req cont + +type AllEffects = + '[ Metrics, + Remote, + DiscoverFederator, + DNSLookup, -- needed by DiscoverFederator + ServiceStreaming, + Input RunSettings, + Input Http2Manager, -- needed by Remote + Input FedUp.FederationDomainConfigs, -- needed for the domain list and federation policy. + Input Env, -- needed by Service + Input RequestId, + Error ValidationError, + Error RemoteError, + Error Federator.Error.ServerError.ServerError, + Error DiscoveryFailure, + Error Servant.ServerError, + TinyLog, + Embed IO, + Embed (Codensity IO) + ] + +runFederator :: Env -> RequestId -> Sem AllEffects a -> Handler a +runFederator env rid = + Handler + . ExceptT + . lowerCodensity + . runM + . runEmbedded (liftIO @(Codensity IO)) + . loggerToTinyLogReqId rid (view applog env) + . runError + . runWaiErrors + @'[ ValidationError, + RemoteError, + Federator.Error.ServerError.ServerError, + DiscoveryFailure + ] + . runInputConst rid + . runInputConst env + . runInputSem (embed @IO (getFederationDomainConfigs env)) + . runInputSem (embed @IO (readIORef (view http2Manager env))) + . runInputConst (view runSettings env) + . interpretServiceHTTP + . runDNSLookupWithResolver (view dnsResolver env) + . runFederatorDiscovery + . interpretRemote + . interpretMetrics + +waiToServant :: Wai.Error -> Servant.ServerError +waiToServant waierr = + ServerError + { errHTTPCode = HTTP.statusCode (Wai.code waierr), + errReasonPhrase = LText.unpack (Wai.label waierr), + errBody = encode waierr, + errHeaders = [("Content-Type", "application/json")] + } + +getFederationDomainConfigs :: Env -> IO FedUp.FederationDomainConfigs +getFederationDomainConfigs env = do + let mgr = env ^. httpManager + Endpoint h p = env ^. service $ Brig + baseurl = BaseUrl Http (T.unpack h) (fromIntegral p) "" + clientEnv = mkClientEnv mgr baseurl + FedUp.getFederationDomainConfigs clientEnv >>= \case + Right v -> pure v + Left e -> error $ show e diff --git a/services/federator/src/Federator/MockServer.hs b/services/federator/src/Federator/MockServer.hs index 463967531ba..d7706119998 100644 --- a/services/federator/src/Federator/MockServer.hs +++ b/services/federator/src/Federator/MockServer.hs @@ -52,8 +52,8 @@ import Data.Text.Lazy qualified as LText import Federator.Error import Federator.Error.ServerError import Federator.InternalServer +import Federator.Interpreter import Federator.RPC -import Federator.Response import Federator.Validation import Imports hiding (fromException) import Network.HTTP.Media qualified as HTTP @@ -65,7 +65,7 @@ import Network.Wai.Utilities.MockServer import Polysemy import Polysemy.Error hiding (throw) import Servant.API -import Servant.Server (Tagged (..)) +import Servant.Server qualified as Servant import Servant.Server.Generic import Wire.API.Federation.API (Component) import Wire.API.Federation.API.Common @@ -108,14 +108,11 @@ mockServer :: ) => IORef [FederatedRequest] -> MockFederator -> - (Sem r Wai.Response -> IO Wai.Response) -> - API AsServer -mockServer remoteCalls mock interpreter = + API (AsServerT (Sem r)) +mockServer remoteCalls mock = Federator.InternalServer.API { status = const $ pure NoContent, - internalRequest = \_mReqId targetDomain component rpc -> - Tagged $ \req respond -> - respond =<< interpreter (mockInternalRequest remoteCalls mock targetDomain component rpc req) + internalRequest = mockInternalRequest remoteCalls mock } mockInternalRequest :: @@ -130,8 +127,9 @@ mockInternalRequest :: Component -> RPC -> Wai.Request -> - Sem r Wai.Response -mockInternalRequest remoteCalls mock targetDomain component (RPC path) req = do + (Wai.Response -> IO Wai.ResponseReceived) -> + Sem r Wai.ResponseReceived +mockInternalRequest remoteCalls mock targetDomain component (RPC path) req cont = do domainTxt <- note NoOriginDomain $ lookup originDomainHeaderName (Wai.requestHeaders req) originDomain <- parseDomain domainTxt reqBody <- embed $ Wai.lazyRequestBody req @@ -153,7 +151,7 @@ mockInternalRequest remoteCalls mock targetDomain component (RPC path) req = do . handle (throw . handleException) $ mock.handler fedRequest let headers = ("Content-Type", HTTP.renderHeader ct) : mock.headers - pure $ Wai.responseLBS HTTP.status200 headers resBody + embed . cont $ Wai.responseLBS HTTP.status200 headers resBody where handleException :: SomeException -> MockException handleException e = case Exception.fromException e of @@ -187,14 +185,17 @@ withTempMockFederator :: withTempMockFederator mock action = do remoteCalls <- newIORef [] let interpreter = - runM + Servant.Handler + . ExceptT + . runM . discardTinyLogs + . runError . runWaiErrors @'[ ValidationError, ServerError, MockException ] - app = genericServe (mockServer remoteCalls mock interpreter) + app = genericServeT interpreter (mockServer remoteCalls mock) result <- bracket (liftIO (startMockServer Nothing app)) @@ -233,7 +234,7 @@ getRequestRPC :: Mock Text getRequestRPC = frRPC <$> getRequest -- | Retrieve and deserialise the body of the current request. -getRequestBody :: Aeson.FromJSON a => Mock a +getRequestBody :: (Aeson.FromJSON a) => Mock a getRequestBody = do b <- frBody <$> getRequest case Aeson.eitherDecode b of @@ -256,7 +257,7 @@ guardComponent c = do guard (c == c') -- | Serialise and return a response. -mockReply :: Aeson.ToJSON a => a -> Mock LByteString +mockReply :: (Aeson.ToJSON a) => a -> Mock LByteString mockReply = pure . Aeson.encode -- | Provide a mock reply simulating an unreachable backend. @@ -274,5 +275,5 @@ infixl 5 ~> -- | Expect a given RPC and simply return a pure response when the current -- request matches. -(~>) :: Aeson.ToJSON a => Text -> a -> Mock LByteString +(~>) :: (Aeson.ToJSON a) => Text -> a -> Mock LByteString (~>) rpc x = guardRPC rpc *> mockReply x diff --git a/services/federator/src/Federator/Monitor/Internal.hs b/services/federator/src/Federator/Monitor/Internal.hs index 1b6b74f84d1..6f37abdc80f 100644 --- a/services/federator/src/Federator/Monitor/Internal.hs +++ b/services/federator/src/Federator/Monitor/Internal.hs @@ -344,7 +344,7 @@ mkSSLContext settings = do ctx <- mkSSLContextWithoutCert settings Polysemy.fromExceptionVia @SomeException (InvalidClientCertificate . displayException) $ - SSL.contextSetCertificateFile ctx (clientCertificate settings) + SSL.contextSetCertificateChainFile ctx (clientCertificate settings) Polysemy.fromExceptionVia @SomeException (InvalidClientPrivateKey . displayException) $ SSL.contextSetPrivateKeyFile ctx (clientPrivateKey settings) @@ -355,7 +355,7 @@ mkSSLContext settings = do pure ctx -mkSSLContextWithoutCert :: Members '[Embed IO, Polysemy.Error FederationSetupError] r => RunSettings -> Sem r SSLContext +mkSSLContextWithoutCert :: (Members '[Embed IO, Polysemy.Error FederationSetupError] r) => RunSettings -> Sem r SSLContext mkSSLContextWithoutCert settings = do ctx <- embed $ SSL.context embed $ do diff --git a/services/federator/src/Federator/Remote.hs b/services/federator/src/Federator/Remote.hs index 2bc3ae9a05b..06d2246bb58 100644 --- a/services/federator/src/Federator/Remote.hs +++ b/services/federator/src/Federator/Remote.hs @@ -70,7 +70,6 @@ instance AsWai RemoteError where data Remote m a where DiscoverAndCall :: - RequestId -> Domain -> Component -> Text -> @@ -85,13 +84,15 @@ interpretRemote :: Member DiscoverFederator r, Member (Error DiscoveryFailure) r, Member (Error RemoteError) r, - Member (Input Http2Manager) r + Member (Input Http2Manager) r, + Member (Input RequestId) r ) => Sem (Remote ': r) a -> Sem r a interpretRemote = interpret $ \case - DiscoverAndCall rid domain component rpc headers body -> do + DiscoverAndCall domain component rpc headers body -> do target@(SrvTarget hostname port) <- discoverFederatorWithError domain + RequestId rid <- input let path = LBS.toStrict . toLazyByteString $ HTTP.encodePathSegments ["federation", componentName component, rpc] @@ -99,7 +100,7 @@ interpretRemote = interpret $ \case -- filter out Host header, because the HTTP2 client adds it back headers' = filter ((/= "Host") . fst) headers - <> [(RPC.requestIdName, unRequestId rid)] + <> [(RPC.requestIdName, rid)] req' = HTTP2.requestBuilder HTTP.methodPost path headers' body mgr <- input diff --git a/services/federator/src/Federator/Response.hs b/services/federator/src/Federator/Response.hs index f4082f93c1a..7633252c287 100644 --- a/services/federator/src/Federator/Response.hs +++ b/services/federator/src/Federator/Response.hs @@ -15,172 +15,13 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Federator.Response - ( defaultHeaders, - serveServant, - runFederator, - runWaiError, - runWaiErrors, - streamingResponseToWai, - ) -where +module Federator.Response where -import Control.Lens -import Control.Monad.Codensity import Data.ByteString.Builder -import Data.Kind -import Data.Text qualified as T -import Federator.Discovery -import Federator.Env -import Federator.Error -import Federator.Error.ServerError -import Federator.Metrics (Metrics, interpretMetrics) -import Federator.Options -import Federator.Remote -import Federator.Service -import Federator.Validation -import HTTP2.Client.Manager (Http2Manager) import Imports -import Network.HTTP.Types qualified as HTTP -import Network.Wai (Middleware) import Network.Wai qualified as Wai -import Network.Wai.Handler.Warp qualified as Warp -import Network.Wai.Utilities.Error qualified as Wai -import Network.Wai.Utilities.Server qualified as Wai -import Polysemy -import Polysemy.Embed -import Polysemy.Error -import Polysemy.Input -import Polysemy.Internal -import Polysemy.TinyLog -import Servant hiding (ServerError, respond, serve) -import Servant.Client (mkClientEnv) import Servant.Client.Core -import Servant.Server.Generic import Servant.Types.SourceT -import Util.Options (Endpoint (..)) -import Wire.API.FederationUpdate qualified as FedUp (getFederationDomainConfigs) -import Wire.API.MakesFederatedCall (Component (Brig)) -import Wire.API.Routes.FederationDomainConfig qualified as FedUp (FederationDomainConfigs) -import Wire.Network.DNS.Effect -import Wire.Sem.Logger.TinyLog - -defaultHeaders :: [HTTP.Header] -defaultHeaders = [("Content-Type", "application/json")] - -class ErrorEffects (ee :: [Type]) r where - type Row ee :: EffectRow - runWaiErrors :: - Sem (Append (Row ee) r) Wai.Response -> - Sem r Wai.Response - -instance ErrorEffects '[] r where - type Row '[] = '[] - runWaiErrors = id - -instance - ( Member TinyLog (Append (Row ee) r), - AsWai e, - ErrorEffects ee r - ) => - ErrorEffects (e ': ee) r - where - type Row (e ': ee) = (Error e ': Row ee) - runWaiErrors = runWaiErrors @ee . runWaiError @e - -runWaiError :: - (AsWai e, Member TinyLog r) => - Sem (Error e ': r) Wai.Response -> - Sem r Wai.Response -runWaiError = - fmap (either (errorResponse defaultHeaders) id) - . runError - . flip catch logError - . mapError toWai - . raiseUnder - where - logError :: - ( Member (Error Wai.Error) r, - Member TinyLog r - ) => - Wai.Error -> - Sem r a - logError e = do - err $ Wai.logErrorMsg e - throw e - -serveServant :: - forall routes. - (HasServer (ToServantApi routes) '[], GenericServant routes AsServer, Server (ToServantApi routes) ~ ToServant routes AsServer) => - Middleware -> - routes AsServer -> - Env -> - Int -> - IO () -serveServant middleware server env port = - Warp.run port - . Wai.catchErrorsWithRequestId getRequestId (view applog env) [] - . middleware - $ app - where - app :: Wai.Application - app = - genericServe server - - getRequestId :: Wai.Request -> Maybe ByteString - getRequestId = lookup "Wire-Origin-Request-Id" . Wai.requestHeaders - -type AllEffects = - '[ Metrics, - Remote, - DiscoverFederator, - DNSLookup, -- needed by DiscoverFederator - ServiceStreaming, - Input RunSettings, - Input Http2Manager, -- needed by Remote - Input FedUp.FederationDomainConfigs, -- needed for the domain list and federation policy. - Input Env, -- needed by Service - Error ValidationError, - Error RemoteError, - Error ServerError, - Error DiscoveryFailure, - TinyLog, - Embed IO, - Embed (Codensity IO) - ] - --- | Run Sem action containing HTTP handlers. All errors have to been handled --- already by this point. -runFederator :: Env -> Sem AllEffects Wai.Response -> Codensity IO Wai.Response -runFederator env = - runM - . runEmbedded @IO @(Codensity IO) liftIO - . loggerToTinyLogReqId (view requestId env) (view applog env) - . runWaiErrors - @'[ ValidationError, - RemoteError, - ServerError, - DiscoveryFailure - ] - . runInputConst env - . runInputSem (embed @IO (getFederationDomainConfigs env)) - . runInputSem (embed @IO (readIORef (view http2Manager env))) - . runInputConst (view runSettings env) - . interpretServiceHTTP - . runDNSLookupWithResolver (view dnsResolver env) - . runFederatorDiscovery - . interpretRemote - . interpretMetrics - -getFederationDomainConfigs :: Env -> IO FedUp.FederationDomainConfigs -getFederationDomainConfigs env = do - let mgr = env ^. httpManager - Endpoint h p = env ^. service $ Brig - baseurl = BaseUrl Http (T.unpack h) (fromIntegral p) "" - clientEnv = mkClientEnv mgr baseurl - FedUp.getFederationDomainConfigs clientEnv >>= \case - Right v -> pure v - Left e -> error $ show e streamingResponseToWai :: StreamingResponse -> Wai.Response streamingResponseToWai resp = diff --git a/services/federator/src/Federator/Run.hs b/services/federator/src/Federator/Run.hs index 3ebcb41fbf1..c02d9f25f7d 100644 --- a/services/federator/src/Federator/Run.hs +++ b/services/federator/src/Federator/Run.hs @@ -38,7 +38,7 @@ import Control.Concurrent.Async import Control.Exception (bracket) import Control.Lens ((^.)) import Data.Id -import Data.Metrics.Middleware qualified as Metrics +import Data.Metrics.GC import Federator.Env import Federator.ExternalServer (serveInward) import Federator.InternalServer (serveOutward) @@ -60,6 +60,7 @@ import Wire.Network.DNS.Helper qualified as DNS -- FUTUREWORK(federation): Add metrics and status endpoints run :: Opts -> IO () run opts = do + spawnGCMetricsCollector let resolvConf = mkResolvConf (optSettings opts) DNS.defaultResolvConf DNS.withCachingResolver resolvConf $ \res -> do logger <- LogExt.mkLogger (Opt.logLevel opts) (Opt.logNetStrings opts) (Opt.logFormat opts) @@ -91,7 +92,6 @@ run opts = do newEnv :: Opts -> DNS.Resolver -> Log.Logger -> IO Env newEnv o _dnsResolver _applog = do - _metrics <- Metrics.metrics let _requestId = RequestId "N/A" _runSettings = Opt.optSettings o _service Brig = Opt.brig o diff --git a/services/federator/src/Federator/Service.hs b/services/federator/src/Federator/Service.hs index b4f859d52bf..1e9d98330cf 100644 --- a/services/federator/src/Federator/Service.hs +++ b/services/federator/src/Federator/Service.hs @@ -53,11 +53,11 @@ type ServiceStreaming = Service (SourceT IO ByteString) data Service body m a where -- | Returns status, headers and body, 'HTTP.Response' is not nice to work with in tests - ServiceCall :: Component -> ByteString -> RequestHeaders -> LByteString -> RequestId -> Domain -> Service body m (Servant.ResponseF body) + ServiceCall :: Component -> ByteString -> RequestHeaders -> LByteString -> Domain -> Service body m (Servant.ResponseF body) makeSem ''Service -bodyReaderToStreamT :: Monad m => m ByteString -> SourceT m ByteString +bodyReaderToStreamT :: (Monad m) => m ByteString -> SourceT m ByteString bodyReaderToStreamT action = fromStepT go where go = Effect $ do @@ -77,14 +77,16 @@ bodyReaderToStreamT action = fromStepT go -- interpretServiceHTTP :: ( Member (Embed (Codensity IO)) r, - Member (Input Env) r + Member (Input Env) r, + Member (Input RequestId) r ) => Sem (ServiceStreaming ': r) a -> Sem r a interpretServiceHTTP = interpret $ \case - ServiceCall component rpcPath headers body rid domain -> do + ServiceCall component rpcPath headers body domain -> do Endpoint serviceHost servicePort <- inputs (view service) <*> pure component manager <- inputs (view httpManager) + RequestId rid <- input let req = defaultRequest { method = HTTP.methodPost, @@ -95,7 +97,7 @@ interpretServiceHTTP = interpret $ \case requestHeaders = [ ("Content-Type", "application/json"), (originDomainHeaderName, Text.encodeUtf8 (domainText domain)), - (RPC.requestIdName, unRequestId rid) + (RPC.requestIdName, rid) ] <> headers } diff --git a/services/federator/test/integration/Test/Federator/IngressSpec.hs b/services/federator/test/integration/Test/Federator/IngressSpec.hs index f28fca1bdf1..2165edb0761 100644 --- a/services/federator/test/integration/Test/Federator/IngressSpec.hs +++ b/services/federator/test/integration/Test/Federator/IngressSpec.hs @@ -94,8 +94,8 @@ testRejectRequestsWithoutClientCertIngress env = runTestFederator env $ do sslCtxWithoutCert <- either (throwM @_ @FederationSetupError) pure <=< runM - . runEmbedded (liftIO @(TestFederator IO)) - . runError + . runEmbedded (liftIO @(TestFederator IO)) + . runError $ mkSSLContextWithoutCert settings runTestSem $ do r <- @@ -110,7 +110,7 @@ testRejectRequestsWithoutClientCertIngress env = runTestFederator env $ do expectationFailure "Expected client certificate error, got remote error" Left (RemoteErrorResponse _ _ status _) -> status `shouldBe` HTTP.status400 -liftToCodensity :: Member (Embed (Codensity IO)) r => Sem (Embed IO ': r) a -> Sem r a +liftToCodensity :: (Member (Embed (Codensity IO)) r) => Sem (Embed IO ': r) a -> Sem r a liftToCodensity = runEmbedded @IO @(Codensity IO) lift runTestSem :: Sem '[Input TestEnv, Embed (Codensity IO)] a -> TestFederator IO a @@ -124,7 +124,7 @@ discoverConst target = interpret $ \case DiscoverAllFederators _ -> pure (Right (pure target)) inwardBrigCallViaIngress :: - Members [Input TestEnv, Embed (Codensity IO), Error RemoteError] r => + (Members [Input TestEnv, Embed (Codensity IO), Error RemoteError] r) => Text -> Builder -> Sem r StreamingResponse @@ -133,7 +133,7 @@ inwardBrigCallViaIngress path payload = do inwardBrigCallViaIngressWithSettings sslCtx path payload inwardBrigCallViaIngressWithSettings :: - Members [Input TestEnv, Embed (Codensity IO), Error RemoteError] r => + (Members [Input TestEnv, Embed (Codensity IO), Error RemoteError] r) => SSLContext -> Text -> Builder -> @@ -147,7 +147,8 @@ inwardBrigCallViaIngressWithSettings sslCtx requestPath payload = mgr <- liftToCodensity . liftIO $ http2ManagerWithSSLCtx sslCtx liftToCodensity . runInputConst mgr + . runInputConst (RequestId "N/A") . assertNoError @DiscoveryFailure . discoverConst target . interpretRemote - $ discoverAndCall (RequestId "N/A") (Domain "example.com") Brig requestPath headers payload + $ discoverAndCall (Domain "example.com") Brig requestPath headers payload diff --git a/services/federator/test/integration/Test/Federator/Util.hs b/services/federator/test/integration/Test/Federator/Util.hs index 549590cb6af..92d80d7d752 100644 --- a/services/federator/test/integration/Test/Federator/Util.hs +++ b/services/federator/test/integration/Test/Federator/Util.hs @@ -77,10 +77,10 @@ newtype TestFederator m a = TestFederator {unwrapTestFederator :: ReaderT TestEn MonadMask ) -instance MonadRandom m => MonadRandom (TestFederator m) where +instance (MonadRandom m) => MonadRandom (TestFederator m) where getRandomBytes = lift . getRandomBytes -instance MonadIO m => MonadHttp (TestFederator m) where +instance (MonadIO m) => MonadHttp (TestFederator m) where handleRequestWithCont req handler = do manager <- _teMgr <$> ask liftIO $ withResponse req manager handler @@ -149,7 +149,7 @@ cliOptsParser = defaultFederatorPath = "/etc/wire/federator/conf/federator.yaml" -- | Create an environment for integration tests from integration and federator config files. -mkEnv :: HasCallStack => IntegrationConfig -> Opts -> IO TestEnv +mkEnv :: (HasCallStack) => IntegrationConfig -> Opts -> IO TestEnv mkEnv _teTstOpts _teOpts = do let managerSettings = mkManagerSettings (Network.Connection.TLSSettingsSimple True False False) Nothing _teMgr :: Manager <- newManager managerSettings @@ -160,7 +160,7 @@ mkEnv _teTstOpts _teOpts = do let _teSettings = optSettings _teOpts pure TestEnv {..} -destroyEnv :: HasCallStack => TestEnv -> IO () +destroyEnv :: (HasCallStack) => TestEnv -> IO () destroyEnv _ = pure () endpointToReq :: Endpoint -> (Bilge.Request -> Bilge.Request) @@ -273,7 +273,7 @@ putHandle brig usr h = where payload = RequestBodyLBS . encode $ object ["handle" .= h] -randomName :: MonadIO m => m Name +randomName :: (MonadIO m) => m Name randomName = randomNameWithMaxLen 128 -- | For testing purposes we restrict ourselves to code points in the @@ -285,7 +285,7 @@ randomName = randomNameWithMaxLen 128 -- the standard tokenizer considers as word boundaries (or which are -- simply unassigned code points), yielding no tokens to match and thus -- no results in search queries. -randomNameWithMaxLen :: MonadIO m => Word -> m Name +randomNameWithMaxLen :: (MonadIO m) => Word -> m Name randomNameWithMaxLen maxLen = liftIO $ do len <- randomRIO (2, maxLen) chars <- fill len [] @@ -305,7 +305,7 @@ randomNameWithMaxLen maxLen = liftIO $ do then pure c else randLetter -randomPhone :: MonadIO m => m Phone +randomPhone :: (MonadIO m) => m Phone randomPhone = liftIO $ do nrs <- map show <$> replicateM 14 (randomRIO (0, 9) :: IO Int) let phone = parsePhone . Text.pack $ "+0" ++ concat nrs @@ -319,13 +319,13 @@ defCookieLabel = CookieLabel "auth" -- | Generate emails that are in the trusted whitelist of domains whose @+@ suffices count for email -- disambiguation. See also: 'Brig.Email.mkEmailKey'. -randomEmail :: MonadIO m => m Email +randomEmail :: (MonadIO m) => m Email randomEmail = mkSimulatorEmail "success" -mkSimulatorEmail :: MonadIO m => Text -> m Email +mkSimulatorEmail :: (MonadIO m) => Text -> m Email mkSimulatorEmail loc = mkEmailRandomLocalSuffix (loc <> "@simulator.amazonses.com") -mkEmailRandomLocalSuffix :: MonadIO m => Text -> m Email +mkEmailRandomLocalSuffix :: (MonadIO m) => Text -> m Email mkEmailRandomLocalSuffix e = do uid <- liftIO UUID.nextRandom case parseEmail e of @@ -338,7 +338,7 @@ zUser = header "Z-User" . C8.pack . show zConn :: ByteString -> Bilge.Request -> Bilge.Request zConn = header "Z-Connection" -randomHandle :: MonadIO m => m Text +randomHandle :: (MonadIO m) => m Text randomHandle = liftIO $ do nrs <- replicateM 21 (randomRIO (97, 122)) -- a-z pure (Text.pack (map chr nrs)) diff --git a/services/federator/test/unit/Main.hs b/services/federator/test/unit/Main.hs index f58f7a80652..1936df48d0d 100644 --- a/services/federator/test/unit/Main.hs +++ b/services/federator/test/unit/Main.hs @@ -28,7 +28,6 @@ import Test.Federator.InternalServer qualified import Test.Federator.Monitor qualified import Test.Federator.Options qualified import Test.Federator.Remote qualified -import Test.Federator.Response qualified import Test.Federator.Validation qualified import Test.Tasty @@ -44,6 +43,5 @@ main = Test.Federator.InternalServer.tests, Test.Federator.ExternalServer.tests, Test.Federator.Monitor.tests, - Test.Federator.Remote.tests, - Test.Federator.Response.tests + Test.Federator.Remote.tests ] diff --git a/services/federator/test/unit/Test/Federator/Client.hs b/services/federator/test/unit/Test/Federator/Client.hs index 6100252dbbe..a816f7710c9 100644 --- a/services/federator/test/unit/Test/Federator/Client.hs +++ b/services/federator/test/unit/Test/Federator/Client.hs @@ -40,6 +40,7 @@ import Network.HTTP2.Client qualified as HTTP2 import Network.Wai qualified as Wai import Network.Wai.Utilities.Error qualified as Wai import Network.Wai.Utilities.MockServer +import Network.Wai.Utilities.Server import Servant.API import Servant.Client hiding ((//)) import Servant.Client.Core @@ -221,7 +222,7 @@ testResponseHeaders = do HTTP2.requestBuilder HTTP.methodPost "/rpc/target.example.com/brig/test" - [("Wire-Origin-Domain", "origin.example.com")] + [("Wire-Origin-Domain", "origin.example.com"), (federationRequestIdHeaderName, "rid")] "body" mgr <- defaultHttp2Manager performHTTP2Request mgr (False, "127.0.0.1", port) req diff --git a/services/federator/test/unit/Test/Federator/ExternalServer.hs b/services/federator/test/unit/Test/Federator/ExternalServer.hs index 7e499e3bc56..ac45f5aae2d 100644 --- a/services/federator/test/unit/Test/Federator/ExternalServer.hs +++ b/services/federator/test/unit/Test/Federator/ExternalServer.hs @@ -19,7 +19,7 @@ module Test.Federator.ExternalServer where -import Control.Monad.Codensity +import Control.Monad.Except import Data.ByteString qualified as BS import Data.Default import Data.Domain @@ -29,9 +29,9 @@ import Data.Text.Encoding qualified as Text import Federator.Discovery import Federator.Error.ServerError (ServerError (..)) import Federator.ExternalServer +import Federator.Interpreter import Federator.Metrics import Federator.Options -import Federator.Response import Federator.Service (Service (..), ServiceStreaming) import Federator.Validation import Imports @@ -46,6 +46,7 @@ import Polysemy.Input import Polysemy.Output import Polysemy.TinyLog import Servant.Client.Core qualified as Servant +import Servant.Server qualified as Servant import Servant.Server.Generic import Servant.Types.SourceT import System.Logger (Msg) @@ -99,12 +100,12 @@ data Call = Call deriving (Eq, Show) mockService :: - Members [Output Call, Embed IO] r => + (Members [Output Call, Embed IO] r) => HTTP.Status -> Sem (ServiceStreaming ': r) a -> Sem r a mockService status = interpret $ \case - ServiceCall comp path headers body _mReqId domain -> do + ServiceCall comp path headers body domain -> do output (Call comp path headers body domain) pure Servant.Response @@ -130,12 +131,13 @@ requestBrigSuccess = } Right cert <- decodeCertificate <$> BS.readFile "test/resources/unit/localhost.example.com.pem" - let assertMetrics :: Member (Embed IO) r => Sem (Metrics ': r) a -> Sem r a + let assertMetrics :: (Member (Embed IO) r) => Sem (Metrics ': r) a -> Sem r a assertMetrics = interpret $ \case OutgoingCounterIncr _ -> embed @IO $ assertFailure "Should not increment outgoing counter" IncomingCounterIncr od -> embed @IO $ od @?= aValidDomain - (actualCalls, res) <- + resRef <- newIORef Nothing + (actualCalls, _) <- runM . assertMetrics . runOutputList @@ -147,7 +149,9 @@ requestBrigSuccess = . mockDiscoveryTrivial . runInputConst noClientCertSettings . runInputConst scaffoldingFederationDomainConfigs - $ callInward Brig (RPC "get-user-by-handle") Nothing aValidDomain (CertHeader cert) request + $ callInward Brig (RPC "get-user-by-handle") aValidDomain (CertHeader cert) request (saveResponse resRef) + + Just res <- readIORef resRef let expectedCall = Call Brig "/federation/get-user-by-handle" [("X-Wire-API-Version", "v0")] "\"foo\"" aValidDomain assertEqual "one call to brig should be made" [expectedCall] actualCalls Wai.responseStatus res @?= HTTP.status200 @@ -163,7 +167,8 @@ requestBrigFailure = "/federation/brig/get-user-by-handle" Right cert <- decodeCertificate <$> BS.readFile "test/resources/unit/localhost.example.com.pem" - (actualCalls, res) <- + resRef <- newIORef Nothing + (actualCalls, _) <- runM . interpretMetricsEmpty . runOutputList @@ -175,8 +180,9 @@ requestBrigFailure = . mockDiscoveryTrivial . runInputConst noClientCertSettings . runInputConst scaffoldingFederationDomainConfigs - $ callInward Brig (RPC "get-user-by-handle") Nothing aValidDomain (CertHeader cert) request + $ callInward Brig (RPC "get-user-by-handle") aValidDomain (CertHeader cert) request (saveResponse resRef) + Just res <- readIORef resRef let expectedCall = Call Brig "/federation/get-user-by-handle" [] "\"foo\"" aValidDomain assertEqual "one call to brig should be made" [expectedCall] actualCalls Wai.responseStatus res @?= HTTP.notFound404 @@ -193,24 +199,27 @@ requestGalleySuccess = Right cert <- decodeCertificate <$> BS.readFile "test/resources/unit/localhost.example.com.pem" - runM $ do - (actualCalls, res) <- - runOutputList - . interpretMetricsEmpty - . mockService HTTP.ok200 - . assertNoError @ValidationError - . assertNoError @DiscoveryFailure - . assertNoError @ServerError - . discardTinyLogs - . mockDiscoveryTrivial - . runInputConst noClientCertSettings - . runInputConst scaffoldingFederationDomainConfigs - $ callInward Galley (RPC "get-conversations") Nothing aValidDomain (CertHeader cert) request - let expectedCall = Call Galley "/federation/get-conversations" [] "\"foo\"" aValidDomain - embed $ assertEqual "one call to galley should be made" [expectedCall] actualCalls - embed $ Wai.responseStatus res @?= HTTP.status200 - body <- embed $ Wai.lazyResponseBody res - embed $ body @?= "\"bar\"" + resRef <- newIORef Nothing + (actualCalls, _) <- + runM + . runOutputList + . interpretMetricsEmpty + . mockService HTTP.ok200 + . assertNoError @ValidationError + . assertNoError @DiscoveryFailure + . assertNoError @ServerError + . discardTinyLogs + . mockDiscoveryTrivial + . runInputConst noClientCertSettings + . runInputConst scaffoldingFederationDomainConfigs + $ callInward Galley (RPC "get-conversations") aValidDomain (CertHeader cert) request (saveResponse resRef) + + Just res <- readIORef resRef + let expectedCall = Call Galley "/federation/get-conversations" [] "\"foo\"" aValidDomain + assertEqual "one call to galley should be made" [expectedCall] actualCalls + Wai.responseStatus res @?= HTTP.status200 + body <- Wai.lazyResponseBody res + body @?= "\"bar\"" requestNoDomain :: TestTree requestNoDomain = @@ -223,7 +232,7 @@ requestNoDomain = trPath = "/federation/brig/get-users" } serviceCallsRef <- newIORef [] - let serverApp = genericServe $ server undefined undefined (testInterpretter serviceCallsRef) + let serverApp = genericServeT (testInterpreter serviceCallsRef) $ server undefined undefined void . serverApp request $ \res -> do serviceCalls <- readIORef serviceCallsRef assertEqual "Expected response to have status 400" status400 (Wai.responseStatus res) @@ -240,7 +249,7 @@ requestNoCertificate = trPath = "/federation/brig/get-users" } serviceCallsRef <- newIORef [] - let serverApp = genericServe $ server undefined undefined (testInterpretter serviceCallsRef) + let serverApp = genericServeT (testInterpreter serviceCallsRef) $ server undefined undefined void . serverApp request $ \res -> do serviceCalls <- readIORef serviceCallsRef assertEqual "Expected response to have status 400" status400 (Wai.responseStatus res) @@ -258,7 +267,7 @@ requestInvalidCertificate = trCertificateHeader = Just "not a certificate" } serviceCallsRef <- newIORef [] - let serverApp = genericServe $ server undefined undefined (testInterpretter serviceCallsRef) + let serverApp = genericServeT (testInterpreter serviceCallsRef) $ server undefined undefined void . serverApp request $ \res -> do serviceCalls <- readIORef serviceCallsRef assertEqual "Expected response to have status 400" status400 (Wai.responseStatus res) @@ -307,7 +316,7 @@ testInvalidPaths = do invalidPath serviceCallsRef <- newIORef [] - let serverApp = genericServe $ server undefined undefined (testInterpretter serviceCallsRef) + let serverApp = genericServeT (testInterpreter serviceCallsRef) $ server undefined undefined void . serverApp request $ \res -> do serviceCalls <- readIORef serviceCallsRef assertEqual "Unexpected status" expectedStatus (Wai.responseStatus res) @@ -328,7 +337,7 @@ testMethod = } request <- testRequest tr {trMethod = method} serviceCallsRef <- newIORef [] - let serverApp = genericServe $ server undefined undefined (testInterpretter serviceCallsRef) + let serverApp = genericServeT (testInterpreter serviceCallsRef) $ server undefined undefined void . serverApp request $ \res -> do serviceCalls <- readIORef serviceCallsRef assertEqual "Expected response to have status 403" status403 (Wai.responseStatus res) @@ -336,7 +345,7 @@ testMethod = pure Wai.ResponseReceived in map invalidMethodTest [HTTP.methodGet, HTTP.methodDelete, HTTP.methodPut, HTTP.methodPatch] -testInterpretter :: +testInterpreter :: IORef [Call] -> Sem '[ Metrics, @@ -346,25 +355,31 @@ testInterpretter :: Error DiscoveryFailure, Error ValidationError, Error ServerError, + Error Servant.ServerError, Logger (Msg -> Msg), ServiceStreaming, Output Call, Embed IO ] - Wai.Response -> - Codensity IO Wai.Response -testInterpretter serviceCallsRef = - liftIO + a -> + Servant.Handler a +testInterpreter serviceCallsRef = + Servant.Handler + . ExceptT . runM @IO . runOutputMonoidIORef @Call serviceCallsRef (: []) . mockService HTTP.ok200 . discardLogs + . runError . runWaiErrors @'[DiscoveryFailure, ValidationError, ServerError] . mockDiscoveryTrivial . runInputConst noClientCertSettings . runInputConst scaffoldingFederationDomainConfigs . interpretMetricsEmpty +saveResponse :: IORef (Maybe Wai.Response) -> Wai.Response -> IO Wai.ResponseReceived +saveResponse ref res = writeIORef ref (Just res) $> Wai.ResponseReceived + exampleDomain :: Text exampleDomain = "localhost.example.com" diff --git a/services/federator/test/unit/Test/Federator/InternalServer.hs b/services/federator/test/unit/Test/Federator/InternalServer.hs index 86f9f7e93e7..66706b74f68 100644 --- a/services/federator/test/unit/Test/Federator/InternalServer.hs +++ b/services/federator/test/unit/Test/Federator/InternalServer.hs @@ -32,6 +32,8 @@ import Federator.Validation import Imports import Network.HTTP.Types qualified as HTTP import Network.Wai qualified as Wai +import Network.Wai.Internal qualified as Wai +import Network.Wai.Utilities.Server (federationRequestIdHeaderName) import Network.Wai.Utilities.Server qualified as Wai import Polysemy import Polysemy.Error @@ -72,13 +74,13 @@ federatedRequestSuccess = trBody = "\"foo\"", trExtraHeaders = requestHeaders } - let interpretCall :: Member (Embed IO) r => Sem (Remote ': r) a -> Sem r a - interpretCall = interpret $ \case - DiscoverAndCall _ domain component rpc headers body -> embed @IO $ do + let verifyCallAndRespond :: (Member (Embed IO) r) => Sem (Remote ': r) a -> Sem r a + verifyCallAndRespond = interpret $ \case + DiscoverAndCall domain component rpc headers body -> embed @IO $ do domain @?= targetDomain component @?= Brig rpc @?= "get-user-by-handle" - headers @?= requestHeaders + sort headers @?= sort (requestHeaders <> [(federationRequestIdHeaderName, "test")]) toLazyByteString body @?= "\"foo\"" pure Response @@ -88,21 +90,24 @@ federatedRequestSuccess = responseBody = source ["\"bar\""] } - let assertMetrics :: Member (Embed IO) r => Sem (Metrics ': r) a -> Sem r a + let assertMetrics :: (Member (Embed IO) r) => Sem (Metrics ': r) a -> Sem r a assertMetrics = interpret $ \case OutgoingCounterIncr td -> embed @IO $ td @?= targetDomain IncomingCounterIncr _ -> embed @IO $ assertFailure "Should not increment incoming counter" - res <- + resRef <- newIORef Nothing + let saveResponse res = writeIORef resRef (Just res) $> Wai.ResponseReceived + _ <- runM - . interpretCall + . verifyCallAndRespond . assertNoError @ValidationError . assertNoError @ServerError . discardTinyLogs . runInputConst settings . runInputConst (FederationDomainConfigs AllowDynamic [FederationDomainConfig (Domain "target.example.com") FullSearch FederationRestrictionAllowAll] 10) . assertMetrics - $ callOutward Nothing targetDomain Brig (RPC "get-user-by-handle") request + $ callOutward targetDomain Brig (RPC "get-user-by-handle") request saveResponse + Just res <- readIORef resRef Wai.responseStatus res @?= HTTP.status200 body <- Wai.lazyResponseBody res body @?= "\"bar\"" @@ -147,5 +152,5 @@ federatedRequestFailureAllowList = . runInputConst settings . runInputConst (FederationDomainConfigs AllowDynamic [FederationDomainConfig (Domain "hello.world") FullSearch FederationRestrictionAllowAll] 10) . interpretMetricsEmpty - $ callOutward Nothing targetDomain Brig (RPC "get-user-by-handle") request + $ callOutward targetDomain Brig (RPC "get-user-by-handle") request undefined eith @?= Left (FederationDenied targetDomain) diff --git a/services/federator/test/unit/Test/Federator/Remote.hs b/services/federator/test/unit/Test/Federator/Remote.hs index 8d8de9f0660..0a8b92e432a 100644 --- a/services/federator/test/unit/Test/Federator/Remote.hs +++ b/services/federator/test/unit/Test/Federator/Remote.hs @@ -87,10 +87,11 @@ mkTestCall sslCtx hostname port = do . runError @RemoteError . void . runInputConst mgr + . runInputConst (RequestId "test") . discoverLocalhost hostname port . assertNoError @DiscoveryFailure . interpretRemote - $ discoverAndCall (RequestId "N/A") (Domain "localhost") Brig "test" [] mempty + $ discoverAndCall (Domain "localhost") Brig "test" [] mempty withMockServer :: Warp.TLSSettings -> (Warp.Port -> IO a) -> IO a withMockServer tls k = diff --git a/services/federator/test/unit/Test/Federator/Response.hs b/services/federator/test/unit/Test/Federator/Response.hs deleted file mode 100644 index dcc0fec008c..00000000000 --- a/services/federator/test/unit/Test/Federator/Response.hs +++ /dev/null @@ -1,104 +0,0 @@ --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module Test.Federator.Response (tests) where - -import Data.Aeson qualified as Aeson -import Federator.Discovery -import Federator.Error.ServerError (ServerError (..)) -import Federator.Remote -import Federator.Response (runWaiError) -import Federator.Validation -import Imports -import Network.HTTP.Types qualified as HTTP -import Network.Wai qualified as Wai -import Network.Wai.Utilities.Error qualified as Wai -import Network.Wai.Utilities.Server qualified as Wai -import Polysemy -import Polysemy.Error -import Test.Tasty -import Test.Tasty.HUnit -import Wire.API.Federation.Error -import Wire.Network.DNS.SRV -import Wire.Sem.Logger.TinyLog qualified as Log - -tests :: TestTree -tests = - testGroup - "Wai Errors" - [ testValidationError, - testServerError, - testDiscoveryFailure, - testRemoteError - ] - -testValidationError :: TestTree -testValidationError = - testCase "validation errors should be converted to wai error responses" $ do - resp <- - runM - . Log.discardTinyLogs - . runWaiError @ValidationError - $ throw NoClientCertificate - body <- Wai.lazyResponseBody resp - let merr = Aeson.decode body - Wai.responseStatus resp @?= HTTP.status403 - fmap Wai.label merr @?= Just "no-client-certificate" - -testServerError :: TestTree -testServerError = - testCase "server errors should be converted to wai error responses" $ do - resp <- - runM - . Log.discardTinyLogs - . runWaiError @ServerError - $ throw InvalidRoute - body <- Wai.lazyResponseBody resp - let merr = Aeson.decode body - Wai.responseStatus resp @?= HTTP.status403 - fmap Wai.label merr @?= Just "invalid-endpoint" - -testDiscoveryFailure :: TestTree -testDiscoveryFailure = - testCase "discovery failures should be converted to wai error responses" $ do - resp <- - runM - . Log.discardTinyLogs - . runWaiError @DiscoveryFailure - $ throw (DiscoveryFailureDNSError "mock error") - body <- Wai.lazyResponseBody resp - let merr = Aeson.decode body - Wai.responseStatus resp @?= HTTP.status400 - fmap Wai.label merr @?= Just "discovery-failure" - -testRemoteError :: TestTree -testRemoteError = - testCase "remote errors should be converted to wai error responses" $ do - resp <- - runM - . Log.discardTinyLogs - . runWaiError @RemoteError - $ throw - ( RemoteError - (SrvTarget "example.com" 7777) - "" - FederatorClientNoStatusCode - ) - body <- Wai.lazyResponseBody resp - let merr = Aeson.decode body - Wai.responseStatus resp @?= toEnum 533 - fmap Wai.label merr @?= Just "federation-http2-error" diff --git a/services/federator/test/unit/Test/Federator/Util.hs b/services/federator/test/unit/Test/Federator/Util.hs index decf7d356a2..6af804a1d67 100644 --- a/services/federator/test/unit/Test/Federator/Util.hs +++ b/services/federator/test/unit/Test/Federator/Util.hs @@ -25,6 +25,7 @@ import Imports import Network.HTTP.Types qualified as HTTP import Network.Wai qualified as Wai import Network.Wai.Test qualified as Wai +import Network.Wai.Utilities.Server (federationRequestIdHeaderName) import Polysemy import Polysemy.Error import Test.Tasty.HUnit @@ -68,5 +69,6 @@ testRequest tr = do Wai.requestHeaders = [("X-SSL-Certificate", HTTP.urlEncode True h) | h <- toList (trCertificateHeader tr)] <> [(originDomainHeaderName, h) | h <- toList (trDomainHeader tr)] + <> [(federationRequestIdHeaderName, "test")] <> trExtraHeaders tr } diff --git a/services/federator/test/unit/Test/Federator/Validation.hs b/services/federator/test/unit/Test/Federator/Validation.hs index 24879f15aae..bd2c882c0e7 100644 --- a/services/federator/test/unit/Test/Federator/Validation.hs +++ b/services/federator/test/unit/Test/Federator/Validation.hs @@ -44,7 +44,7 @@ mockDiscoveryTrivial = Polysemy.interpret $ \case DiscoverFederator dom -> pure . Right $ SrvTarget (Text.encodeUtf8 (domainText dom)) 443 DiscoverAllFederators dom -> pure . Right $ SrvTarget (Text.encodeUtf8 (domainText dom)) 443 :| [] -mockDiscoveryMapping :: HasCallStack => Domain -> NonEmpty ByteString -> Sem (DiscoverFederator ': r) x -> Sem r x +mockDiscoveryMapping :: (HasCallStack) => Domain -> NonEmpty ByteString -> Sem (DiscoverFederator ': r) x -> Sem r x mockDiscoveryMapping origin targets = Polysemy.interpret $ \case DiscoverFederator _ -> error "Not mocked" DiscoverAllFederators dom -> @@ -53,7 +53,7 @@ mockDiscoveryMapping origin targets = Polysemy.interpret $ \case then Right $ fmap (`SrvTarget` 443) targets else Left $ DiscoveryFailureSrvNotAvailable "invalid origin domain" -mockDiscoveryFailure :: HasCallStack => Sem (DiscoverFederator ': r) x -> Sem r x +mockDiscoveryFailure :: (HasCallStack) => Sem (DiscoverFederator ': r) x -> Sem r x mockDiscoveryFailure = Polysemy.interpret $ \case DiscoverFederator _ -> error "Not mocked" DiscoverAllFederators _ -> pure . Left $ DiscoveryFailureDNSError "mock DNS error" diff --git a/services/galley/default.nix b/services/galley/default.nix index 7985313dc72..b414e5b0551 100644 --- a/services/galley/default.nix +++ b/services/galley/default.nix @@ -44,8 +44,8 @@ , galley-types , gitignoreSource , gundeck-types +, hex , HsOpenSSL -, hspec , http-api-data , http-client , http-client-openssl @@ -69,6 +69,7 @@ , polysemy , polysemy-wire-zoo , process +, prometheus-client , proto-lens , protobuf , QuickCheck @@ -164,6 +165,7 @@ mkDerivation { extra galley-types gundeck-types + hex HsOpenSSL http-client http-client-openssl @@ -175,11 +177,11 @@ mkDerivation { lens metrics-core metrics-wai - mtl optparse-applicative pem polysemy polysemy-wire-zoo + prometheus-client proto-lens raw-strings-qq resourcet @@ -246,7 +248,6 @@ mkDerivation { filepath galley-types HsOpenSSL - hspec http-api-data http-client http-client-openssl diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index 2c51515dbdb..47474894165 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -271,6 +271,7 @@ library Galley.Schema.V89_MlsLockStatus Galley.Schema.V90_EnforceFileDownloadLocationConfig Galley.Schema.V91_TeamMemberDeletedLimitedEventFanout + Galley.Schema.V92_MlsE2EIdConfig Galley.Types.Clients Galley.Types.ToUserRole Galley.Types.UserList @@ -311,6 +312,7 @@ library , extra >=1.3 , galley-types >=0.65.0 , gundeck-types >=1.35.2 + , hex , HsOpenSSL >=0.11 , http-client >=0.7 , http-client-openssl >=0.2 @@ -322,11 +324,11 @@ library , lens >=4.4 , metrics-core , metrics-wai >=0.4 - , mtl >=2.2 , optparse-applicative , pem , polysemy , polysemy-wire-zoo + , prometheus-client , proto-lens >=0.2 , raw-strings-qq >=1.0 , resourcet >=1.1 @@ -396,7 +398,6 @@ executable galley-integration API.Roles API.SQS API.Teams - API.Teams.Feature API.Teams.LegalHold API.Teams.LegalHold.DisabledByDefault API.Teams.LegalHold.Util @@ -488,7 +489,6 @@ executable galley-integration , galley , galley-types , HsOpenSSL - , hspec , http-api-data , http-client , http-client-openssl diff --git a/services/galley/galley.integration.yaml b/services/galley/galley.integration.yaml index acf9326915f..465d807cec3 100644 --- a/services/galley/galley.integration.yaml +++ b/services/galley/galley.integration.yaml @@ -27,8 +27,11 @@ federator: rabbitmq: host: 127.0.0.1 - port: 5672 + port: 5671 vHost: / + enableTls: true + caCert: test/resources/rabbitmq-ca.pem + insecureSkipVerifyTls: false settings: httpPoolSize: 128 diff --git a/services/galley/migrate-data/src/Galley/DataMigration.hs b/services/galley/migrate-data/src/Galley/DataMigration.hs index ac79bcc0fcd..e4c27464ee0 100644 --- a/services/galley/migrate-data/src/Galley/DataMigration.hs +++ b/services/galley/migrate-data/src/Galley/DataMigration.hs @@ -116,5 +116,5 @@ persistVersion (MigrationVersion v) desc time = C.write cql (C.params C.LocalQuo cql :: C.QueryString C.W (Int32, Text, UTCTime) () cql = "insert into data_migration (id, version, descr, date) values (1,?,?,?)" -info :: Log.MonadLogger m => String -> m () +info :: (Log.MonadLogger m) => String -> m () info = Log.info . Log.msg diff --git a/services/galley/migrate-data/src/Galley/DataMigration/Types.hs b/services/galley/migrate-data/src/Galley/DataMigration/Types.hs index 6d92bb0a399..489ac309271 100644 --- a/services/galley/migrate-data/src/Galley/DataMigration/Types.hs +++ b/services/galley/migrate-data/src/Galley/DataMigration/Types.hs @@ -53,7 +53,7 @@ instance (MonadIO m, MonadThrow m) => C.MonadClient (MigrationActionT m) where liftClient = liftCassandra localState f = local (\env -> env {cassandraClientState = f $ cassandraClientState env}) -instance MonadIO m => MonadLogger (MigrationActionT m) where +instance (MonadIO m) => MonadLogger (MigrationActionT m) where log level f = do env <- ask Logger.log (logger env) level f @@ -67,7 +67,7 @@ runMigrationAction :: Env -> MigrationActionT m a -> m a runMigrationAction env action = runReaderT (unMigrationAction action) env -liftCassandra :: MonadIO m => C.Client a -> MigrationActionT m a +liftCassandra :: (MonadIO m) => C.Client a -> MigrationActionT m a liftCassandra m = do env <- ask lift $ C.runClient (cassandraClientState env) m diff --git a/services/galley/migrate-data/src/V1_BackfillBillingTeamMembers.hs b/services/galley/migrate-data/src/V1_BackfillBillingTeamMembers.hs index aa060022e5a..7d46e3f8f13 100644 --- a/services/galley/migrate-data/src/V1_BackfillBillingTeamMembers.hs +++ b/services/galley/migrate-data/src/V1_BackfillBillingTeamMembers.hs @@ -56,13 +56,13 @@ pageSize = 1000 -- Queries -- | Get team members from Galley -getTeamMembers :: MonadClient m => ConduitM () [(TeamId, UserId, Maybe Permissions)] m () +getTeamMembers :: (MonadClient m) => ConduitM () [(TeamId, UserId, Maybe Permissions)] m () getTeamMembers = paginateC cql (paramsP LocalQuorum () pageSize) x5 where cql :: PrepQuery R () (TeamId, UserId, Maybe Permissions) cql = "SELECT team, user, perms FROM team_member" -createBillingTeamMembers :: MonadClient m => (TeamId, UserId) -> m () +createBillingTeamMembers :: (MonadClient m) => (TeamId, UserId) -> m () createBillingTeamMembers pair = retry x5 $ write cql (params LocalQuorum pair) where diff --git a/services/galley/migrate-data/src/V3_BackfillTeamAdmins.hs b/services/galley/migrate-data/src/V3_BackfillTeamAdmins.hs index 6578b4e9631..c835112b40b 100644 --- a/services/galley/migrate-data/src/V3_BackfillTeamAdmins.hs +++ b/services/galley/migrate-data/src/V3_BackfillTeamAdmins.hs @@ -56,13 +56,13 @@ pageSize = 1000 -- Queries -- | Get team members from Galley -getTeamMembers :: MonadClient m => ConduitM () [(TeamId, UserId, Maybe Permissions)] m () +getTeamMembers :: (MonadClient m) => ConduitM () [(TeamId, UserId, Maybe Permissions)] m () getTeamMembers = paginateC cql (paramsP LocalQuorum () pageSize) x5 where cql :: PrepQuery R () (TeamId, UserId, Maybe Permissions) cql = "SELECT team, user, perms FROM team_member" -createTeamAdmins :: MonadClient m => (TeamId, UserId) -> m () +createTeamAdmins :: (MonadClient m) => (TeamId, UserId) -> m () createTeamAdmins pair = retry x5 $ write cql (params LocalQuorum pair) where diff --git a/services/galley/src/Galley/API/Create.hs b/services/galley/src/Galley/API/Create.hs index b998a108339..fa65410616d 100644 --- a/services/galley/src/Galley/API/Create.hs +++ b/services/galley/src/Galley/API/Create.hs @@ -278,7 +278,7 @@ checkCreateConvPermissions lusr newConv (Just tinfo) allUsers = do ensureConnectedToLocals (tUnqualified lusr) (notTeamMember (ulLocals allUsers) (catMaybes convLocalMemberships)) ensureConnectedToRemotes lusr (ulRemotes allUsers) -getTeamMember :: Member TeamStore r => UserId -> Maybe TeamId -> Sem r (Maybe TeamMember) +getTeamMember :: (Member TeamStore r) => UserId -> Maybe TeamId -> Sem r (Maybe TeamMember) getTeamMember uid (Just tid) = E.getTeamMember tid uid getTeamMember uid Nothing = E.getUserTeams uid >>= maybe (pure Nothing) (flip E.getTeamMember uid) . headMay @@ -495,7 +495,7 @@ createOne2OneConversationLocally lcnv self zcon name mtid other = do conversationCreated self c createOne2OneConversationRemotely :: - Member (Error FederationError) r => + (Member (Error FederationError) r) => Remote ConvId -> Local UserId -> ConnId -> @@ -695,7 +695,7 @@ notifyCreatedConversation lusr conn c = do & pushRoute .~ route localOne2OneConvId :: - Member (Error InvalidInput) r => + (Member (Error InvalidInput) r) => Local UserId -> Local UserId -> Sem r (Local ConvId) @@ -704,7 +704,7 @@ localOne2OneConvId self other = do pure . qualifyAs self $ Data.localOne2OneConvId x y toUUIDs :: - Member (Error InvalidInput) r => + (Member (Error InvalidInput) r) => UserId -> UserId -> Sem r (U.UUID U.V4, U.UUID U.V4) @@ -726,6 +726,6 @@ newConvMembers loc body = UserList (newConvUsers body) [] <> toUserList loc (newConvQualifiedUsers body) -ensureOne :: Member (Error InvalidInput) r => [a] -> Sem r a +ensureOne :: (Member (Error InvalidInput) r) => [a] -> Sem r a ensureOne [x] = pure x ensureOne _ = throw (InvalidRange "One-to-one conversations can only have a single invited member") diff --git a/services/galley/src/Galley/API/Error.hs b/services/galley/src/Galley/API/Error.hs index 6a1c4d7c97c..04423558a2f 100644 --- a/services/galley/src/Galley/API/Error.hs +++ b/services/galley/src/Galley/API/Error.hs @@ -99,7 +99,7 @@ badConvState cid = "Connect conversation with more than 2 members: " <> LT.pack (show cid) -legalHoldServiceUnavailable :: Show a => a -> Wai.Error +legalHoldServiceUnavailable :: (Show a) => a -> Wai.Error legalHoldServiceUnavailable e = Wai.mkError status412 "legalhold-unavailable" ("legal hold service unavailable with underlying error: " <> (LT.pack . show $ e)) invalidTeamNotificationId :: Wai.Error diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index 7bbc9c8bd8d..aab4029df73 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -664,14 +664,15 @@ sendMLSMessage remoteDomain msr = handleMLSMessageErrors $ do msg getSubConversationForRemoteUser :: - Members - '[ SubConversationStore, - ConversationStore, - Input (Local ()), - Error InternalError, - P.TinyLog - ] - r => + ( Members + '[ SubConversationStore, + ConversationStore, + Input (Local ()), + Error InternalError, + P.TinyLog + ] + r + ) => Domain -> GetSubConversationsRequest -> Sem r GetSubConversationsResponse @@ -769,7 +770,7 @@ getOne2OneConversation domain (GetOne2OneConversationRequest self other) = class ToGalleyRuntimeError (effs :: EffectRow) r where mapToGalleyError :: - Member (Error GalleyError) r => + (Member (Error GalleyError) r) => Sem (Append effs r) a -> Sem r a @@ -835,7 +836,7 @@ onMLSMessageSent domain rmm = runMessagePush loc (Just (tUntagged rcnv)) $ newMessagePush mempty Nothing rmm.metadata recipients e where - logError :: Member P.TinyLog r => Either (Tagged 'MLSNotEnabled ()) () -> Sem r () + logError :: (Member P.TinyLog r) => Either (Tagged 'MLSNotEnabled ()) () -> Sem r () logError (Left _) = P.warn $ Log.field "conversation" (toByteString' rmm.conversation) @@ -937,7 +938,7 @@ onTypingIndicatorUpdated origDomain TypingDataUpdated {..} = do -- | Log a federation error that is impossible in processing a remote request -- for a local conversation. logFederationError :: - Member P.TinyLog r => + (Member P.TinyLog r) => Local ConvId -> FederationError -> Sem r () diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index 27177595cac..3cf4708fa8b 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -14,7 +14,6 @@ -- -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . - module Galley.API.Internal ( internalAPI, InternalAPI, @@ -86,9 +85,11 @@ import Wire.API.Federation.API import Wire.API.Federation.API.Galley import Wire.API.Federation.Error import Wire.API.Routes.API +import Wire.API.Routes.Internal.Brig.EJPD import Wire.API.Routes.Internal.Galley import Wire.API.Routes.Internal.Galley.TeamsIntra import Wire.API.Routes.MultiTablePaging (mtpHasMore, mtpPagingState, mtpResults) +import Wire.API.Routes.MultiTablePaging qualified as MTP import Wire.API.Team.Feature hiding (setStatus) import Wire.API.User.Client import Wire.NotificationSubsystem @@ -110,6 +111,57 @@ internalAPI = <@> featureAPI <@> federationAPI <@> conversationAPI + <@> iEJPDAPI + +iEJPDAPI :: API IEJPDAPI GalleyEffects +iEJPDAPI = mkNamedAPI @"get-conversations-by-user" (callsFed (exposeAnnotations ejpdGetConvInfo)) + +-- | An unpaginated, internal http interface to `Query.conversationIdsPageFrom`. Used for +-- EJPD reports. Called locally with very little data for each conv, so we don't expect +-- pagination to ever be needed. +ejpdGetConvInfo :: + forall r p. + ( p ~ CassandraPaging, + Member ConversationStore r, + Member (Error InternalError) r, + Member (Input (Local ())) r, + Member (Input Env) r, + Member (ListItems p ConvId) r, + Member (ListItems p (Remote ConvId)) r, + Member P.TinyLog r + ) => + UserId -> + Sem r [EJPDConvInfo] +ejpdGetConvInfo uid = do + luid <- qualifyLocal uid + firstPage <- Query.conversationIdsPageFrom luid initialPageRequest + getPages luid firstPage + where + initialPageRequest = mkPageRequest (MTP.MultiTablePagingState MTP.PagingLocals Nothing) + mkPageRequest = MTP.GetMultiTablePageRequest (toRange (Proxy @1000)) . Just + + getPages :: Local UserId -> ConvIdsPage -> Sem r [EJPDConvInfo] + getPages luid page = do + let convids = MTP.mtpResults page + mk :: Data.Conversation -> Maybe EJPDConvInfo + mk conv = do + let convType = conv.convMetadata.cnvmType + ejpdConvInfo = EJPDConvInfo (fromMaybe "n/a" conv.convMetadata.cnvmName) (tUntagged $ qualifyAs luid conv.convId) + -- we don't want self conversations as they don't tell us anything about connections + -- we don't want connect conversations, because the peer has not responded yet + case convType of + RegularConv -> Just ejpdConvInfo + -- FUTUREWORK(mangoiv): with GHC 9.12 we can refactor this to or-patterns + One2OneConv -> Nothing + SelfConv -> Nothing + ConnectConv -> Nothing + renderedPage <- mapMaybe mk <$> getConversations (fst $ partitionQualified luid convids) + if MTP.mtpHasMore page + then do + newPage <- Query.conversationIdsPageFrom luid (mkPageRequest . MTP.mtpPagingState $ page) + morePages <- getPages luid newPage + pure $ renderedPage <> morePages + else pure renderedPage federationAPI :: API IFederationAPI GalleyEffects federationAPI = @@ -433,11 +485,12 @@ guardLegalholdPolicyConflictsH glh = do -- | Get an MLS conversation client list iGetMLSClientListForConv :: forall r. - Members - '[ MemberStore, - ErrorS 'ConvNotFound - ] - r => + ( Members + '[ MemberStore, + ErrorS 'ConvNotFound + ] + r + ) => GroupId -> Sem r ClientList iGetMLSClientListForConv gid = do diff --git a/services/galley/src/Galley/API/LegalHold.hs b/services/galley/src/Galley/API/LegalHold.hs index 79a3eb942e4..75eceeec319 100644 --- a/services/galley/src/Galley/API/LegalHold.hs +++ b/services/galley/src/Galley/API/LegalHold.hs @@ -288,7 +288,7 @@ removeSettings' tid = luid <- qualifyLocal (member ^. userId) removeLegalHoldClientFromUser (tUnqualified luid) LHService.removeLegalHold tid (tUnqualified luid) - changeLegalholdStatus tid luid (member ^. legalHoldStatus) UserLegalHoldDisabled -- (support for withdrawing consent is not planned yet.) + changeLegalholdStatusAndHandlePolicyConflicts tid luid (member ^. legalHoldStatus) UserLegalHoldDisabled -- (support for withdrawing consent is not planned yet.) -- | Learn whether a user has LH enabled and fetch pre-keys. -- Note that this is accessible to ANY authenticated user, even ones outside the team @@ -364,7 +364,7 @@ grantConsent lusr tid = do =<< fmap (view legalHoldStatus) <$> getTeamMember tid (tUnqualified lusr) case userLHStatus of lhs@UserLegalHoldNoConsent -> - changeLegalholdStatus tid lusr lhs UserLegalHoldDisabled $> GrantConsentSuccess + changeLegalholdStatusAndHandlePolicyConflicts tid lusr lhs UserLegalHoldDisabled $> GrantConsentSuccess UserLegalHoldEnabled -> pure GrantConsentAlreadyGranted UserLegalHoldPending -> pure GrantConsentAlreadyGranted UserLegalHoldDisabled -> pure GrantConsentAlreadyGranted @@ -420,7 +420,12 @@ requestDevice lzusr tid uid = do member <- noteS @'TeamMemberNotFound =<< getTeamMember tid uid case member ^. legalHoldStatus of UserLegalHoldEnabled -> throwS @'UserLegalHoldAlreadyEnabled - lhs@UserLegalHoldPending -> RequestDeviceAlreadyPending <$ provisionLHDevice zusr luid lhs + lhs@UserLegalHoldPending -> + -- FUTUREWORK: we create a new device if a pending one is found. this helps with + -- recovering from lost credentials (but where would that happen?). on the other + -- hand. do we properly gc the old pending device? maybe we should just throw an error + -- here? + RequestDeviceAlreadyPending <$ provisionLHDevice zusr luid lhs lhs@UserLegalHoldDisabled -> RequestDeviceSuccess <$ provisionLHDevice zusr luid lhs UserLegalHoldNoConsent -> throwS @'NoUserLegalHoldConsent where @@ -436,7 +441,7 @@ requestDevice lzusr tid uid = do (lastPrekey', prekeys) <- requestDeviceFromService luid -- We don't distinguish the last key here; brig will do so when the device is added LegalHoldData.insertPendingPrekeys (tUnqualified luid) (unpackLastPrekey lastPrekey' : prekeys) - changeLegalholdStatus tid luid userLHStatus UserLegalHoldPending + changeLegalholdStatusAndHandlePolicyConflicts tid luid userLHStatus UserLegalHoldPending notifyClientsAboutLegalHoldRequest zusr (tUnqualified luid) lastPrekey' requestDeviceFromService :: Local UserId -> Sem r (LastPrekey, [Prekey]) @@ -520,7 +525,7 @@ approveDevice lzusr connId tid uid (Public.ApproveLegalHoldForUserRequest mPassw LHService.confirmLegalHold clientId tid (tUnqualified luid) legalHoldAuthToken -- TODO: send event at this point (see also: -- https://github.com/wireapp/wire-server/pull/802#pullrequestreview-262280386) - changeLegalholdStatus tid luid userLHStatus UserLegalHoldEnabled + changeLegalholdStatusAndHandlePolicyConflicts tid luid userLHStatus UserLegalHoldEnabled where assertUserLHPending :: UserLegalHoldStatus -> @@ -576,9 +581,18 @@ disableForUser lzusr tid uid (Public.DisableLegalHoldForUserRequest mPassword) = userLHStatus <- maybe defUserLegalHoldStatus (view legalHoldStatus) <$> getTeamMember tid (tUnqualified luid) - if not $ userLHEnabled userLHStatus - then pure DisableLegalHoldWasNotEnabled - else disableLH (tUnqualified lzusr) luid userLHStatus $> DisableLegalHoldSuccess + + let doDisable = disableLH (tUnqualified lzusr) luid userLHStatus $> DisableLegalHoldSuccess + case userLHStatus of + -- no state change necessary + UserLegalHoldDisabled -> pure DisableLegalHoldWasNotEnabled + UserLegalHoldNoConsent -> + -- no state change allowed + -- we cannot go to disabled because that would subsume consent + pure DisableLegalHoldWasNotEnabled + -- LH is enabled or pending, we can disable (change state) without issue + UserLegalHoldEnabled -> doDisable + UserLegalHoldPending -> doDisable where disableLH :: UserId -> Local UserId -> UserLegalHoldStatus -> Sem r () disableLH zusr luid userLHStatus = do @@ -588,12 +602,12 @@ disableForUser lzusr tid uid (Public.DisableLegalHoldForUserRequest mPassword) = -- TODO: send event at this point (see also: related TODO in this module in -- 'approveDevice' and -- https://github.com/wireapp/wire-server/pull/802#pullrequestreview-262280386) - changeLegalholdStatus tid luid userLHStatus UserLegalHoldDisabled + changeLegalholdStatusAndHandlePolicyConflicts tid luid userLHStatus UserLegalHoldDisabled --- | Allow no-consent => consent without further changes. If LH device is requested, enabled, --- or disabled, make sure the affected connections are screened for policy conflict (anybody --- with no-consent), and put those connections in the appropriate blocked state. -changeLegalholdStatus :: +-- | Allow no-consent or requested => consent without further changes. If LH device is +-- enabled, or disabled, make sure the affected connections are screened for policy conflict +-- (anybody with no-consent), and put those connections in the appropriate blocked state. +changeLegalholdStatusAndHandlePolicyConflicts :: ( Member BackendNotificationQueueAccess r, Member BrigAccess r, Member ConversationStore r, @@ -621,24 +635,24 @@ changeLegalholdStatus :: UserLegalHoldStatus -> UserLegalHoldStatus -> Sem r () -changeLegalholdStatus tid luid old new = do +changeLegalholdStatusAndHandlePolicyConflicts tid luid old new = do case old of UserLegalHoldEnabled -> case new of UserLegalHoldEnabled -> noop UserLegalHoldPending -> illegal - UserLegalHoldDisabled -> update >> removeblocks + UserLegalHoldDisabled -> update >> removeBlocks UserLegalHoldNoConsent -> illegal -- UserLegalHoldPending -> case new of - UserLegalHoldEnabled -> update + UserLegalHoldEnabled -> addBlocks >> update UserLegalHoldPending -> noop - UserLegalHoldDisabled -> update >> removeblocks + UserLegalHoldDisabled -> update >> removeBlocks UserLegalHoldNoConsent -> illegal -- UserLegalHoldDisabled -> case new of UserLegalHoldEnabled -> illegal - UserLegalHoldPending -> addblocks >> update - UserLegalHoldDisabled -> {- in case the last attempt crashed -} removeblocks + UserLegalHoldPending -> update + UserLegalHoldDisabled -> {- in case the last attempt crashed -} removeBlocks UserLegalHoldNoConsent -> {- withdrawing consent is not (yet?) implemented -} illegal -- UserLegalHoldNoConsent -> case new of @@ -648,8 +662,8 @@ changeLegalholdStatus tid luid old new = do UserLegalHoldNoConsent -> noop where update = LegalHoldData.setUserLegalHoldStatus tid (tUnqualified luid) new - removeblocks = void $ putConnectionInternal (RemoveLHBlocksInvolving (tUnqualified luid)) - addblocks = do + removeBlocks = void $ putConnectionInternal (RemoveLHBlocksInvolving (tUnqualified luid)) + addBlocks = do blockNonConsentingConnections (tUnqualified luid) handleGroupConvPolicyConflicts luid new noop = pure () @@ -690,7 +704,7 @@ blockNonConsentingConnections uid = do status <- putConnectionInternal (BlockForMissingLHConsent userLegalhold othersToBlock) pure $ ["blocking users failed: " <> show (status, othersToBlock) | status /= status200] -unsetTeamLegalholdWhitelistedH :: Member LegalHoldStore r => TeamId -> Sem r () +unsetTeamLegalholdWhitelistedH :: (Member LegalHoldStore r) => TeamId -> Sem r () unsetTeamLegalholdWhitelistedH tid = do () <- error diff --git a/services/galley/src/Galley/API/LegalHold/Conflicts.hs b/services/galley/src/Galley/API/LegalHold/Conflicts.hs index 4f898bd4856..e70ffff0f3d 100644 --- a/services/galley/src/Galley/API/LegalHold/Conflicts.hs +++ b/services/galley/src/Galley/API/LegalHold/Conflicts.hs @@ -56,7 +56,6 @@ data LegalholdConflictsOldClients = LegalholdConflictsOldClients guardQualifiedLegalholdPolicyConflicts :: ( Member BrigAccess r, Member (Error LegalholdConflicts) r, - Member (Error LegalholdConflictsOldClients) r, Member (Input (Local ())) r, Member (Input Opts) r, Member TeamStore r, @@ -82,7 +81,6 @@ guardQualifiedLegalholdPolicyConflicts protectee qclients = do guardLegalholdPolicyConflicts :: ( Member BrigAccess r, Member (Error LegalholdConflicts) r, - Member (Error LegalholdConflictsOldClients) r, Member (Input Opts) r, Member TeamStore r, Member P.TinyLog r @@ -107,7 +105,6 @@ guardLegalholdPolicyConflictsUid :: forall r. ( Member BrigAccess r, Member (Error LegalholdConflicts) r, - Member (Error LegalholdConflictsOldClients) r, Member TeamStore r, Member P.TinyLog r ) => @@ -128,15 +125,6 @@ guardLegalholdPolicyConflictsUid self (Map.keys . userClients -> otherUids) = do anyClientHasLH :: Bool anyClientHasLH = Client.LegalHoldClientType `elem` (Client.clientType <$> allClientsMetadata) - anyClientIsOld :: Bool - anyClientIsOld = any isOld allClientsMetadata - where - isOld :: Client.Client -> Bool - isOld = - (Client.ClientSupportsLegalholdImplicitConsent `Set.notMember`) - . Client.fromClientCapabilityList - . Client.clientCapabilities - checkAnyConsentMissing :: Sem r Bool checkAnyConsentMissing = do users :: [User] <- accountUser <$$> getUsers (self : otherUids) @@ -148,7 +136,11 @@ guardLegalholdPolicyConflictsUid self (Map.keys . userClients -> otherUids) = do mbMem <- getTeamMember tid (Wire.API.User.userId user) case mbMem of Nothing -> pure True -- it's weird that there is a member id but no member, we better bail - Just mem -> pure $ mem ^. legalHoldStatus `notElem` [UserLegalHoldDisabled, UserLegalHoldEnabled] + Just mem -> pure $ case mem ^. legalHoldStatus of + UserLegalHoldDisabled -> False + UserLegalHoldPending -> False + UserLegalHoldEnabled -> False + UserLegalHoldNoConsent -> True Nothing -> do pure True -- personal users can not give consent or <$> checkUserConsentMissing `mapM` users @@ -157,22 +149,12 @@ guardLegalholdPolicyConflictsUid self (Map.keys . userClients -> otherUids) = do Log.field "self" (toByteString' self) Log.~~ Log.field "allClients" (toByteString' $ show allClients) Log.~~ Log.field "allClientsMetadata" (toByteString' $ show allClientsMetadata) - Log.~~ Log.field "anyClientIsOld" (toByteString' anyClientIsOld) Log.~~ Log.field "anyClientHasLH" (toByteString' anyClientHasLH) Log.~~ Log.msg ("guardLegalholdPolicyConflicts[1]" :: Text) -- when no other client is under LH, then we're good and can leave this function. but... when anyClientHasLH $ do P.debug $ Log.msg ("guardLegalholdPolicyConflicts[5]: anyClientHasLH" :: Text) - if anyClientIsOld && False -- https://wearezeta.atlassian.net/browse/WPB-6392 - then do - -- you can't effectively give consent as long as you have old clients: when using the - -- old clients, you still would not be exposed to the popups and red dot where - -- required. - P.debug $ Log.msg ("guardLegalholdPolicyConflicts[2]: anyClientIsOld" :: Text) - throw LegalholdConflictsOldClients - else do - P.debug $ Log.msg ("guardLegalholdPolicyConflicts[3]: checkConsentMissing?" :: Text) - whenM checkAnyConsentMissing $ do - P.debug $ Log.msg ("guardLegalholdPolicyConflicts[4]: checkConsentMissing!" :: Text) - throw LegalholdConflicts + whenM checkAnyConsentMissing $ do + P.debug $ Log.msg ("guardLegalholdPolicyConflicts[4]: checkConsentMissing!" :: Text) + throw LegalholdConflicts diff --git a/services/galley/src/Galley/API/LegalHold/Team.hs b/services/galley/src/Galley/API/LegalHold/Team.hs index 6345f8fdb30..6fbc8f3bfd6 100644 --- a/services/galley/src/Galley/API/LegalHold/Team.hs +++ b/services/galley/src/Galley/API/LegalHold/Team.hs @@ -85,7 +85,7 @@ ensureNotTooLargeToActivateLegalHold tid = do unlessM (teamSizeBelowLimit (fromIntegral teamSize)) $ throwS @'CannotEnableLegalHoldServiceLargeTeam -teamSizeBelowLimit :: Member TeamStore r => Int -> Sem r Bool +teamSizeBelowLimit :: (Member TeamStore r) => Int -> Sem r Bool teamSizeBelowLimit teamSize = do limit <- fromIntegral . fromRange <$> fanoutLimit let withinLimit = teamSize <= limit diff --git a/services/galley/src/Galley/API/MLS/Commit/ExternalCommit.hs b/services/galley/src/Galley/API/MLS/Commit/ExternalCommit.hs index 52b5a447ca8..7a3a815b950 100644 --- a/services/galley/src/Galley/API/MLS/Commit/ExternalCommit.hs +++ b/services/galley/src/Galley/API/MLS/Commit/ExternalCommit.hs @@ -168,21 +168,21 @@ processExternalCommit senderIdentity lConvOrSub ciphersuite epoch action updateP lConvOrSub' <- for lConvOrSub incrementEpoch -- fetch backend remove proposals of the previous epoch - indicesInRemoveProposals <- - -- skip remove proposals of already removed by the external commit - (\\ toList action.remove) - <$> getPendingBackendRemoveProposals groupId epoch + indices0 <- getPendingBackendRemoveProposals groupId epoch + + -- skip proposals for clients already removed by the external commit + let indices = maybe id Set.delete action.remove indices0 -- requeue backend remove proposals for the current epoch createAndSendRemoveProposals lConvOrSub' - indicesInRemoveProposals + indices (cidQualifiedUser senderIdentity) (tUnqualified lConvOrSub').members executeExternalCommitAction :: forall r. - HasProposalActionEffects r => + (HasProposalActionEffects r) => Local ConvOrSubConv -> ClientIdentity -> ExternalCommitAction -> diff --git a/services/galley/src/Galley/API/MLS/Commit/InternalCommit.hs b/services/galley/src/Galley/API/MLS/Commit/InternalCommit.hs index 4e7974de17d..f0b71cb216f 100644 --- a/services/galley/src/Galley/API/MLS/Commit/InternalCommit.hs +++ b/services/galley/src/Galley/API/MLS/Commit/InternalCommit.hs @@ -267,7 +267,7 @@ processInternalCommit senderIdentity con lConvOrSub ciphersuite epoch action com pure events addMembers :: - HasProposalActionEffects r => + (HasProposalActionEffects r) => Qualified UserId -> Maybe ConnId -> Local ConvOrSubConv -> @@ -291,7 +291,7 @@ addMembers qusr con lConvOrSub users = case tUnqualified lConvOrSub of SubConv _ _ -> pure [] removeMembers :: - HasProposalActionEffects r => + (HasProposalActionEffects r) => Qualified UserId -> Maybe ConnId -> Local ConvOrSubConv -> @@ -313,7 +313,7 @@ removeMembers qusr con lConvOrSub users = case tUnqualified lConvOrSub of $ users SubConv _ _ -> pure [] -handleNoChanges :: Monoid a => Sem (Error NoChanges ': r) a -> Sem r a +handleNoChanges :: (Monoid a) => Sem (Error NoChanges ': r) a -> Sem r a handleNoChanges = fmap fold . runError existingLocalMembers :: Local Data.Conversation -> Set (Qualified UserId) diff --git a/services/galley/src/Galley/API/MLS/Conversation.hs b/services/galley/src/Galley/API/MLS/Conversation.hs index 1a7ed3d62bc..09e66ff52c7 100644 --- a/services/galley/src/Galley/API/MLS/Conversation.hs +++ b/services/galley/src/Galley/API/MLS/Conversation.hs @@ -33,7 +33,7 @@ import Wire.API.Conversation hiding (Member) import Wire.API.Conversation.Protocol mkMLSConversation :: - Member MemberStore r => + (Member MemberStore r) => Data.Conversation -> Sem r (Maybe MLSConversation) mkMLSConversation conv = diff --git a/services/galley/src/Galley/API/MLS/Enabled.hs b/services/galley/src/Galley/API/MLS/Enabled.hs index d8106726f0f..ec1bd099baa 100644 --- a/services/galley/src/Galley/API/MLS/Enabled.hs +++ b/services/galley/src/Galley/API/MLS/Enabled.hs @@ -26,7 +26,7 @@ import Wire.API.Error import Wire.API.Error.Galley import Wire.API.MLS.Keys -isMLSEnabled :: Member (Input Env) r => Sem r Bool +isMLSEnabled :: (Member (Input Env) r) => Sem r Bool isMLSEnabled = inputs (isJust . view mlsKeys) -- | Fail if MLS is not enabled. Only use this function at the beginning of an diff --git a/services/galley/src/Galley/API/MLS/GroupInfo.hs b/services/galley/src/Galley/API/MLS/GroupInfo.hs index 692b9524a5d..252551100f2 100644 --- a/services/galley/src/Galley/API/MLS/GroupInfo.hs +++ b/services/galley/src/Galley/API/MLS/GroupInfo.hs @@ -52,7 +52,7 @@ getGroupInfo :: Member (Input Env) r, Member MemberStore r ) => - Members MLSGroupInfoStaticErrors r => + (Members MLSGroupInfoStaticErrors r) => Local UserId -> Qualified ConvId -> Sem r GroupInfoData @@ -68,7 +68,7 @@ getGroupInfoFromLocalConv :: ( Member ConversationStore r, Member MemberStore r ) => - Members MLSGroupInfoStaticErrors r => + (Members MLSGroupInfoStaticErrors r) => Qualified UserId -> Local ConvId -> Sem r GroupInfoData @@ -81,7 +81,7 @@ getGroupInfoFromRemoteConv :: ( Member (Error FederationError) r, Member FederatorAccess r ) => - Members MLSGroupInfoStaticErrors r => + (Members MLSGroupInfoStaticErrors r) => Local UserId -> Remote ConvOrSubConvId -> Sem r GroupInfoData diff --git a/services/galley/src/Galley/API/MLS/Keys.hs b/services/galley/src/Galley/API/MLS/Keys.hs index f8bfe8e458b..71895166859 100644 --- a/services/galley/src/Galley/API/MLS/Keys.hs +++ b/services/galley/src/Galley/API/MLS/Keys.hs @@ -29,10 +29,10 @@ import Wire.API.MLS.CipherSuite import Wire.API.MLS.Keys data SomeKeyPair where - SomeKeyPair :: forall ss. IsSignatureScheme ss => Proxy ss -> KeyPair ss -> SomeKeyPair + SomeKeyPair :: forall ss. (IsSignatureScheme ss) => Proxy ss -> KeyPair ss -> SomeKeyPair getMLSRemovalKey :: - Member (Input Env) r => + (Member (Input Env) r) => SignatureSchemeTag -> Sem r (Maybe SomeKeyPair) getMLSRemovalKey ss = fmap hush . runError @() $ do diff --git a/services/galley/src/Galley/API/MLS/Message.hs b/services/galley/src/Galley/API/MLS/Message.hs index a4add447b06..8451e05019c 100644 --- a/services/galley/src/Galley/API/MLS/Message.hs +++ b/services/galley/src/Galley/API/MLS/Message.hs @@ -414,7 +414,9 @@ postMLSMessageToLocalConv qusr c con msg ctype convOrSubId = do Nothing -> throw $ mlsProtocolError "Application messages at epoch 0 are not supported" Just activeData -> when - (epochInt msg.epoch < epochInt activeData.epoch - 2) + ( epochInt msg.epoch < epochInt activeData.epoch - 2 + || epochInt msg.epoch > epochInt activeData.epoch + ) $ throwS @'MLSStaleMessage propagateMessage qusr (Just c) lConvOrSub con msg.rawMessage (tUnqualified lConvOrSub).members diff --git a/services/galley/src/Galley/API/MLS/Migration.hs b/services/galley/src/Galley/API/MLS/Migration.hs index b59fa410655..747de458cd4 100644 --- a/services/galley/src/Galley/API/MLS/Migration.hs +++ b/services/galley/src/Galley/API/MLS/Migration.hs @@ -40,10 +40,10 @@ import Wire.API.User -- does not print anything. newtype ApAll f = ApAll {unApAll :: f Bool} -instance Monad f => Semigroup (ApAll f) where +instance (Monad f) => Semigroup (ApAll f) where ApAll a <> ApAll b = ApAll $ a >>= \x -> if x then b else pure False -instance Monad f => Monoid (ApAll f) where +instance (Monad f) => Monoid (ApAll f) where mempty = ApAll (pure True) checkMigrationCriteria :: diff --git a/services/galley/src/Galley/API/MLS/One2One.hs b/services/galley/src/Galley/API/MLS/One2One.hs index 462c0beb66f..00dd1a534de 100644 --- a/services/galley/src/Galley/API/MLS/One2One.hs +++ b/services/galley/src/Galley/API/MLS/One2One.hs @@ -118,7 +118,7 @@ remoteMLSOne2OneConversation lself rother rc = -- | Create a new record for an MLS 1-1 conversation in the database and add -- the two members to it. createMLSOne2OneConversation :: - Member ConversationStore r => + (Member ConversationStore r) => Qualified UserId -> Qualified UserId -> Local MLSConversation -> diff --git a/services/galley/src/Galley/API/MLS/Proposal.hs b/services/galley/src/Galley/API/MLS/Proposal.hs index cbaba7f43db..7f7fb3e40f8 100644 --- a/services/galley/src/Galley/API/MLS/Proposal.hs +++ b/services/galley/src/Galley/API/MLS/Proposal.hs @@ -182,7 +182,7 @@ checkProposal ciphersuite im p = case p of void $ noteS @'MLSInvalidLeafNodeIndex $ imLookup im idx _ -> pure () -addProposedClient :: Member (State IndexMap) r => ClientIdentity -> Sem r ProposalAction +addProposedClient :: (Member (State IndexMap) r) => ClientIdentity -> Sem r ProposalAction addProposedClient cid = do im <- get let (idx, im') = imAddClient im cid @@ -233,7 +233,7 @@ applyProposal _ciphersuite _groupId (RemoveProposal idx) = do applyProposal _activeData _groupId _ = pure mempty processProposal :: - HasProposalEffects r => + (HasProposalEffects r) => ( Member (ErrorS 'ConvNotFound) r, Member (ErrorS 'MLSStaleMessage) r ) => @@ -265,7 +265,7 @@ processProposal qusr lConvOrSub groupId epoch pub prop = do storeProposal groupId epoch propRef ProposalOriginClient prop getKeyPackageIdentity :: - Member (ErrorS 'MLSUnsupportedProposal) r => + (Member (ErrorS 'MLSUnsupportedProposal) r) => KeyPackage -> Sem r ClientIdentity getKeyPackageIdentity = diff --git a/services/galley/src/Galley/API/MLS/Removal.hs b/services/galley/src/Galley/API/MLS/Removal.hs index 53c9a4f2a97..1da9c52369a 100644 --- a/services/galley/src/Galley/API/MLS/Removal.hs +++ b/services/galley/src/Galley/API/MLS/Removal.hs @@ -263,7 +263,7 @@ removeUser lc includeMain qusr = do -- | Convert cassandra subconv maps into SubConversations listSubConversations' :: - Member SubConversationStore r => + (Member SubConversationStore r) => ConvId -> Sem r [SubConversation] listSubConversations' cid = do diff --git a/services/galley/src/Galley/API/MLS/SubConversation.hs b/services/galley/src/Galley/API/MLS/SubConversation.hs index af4df8a7482..c5c57889e1a 100644 --- a/services/galley/src/Galley/API/MLS/SubConversation.hs +++ b/services/galley/src/Galley/API/MLS/SubConversation.hs @@ -99,14 +99,15 @@ getSubConversation lusr qconv sconv = do qconv getLocalSubConversation :: - Members - '[ SubConversationStore, - ConversationStore, - ErrorS 'ConvNotFound, - ErrorS 'ConvAccessDenied, - ErrorS 'MLSSubConvUnsupportedConvType - ] - r => + ( Members + '[ SubConversationStore, + ConversationStore, + ErrorS 'ConvNotFound, + ErrorS 'ConvAccessDenied, + ErrorS 'MLSSubConvUnsupportedConvType + ] + r + ) => Qualified UserId -> Local ConvId -> SubConvId -> @@ -186,13 +187,14 @@ getSubConversationGroupInfo lusr qcnvId subconv = do qcnvId getSubConversationGroupInfoFromLocalConv :: - Members - '[ ConversationStore, - SubConversationStore, - MemberStore - ] - r => - Members MLSGroupInfoStaticErrors r => + ( Members + '[ ConversationStore, + SubConversationStore, + MemberStore + ] + r + ) => + (Members MLSGroupInfoStaticErrors r) => Qualified UserId -> SubConvId -> Local ConvId -> diff --git a/services/galley/src/Galley/API/MLS/Util.hs b/services/galley/src/Galley/API/MLS/Util.hs index cc77d6f3dfa..4b5b93ce437 100644 --- a/services/galley/src/Galley/API/MLS/Util.hs +++ b/services/galley/src/Galley/API/MLS/Util.hs @@ -18,8 +18,10 @@ module Galley.API.MLS.Util where import Control.Comonad +import Data.Hex import Data.Id import Data.Qualified +import Data.Set qualified as Set import Data.Text qualified as T import Galley.Data.Conversation.Types hiding (Conversation) import Galley.Data.Conversation.Types qualified as Data @@ -77,21 +79,30 @@ getPendingBackendRemoveProposals :: ) => GroupId -> Epoch -> - Sem r [LeafIndex] + Sem r (Set LeafIndex) getPendingBackendRemoveProposals gid epoch = do proposals <- getAllPendingProposals gid epoch - catMaybes - <$> for - proposals - ( \case - (Just ProposalOriginBackend, proposal) -> case value proposal of - RemoveProposal i -> pure (Just i) - _ -> pure Nothing - (Just ProposalOriginClient, _) -> pure Nothing - (Nothing, _) -> do - TinyLog.warn $ Log.msg ("found pending proposal without origin, ignoring" :: ByteString) - pure Nothing - ) + indexList <- + catMaybes + <$> for + proposals + ( \case + (Just ProposalOriginBackend, proposal) -> case proposal.value of + RemoveProposal i -> pure (Just i) + _ -> pure Nothing + (Just ProposalOriginClient, _) -> pure Nothing + (Nothing, _) -> do + TinyLog.warn $ Log.msg ("found pending proposal without origin, ignoring" :: ByteString) + pure Nothing + ) + + let indexSet = Set.fromList indexList + when (length indexList /= length indexSet) $ do + TinyLog.warn $ + Log.msg ("found duplicate proposals" :: ByteString) + . Log.field "groupId" ("0x" <> hex (unGroupId gid)) + . Log.field "epoch" (epochNumber epoch) + pure indexSet withCommitLock :: forall r a. @@ -126,7 +137,7 @@ withCommitLock lConvOrSubId gid epoch action = ttl = fromIntegral (600 :: Int) -- 10 minutes getConvFromGroupId :: - Member (Error MLSProtocolError) r => + (Member (Error MLSProtocolError) r) => GroupId -> Sem r (ConvType, Qualified ConvOrSubConvId) getConvFromGroupId gid = case groupIdToConv gid of diff --git a/services/galley/src/Galley/API/MLS/Welcome.hs b/services/galley/src/Galley/API/MLS/Welcome.hs index 6f051263247..c9a182d890b 100644 --- a/services/galley/src/Galley/API/MLS/Welcome.hs +++ b/services/galley/src/Galley/API/MLS/Welcome.hs @@ -124,7 +124,7 @@ sendRemoteWelcomes qcnv qusr welcome clients = do } where handleError :: - Member P.TinyLog r => + (Member P.TinyLog r) => Either (Remote [a], FederationError) (Remote MLSWelcomeResponse) -> Sem r () handleError (Right x) = case tUnqualified x of @@ -132,7 +132,7 @@ sendRemoteWelcomes qcnv qusr welcome clients = do MLSWelcomeMLSNotEnabled -> logFedError x (errorToResponse @'MLSNotEnabled) handleError (Left (r, e)) = logFedError r (toResponse e) - logFedError :: Member P.TinyLog r => Remote x -> JSONResponse -> Sem r () + logFedError :: (Member P.TinyLog r) => Remote x -> JSONResponse -> Sem r () logFedError r e = P.warn $ Logger.msg ("A welcome message could not be delivered to a remote backend" :: ByteString) diff --git a/services/galley/src/Galley/API/Message.hs b/services/galley/src/Galley/API/Message.hs index 8d0d8dba25c..483010aa828 100644 --- a/services/galley/src/Galley/API/Message.hs +++ b/services/galley/src/Galley/API/Message.hs @@ -566,7 +566,7 @@ guardQualifiedLegalholdPolicyConflictsWrapper senderType sender localClients qua -- FUTUREWORK: This is just a workaround and would not be needed if we had a proper monoid/semigroup instance for Map where the values have a monoid instance. collectFailedToSend :: - Foldable f => + (Foldable f) => f (Map Domain (Map UserId (Set ClientId))) -> Map Domain (Map UserId (Set ClientId)) collectFailedToSend = foldr (Map.unionWith (Map.unionWith Set.union)) mempty @@ -766,6 +766,6 @@ instance Unqualify QualifiedUserClients UserClients where . Map.findWithDefault mempty domain . qualifiedUserClients -instance Unqualify a b => Unqualify (PostOtrResponse a) (PostOtrResponse b) where +instance (Unqualify a b) => Unqualify (PostOtrResponse a) (PostOtrResponse b) where unqualify domain (Left a) = Left (unqualify domain <$> a) unqualify domain (Right a) = Right (unqualify domain a) diff --git a/services/galley/src/Galley/API/Public/Feature.hs b/services/galley/src/Galley/API/Public/Feature.hs index 61fc38c87b8..3e9d3f68a54 100644 --- a/services/galley/src/Galley/API/Public/Feature.hs +++ b/services/galley/src/Galley/API/Public/Feature.hs @@ -62,7 +62,8 @@ featureAPI = <@> mkNamedAPI @'("get", OutlookCalIntegrationConfig) (getFeatureStatus . DoAuth) <@> mkNamedAPI @'("put", OutlookCalIntegrationConfig) (setFeatureStatus . DoAuth) <@> mkNamedAPI @'("get", MlsE2EIdConfig) (getFeatureStatus . DoAuth) - <@> mkNamedAPI @'("put", MlsE2EIdConfig) (setFeatureStatus . DoAuth) + <@> mkNamedAPI @"put-MlsE2EIdConfig@v5" (setFeatureStatus . DoAuth) + <@> mkNamedAPI @'("put", MlsE2EIdConfig) (guardMlsE2EIdConfig (setFeatureStatus . DoAuth)) <@> mkNamedAPI @'("get", MlsMigrationConfig) (getFeatureStatus . DoAuth) <@> mkNamedAPI @'("put", MlsMigrationConfig) (setFeatureStatus . DoAuth) <@> mkNamedAPI @'("get", EnforceFileDownloadLocationConfig) (getFeatureStatus . DoAuth) diff --git a/services/galley/src/Galley/API/Public/TeamNotification.hs b/services/galley/src/Galley/API/Public/TeamNotification.hs index f8e5a828096..85e4c00358e 100644 --- a/services/galley/src/Galley/API/Public/TeamNotification.hs +++ b/services/galley/src/Galley/API/Public/TeamNotification.hs @@ -41,7 +41,7 @@ getTeamNotifications uid since size = do (fromMaybe defaultSize size) where checkSince :: - Member (ErrorS 'InvalidTeamNotificationId) r => + (Member (ErrorS 'InvalidTeamNotificationId) r) => Maybe NotificationId -> Sem r (Maybe NotificationId) checkSince Nothing = pure Nothing diff --git a/services/galley/src/Galley/API/Push.hs b/services/galley/src/Galley/API/Push.hs index b501c804009..c66a8ae73a4 100644 --- a/services/galley/src/Galley/API/Push.hs +++ b/services/galley/src/Galley/API/Push.hs @@ -61,7 +61,7 @@ instance ToRecipient Recipient where toRecipient = id newMessagePush :: - ToRecipient r => + (ToRecipient r) => BotMap -> Maybe ConnId -> MessageMetadata -> @@ -98,6 +98,6 @@ toPush (MessagePush mconn mm rs _ event) = let usr = qUnqualified (evtFrom event) in newPush (Just usr) (toJSONObject event) rs <&> set pushConn mconn - . set pushNativePriority (mmNativePriority mm) - . set pushRoute (bool RouteDirect RouteAny (mmNativePush mm)) - . set pushTransient (mmTransient mm) + . set pushNativePriority (mmNativePriority mm) + . set pushRoute (bool RouteDirect RouteAny (mmNativePush mm)) + . set pushTransient (mmTransient mm) diff --git a/services/galley/src/Galley/API/Query.hs b/services/galley/src/Galley/API/Query.hs index f46696d34bb..8facb7f7b76 100644 --- a/services/galley/src/Galley/API/Query.hs +++ b/services/galley/src/Galley/API/Query.hs @@ -263,7 +263,7 @@ getRemoteConversationsWithFailures lusr convs = do <$> traverse handleFailure resp where handleFailure :: - Member P.TinyLog r => + (Member P.TinyLog r) => Either (Remote [ConvId], FederationError) (Remote GetConversationsResponse) -> Sem r (Either FailedGetConversation [Remote RemoteConversation]) handleFailure (Left (rcids, e)) = do @@ -288,7 +288,7 @@ getConversationRoles lusr cnv = do pure $ Public.ConversationRolesList wireConvRoles conversationIdsPageFromUnqualified :: - Member (ListItems LegacyPaging ConvId) r => + (Member (ListItems LegacyPaging ConvId) r) => Local UserId -> Maybe ConvId -> Maybe (Range 1 1000 Int32) -> @@ -343,9 +343,7 @@ conversationIdsPageFromV2 listGlobalSelf lusr Public.GetMultiTablePageRequest {. Range 1 1000 Int32 -> Sem r Public.ConvIdsPage localsAndRemotes localDomain pagingState size = do - localPage <- - pageToConvIdPage Public.PagingLocals . fmap (`Qualified` localDomain) - <$> E.listItems (tUnqualified lusr) pagingState size + localPage <- localsOnly localDomain pagingState size let remainingSize = fromRange size - fromIntegral (length (Public.mtpResults localPage)) if Public.mtpHasMore localPage || remainingSize <= 0 then -- We haven't checked the remotes yet, so has_more must always be True here. @@ -360,6 +358,16 @@ conversationIdsPageFromV2 listGlobalSelf lusr Public.GetMultiTablePageRequest {. <> Public.mtpResults remotePage } + localsOnly :: + Domain -> + Maybe C.PagingState -> + Range 1 1000 Int32 -> + Sem r Public.ConvIdsPage + localsOnly localDomain pagingState size = + pageToConvIdPage Public.PagingLocals + . fmap (`Qualified` localDomain) + <$> E.listItems (tUnqualified lusr) pagingState size + remotesOnly :: Maybe C.PagingState -> Range 1 1000 Int32 -> @@ -480,7 +488,7 @@ getConversationsInternal luser mids mstart msize = do pure (hasMore, resultSetResult r) removeDeleted :: - Member ConversationStore r => + (Member ConversationStore r) => Data.Conversation -> Sem r Bool removeDeleted c @@ -532,7 +540,7 @@ listConversations luser (Public.ListConversations ids) = do } where removeDeleted :: - Member ConversationStore r => + (Member ConversationStore r) => Data.Conversation -> Sem r Bool removeDeleted c @@ -824,7 +832,7 @@ isMLSOne2OneEstablished lself qother = do convId isLocalMLSOne2OneEstablished :: - Member ConversationStore r => + (Member ConversationStore r) => Local ConvId -> Sem r Bool isLocalMLSOne2OneEstablished lconv = do diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index d92aa3b2097..e3aed8fbd4c 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -182,7 +182,7 @@ getTeamNameInternalH :: getTeamNameInternalH tid = getTeamNameInternal tid >>= noteS @'TeamNotFound -getTeamNameInternal :: Member TeamStore r => TeamId -> Sem r (Maybe TeamName) +getTeamNameInternal :: (Member TeamStore r) => TeamId -> Sem r (Maybe TeamName) getTeamNameInternal = fmap (fmap TeamName) . E.getTeamName -- | DEPRECATED. @@ -310,7 +310,7 @@ updateTeamStatus tid (TeamStatusUpdate newStatus cur) = do else possiblyStaleSize Journal.teamActivate tid size c teamCreationTime runJournal _ _ = throwS @'InvalidTeamStatusUpdate - validateTransition :: Member (ErrorS 'InvalidTeamStatusUpdate) r => (TeamStatus, TeamStatus) -> Sem r Bool + validateTransition :: (Member (ErrorS 'InvalidTeamStatusUpdate) r) => (TeamStatus, TeamStatus) -> Sem r Bool validateTransition = \case (PendingActive, Active) -> pure True (Active, Active) -> pure False @@ -519,7 +519,7 @@ getTeamMembers lzusr tid mbMaxResults mbPagingState = do (pwsHasMore p) (teamMemberPagingState p) -outputToStreamingBody :: Member (Final IO) r => Sem (Output LByteString ': r) () -> Sem r StreamingBody +outputToStreamingBody :: (Member (Final IO) r) => Sem (Output LByteString ': r) () -> Sem r StreamingBody outputToStreamingBody action = withWeavingToFinal @IO $ \state weave _inspect -> pure . (<$ state) $ \write flush -> do let writeChunk c = embedFinal $ do @@ -605,7 +605,7 @@ getTeamMembersCSV lusr tid = do tExportNumDevices = numClients uid } - lookupInviterHandle :: Member BrigAccess r => [TeamMember] -> Sem r (UserId -> Maybe Handle.Handle) + lookupInviterHandle :: (Member BrigAccess r) => [TeamMember] -> Sem r (UserId -> Maybe Handle.Handle) lookupInviterHandle members = do let inviterIds :: [UserId] inviterIds = nub $ mapMaybe (fmap fst . view invitation) members @@ -691,7 +691,7 @@ uncheckedGetTeamMember tid uid = E.getTeamMember tid uid >>= noteS @'TeamMemberNotFound uncheckedGetTeamMembersH :: - Member TeamStore r => + (Member TeamStore r) => TeamId -> Maybe (Range 1 HardTruncationLimit Int32) -> Sem r TeamMemberList @@ -699,7 +699,7 @@ uncheckedGetTeamMembersH tid mMaxResults = uncheckedGetTeamMembers tid (fromMaybe (unsafeRange hardTruncationLimit) mMaxResults) uncheckedGetTeamMembers :: - Member TeamStore r => + (Member TeamStore r) => TeamId -> Range 1 HardTruncationLimit Int32 -> Sem r TeamMemberList @@ -1253,7 +1253,7 @@ ensureNonBindingTeam tid = do -- ensure that the permissions are not "greater" than the user's copy permissions -- this is used to ensure users cannot "elevate" permissions -ensureNotElevated :: Member (ErrorS 'InvalidPermissions) r => Permissions -> TeamMember -> Sem r () +ensureNotElevated :: (Member (ErrorS 'InvalidPermissions) r) => Permissions -> TeamMember -> Sem r () ensureNotElevated targetPermissions member = unless ( (targetPermissions ^. self) @@ -1405,7 +1405,7 @@ canUserJoinTeam tid = do -- | Modify and get visibility type for a team (internal, no user permission checks) getSearchVisibilityInternal :: - Member SearchVisibilityStore r => + (Member SearchVisibilityStore r) => TeamId -> Sem r TeamSearchVisibilityView getSearchVisibilityInternal = @@ -1454,7 +1454,7 @@ queueTeamDeletion tid zusr zcon = do ok <- E.tryPush (TeamItem tid zusr zcon) unless ok $ throwS @'DeleteQueueFull -checkAdminLimit :: Member (ErrorS 'TooManyTeamAdmins) r => Int -> Sem r () +checkAdminLimit :: (Member (ErrorS 'TooManyTeamAdmins) r) => Int -> Sem r () checkAdminLimit adminCount = when (adminCount > 2000) $ throwS @'TooManyTeamAdmins diff --git a/services/galley/src/Galley/API/Teams/Features.hs b/services/galley/src/Galley/API/Teams/Features.hs index 6425dd772a9..aa65a594ed4 100644 --- a/services/galley/src/Galley/API/Teams/Features.hs +++ b/services/galley/src/Galley/API/Teams/Features.hs @@ -32,6 +32,7 @@ module Galley.API.Teams.Features guardSecondFactorDisabled, DoAuth (..), featureEnabledForTeam, + guardMlsE2EIdConfig, ) where @@ -225,7 +226,7 @@ guardLockStatus = \case -- SetFeatureConfig instances -- | Don't export methods of this typeclass -class GetFeatureConfig cfg => SetFeatureConfig cfg where +class (GetFeatureConfig cfg) => SetFeatureConfig cfg where type SetConfigForTeamConstraints cfg (r :: EffectRow) :: Constraint type SetConfigForTeamConstraints cfg (r :: EffectRow) = () @@ -385,6 +386,18 @@ instance SetFeatureConfig OutlookCalIntegrationConfig instance SetFeatureConfig MlsE2EIdConfig +guardMlsE2EIdConfig :: + forall r a. + (Member (Error TeamFeatureError) r) => + (UserId -> TeamId -> WithStatusNoLock MlsE2EIdConfig -> Sem r a) -> + UserId -> + TeamId -> + WithStatusNoLock MlsE2EIdConfig -> + Sem r a +guardMlsE2EIdConfig handler uid tid conf = do + when (isNothing . crlProxy . wssConfig $ conf) $ throw MLSE2EIDMissingCrlProxy + handler uid tid conf + instance SetFeatureConfig MlsMigrationConfig where type SetConfigForTeamConstraints MlsMigrationConfig (r :: EffectRow) = (Member (Error TeamFeatureError) r) setConfigForTeam tid wsnl = do diff --git a/services/galley/src/Galley/API/Teams/Features/Get.hs b/services/galley/src/Galley/API/Teams/Features/Get.hs index 79f1b4e0ba8..685266b3ea1 100644 --- a/services/galley/src/Galley/API/Teams/Features/Get.hs +++ b/services/galley/src/Galley/API/Teams/Features/Get.hs @@ -56,7 +56,7 @@ import Wire.API.Team.Feature data DoAuth = DoAuth UserId | DontDoAuth -- | Don't export methods of this typeclass -class IsFeatureConfig cfg => GetFeatureConfig cfg where +class (IsFeatureConfig cfg) => GetFeatureConfig cfg where type GetConfigForTeamConstraints cfg (r :: EffectRow) :: Constraint type GetConfigForTeamConstraints cfg (r :: EffectRow) = @@ -76,7 +76,7 @@ class IsFeatureConfig cfg => GetFeatureConfig cfg where ) getConfigForServer :: - Member (Input Opts) r => + (Member (Input Opts) r) => Sem r (WithStatus cfg) -- only override if there is additional business logic for getting the feature config -- and/or if the feature flag is configured for the backend in 'FeatureFlags' for galley in 'Galley.Types.Teams' @@ -85,7 +85,7 @@ class IsFeatureConfig cfg => GetFeatureConfig cfg where getConfigForServer = pure defFeatureStatus getConfigForTeam :: - GetConfigForTeamConstraints cfg r => + (GetConfigForTeamConstraints cfg r) => TeamId -> Sem r (WithStatus cfg) default getConfigForTeam :: @@ -97,7 +97,7 @@ class IsFeatureConfig cfg => GetFeatureConfig cfg where getConfigForTeam = genericGetConfigForTeam getConfigForUser :: - GetConfigForUserConstraints cfg r => + (GetConfigForUserConstraints cfg r) => UserId -> Sem r (WithStatus cfg) default getConfigForUser :: @@ -213,7 +213,7 @@ getAllFeatureConfigsForTeam luid tid = do getAllFeatureConfigsForServer :: forall r. - Member (Input Opts) r => + (Member (Input Opts) r) => Sem r AllFeatureConfigs getAllFeatureConfigsForServer = AllFeatureConfigs @@ -277,9 +277,9 @@ getAllFeatureConfigsUser uid = -- | Note: this is an internal function which doesn't cover all features, e.g. LegalholdConfig genericGetConfigForTeam :: forall cfg r. - GetFeatureConfig cfg => - Member TeamFeatureStore r => - Member (Input Opts) r => + (GetFeatureConfig cfg) => + (Member TeamFeatureStore r) => + (Member (Input Opts) r) => TeamId -> Sem r (WithStatus cfg) genericGetConfigForTeam tid = do @@ -291,9 +291,9 @@ genericGetConfigForTeam tid = do -- Note: this function assumes the feature cannot be locked genericGetConfigForMultiTeam :: forall cfg r. - GetFeatureConfig cfg => - Member TeamFeatureStore r => - Member (Input Opts) r => + (GetFeatureConfig cfg) => + (Member TeamFeatureStore r) => + (Member (Input Opts) r) => [TeamId] -> Sem r [(TeamId, WithStatus cfg)] genericGetConfigForMultiTeam tids = do diff --git a/services/galley/src/Galley/API/Teams/Notifications.hs b/services/galley/src/Galley/API/Teams/Notifications.hs index 5c5e040ceb4..f3e31f9ec33 100644 --- a/services/galley/src/Galley/API/Teams/Notifications.hs +++ b/services/galley/src/Galley/API/Teams/Notifications.hs @@ -73,7 +73,7 @@ getTeamNotifications zusr since size = do (DataTeamQueue.resultHasMore page) Nothing -pushTeamEvent :: Member TeamNotificationStore r => TeamId -> Event -> Sem r () +pushTeamEvent :: (Member TeamNotificationStore r) => TeamId -> Event -> Sem r () pushTeamEvent tid evt = do nid <- E.mkNotificationId E.createTeamNotification tid nid (List1.singleton $ toJSONObject evt) diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index 750b9324ca3..6fe22e53beb 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -74,7 +74,6 @@ where import Control.Error.Util (hush) import Control.Lens -import Control.Monad.State import Data.Code import Data.Id import Data.Json.Util @@ -126,7 +125,7 @@ import Wire.API.Federation.API import Wire.API.Federation.API.Galley import Wire.API.Federation.Error import Wire.API.Message -import Wire.API.Password (mkSafePassword) +import Wire.API.Password (mkSafePasswordScrypt) import Wire.API.Routes.Public (ZHostValue) import Wire.API.Routes.Public.Galley.Messaging import Wire.API.Routes.Public.Util (UpdateResult (..)) @@ -570,7 +569,7 @@ addCode lusr mbZHost mZcon lcnv mReq = do Nothing -> do ttl <- realToFrac . unGuestLinkTTLSeconds . fromMaybe defGuestLinkTTLSeconds . view (settings . guestLinkTTLSeconds) <$> input code <- E.generateCode (tUnqualified lcnv) ReusableCode (Timeout ttl) - mPw <- for (mReq >>= (.password)) mkSafePassword + mPw <- for (mReq >>= (.password)) mkSafePasswordScrypt E.createCode code mPw now <- input let event = Event (tUntagged lcnv) Nothing (tUntagged lusr) now (EdConvCodeUpdate (mkConversationCodeInfo (isJust mPw) (codeKey code) (codeValue code) convUri)) diff --git a/services/galley/src/Galley/API/Util.hs b/services/galley/src/Galley/API/Util.hs index dc4b824449e..b87dcf5e051 100644 --- a/services/galley/src/Galley/API/Util.hs +++ b/services/galley/src/Galley/API/Util.hs @@ -222,7 +222,7 @@ ensureActionAllowed action self = case isActionAllowed (fromSing action) (convMe -- fact that there can be no custom roles at the moment Nothing -> throwS @('ActionDenied action) -ensureGroupConversation :: Member (ErrorS 'InvalidOperation) r => Data.Conversation -> Sem r () +ensureGroupConversation :: (Member (ErrorS 'InvalidOperation) r) => Data.Conversation -> Sem r () ensureGroupConversation conv = do let ty = Data.convType conv when (ty /= RegularConv) $ throwS @'InvalidOperation @@ -378,7 +378,7 @@ memberJoinEvent lorig qconv t lmems rmems = remoteToSimple u = SimpleMember (tUntagged (rmId u)) (rmConvRoleName u) convDeleteMembers :: - Member MemberStore r => + (Member MemberStore r) => UserList UserId -> Data.Conversation -> Sem r Data.Conversation @@ -395,13 +395,13 @@ convDeleteMembers ul conv = do filter (\rm -> Set.notMember (rmId rm) remotes) (Data.convRemoteMembers conv) } -isMember :: Foldable m => UserId -> m LocalMember -> Bool +isMember :: (Foldable m) => UserId -> m LocalMember -> Bool isMember u = isJust . find ((u ==) . lmId) -isRemoteMember :: Foldable m => Remote UserId -> m RemoteMember -> Bool +isRemoteMember :: (Foldable m) => Remote UserId -> m RemoteMember -> Bool isRemoteMember u = isJust . find ((u ==) . rmId) -class IsConvMember mem => IsConvMemberId uid mem | uid -> mem where +class (IsConvMember mem) => IsConvMemberId uid mem | uid -> mem where getConvMember :: Local x -> Data.Conversation -> uid -> Maybe mem isConvMember :: Local x -> Data.Conversation -> uid -> Bool @@ -410,7 +410,7 @@ 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 :: (IsConvMemberId uid mem) => Local Data.Conversation -> uid -> Bool isConvMemberL lconv = isConvMember lconv (tUnqualified lconv) instance IsConvMemberId UserId LocalMember where @@ -512,7 +512,7 @@ bmFromMembers lmems rusers = case localBotsAndUsers lmems of convBotsAndMembers :: Data.Conversation -> BotsAndMembers convBotsAndMembers conv = bmFromMembers (Data.convLocalMembers conv) (Data.convRemoteMembers conv) -localBotsAndUsers :: Foldable f => f LocalMember -> ([BotMember], [LocalMember]) +localBotsAndUsers :: (Foldable f) => f LocalMember -> ([BotMember], [LocalMember]) localBotsAndUsers = foldMap botOrUser where botOrUser m = case lmService m of @@ -520,7 +520,7 @@ localBotsAndUsers = foldMap botOrUser Just _ -> (toList (newBotMember m), []) Nothing -> ([], [m]) -location :: ToByteString a => a -> Response -> Response +location :: (ToByteString a) => a -> Response -> Response location = Wai.addHeader hLocation . toByteString' nonTeamMembers :: [LocalMember] -> [TeamMember] -> [LocalMember] @@ -544,15 +544,17 @@ getSelfMemberFromLocals = getMember @'ConvNotFound lmId -- | Throw 'ConvMemberNotFound' if the given user is not part of a -- conversation (either locally or remotely). ensureOtherMember :: - Member (ErrorS 'ConvMemberNotFound) r => + (Member (ErrorS 'ConvMemberNotFound) r) => Local a -> Qualified UserId -> Data.Conversation -> Sem r (Either LocalMember RemoteMember) ensureOtherMember loc quid conv = noteS @'ConvMemberNotFound $ - Left <$> find ((== quid) . tUntagged . qualifyAs loc . lmId) (Data.convLocalMembers conv) - <|> Right <$> find ((== quid) . tUntagged . rmId) (Data.convRemoteMembers conv) + Left + <$> find ((== quid) . tUntagged . qualifyAs loc . lmId) (Data.convLocalMembers conv) + <|> Right + <$> find ((== quid) . tUntagged . rmId) (Data.convRemoteMembers conv) getMember :: forall e mem t userId r. @@ -696,7 +698,7 @@ ensureConversationAccess zusr conv access = do ensureAccessRole (Data.convAccessRoles conv) [(zusr, zusrMembership)] ensureAccess :: - Member (ErrorS 'ConvAccessDenied) r => + (Member (ErrorS 'ConvAccessDenied) r) => Data.Conversation -> Access -> Sem r () @@ -704,13 +706,13 @@ ensureAccess conv access = unless (access `elem` Data.convAccess conv) $ throwS @'ConvAccessDenied -ensureLocal :: Member (Error FederationError) r => Local x -> Qualified a -> Sem r (Local a) +ensureLocal :: (Member (Error FederationError) r) => Local x -> Qualified a -> Sem r (Local a) ensureLocal loc = foldQualified loc pure (\_ -> throw FederationNotImplemented) -------------------------------------------------------------------------------- -- Federation -qualifyLocal :: Member (Input (Local ())) r => a -> Sem r (Local a) +qualifyLocal :: (Member (Input (Local ())) r) => a -> Sem r (Local a) qualifyLocal a = toLocalUnsafe <$> fmap getDomain input <*> pure a where getDomain :: Local () -> Domain @@ -776,7 +778,7 @@ fromConversationCreated loc rc@ConversationCreated {..} = where inDomain :: OtherMember -> Bool inDomain = (== tDomain loc) . qDomain . Public.omQualifiedId - setHoles :: Ord a => Set a -> [(a, Set a)] + setHoles :: (Ord a) => Set a -> [(a, Set a)] setHoles s = foldMap (\x -> [(x, Set.delete x s)]) s -- Currently this function creates a Member with default conversation attributes -- FUTUREWORK(federation): retrieve member's conversation attributes (muted, archived, etc) here once supported by the database schema. @@ -815,7 +817,7 @@ fromConversationCreated loc rc@ConversationCreated {..} = ProtocolProteus ensureNoUnreachableBackends :: - Member (Error UnreachableBackends) r => + (Member (Error UnreachableBackends) r) => [Either (Remote e, b) a] -> Sem r [a] ensureNoUnreachableBackends results = do @@ -924,7 +926,7 @@ registerRemoteConversationMemberships now lusr lc = deleteOnUnreachable $ do userLHEnabled :: UserLegalHoldStatus -> Bool userLHEnabled = \case UserLegalHoldEnabled -> True - UserLegalHoldPending -> True + UserLegalHoldPending -> False UserLegalHoldDisabled -> False UserLegalHoldNoConsent -> False @@ -939,7 +941,7 @@ consentGiven = \case UserLegalHoldNoConsent -> ConsentNotGiven checkConsent :: - Member TeamStore r => + (Member TeamStore r) => Map UserId TeamId -> UserId -> Sem r ConsentGiven @@ -949,7 +951,7 @@ checkConsent teamsOfUsers other = do -- Get legalhold status of user. Defaults to 'defUserLegalHoldStatus' if user -- doesn't belong to a team. getLHStatus :: - Member TeamStore r => + (Member TeamStore r) => Maybe TeamId -> UserId -> Sem r UserLegalHoldStatus @@ -1006,7 +1008,7 @@ allLegalholdConsentGiven uids = do -- | Add to every uid the legalhold status getLHStatusForUsers :: - Member TeamStore r => + (Member TeamStore r) => [UserId] -> Sem r [(UserId, UserLegalHoldStatus)] getLHStatusForUsers uids = @@ -1019,7 +1021,7 @@ getLHStatusForUsers uids = (uid,) <$> getLHStatus (Map.lookup uid teamsOfUsers) uid ) -getTeamMembersForFanout :: Member TeamStore r => TeamId -> Sem r TeamMemberList +getTeamMembersForFanout :: (Member TeamStore r) => TeamId -> Sem r TeamMemberList getTeamMembersForFanout tid = do lim <- fanoutLimit getTeamMembersWithLimit tid lim diff --git a/services/galley/src/Galley/App.hs b/services/galley/src/Galley/App.hs index 086fac2cad2..0eab89da5c7 100644 --- a/services/galley/src/Galley/App.hs +++ b/services/galley/src/Galley/App.hs @@ -22,7 +22,6 @@ module Galley.App Env, reqId, options, - monitor, applog, manager, federator, @@ -50,7 +49,6 @@ import Cassandra.Util (initCassandraForService) import Control.Error hiding (err) import Control.Lens hiding ((.=)) import Data.Id -import Data.Metrics.Middleware import Data.Misc import Data.Qualified import Data.Range @@ -162,13 +160,13 @@ validateOptions o = do (Just uri, Nothing) -> pure (Left uri) (Just _, Just _) -> error errMsg -createEnv :: Metrics -> Opts -> Logger -> IO Env -createEnv m o l = do +createEnv :: Opts -> Logger -> IO Env +createEnv o l = do cass <- initCassandra o l mgr <- initHttpManager o h2mgr <- initHttp2Manager codeURIcfg <- validateOptions o - Env (RequestId "N/A") m o l mgr h2mgr (o ^. O.federator) (o ^. O.brig) cass + Env (RequestId "N/A") o l mgr h2mgr (o ^. O.federator) (o ^. O.brig) cass <$> Q.new 16000 <*> initExtEnv <*> maybe (pure Nothing) (fmap Just . Aws.mkEnv l mgr) (o ^. journal) @@ -214,7 +212,7 @@ initHttp2Manager = do http2ManagerWithSSLCtx ctx interpretTinyLog :: - Member (Embed IO) r => + (Member (Embed IO) r) => Env -> Sem (P.TinyLog ': r) a -> Sem r a diff --git a/services/galley/src/Galley/Aws.hs b/services/galley/src/Galley/Aws.hs index 2a7050784f6..67963a7e908 100644 --- a/services/galley/src/Galley/Aws.hs +++ b/services/galley/src/Galley/Aws.hs @@ -156,7 +156,7 @@ mkEnv lgr mgr opts = do (pure . QueueUrl . view SQS.getQueueUrlResponse_queueUrl) x -execute :: MonadIO m => Env -> Amazon a -> m a +execute :: (MonadIO m) => Env -> Amazon a -> m a execute e m = liftIO $ runResourceT (runReaderT (unAmazon m) e) enqueue :: E.TeamEvent -> Amazon () @@ -186,7 +186,7 @@ sendCatch :: Amazon (Either AWS.Error (AWS.AWSResponse r)) sendCatch e = AWS.trying AWS._Error . AWS.send e -canRetry :: MonadIO m => Either AWS.Error a -> m Bool +canRetry :: (MonadIO m) => Either AWS.Error a -> m Bool canRetry (Right _) = pure False canRetry (Left e) = case e of AWS.TransportError (HttpExceptionRequest _ ResponseTimeout) -> pure True diff --git a/services/galley/src/Galley/Cassandra/Conversation.hs b/services/galley/src/Galley/Cassandra/Conversation.hs index 919b7b21836..5bc1fdc7ebe 100644 --- a/services/galley/src/Galley/Cassandra/Conversation.hs +++ b/services/galley/src/Galley/Cassandra/Conversation.hs @@ -389,11 +389,12 @@ toConv cid ms remoteMems mconv = do } updateToMixedProtocol :: - Members - '[ Embed IO, - Input ClientState - ] - r => + ( Members + '[ Embed IO, + Input ClientState + ] + r + ) => Local ConvId -> ConvType -> Sem r () @@ -407,11 +408,12 @@ updateToMixedProtocol lcnv ct = do pure () updateToMLSProtocol :: - Members - '[ Embed IO, - Input ClientState - ] - r => + ( Members + '[ Embed IO, + Input ClientState + ] + r + ) => Local ConvId -> Sem r () updateToMLSProtocol lcnv = diff --git a/services/galley/src/Galley/Cassandra/Conversation/Members.hs b/services/galley/src/Galley/Cassandra/Conversation/Members.hs index 4b0482f712b..26c3db667bd 100644 --- a/services/galley/src/Galley/Cassandra/Conversation/Members.hs +++ b/services/galley/src/Galley/Cassandra/Conversation/Members.hs @@ -369,7 +369,7 @@ addMLSClients groupId (Qualified usr domain) cs = retry x5 . batch $ do for_ cs $ \(c, idx) -> addPrepQuery Cql.addMLSClient (groupId, domain, usr, c, fromIntegral idx) -planMLSClientRemoval :: Foldable f => GroupId -> f ClientIdentity -> Client () +planMLSClientRemoval :: (Foldable f) => GroupId -> f ClientIdentity -> Client () planMLSClientRemoval groupId cids = retry x5 . batch $ do setType BatchLogged diff --git a/services/galley/src/Galley/Cassandra/CustomBackend.hs b/services/galley/src/Galley/Cassandra/CustomBackend.hs index f06f8187ac9..df0af160cec 100644 --- a/services/galley/src/Galley/Cassandra/CustomBackend.hs +++ b/services/galley/src/Galley/Cassandra/CustomBackend.hs @@ -50,7 +50,7 @@ interpretCustomBackendStoreToCassandra = interpret $ \case logEffect "CustomBackendStore.DeleteCustomBackend" embedClient $ deleteCustomBackend dom -getCustomBackend :: MonadClient m => Domain -> m (Maybe CustomBackend) +getCustomBackend :: (MonadClient m) => Domain -> m (Maybe CustomBackend) getCustomBackend domain = fmap toCustomBackend <$> do retry x1 $ query1 Cql.selectCustomBackend (params LocalQuorum (Identity domain)) @@ -58,10 +58,10 @@ getCustomBackend domain = toCustomBackend (backendConfigJsonUrl, backendWebappWelcomeUrl) = CustomBackend {..} -setCustomBackend :: MonadClient m => Domain -> CustomBackend -> m () +setCustomBackend :: (MonadClient m) => Domain -> CustomBackend -> m () setCustomBackend domain CustomBackend {..} = do retry x5 $ write Cql.upsertCustomBackend (params LocalQuorum (backendConfigJsonUrl, backendWebappWelcomeUrl, domain)) -deleteCustomBackend :: MonadClient m => Domain -> m () +deleteCustomBackend :: (MonadClient m) => Domain -> m () deleteCustomBackend domain = do retry x5 $ write Cql.deleteCustomBackend (params LocalQuorum (Identity domain)) diff --git a/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs b/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs index d6b070c7f91..282e9d916c2 100644 --- a/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs +++ b/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs @@ -58,6 +58,8 @@ data AllTeamFeatureConfigsRow = AllTeamFeatureConfigsRow mlsE2eid :: Maybe FeatureStatus, mlsE2eidGracePeriod :: Maybe Int32, mlsE2eidAcmeDiscoverUrl :: Maybe HttpsUrl, + mlsE2eidMaybeCrlProxy :: Maybe HttpsUrl, + mlsE2eidMaybeUseProxyOnMobile :: Maybe Bool, mlsE2eidLock :: Maybe LockStatus, -- mls migration mlsMigration :: Maybe FeatureStatus, @@ -112,6 +114,8 @@ emptyRow = mlsE2eid = Nothing, mlsE2eidGracePeriod = Nothing, mlsE2eidAcmeDiscoverUrl = Nothing, + mlsE2eidMaybeCrlProxy = Nothing, + mlsE2eidMaybeUseProxyOnMobile = Nothing, mlsE2eidLock = Nothing, mlsMigration = Nothing, mlsMigrationStartTime = Nothing, @@ -295,6 +299,8 @@ allFeatureConfigsFromRow ourteam allowListForExposeInvitationURLs featureLH hasT MlsE2EIdConfig (toGracePeriodOrDefault row.mlsE2eidGracePeriod) row.mlsE2eidAcmeDiscoverUrl + row.mlsE2eidMaybeCrlProxy + (fromMaybe (useProxyOnMobile . wsConfig $ defFeatureStatus) row.mlsE2eidMaybeUseProxyOnMobile) where toGracePeriodOrDefault :: Maybe Int32 -> NominalDiffTime toGracePeriodOrDefault = maybe (verificationExpiration $ wsConfig defFeatureStatus) fromIntegral @@ -334,7 +340,7 @@ allFeatureConfigsFromRow ourteam allowListForExposeInvitationURLs featureLH hasT FeatureLegalHoldDisabledByDefault -> maybe False ((==) FeatureStatusEnabled) mStatusValue FeatureLegalHoldWhitelistTeamsAndImplicitConsent -> hasTeamImplicitLegalhold -getAllFeatureConfigs :: MonadClient m => Maybe [TeamId] -> FeatureLegalHold -> Bool -> AllFeatureConfigs -> TeamId -> m AllFeatureConfigs +getAllFeatureConfigs :: (MonadClient m) => Maybe [TeamId] -> FeatureLegalHold -> Bool -> AllFeatureConfigs -> TeamId -> m AllFeatureConfigs getAllFeatureConfigs allowListForExposeInvitationURLs featureLH hasTeamImplicitLegalhold serverConfigs tid = do mRow <- retry x1 $ query1 select (params LocalQuorum (Identity tid)) pure @@ -368,7 +374,7 @@ getAllFeatureConfigs allowListForExposeInvitationURLs featureLH hasTeamImplicitL \mls_status, mls_default_protocol, mls_protocol_toggle_users, mls_allowed_ciphersuites, \ \mls_default_ciphersuite, mls_supported_protocols, mls_lock_status, \ \\ - \mls_e2eid_status, mls_e2eid_grace_period, mls_e2eid_acme_discovery_url, mls_e2eid_lock_status, \ + \mls_e2eid_status, mls_e2eid_grace_period, mls_e2eid_acme_discovery_url, mls_e2eid_crl_proxy, mls_e2eid_use_proxy_on_mobile, mls_e2eid_lock_status, \ \\ \mls_migration_status, mls_migration_start_time, mls_migration_finalise_regardless_after, \ \mls_migration_lock_status, \ diff --git a/services/galley/src/Galley/Cassandra/LegalHold.hs b/services/galley/src/Galley/Cassandra/LegalHold.hs index ccc4b9c53f5..490e46dcaa9 100644 --- a/services/galley/src/Galley/Cassandra/LegalHold.hs +++ b/services/galley/src/Galley/Cassandra/LegalHold.hs @@ -109,23 +109,23 @@ interpretLegalHoldStoreToCassandra lh = interpret $ \case -- | Returns 'False' if legal hold is not enabled for this team -- The Caller is responsible for checking whether legal hold is enabled for this team -createSettings :: MonadClient m => LegalHoldService -> m () +createSettings :: (MonadClient m) => LegalHoldService -> m () createSettings (LegalHoldService tid url fpr tok key) = do retry x1 $ write Q.insertLegalHoldSettings (params LocalQuorum (url, fpr, tok, key, tid)) -- | Returns 'Nothing' if no settings are saved -- The Caller is responsible for checking whether legal hold is enabled for this team -getSettings :: MonadClient m => TeamId -> m (Maybe LegalHoldService) +getSettings :: (MonadClient m) => TeamId -> m (Maybe LegalHoldService) getSettings tid = fmap toLegalHoldService <$> do retry x1 $ query1 Q.selectLegalHoldSettings (params LocalQuorum (Identity tid)) where toLegalHoldService (httpsUrl, fingerprint, tok, key) = LegalHoldService tid httpsUrl fingerprint tok key -removeSettings :: MonadClient m => TeamId -> m () +removeSettings :: (MonadClient m) => TeamId -> m () removeSettings tid = retry x5 (write Q.removeLegalHoldSettings (params LocalQuorum (Identity tid))) -insertPendingPrekeys :: MonadClient m => UserId -> [Prekey] -> m () +insertPendingPrekeys :: (MonadClient m) => UserId -> [Prekey] -> m () insertPendingPrekeys uid keys = retry x5 . batch $ forM_ keys $ \key -> @@ -133,7 +133,7 @@ insertPendingPrekeys uid keys = retry x5 . batch $ where toTuple (Prekey keyId key) = (uid, keyId, key) -selectPendingPrekeys :: MonadClient m => UserId -> m (Maybe ([Prekey], LastPrekey)) +selectPendingPrekeys :: (MonadClient m) => UserId -> m (Maybe ([Prekey], LastPrekey)) selectPendingPrekeys uid = pickLastKey . fmap fromTuple <$> retry x1 (query Q.selectPendingPrekeys (params LocalQuorum (Identity uid))) @@ -144,18 +144,18 @@ selectPendingPrekeys uid = Nothing -> Nothing Just (keys, lst) -> pure (keys, lastPrekey . prekeyKey $ lst) -dropPendingPrekeys :: MonadClient m => UserId -> m () +dropPendingPrekeys :: (MonadClient m) => UserId -> m () dropPendingPrekeys uid = retry x5 (write Q.dropPendingPrekeys (params LocalQuorum (Identity uid))) -setUserLegalHoldStatus :: MonadClient m => TeamId -> UserId -> UserLegalHoldStatus -> m () +setUserLegalHoldStatus :: (MonadClient m) => TeamId -> UserId -> UserLegalHoldStatus -> m () setUserLegalHoldStatus tid uid status = retry x5 (write Q.updateUserLegalHoldStatus (params LocalQuorum (status, tid, uid))) -setTeamLegalholdWhitelisted :: MonadClient m => TeamId -> m () +setTeamLegalholdWhitelisted :: (MonadClient m) => TeamId -> m () setTeamLegalholdWhitelisted tid = retry x5 (write Q.insertLegalHoldWhitelistedTeam (params LocalQuorum (Identity tid))) -unsetTeamLegalholdWhitelisted :: MonadClient m => TeamId -> m () +unsetTeamLegalholdWhitelisted :: (MonadClient m) => TeamId -> m () unsetTeamLegalholdWhitelisted tid = retry x5 (write Q.removeLegalHoldWhitelistedTeam (params LocalQuorum (Identity tid))) @@ -171,7 +171,7 @@ isTeamLegalholdWhitelisted FeatureLegalHoldWhitelistTeamsAndImplicitConsent tid -- -- FUTUREWORK: It would be nice to move (part of) this to ssl-util, but it has types from -- brig-types and types-common. -validateServiceKey :: MonadIO m => ServiceKeyPEM -> m (Maybe (ServiceKey, Fingerprint Rsa)) +validateServiceKey :: (MonadIO m) => ServiceKeyPEM -> m (Maybe (ServiceKey, Fingerprint Rsa)) validateServiceKey pem = liftIO $ readPublicKey >>= \pk -> diff --git a/services/galley/src/Galley/Cassandra/SearchVisibility.hs b/services/galley/src/Galley/Cassandra/SearchVisibility.hs index 84505b5809a..bf656fd8204 100644 --- a/services/galley/src/Galley/Cassandra/SearchVisibility.hs +++ b/services/galley/src/Galley/Cassandra/SearchVisibility.hs @@ -49,7 +49,7 @@ interpretSearchVisibilityStoreToCassandra = interpret $ \case embedClient $ resetSearchVisibility tid -- | Return whether a given team is allowed to enable/disable sso -getSearchVisibility :: MonadClient m => TeamId -> m TeamSearchVisibility +getSearchVisibility :: (MonadClient m) => TeamId -> m TeamSearchVisibility getSearchVisibility tid = toSearchVisibility <$> do retry x1 $ query1 selectSearchVisibility (params LocalQuorum (Identity tid)) @@ -60,10 +60,10 @@ getSearchVisibility tid = toSearchVisibility _ = SearchVisibilityStandard -- | Determines whether a given team is allowed to enable/disable sso -setSearchVisibility :: MonadClient m => TeamId -> TeamSearchVisibility -> m () +setSearchVisibility :: (MonadClient m) => TeamId -> TeamSearchVisibility -> m () setSearchVisibility tid visibilityType = do retry x5 $ write updateSearchVisibility (params LocalQuorum (visibilityType, tid)) -resetSearchVisibility :: MonadClient m => TeamId -> m () +resetSearchVisibility :: (MonadClient m) => TeamId -> m () resetSearchVisibility tid = do retry x5 $ write updateSearchVisibility (params LocalQuorum (SearchVisibilityStandard, tid)) diff --git a/services/galley/src/Galley/Cassandra/Services.hs b/services/galley/src/Galley/Cassandra/Services.hs index 7e8012e2998..0b3e3fa15a7 100644 --- a/services/galley/src/Galley/Cassandra/Services.hs +++ b/services/galley/src/Galley/Cassandra/Services.hs @@ -67,7 +67,7 @@ interpretServiceStoreToCassandra = interpret $ \case logEffect "ServiceStore.DeleteService" embedClient $ deleteService sr -insertService :: MonadClient m => Bot.Service -> m () +insertService :: (MonadClient m) => Bot.Service -> m () insertService s = do let sid = s ^. Bot.serviceRef . serviceRefId let pid = s ^. Bot.serviceRef . serviceRefProvider @@ -77,7 +77,7 @@ insertService s = do let ena = s ^. Bot.serviceEnabled retry x5 $ write insertSrv (params LocalQuorum (pid, sid, url, tok, fps, ena)) -lookupService :: MonadClient m => ServiceRef -> m (Maybe Bot.Service) +lookupService :: (MonadClient m) => ServiceRef -> m (Maybe Bot.Service) lookupService s = fmap toService <$> retry x1 (query1 selectSrv (params LocalQuorum (s ^. serviceRefProvider, s ^. serviceRefId))) @@ -85,5 +85,5 @@ lookupService s = toService (url, tok, Set fps, ena) = Bot.newService s url tok fps & set Bot.serviceEnabled ena -deleteService :: MonadClient m => ServiceRef -> m () +deleteService :: (MonadClient m) => ServiceRef -> m () deleteService s = retry x5 (write rmSrv (params LocalQuorum (s ^. serviceRefProvider, s ^. serviceRefId))) diff --git a/services/galley/src/Galley/Cassandra/SubConversation.hs b/services/galley/src/Galley/Cassandra/SubConversation.hs index 4d775d02b99..b410e2bcc71 100644 --- a/services/galley/src/Galley/Cassandra/SubConversation.hs +++ b/services/galley/src/Galley/Cassandra/SubConversation.hs @@ -15,14 +15,10 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.Cassandra.SubConversation - ( interpretSubConversationStoreToCassandra, - ) -where +module Galley.Cassandra.SubConversation (interpretSubConversationStoreToCassandra) where import Cassandra import Cassandra.Util -import Control.Error.Util import Control.Monad.Trans.Maybe import Data.Id import Data.Map qualified as Map diff --git a/services/galley/src/Galley/Cassandra/TeamFeatures.hs b/services/galley/src/Galley/Cassandra/TeamFeatures.hs index dc8e82fe6ce..618b242efaf 100644 --- a/services/galley/src/Galley/Cassandra/TeamFeatures.hs +++ b/services/galley/src/Galley/Cassandra/TeamFeatures.hs @@ -85,7 +85,7 @@ interpretTeamFeatureStoreToCassandra = interpret $ \case serverConfigs tid -getFeatureConfig :: MonadClient m => FeatureSingleton cfg -> TeamId -> m (Maybe (WithStatusNoLock cfg)) +getFeatureConfig :: (MonadClient m) => FeatureSingleton cfg -> TeamId -> m (Maybe (WithStatusNoLock cfg)) getFeatureConfig FeatureSingletonLegalholdConfig tid = getTrivialConfigC "legalhold_status" tid getFeatureConfig FeatureSingletonSSOConfig tid = getTrivialConfigC "sso_status" tid getFeatureConfig FeatureSingletonSearchVisibilityAvailableConfig tid = getTrivialConfigC "search_visibility_status" tid @@ -170,24 +170,24 @@ getFeatureConfig FeatureSingletonMlsE2EIdConfig tid = do let q = query1 select (params LocalQuorum (Identity tid)) retry x1 q <&> \case Nothing -> Nothing - Just (Nothing, _, _) -> Nothing - Just (Just fs, mGracePeriod, mUrl) -> + Just (Nothing, _, _, _, _) -> Nothing + Just (Just fs, mGracePeriod, mUrl, mCrlProxy, mUseProxyOnMobile) -> Just $ WithStatusNoLock fs ( -- FUTUREWORK: this block is duplicated in -- "Galley.Cassandra.GetAllTeamFeatureConfigs"; make sure the two don't diverge! - MlsE2EIdConfig (toGracePeriodOrDefault mGracePeriod) mUrl + MlsE2EIdConfig (toGracePeriodOrDefault mGracePeriod) mUrl mCrlProxy (fromMaybe (useProxyOnMobile . wsConfig $ defFeatureStatus @MlsE2EIdConfig) mUseProxyOnMobile) ) FeatureTTLUnlimited where toGracePeriodOrDefault :: Maybe Int32 -> NominalDiffTime toGracePeriodOrDefault = maybe (verificationExpiration $ wsConfig defFeatureStatus) fromIntegral - select :: PrepQuery R (Identity TeamId) (Maybe FeatureStatus, Maybe Int32, Maybe HttpsUrl) + select :: PrepQuery R (Identity TeamId) (Maybe FeatureStatus, Maybe Int32, Maybe HttpsUrl, Maybe HttpsUrl, Maybe Bool) select = fromString $ - "select mls_e2eid_status, mls_e2eid_grace_period, mls_e2eid_acme_discovery_url from team_features where team_id = ?" + "select mls_e2eid_status, mls_e2eid_grace_period, mls_e2eid_acme_discovery_url, mls_e2eid_crl_proxy, mls_e2eid_use_proxy_on_mobile from team_features where team_id = ?" getFeatureConfig FeatureSingletonMlsMigration tid = do let q = query1 select (params LocalQuorum (Identity tid)) retry x1 q <&> \case @@ -222,7 +222,7 @@ getFeatureConfig FeatureSingletonEnforceFileDownloadLocationConfig tid = do getFeatureConfig FeatureSingletonLimitedEventFanoutConfig tid = getTrivialConfigC "limited_event_fanout_status" tid -setFeatureConfig :: MonadClient m => FeatureSingleton cfg -> TeamId -> WithStatusNoLock cfg -> m () +setFeatureConfig :: (MonadClient m) => FeatureSingleton cfg -> TeamId -> WithStatusNoLock cfg -> m () setFeatureConfig FeatureSingletonLegalholdConfig tid statusNoLock = setFeatureStatusC "legalhold_status" tid (wssStatus statusNoLock) setFeatureConfig FeatureSingletonSSOConfig tid statusNoLock = setFeatureStatusC "sso_status" tid (wssStatus statusNoLock) setFeatureConfig FeatureSingletonSearchVisibilityAvailableConfig tid statusNoLock = setFeatureStatusC "search_visibility_status" tid (wssStatus statusNoLock) @@ -292,11 +292,13 @@ setFeatureConfig FeatureSingletonMlsE2EIdConfig tid status = do let statusValue = wssStatus status vex = verificationExpiration . wssConfig $ status mUrl = acmeDiscoveryUrl . wssConfig $ status - retry x5 $ write insert (params LocalQuorum (tid, statusValue, truncate vex, mUrl)) + mCrlProxy = crlProxy . wssConfig $ status + useProxy = useProxyOnMobile . wssConfig $ status + retry x5 $ write insert (params LocalQuorum (tid, statusValue, truncate vex, mUrl, mCrlProxy, useProxy)) where - insert :: PrepQuery W (TeamId, FeatureStatus, Int32, Maybe HttpsUrl) () + insert :: PrepQuery W (TeamId, FeatureStatus, Int32, Maybe HttpsUrl, Maybe HttpsUrl, Bool) () insert = - "insert into team_features (team_id, mls_e2eid_status, mls_e2eid_grace_period, mls_e2eid_acme_discovery_url) values (?, ?, ?, ?)" + "insert into team_features (team_id, mls_e2eid_status, mls_e2eid_grace_period, mls_e2eid_acme_discovery_url, mls_e2eid_crl_proxy, mls_e2eid_use_proxy_on_mobile) values (?, ?, ?, ?, ?, ?)" setFeatureConfig FeatureSingletonMlsMigration tid status = do let statusValue = wssStatus status config = wssConfig status @@ -320,7 +322,7 @@ setFeatureConfig FeatureSingletonEnforceFileDownloadLocationConfig tid status = setFeatureConfig FeatureSingletonLimitedEventFanoutConfig tid statusNoLock = setFeatureStatusC "limited_event_fanout_status" tid (wssStatus statusNoLock) -getFeatureLockStatus :: MonadClient m => FeatureSingleton cfg -> TeamId -> m (Maybe LockStatus) +getFeatureLockStatus :: (MonadClient m) => FeatureSingleton cfg -> TeamId -> m (Maybe LockStatus) getFeatureLockStatus FeatureSingletonFileSharingConfig tid = getLockStatusC "file_sharing_lock_status" tid getFeatureLockStatus FeatureSingletonSelfDeletingMessagesConfig tid = getLockStatusC "self_deleting_messages_lock_status" tid getFeatureLockStatus FeatureSingletonGuestLinksConfig tid = getLockStatusC "guest_links_lock_status" tid @@ -332,7 +334,7 @@ getFeatureLockStatus FeatureSingletonMLSConfig tid = getLockStatusC "mls_lock_st getFeatureLockStatus FeatureSingletonEnforceFileDownloadLocationConfig tid = getLockStatusC "enforce_file_download_location_lock_status" tid getFeatureLockStatus _ _ = pure Nothing -setFeatureLockStatus :: MonadClient m => FeatureSingleton cfg -> TeamId -> LockStatus -> m () +setFeatureLockStatus :: (MonadClient m) => FeatureSingleton cfg -> TeamId -> LockStatus -> m () setFeatureLockStatus FeatureSingletonFileSharingConfig tid status = setLockStatusC "file_sharing_lock_status" tid status setFeatureLockStatus FeatureSingletonSelfDeletingMessagesConfig tid status = setLockStatusC "self_deleting_messages_lock_status" tid status setFeatureLockStatus FeatureSingletonGuestLinksConfig tid status = setLockStatusC "guest_links_lock_status" tid status @@ -397,7 +399,7 @@ getLockStatusC lockStatusCol tid = do <> " from team_features where team_id = ?" setLockStatusC :: - MonadClient m => + (MonadClient m) => String -> TeamId -> LockStatus -> diff --git a/services/galley/src/Galley/Cassandra/Util.hs b/services/galley/src/Galley/Cassandra/Util.hs index 2e3169fb523..f0cd114d5f4 100644 --- a/services/galley/src/Galley/Cassandra/Util.hs +++ b/services/galley/src/Galley/Cassandra/Util.hs @@ -23,5 +23,5 @@ import Polysemy import Polysemy.TinyLog import System.Logger.Message -logEffect :: Member TinyLog r => ByteString -> Sem r () +logEffect :: (Member TinyLog r) => ByteString -> Sem r () logEffect = debug . msg . val diff --git a/services/galley/src/Galley/Data/Types.hs b/services/galley/src/Galley/Data/Types.hs index 81feef99324..9cd3fe16257 100644 --- a/services/galley/src/Galley/Data/Types.hs +++ b/services/galley/src/Galley/Data/Types.hs @@ -76,7 +76,7 @@ toCode k s (val, ttl, cnv, mPw) = -- The 'key' is a stable, truncated, base64 encoded sha256 hash of the conversation ID -- The 'value' is a base64 encoded, 120-bit random value (changing on each generation) -generate :: MonadIO m => ConvId -> Scope -> Timeout -> m Code +generate :: (MonadIO m) => ConvId -> Scope -> Timeout -> m Code generate cnv s t = do key <- mkKey cnv val <- liftIO $ Value . unsafeRange . Ascii.encodeBase64Url <$> randBytes 15 @@ -90,7 +90,7 @@ generate cnv s t = do codeHasPassword = False } -mkKey :: MonadIO m => ConvId -> m Key +mkKey :: (MonadIO m) => ConvId -> m Key mkKey cnv = do sha256 <- liftIO $ fromJust <$> getDigestByName "SHA256" pure $ Key . unsafeRange . Ascii.encodeBase64Url . BS.take 15 $ digestBS sha256 (toByteString' cnv) diff --git a/services/galley/src/Galley/Effects/BackendNotificationQueueAccess.hs b/services/galley/src/Galley/Effects/BackendNotificationQueueAccess.hs index 9c2fe5d4004..fee78987c23 100644 --- a/services/galley/src/Galley/Effects/BackendNotificationQueueAccess.hs +++ b/services/galley/src/Galley/Effects/BackendNotificationQueueAccess.hs @@ -11,7 +11,7 @@ import Wire.API.Federation.Error data BackendNotificationQueueAccess m a where EnqueueNotification :: - KnownComponent c => + (KnownComponent c) => Q.DeliveryMode -> Remote x -> FedQueueClient c a -> diff --git a/services/galley/src/Galley/Effects/BrigAccess.hs b/services/galley/src/Galley/Effects/BrigAccess.hs index 642a3ab4c10..c825a3e7129 100644 --- a/services/galley/src/Galley/Effects/BrigAccess.hs +++ b/services/galley/src/Galley/Effects/BrigAccess.hs @@ -130,7 +130,7 @@ data BrigAccess m a where makeSem ''BrigAccess -getUser :: Member BrigAccess r => UserId -> Sem r (Maybe UserAccount) +getUser :: (Member BrigAccess r) => UserId -> Sem r (Maybe UserAccount) getUser = fmap listToMaybe . getUsers . pure addLegalHoldClientToUser :: diff --git a/services/galley/src/Galley/Effects/ConversationStore.hs b/services/galley/src/Galley/Effects/ConversationStore.hs index 234dfa64bda..d85d2258e85 100644 --- a/services/galley/src/Galley/Effects/ConversationStore.hs +++ b/services/galley/src/Galley/Effects/ConversationStore.hs @@ -106,5 +106,5 @@ data ConversationStore m a where makeSem ''ConversationStore -acceptConnectConversation :: Member ConversationStore r => ConvId -> Sem r () +acceptConnectConversation :: (Member ConversationStore r) => ConvId -> Sem r () acceptConnectConversation cid = setConversationType cid One2OneConv diff --git a/services/galley/src/Galley/Effects/ExternalAccess.hs b/services/galley/src/Galley/Effects/ExternalAccess.hs index 7f6f3c4f0f7..e2d0bb75404 100644 --- a/services/galley/src/Galley/Effects/ExternalAccess.hs +++ b/services/galley/src/Galley/Effects/ExternalAccess.hs @@ -26,7 +26,6 @@ module Galley.Effects.ExternalAccess ) where -import Data.Aeson import Data.Id import Galley.Data.Services import Imports @@ -34,8 +33,8 @@ import Polysemy import Wire.API.Event.Conversation data ExternalAccess m a where - Deliver :: Foldable f => f (BotMember, Event) -> ExternalAccess m [BotMember] - DeliverAsync :: (ToJSON e, Foldable f) => f (BotMember, e) -> ExternalAccess m () - DeliverAndDeleteAsync :: Foldable f => ConvId -> f (BotMember, Event) -> ExternalAccess m () + Deliver :: (Foldable f) => f (BotMember, Event) -> ExternalAccess m [BotMember] + DeliverAsync :: (Foldable f) => f (BotMember, Event) -> ExternalAccess m () + DeliverAndDeleteAsync :: (Foldable f) => ConvId -> f (BotMember, Event) -> ExternalAccess m () makeSem ''ExternalAccess diff --git a/services/galley/src/Galley/Effects/FederatorAccess.hs b/services/galley/src/Galley/Effects/FederatorAccess.hs index cfa3b508c76..eaa5e70ba01 100644 --- a/services/galley/src/Galley/Effects/FederatorAccess.hs +++ b/services/galley/src/Galley/Effects/FederatorAccess.hs @@ -39,12 +39,12 @@ import Wire.API.Federation.Error data FederatorAccess m a where RunFederated :: - KnownComponent c => + (KnownComponent c) => Remote x -> FederatorClient c a -> FederatorAccess m a RunFederatedEither :: - KnownComponent c => + (KnownComponent c) => Remote x -> FederatorClient c a -> FederatorAccess m (Either FederationError a) diff --git a/services/galley/src/Galley/Effects/FireAndForget.hs b/services/galley/src/Galley/Effects/FireAndForget.hs index 0a99f3c5551..b78264acaf3 100644 --- a/services/galley/src/Galley/Effects/FireAndForget.hs +++ b/services/galley/src/Galley/Effects/FireAndForget.hs @@ -36,14 +36,14 @@ data FireAndForget m a where makeSem ''FireAndForget -fireAndForget :: Member FireAndForget r => Sem r () -> Sem r () +fireAndForget :: (Member FireAndForget r) => Sem r () -> Sem r () fireAndForget = fireAndForgetOne -- | Run actions in separate threads and ignore results. -- -- /Note/: this will also ignore any state and error effects contained in the -- 'FireAndForget' action. Use with care. -interpretFireAndForget :: Member (Final IO) r => Sem (FireAndForget ': r) a -> Sem r a +interpretFireAndForget :: (Member (Final IO) r) => Sem (FireAndForget ': r) a -> Sem r a interpretFireAndForget = interpretFinal @IO $ \case FireAndForgetOne action -> do action' <- runS action diff --git a/services/galley/src/Galley/Effects/MemberStore.hs b/services/galley/src/Galley/Effects/MemberStore.hs index 0513cc6570e..e1e0d4c372f 100644 --- a/services/galley/src/Galley/Effects/MemberStore.hs +++ b/services/galley/src/Galley/Effects/MemberStore.hs @@ -86,7 +86,7 @@ data MemberStore m a where DeleteMembers :: ConvId -> UserList UserId -> MemberStore m () DeleteMembersInRemoteConversation :: Remote ConvId -> [UserId] -> MemberStore m () AddMLSClients :: GroupId -> Qualified UserId -> Set (ClientId, LeafIndex) -> MemberStore m () - PlanClientRemoval :: Foldable f => GroupId -> f ClientIdentity -> MemberStore m () + PlanClientRemoval :: (Foldable f) => GroupId -> f ClientIdentity -> MemberStore m () RemoveMLSClients :: GroupId -> Qualified UserId -> Set ClientId -> MemberStore m () RemoveAllMLSClients :: GroupId -> MemberStore m () LookupMLSClients :: GroupId -> MemberStore m ClientMap diff --git a/services/galley/src/Galley/Effects/TeamStore.hs b/services/galley/src/Galley/Effects/TeamStore.hs index cf0a2257156..bd403e17f55 100644 --- a/services/galley/src/Galley/Effects/TeamStore.hs +++ b/services/galley/src/Galley/Effects/TeamStore.hs @@ -141,7 +141,7 @@ data TeamStore m a where makeSem ''TeamStore listTeams :: - Member (ListItems p TeamId) r => + (Member (ListItems p TeamId) r) => UserId -> Maybe (PagingState p TeamId) -> PagingBounds p TeamId -> diff --git a/services/galley/src/Galley/Env.hs b/services/galley/src/Galley/Env.hs index 87a0ddbd70f..9d88c703b86 100644 --- a/services/galley/src/Galley/Env.hs +++ b/services/galley/src/Galley/Env.hs @@ -24,7 +24,6 @@ import Cassandra import Control.Lens hiding ((.=)) import Data.ByteString.Conversion (toByteString') import Data.Id -import Data.Metrics.Middleware import Data.Misc (Fingerprint, HttpsUrl, Rsa) import Data.Range import Data.Time.Clock.DiffTime (millisecondsToDiffTime) @@ -52,7 +51,6 @@ data DeleteItem = TeamItem TeamId UserId (Maybe ConnId) -- | Main application environment. data Env = Env { _reqId :: RequestId, - _monitor :: Metrics, _options :: Opts, _applog :: Logger, _manager :: Manager, diff --git a/services/galley/src/Galley/External.hs b/services/galley/src/Galley/External.hs index c7ea60ed63d..a3ada1d3c51 100644 --- a/services/galley/src/Galley/External.hs +++ b/services/galley/src/Galley/External.hs @@ -21,7 +21,6 @@ import Bilge.Request import Bilge.Retry (httpHandlers) import Control.Lens import Control.Retry -import Data.Aeson (ToJSON) import Data.ByteString.Conversion.To import Data.Id import Data.Misc @@ -70,7 +69,7 @@ interpretExternalAccess = interpret $ \case -- | Like deliver, but ignore orphaned bots and return immediately. -- -- FUTUREWORK: Check if this can be removed. -deliverAsync :: ToJSON e => [(BotMember, e)] -> App () +deliverAsync :: [(BotMember, Event)] -> App () deliverAsync = void . forkIO . void . deliver -- | Like deliver, but remove orphaned bots and return immediately. @@ -79,10 +78,10 @@ deliverAndDeleteAsync cnv pushes = void . forkIO $ do gone <- deliver pushes mapM_ (deleteBot cnv . botMemId) gone -deliver :: forall e. ToJSON e => [(BotMember, e)] -> App [BotMember] +deliver :: [(BotMember, Event)] -> App [BotMember] deliver pp = mapM (async . exec) pp >>= foldM eval [] . zip (map fst pp) where - exec :: (BotMember, e) -> App Bool + exec :: (BotMember, Event) -> App Bool exec (b, e) = lookupService (botMemService b) >>= \case Nothing -> pure False @@ -128,7 +127,7 @@ deliver pp = mapM (async . exec) pp >>= foldM eval [] . zip (map fst pp) -- Internal ------------------------------------------------------------------- -deliver1 :: ToJSON e => Service -> BotMember -> e -> App () +deliver1 :: Service -> BotMember -> Event -> App () deliver1 s bm e | s ^. serviceEnabled = do let t = toByteString' (s ^. serviceToken) diff --git a/services/galley/src/Galley/External/LegalHoldService/Internal.hs b/services/galley/src/Galley/External/LegalHoldService/Internal.hs index 6923ebf02da..6cf5cabe5bf 100644 --- a/services/galley/src/Galley/External/LegalHoldService/Internal.hs +++ b/services/galley/src/Galley/External/LegalHoldService/Internal.hs @@ -67,7 +67,7 @@ makeVerifiedRequestWithManager mgr verifyFingerprints fpr (HttpsUrl url) reqBuil a b = fromMaybe a (BS.stripSuffix "/" a) <> "/" <> fromMaybe b (BS.stripPrefix "/" b) x3 :: RetryPolicy x3 = limitRetries 3 <> exponentialBackoff 100000 - extHandleAll :: MonadCatch m => (SomeException -> m a) -> m a -> m a + extHandleAll :: (MonadCatch m) => (SomeException -> m a) -> m a -> m a extHandleAll f ma = catches ma diff --git a/services/galley/src/Galley/Intra/Federator.hs b/services/galley/src/Galley/Intra/Federator.hs index 565cd417d3e..6c35754d292 100644 --- a/services/galley/src/Galley/Intra/Federator.hs +++ b/services/galley/src/Galley/Intra/Federator.hs @@ -18,7 +18,6 @@ module Galley.Intra.Federator (interpretFederatorAccess) where import Control.Lens -import Control.Monad.Except import Data.Bifunctor import Data.Qualified import Galley.Cassandra.Util @@ -113,7 +112,7 @@ runFederatedConcurrentlyEither xs rpc = bimap (r,) (qualifyAs r) <$> runFederatedEither r (rpc r) runFederatedConcurrentlyBucketsEither :: - Foldable f => + (Foldable f) => f (Remote x) -> (Remote x -> FederatorClient c b) -> App [Either (Remote x, FederationError) (Remote b)] diff --git a/services/galley/src/Galley/Intra/User.hs b/services/galley/src/Galley/Intra/User.hs index 27b3497afae..5419b68ecea 100644 --- a/services/galley/src/Galley/Intra/User.hs +++ b/services/galley/src/Galley/Intra/User.hs @@ -238,7 +238,7 @@ getRichInfoMultiUser = chunkify $ \uids -> do . expect2xx parseResponse (mkError status502 "server-error: could not parse response to `GET brig:/i/users/rich-info`") resp -getAccountConferenceCallingConfigClient :: HasCallStack => UserId -> App (WithStatusNoLock ConferenceCallingConfig) +getAccountConferenceCallingConfigClient :: (HasCallStack) => UserId -> App (WithStatusNoLock ConferenceCallingConfig) getAccountConferenceCallingConfigClient uid = runHereClientM (namedClient @IAPI.API @"get-account-conference-calling-config" uid) >>= handleServantResp @@ -247,9 +247,9 @@ updateSearchVisibilityInbound :: Multi.TeamStatus SearchVisibilityInboundConfig updateSearchVisibilityInbound = handleServantResp <=< runHereClientM - . namedClient @IAPI.API @"updateSearchVisibilityInbound" + . namedClient @IAPI.API @"updateSearchVisibilityInbound" -runHereClientM :: HasCallStack => Client.ClientM a -> App (Either Client.ClientError a) +runHereClientM :: (HasCallStack) => Client.ClientM a -> App (Either Client.ClientError a) runHereClientM action = do mgr <- view manager brigep <- view brig diff --git a/services/galley/src/Galley/Monad.hs b/services/galley/src/Galley/Monad.hs index 1780f3d827c..43af4e1dc20 100644 --- a/services/galley/src/Galley/Monad.hs +++ b/services/galley/src/Galley/Monad.hs @@ -24,11 +24,11 @@ import Bilge.RPC import Cassandra import Control.Lens import Control.Monad.Catch -import Control.Monad.Except import Galley.Env import Imports hiding (log) import Polysemy import Polysemy.Input +import Prometheus import System.Logger import System.Logger.Class qualified as LC @@ -42,7 +42,8 @@ newtype App a = App {unApp :: ReaderT Env IO a} MonadMask, MonadReader Env, MonadThrow, - MonadUnliftIO + MonadUnliftIO, + MonadMonitor ) runApp :: Env -> App a -> IO a diff --git a/services/galley/src/Galley/Queue.hs b/services/galley/src/Galley/Queue.hs index 2ec064374ba..de320bde244 100644 --- a/services/galley/src/Galley/Queue.hs +++ b/services/galley/src/Galley/Queue.hs @@ -38,10 +38,10 @@ data Queue a = Queue _queue :: Stm.TBQueue a } -new :: MonadIO m => Natural -> m (Queue a) +new :: (MonadIO m) => Natural -> m (Queue a) new n = liftIO $ Queue <$> Stm.newTVarIO 0 <*> Stm.newTBQueueIO n -tryPush :: MonadIO m => Queue a -> a -> m Bool +tryPush :: (MonadIO m) => Queue a -> a -> m Bool tryPush q a = liftIO . atomically $ do isFull <- Stm.isFullTBQueue (_queue q) unless isFull $ do @@ -49,16 +49,16 @@ tryPush q a = liftIO . atomically $ do Stm.writeTBQueue (_queue q) a pure (not isFull) -pop :: MonadIO m => Queue a -> m a +pop :: (MonadIO m) => Queue a -> m a pop q = liftIO . atomically $ do Stm.modifyTVar' (_len q) (pred . max 1) Stm.readTBQueue (_queue q) -len :: MonadIO m => Queue a -> m Word +len :: (MonadIO m) => Queue a -> m Word len q = liftIO $ Stm.readTVarIO (_len q) interpretQueue :: - Member (Embed IO) r => + (Member (Embed IO) r) => Queue a -> Sem (E.Queue a ': r) x -> Sem r x diff --git a/services/galley/src/Galley/Run.hs b/services/galley/src/Galley/Run.hs index bda488ad4b6..4ac4bc764ca 100644 --- a/services/galley/src/Galley/Run.hs +++ b/services/galley/src/Galley/Run.hs @@ -24,7 +24,6 @@ where import AWS.Util (readAuthExpiration) import Amazonka qualified as AWS -import Bilge.Request (requestIdName) import Cassandra (runClient, shutdown) import Cassandra.Schema (versionCheck) import Control.Concurrent.Async qualified as Async @@ -33,16 +32,11 @@ import Control.Lens (view, (.~), (^.)) import Control.Monad.Codensity import Data.Aeson qualified as Aeson import Data.ByteString.UTF8 qualified as UTF8 -import Data.Id -import Data.Metrics (Metrics) import Data.Metrics.AWS (gaugeTokenRemaing) -import Data.Metrics.Middleware qualified as M import Data.Metrics.Servant import Data.Misc (portNumber) import Data.Singletons import Data.Text (unpack) -import Data.UUID as UUID -import Data.UUID.V4 as UUID import Galley.API.Federation import Galley.API.Internal import Galley.API.Public.Servant @@ -60,9 +54,10 @@ import Network.Wai import Network.Wai.Middleware.Gunzip qualified as GZip import Network.Wai.Middleware.Gzip qualified as GZip import Network.Wai.Utilities.Error +import Network.Wai.Utilities.Request import Network.Wai.Utilities.Server +import Prometheus qualified as Prom import Servant hiding (route) -import System.Logger (Logger, msg, val, (.=), (~~)) import System.Logger qualified as Log import System.Logger.Extended (mkLogger) import Util.Options @@ -81,10 +76,9 @@ run opts = lowerCodensity $ do (unpack $ opts ^. galley . host) (portNumber $ fromIntegral $ opts ^. galley . port) (env ^. App.applog) - (env ^. monitor) forM_ (env ^. aEnv) $ \aws -> - void $ Codensity $ Async.withAsync $ collectAuthMetrics (env ^. monitor) (aws ^. awsEnv) + void $ Codensity $ Async.withAsync $ collectAuthMetrics (aws ^. awsEnv) void $ Codensity $ Async.withAsync $ runApp env deleteLoop void $ Codensity $ Async.withAsync $ runApp env refreshMetrics @@ -94,15 +88,15 @@ mkApp :: Opts -> Codensity IO (Application, Env) mkApp opts = do logger <- lift $ mkLogger (opts ^. logLevel) (opts ^. logNetStrings) (opts ^. logFormat) - metrics <- lift $ M.metrics - env <- lift $ App.createEnv metrics opts logger + env <- lift $ App.createEnv opts logger lift $ runClient (env ^. cstate) $ versionCheck schemaVersion let middlewares = versionMiddleware (foldMap expandVersionExp (opts ^. settings . disabledAPIVersions)) + . requestIdMiddleware logger defaultRequestIdHeaderName . servantPrometheusMiddleware (Proxy @CombinedAPI) . GZip.gunzip . GZip.gzip GZip.def - . catchErrors logger [Right metrics] + . catchErrors logger defaultRequestIdHeaderName Codensity $ \k -> finally (k ()) $ do Log.info logger $ Log.msg @Text "Galley application finished." Log.flush logger @@ -133,8 +127,8 @@ mkApp opts = servantApp :: Env -> Application servantApp e0 r cont = do - rid <- lookupReqId (e0 ^. applog) r - let e = reqId .~ rid $ e0 + let rid = getRequestId defaultRequestIdHeaderName r + e = reqId .~ rid $ e0 Servant.serveWithContext (Proxy @CombinedAPI) ( view (options . settings . federationDomain) e @@ -149,18 +143,6 @@ mkApp opts = r cont - lookupReqId :: Logger -> Request -> IO RequestId - lookupReqId l r = case lookup requestIdName $ requestHeaders r of - Just rid -> pure $ RequestId rid - Nothing -> do - localRid <- RequestId . UUID.toASCIIBytes <$> UUID.nextRandom - Log.info l $ - "request-id" .= localRid - ~~ "method" .= requestMethod r - ~~ "path" .= rawPathInfo r - ~~ msg (val "generated a new request id for local request") - pure localRid - closeApp :: Env -> IO () closeApp env = do shutdown (env ^. cstate) @@ -194,17 +176,26 @@ type CombinedAPI = refreshMetrics :: App () refreshMetrics = do - m <- view monitor q <- view deleteQueue safeForever "refreshMetrics" $ do n <- Q.len q - M.gaugeSet (fromIntegral n) (M.path "galley.deletequeue.len") m + Prom.setGauge deleteQueueLengthGauge (fromIntegral n) threadDelay 1000000 -collectAuthMetrics :: (MonadIO m) => Metrics -> AWS.Env -> m () -collectAuthMetrics m env = do +{-# NOINLINE deleteQueueLengthGauge #-} +deleteQueueLengthGauge :: Prom.Gauge +deleteQueueLengthGauge = + Prom.unsafeRegister $ + Prom.gauge + Prom.Info + { Prom.metricName = "galley.deletequeue.len", + Prom.metricHelp = "Length of the galley delete queue" + } + +collectAuthMetrics :: (MonadIO m) => AWS.Env -> m () +collectAuthMetrics env = do liftIO $ forever $ do mbRemaining <- readAuthExpiration env - gaugeTokenRemaing m mbRemaining + gaugeTokenRemaing mbRemaining threadDelay 1_000_000 diff --git a/services/galley/src/Galley/Schema/Run.hs b/services/galley/src/Galley/Schema/Run.hs index 51e29417032..5039676a3fa 100644 --- a/services/galley/src/Galley/Schema/Run.hs +++ b/services/galley/src/Galley/Schema/Run.hs @@ -92,6 +92,7 @@ import Galley.Schema.V88_RemoveMemberClientAndTruncateMLSGroupMemberClient quali import Galley.Schema.V89_MlsLockStatus qualified as V89_MlsLockStatus import Galley.Schema.V90_EnforceFileDownloadLocationConfig qualified as V90_EnforceFileDownloadLocationConfig import Galley.Schema.V91_TeamMemberDeletedLimitedEventFanout qualified as V91_TeamMemberDeletedLimitedEventFanout +import Galley.Schema.V92_MlsE2EIdConfig qualified as V92_MlsE2EIdConfig import Imports import Options.Applicative import System.Logger.Extended qualified as Log @@ -184,7 +185,8 @@ migrations = V88_RemoveMemberClientAndTruncateMLSGroupMemberClient.migration, V89_MlsLockStatus.migration, V90_EnforceFileDownloadLocationConfig.migration, - V91_TeamMemberDeletedLimitedEventFanout.migration + V91_TeamMemberDeletedLimitedEventFanout.migration, + V92_MlsE2EIdConfig.migration -- FUTUREWORK: once #1726 has made its way to master/production, -- the 'message' field in connections table can be dropped. -- See also https://github.com/wireapp/wire-server/pull/1747/files diff --git a/libs/brig-types/src/Brig/Types/Common.hs b/services/galley/src/Galley/Schema/V92_MlsE2EIdConfig.hs similarity index 61% rename from libs/brig-types/src/Brig/Types/Common.hs rename to services/galley/src/Galley/Schema/V92_MlsE2EIdConfig.hs index 0def1dde6a4..0c11ebf6cd6 100644 --- a/libs/brig-types/src/Brig/Types/Common.hs +++ b/services/galley/src/Galley/Schema/V92_MlsE2EIdConfig.hs @@ -1,6 +1,6 @@ -- This file is part of the Wire Server implementation. -- --- Copyright (C) 2022 Wire Swiss GmbH +-- Copyright (C) 2023 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 @@ -14,19 +14,18 @@ -- -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . +module Galley.Schema.V92_MlsE2EIdConfig where --- rename to Brig.Types.Account? -module Brig.Types.Common - ( -- * PhoneBudgetTimeout - PhoneBudgetTimeout (..), +import Cassandra.Schema +import Imports +import Text.RawString.QQ - -- * PhonePrefix - PhonePrefix (..), - parsePhonePrefix, - isValidPhonePrefix, - allPrefixes, - ExcludedPrefix (..), - ) -where - -import Wire.API.User +migration :: Migration +migration = + Migration 92 "Add mls_e2eid_crl_proxy and mls_e2eid_use_proxy_on_mobile to team_features" $ + schema' + [r| ALTER TABLE team_features ADD ( + mls_e2eid_crl_proxy blob, + mls_e2eid_use_proxy_on_mobile boolean + ) + |] diff --git a/services/galley/src/Galley/Types/UserList.hs b/services/galley/src/Galley/Types/UserList.hs index 3dbc81444de..071403b5c9d 100644 --- a/services/galley/src/Galley/Types/UserList.hs +++ b/services/galley/src/Galley/Types/UserList.hs @@ -43,7 +43,7 @@ instance Semigroup (UserList a) where instance Monoid (UserList a) where mempty = UserList mempty mempty -toUserList :: Foldable f => Local x -> f (Qualified a) -> UserList a +toUserList :: (Foldable f) => Local x -> f (Qualified a) -> UserList a toUserList loc = uncurry UserList . partitionQualified loc ulAddLocal :: a -> UserList a -> UserList a @@ -59,7 +59,7 @@ ulFromRemotes :: [Remote a] -> UserList a ulFromRemotes = UserList [] -- | Remove from the first list all the users that are in the second list. -ulDiff :: Eq a => UserList a -> UserList a -> UserList a +ulDiff :: (Eq a) => UserList a -> UserList a -> UserList a ulDiff (UserList lA rA) (UserList lB rB) = UserList (filter (`notElem` lB) lA) diff --git a/services/galley/src/Galley/Validation.hs b/services/galley/src/Galley/Validation.hs index 964963e4e65..7d045d21026 100644 --- a/services/galley/src/Galley/Validation.hs +++ b/services/galley/src/Galley/Validation.hs @@ -51,9 +51,9 @@ rangeCheckedMaybe (Just a) = Just <$> rangeChecked a newtype ConvSizeChecked f a = ConvSizeChecked {fromConvSize :: f a} deriving (Functor, Foldable, Traversable) -deriving newtype instance Semigroup (f a) => Semigroup (ConvSizeChecked f a) +deriving newtype instance (Semigroup (f a)) => Semigroup (ConvSizeChecked f a) -deriving newtype instance Monoid (f a) => Monoid (ConvSizeChecked f a) +deriving newtype instance (Monoid (f a)) => Monoid (ConvSizeChecked f a) checkedConvSize :: (Member (Error InvalidInput) r, Foldable f) => @@ -67,5 +67,5 @@ checkedConvSize o x = do then pure (ConvSizeChecked x) else throwErr (errorMsg minV limit "") -throwErr :: Member (Error InvalidInput) r => String -> Sem r a +throwErr :: (Member (Error InvalidInput) r) => String -> Sem r a throwErr = throw . InvalidRange . fromString diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index b20fb577974..2a6c1f3a8bf 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -32,7 +32,6 @@ import API.MessageTimer qualified as MessageTimer import API.Roles qualified as Roles import API.SQS import API.Teams qualified as Teams -import API.Teams.Feature qualified as TeamFeature import API.Teams.LegalHold qualified as Teams.LegalHold import API.Teams.LegalHold.DisabledByDefault qualified import API.Util @@ -120,7 +119,6 @@ tests s = MessageTimer.tests s, Roles.tests s, CustomBackend.tests s, - TeamFeature.tests s, Federation.tests s, API.MLS.tests s ] @@ -1810,7 +1808,7 @@ paginateConvListIdsPageEndingAtLocalsAndDomain = do -- to go, when this is 0, it is assumed that this chunk is last and the response -- must set @has_more@ to 'False' and the number of conv ids returned should -- match @lastSize@. -getChunkedConvs :: HasCallStack => Int32 -> Int -> UserId -> Maybe ConversationPagingState -> Int -> TestM (Maybe ConversationPagingState) +getChunkedConvs :: (HasCallStack) => Int32 -> Int -> UserId -> Maybe ConversationPagingState -> Int -> TestM (Maybe ConversationPagingState) getChunkedConvs size lastSize alice pagingState n = do resp <- getConvPage alice pagingState (Just size) UserId -> t Int -> TestM () + walk :: (Foldable t) => UserId -> t Int -> TestM () walk u = foldM_ (next u 3) Nothing next :: @@ -2008,7 +2006,7 @@ postConvQualifiedFederationNotEnabled = do -- like postConvQualified -- FUTUREWORK: figure out how to use functions in the TestM monad inside withSettingsOverrides and remove this duplication -postConvHelper :: MonadHttp m => (Request -> Request) -> UserId -> [Qualified UserId] -> m ResponseLBS +postConvHelper :: (MonadHttp m) => (Request -> Request) -> UserId -> [Qualified UserId] -> m ResponseLBS postConvHelper g zusr newUsers = do let conv = NewConv [] newUsers (checked "gossip") (Set.fromList []) Nothing Nothing Nothing Nothing roleNameWireAdmin BaseProtocolProteusTag post $ g . path "/conversations" . zUser zusr . zConn "conn" . zType "access" . json conv diff --git a/services/galley/test/integration/API/Federation/Util.hs b/services/galley/test/integration/API/Federation/Util.hs index 9f2f052365c..c4e6a41ea49 100644 --- a/services/galley/test/integration/API/Federation/Util.hs +++ b/services/galley/test/integration/API/Federation/Util.hs @@ -44,22 +44,22 @@ class HasTrivialHandler api where instance HasTrivialHandler (Verb m c cs a) where trivialHandler name = throwError err501 {errBody = cs ("mock not implemented: " <> name)} -instance HasTrivialHandler api => HasTrivialHandler ((path :: Symbol) :> api) where +instance (HasTrivialHandler api) => HasTrivialHandler ((path :: Symbol) :> api) where trivialHandler = trivialHandler @api -instance HasTrivialHandler api => HasTrivialHandler (OriginDomainHeader :> api) where +instance (HasTrivialHandler api) => HasTrivialHandler (OriginDomainHeader :> api) where trivialHandler name _ = trivialHandler @api name -instance HasTrivialHandler api => HasTrivialHandler (MakesFederatedCall comp name :> api) where +instance (HasTrivialHandler api) => HasTrivialHandler (MakesFederatedCall comp name :> api) where trivialHandler name _ = trivialHandler @api name -instance HasTrivialHandler api => HasTrivialHandler (ReqBody cs a :> api) where +instance (HasTrivialHandler api) => HasTrivialHandler (ReqBody cs a :> api) where trivialHandler name _ = trivialHandler @api name -instance HasTrivialHandler api => HasTrivialHandler (Until v :> api) where +instance (HasTrivialHandler api) => HasTrivialHandler (Until v :> api) where trivialHandler = trivialHandler @api -instance HasTrivialHandler api => HasTrivialHandler (From v :> api) where +instance (HasTrivialHandler api) => HasTrivialHandler (From v :> api) where trivialHandler = trivialHandler @api trivialNamedHandler :: diff --git a/services/galley/test/integration/API/MLS/Mocks.hs b/services/galley/test/integration/API/MLS/Mocks.hs index 69cd62f2902..49165e64bc7 100644 --- a/services/galley/test/integration/API/MLS/Mocks.hs +++ b/services/galley/test/integration/API/MLS/Mocks.hs @@ -49,8 +49,8 @@ receiveCommitMock clients = asum [ "on-conversation-updated" ~> EmptyResponse, "get-not-fully-connected-backends" ~> NonConnectedBackends mempty, - "get-mls-clients" ~> - Set.fromList + "get-mls-clients" + ~> Set.fromList ( map (flip ClientInfo True . ciClient) clients ) ] @@ -82,8 +82,8 @@ welcomeMockByDomain reachables = do sendMessageMock :: Mock LByteString sendMessageMock = - "send-mls-message" ~> - MLSMessageResponseUpdates + "send-mls-message" + ~> MLSMessageResponseUpdates [] claimKeyPackagesMock :: KeyPackageBundle -> Mock LByteString diff --git a/services/galley/test/integration/API/MLS/Util.hs b/services/galley/test/integration/API/MLS/Util.hs index 3c38958eb58..978f7ab4d14 100644 --- a/services/galley/test/integration/API/MLS/Util.hs +++ b/services/galley/test/integration/API/MLS/Util.hs @@ -177,7 +177,7 @@ remotePostCommitBundle rsender qcs bundle = do MLSMessageResponseUpdates _ -> pure [] postCommitBundle :: - HasCallStack => + (HasCallStack) => ClientIdentity -> Qualified ConvOrSubConvId -> ByteString -> @@ -270,7 +270,7 @@ data MessagePackage = MessagePackage } deriving (Show) -takeLastPrekeyNG :: HasCallStack => MLSTest LastPrekey +takeLastPrekeyNG :: (HasCallStack) => MLSTest LastPrekey takeLastPrekeyNG = do s <- State.get case mlsUnusedPrekeys s of @@ -290,7 +290,7 @@ randomFileName = do bd <- State.gets mlsBaseDir (bd ) . UUID.toString <$> liftIO UUIDV4.nextRandom -mlscli :: HasCallStack => ClientIdentity -> [String] -> Maybe ByteString -> MLSTest ByteString +mlscli :: (HasCallStack) => ClientIdentity -> [String] -> Maybe ByteString -> MLSTest ByteString mlscli qcid args mbstdin = do bd <- State.gets mlsBaseDir let cdir = bd cid2Str qcid @@ -328,13 +328,13 @@ argSubst :: String -> String -> String -> String argSubst from to_ s = if s == from then to_ else s -createWireClient :: HasCallStack => Qualified UserId -> MLSTest ClientIdentity +createWireClient :: (HasCallStack) => Qualified UserId -> MLSTest ClientIdentity createWireClient qusr = do lpk <- takeLastPrekeyNG clientId <- liftTest $ randomClient (qUnqualified qusr) lpk pure $ mkClientIdentity qusr clientId -initMLSClient :: HasCallStack => ClientIdentity -> MLSTest () +initMLSClient :: (HasCallStack) => ClientIdentity -> MLSTest () initMLSClient cid = do bd <- State.gets mlsBaseDir createDirectory $ bd cid2Str cid @@ -360,13 +360,13 @@ createLocalMLSClient (tUntagged -> qusr) = do -- | Create new mls client and register with backend. If the user is remote, -- this only creates a fake client (see 'createFakeMLSClient'). -createMLSClient :: HasCallStack => Qualified UserId -> MLSTest ClientIdentity +createMLSClient :: (HasCallStack) => Qualified UserId -> MLSTest ClientIdentity createMLSClient qusr = do loc <- liftTest $ qualifyLocal () foldQualified loc createLocalMLSClient (createFakeMLSClient . tUntagged) qusr -- | Like 'createMLSClient', but do not actually register client with backend. -createFakeMLSClient :: HasCallStack => Qualified UserId -> MLSTest ClientIdentity +createFakeMLSClient :: (HasCallStack) => Qualified UserId -> MLSTest ClientIdentity createFakeMLSClient qusr = do c <- liftIO $ generate arbitrary let cid = mkClientIdentity qusr c @@ -374,7 +374,7 @@ createFakeMLSClient qusr = do pure cid -- | create and upload to backend -uploadNewKeyPackage :: HasCallStack => ClientIdentity -> MLSTest (RawMLS KeyPackage) +uploadNewKeyPackage :: (HasCallStack) => ClientIdentity -> MLSTest (RawMLS KeyPackage) uploadNewKeyPackage qcid = do (kp, _) <- generateKeyPackage qcid @@ -389,33 +389,33 @@ uploadNewKeyPackage qcid = do !!! const 201 === statusCode pure kp -generateKeyPackage :: HasCallStack => ClientIdentity -> MLSTest (RawMLS KeyPackage, KeyPackageRef) +generateKeyPackage :: (HasCallStack) => ClientIdentity -> MLSTest (RawMLS KeyPackage, KeyPackageRef) generateKeyPackage qcid = do kpData <- mlscli qcid ["key-package", "create"] Nothing kp <- liftIO $ decodeMLSError kpData let ref = fromJust (kpRef' kp) pure (kp, ref) -setClientGroupState :: HasCallStack => ClientIdentity -> ByteString -> MLSTest () +setClientGroupState :: (HasCallStack) => ClientIdentity -> ByteString -> MLSTest () setClientGroupState cid g = State.modify $ \s -> s {mlsClientGroupState = Map.insert cid g (mlsClientGroupState s)} -getClientGroupState :: HasCallStack => ClientIdentity -> MLSTest ByteString +getClientGroupState :: (HasCallStack) => ClientIdentity -> MLSTest ByteString getClientGroupState cid = do mgs <- State.gets (Map.lookup cid . mlsClientGroupState) case mgs of Nothing -> liftIO $ assertFailure ("Attempted to get non-existing group state for client " <> show cid) Just g -> pure g -hasClientGroupState :: HasCallStack => ClientIdentity -> MLSTest Bool +hasClientGroupState :: (HasCallStack) => ClientIdentity -> MLSTest Bool hasClientGroupState cid = State.gets (isJust . Map.lookup cid . mlsClientGroupState) -- | Create a conversation from a provided action and then create a -- corresponding group. setupMLSGroupWithConv :: - HasCallStack => + (HasCallStack) => MLSTest Conversation -> ClientIdentity -> MLSTest (GroupId, Qualified ConvId) @@ -435,7 +435,7 @@ setupMLSGroupWithConv convAction creator = do pure (groupId, qcnv) -- | Create conversation and corresponding group. -setupMLSGroup :: HasCallStack => ClientIdentity -> MLSTest (GroupId, Qualified ConvId) +setupMLSGroup :: (HasCallStack) => ClientIdentity -> MLSTest (GroupId, Qualified ConvId) setupMLSGroup creator = setupMLSGroupWithConv action creator where action = @@ -449,7 +449,7 @@ setupMLSGroup creator = setupMLSGroupWithConv action creator ClientIdentity -> MLSTest (GroupId, Qualified ConvId) +setupMLSSelfGroup :: (HasCallStack) => ClientIdentity -> MLSTest (GroupId, Qualified ConvId) setupMLSSelfGroup creator = setupMLSGroupWithConv action creator where action = @@ -498,7 +498,7 @@ getConvId = >>= maybe (liftIO (assertFailure "Uninitialised test conversation")) pure createSubConv :: - HasCallStack => + (HasCallStack) => Qualified ConvId -> ClientIdentity -> SubConvId -> @@ -517,7 +517,7 @@ createSubConv qcnv creator subId = do -- | Create a local group only without a conversation. This simulates creating -- an MLS conversation on a remote backend. setupFakeMLSGroup :: - HasCallStack => + (HasCallStack) => ClientIdentity -> Maybe SubConvId -> MLSTest (GroupId, Qualified ConvId) @@ -527,7 +527,7 @@ setupFakeMLSGroup creator mSubId = do createGroup creator (fmap Conv qcnv) groupId pure (groupId, qcnv) -claimLocalKeyPackages :: HasCallStack => ClientIdentity -> Local UserId -> MLSTest KeyPackageBundle +claimLocalKeyPackages :: (HasCallStack) => ClientIdentity -> Local UserId -> MLSTest KeyPackageBundle claimLocalKeyPackages qcid lusr = do brigCall <- viewBrig responseJsonError @@ -539,7 +539,7 @@ claimLocalKeyPackages qcid lusr = do Qualified UserId -> MLSTest [ClientIdentity] +getUserClients :: (HasCallStack) => Qualified UserId -> MLSTest [ClientIdentity] getUserClients qusr = do bd <- State.gets mlsBaseDir files <- getDirectoryContents bd @@ -550,7 +550,7 @@ getUserClients qusr = do pure . mapMaybe toClient $ files -- | Generate one key package for each client of a remote user -claimRemoteKeyPackages :: HasCallStack => Remote UserId -> MLSTest KeyPackageBundle +claimRemoteKeyPackages :: (HasCallStack) => Remote UserId -> MLSTest KeyPackageBundle claimRemoteKeyPackages (tUntagged -> qusr) = do clients <- getUserClients qusr fmap (KeyPackageBundle . Set.fromList) $ @@ -566,7 +566,7 @@ claimRemoteKeyPackages (tUntagged -> qusr) = do -- | Claim key package for a local user, or generate and map key packages for remote ones. claimKeyPackages :: - HasCallStack => + (HasCallStack) => ClientIdentity -> Qualified UserId -> MLSTest KeyPackageBundle @@ -586,14 +586,14 @@ bundleKeyPackages bundle = -- Note that this alters the state of the group immediately. If we want to test -- a scenario where the commit is rejected by the backend, we can restore the -- group to the previous state by using an older version of the group file. -createAddCommit :: HasCallStack => ClientIdentity -> [Qualified UserId] -> MLSTest MessagePackage +createAddCommit :: (HasCallStack) => ClientIdentity -> [Qualified UserId] -> MLSTest MessagePackage createAddCommit cid users = do kps <- fmap (concatMap bundleKeyPackages) . traverse (claimKeyPackages cid) $ users liftIO $ assertBool "no key packages could be claimed" (not (null kps)) createAddCommitWithKeyPackages cid kps createExternalCommit :: - HasCallStack => + (HasCallStack) => ClientIdentity -> Maybe ByteString -> Qualified ConvOrSubConvId -> @@ -633,14 +633,14 @@ createExternalCommit qcid mpgs qcs = do mpGroupInfo = Just newPgs } -createAddProposals :: HasCallStack => ClientIdentity -> [Qualified UserId] -> MLSTest [MessagePackage] +createAddProposals :: (HasCallStack) => ClientIdentity -> [Qualified UserId] -> MLSTest [MessagePackage] createAddProposals cid users = do kps <- fmap (concatMap bundleKeyPackages) . traverse (claimKeyPackages cid) $ users traverse (createAddProposalWithKeyPackage cid) kps -- | Create an application message. createApplicationMessage :: - HasCallStack => + (HasCallStack) => ClientIdentity -> String -> MLSTest MessagePackage @@ -660,7 +660,7 @@ createApplicationMessage cid messageContent = do } createAddCommitWithKeyPackages :: - HasCallStack => + (HasCallStack) => ClientIdentity -> [(ClientIdentity, ByteString)] -> MLSTest MessagePackage @@ -720,7 +720,7 @@ createAddProposalWithKeyPackage cid (_, kp) = do mpGroupInfo = Nothing } -createPendingProposalCommit :: HasCallStack => ClientIdentity -> MLSTest MessagePackage +createPendingProposalCommit :: (HasCallStack) => ClientIdentity -> MLSTest MessagePackage createPendingProposalCommit qcid = do bd <- State.gets mlsBaseDir welcomeFile <- liftIO $ emptyTempFile bd "welcome" @@ -757,7 +757,7 @@ readWelcome fp = runMaybeT $ do guard $ fileSize stat > 0 liftIO $ BS.readFile fp -createRemoveCommit :: HasCallStack => ClientIdentity -> [ClientIdentity] -> MLSTest MessagePackage +createRemoveCommit :: (HasCallStack) => ClientIdentity -> [ClientIdentity] -> MLSTest MessagePackage createRemoveCommit cid targets = do bd <- State.gets mlsBaseDir welcomeFile <- liftIO $ emptyTempFile bd "welcome" @@ -794,7 +794,7 @@ createRemoveCommit cid targets = do mpGroupInfo = Just pgs } -createExternalAddProposal :: HasCallStack => ClientIdentity -> MLSTest MessagePackage +createExternalAddProposal :: (HasCallStack) => ClientIdentity -> MLSTest MessagePackage createExternalAddProposal joiner = do groupId <- State.gets mlsGroupId >>= \case @@ -825,7 +825,7 @@ createExternalAddProposal joiner = do mpGroupInfo = Nothing } -consumeWelcome :: HasCallStack => ByteString -> MLSTest () +consumeWelcome :: (HasCallStack) => ByteString -> MLSTest () consumeWelcome welcome = do qcids <- State.gets mlsNewMembers for_ qcids $ \qcid -> do @@ -843,13 +843,13 @@ consumeWelcome welcome = do (Just welcome) -- | Make all member clients consume a given message. -consumeMessage :: HasCallStack => MessagePackage -> MLSTest () +consumeMessage :: (HasCallStack) => MessagePackage -> MLSTest () consumeMessage msg = do mems <- State.gets mlsMembers for_ (Set.delete (mpSender msg) mems) $ \cid -> consumeMessage1 cid (mpMessage msg) -consumeMessage1 :: HasCallStack => ClientIdentity -> ByteString -> MLSTest () +consumeMessage1 :: (HasCallStack) => ClientIdentity -> ByteString -> MLSTest () consumeMessage1 cid msg = void $ mlscli @@ -865,7 +865,7 @@ consumeMessage1 cid msg = -- | Send an MLS message and simulate clients receiving it. If the message is a -- commit, the 'sendAndConsumeCommitBundle' function should be used instead. -sendAndConsumeMessage :: HasCallStack => MessagePackage -> MLSTest [Event] +sendAndConsumeMessage :: (HasCallStack) => MessagePackage -> MLSTest [Event] sendAndConsumeMessage mp = do for_ mp.mpWelcome $ \_ -> liftIO $ assertFailure "use sendAndConsumeCommitBundle" res <- @@ -895,7 +895,7 @@ createBundle mp = do mkBundle mp pure (encodeMLS' bundle) -sendAndConsumeCommitBundle :: HasCallStack => MessagePackage -> MLSTest [Event] +sendAndConsumeCommitBundle :: (HasCallStack) => MessagePackage -> MLSTest [Event] sendAndConsumeCommitBundle mp = do qcs <- getConvId bundle <- createBundle mp @@ -914,7 +914,7 @@ sendAndConsumeCommitBundle mp = do pure resp mlsBracket :: - HasCallStack => + (HasCallStack) => [ClientIdentity] -> ([WS.WebSocket] -> MLSTest a) -> MLSTest a @@ -985,7 +985,7 @@ receiveOnConvUpdated conv origUser joiner = do (qDomain conv) cu -getGroupInfo :: HasCallStack => Qualified UserId -> Qualified ConvOrSubConvId -> TestM ByteString +getGroupInfo :: (HasCallStack) => Qualified UserId -> Qualified ConvOrSubConvId -> TestM ByteString getGroupInfo qusr qcs = do loc <- qualifyLocal () foldQualified @@ -1068,7 +1068,7 @@ getSelfConv u = do . zConn "conn" . zType "access" -withMLSDisabled :: HasSettingsOverrides m => m a -> m a +withMLSDisabled :: (HasSettingsOverrides m) => m a -> m a withMLSDisabled = withSettingsOverrides noMLS where noMLS = Opts.settings . Opts.mlsPrivateKeyPaths .~ Nothing @@ -1162,7 +1162,7 @@ remoteLeaveCurrentConv rcid qcnv subId = do LeaveSubConversationResponseOk -> pure () leaveCurrentConv :: - HasCallStack => + (HasCallStack) => ClientIdentity -> Qualified ConvOrSubConvId -> MLSTest () diff --git a/services/galley/test/integration/API/Roles.hs b/services/galley/test/integration/API/Roles.hs index 1fdf61a1e4b..898f42dc8a7 100644 --- a/services/galley/test/integration/API/Roles.hs +++ b/services/galley/test/integration/API/Roles.hs @@ -316,10 +316,10 @@ testAccessRoleUpdateV2 = do -------------------------------------------------------------------------------- -- Utilities -assertActionSucceeded :: HasCallStack => Assertions () +assertActionSucceeded :: (HasCallStack) => Assertions () assertActionSucceeded = const 200 === statusCode -assertActionDenied :: HasCallStack => Assertions () +assertActionDenied :: (HasCallStack) => Assertions () assertActionDenied = do const 403 === statusCode const (Just "action-denied") === fmap label . responseJsonUnsafe diff --git a/services/galley/test/integration/API/SQS.hs b/services/galley/test/integration/API/SQS.hs index 16c7307c012..2057433b150 100644 --- a/services/galley/test/integration/API/SQS.hs +++ b/services/galley/test/integration/API/SQS.hs @@ -42,13 +42,13 @@ import Test.Tasty.HUnit import TestSetup import Util.Test.SQS qualified as SQS -withTeamEventWatcher :: HasCallStack => (SQS.SQSWatcher TeamEvent -> TestM ()) -> TestM () +withTeamEventWatcher :: (HasCallStack) => (SQS.SQSWatcher TeamEvent -> TestM ()) -> TestM () withTeamEventWatcher action = do view tsTeamEventWatcher >>= \case Nothing -> pure () Just w -> action w -assertIfWatcher :: HasCallStack => String -> (TeamEvent -> Bool) -> (String -> Maybe TeamEvent -> TestM ()) -> TestM () +assertIfWatcher :: (HasCallStack) => String -> (TeamEvent -> Bool) -> (String -> Maybe TeamEvent -> TestM ()) -> TestM () assertIfWatcher l matcher assertion = view tsTeamEventWatcher >>= \case Nothing -> pure () @@ -63,7 +63,7 @@ tActivateWithCurrency c l (Just e) = liftIO $ do assertEqual "currency" cur (e ^. eventData . maybe'currency) tActivateWithCurrency _ l Nothing = liftIO $ assertFailure $ l <> ": Expected 1 TeamActivate, got nothing" -assertTeamActivateWithCurrency :: HasCallStack => String -> TeamId -> Maybe Currency.Alpha -> TestM () +assertTeamActivateWithCurrency :: (HasCallStack) => String -> TeamId -> Maybe Currency.Alpha -> TestM () assertTeamActivateWithCurrency l tid c = assertIfWatcher l (teamActivateMatcher tid) (tActivateWithCurrency c) @@ -73,7 +73,7 @@ tActivate l (Just e) = liftIO $ do assertEqual "count" 1 (e ^. eventData . memberCount) tActivate l Nothing = liftIO $ assertFailure $ l <> ": Expected 1 TeamActivate, got nothing" -assertTeamActivate :: HasCallStack => String -> TeamId -> TestM () +assertTeamActivate :: (HasCallStack) => String -> TeamId -> TestM () assertTeamActivate l tid = assertIfWatcher l (teamActivateMatcher tid) tActivate @@ -84,7 +84,7 @@ tDelete :: (HasCallStack, MonadIO m) => String -> Maybe E.TeamEvent -> m () tDelete l (Just e) = liftIO $ assertEqual (l <> ": eventType") E.TeamEvent'TEAM_DELETE (e ^. eventType) tDelete l Nothing = liftIO $ assertFailure $ l <> ": Expected 1 TeamDelete, got nothing" -assertTeamDelete :: HasCallStack => Int -> String -> TeamId -> TestM () +assertTeamDelete :: (HasCallStack) => Int -> String -> TeamId -> TestM () assertTeamDelete maxWaitSeconds l tid = withTeamEventWatcher $ \w -> do mEvent <- SQS.waitForMessage w maxWaitSeconds (\e -> e ^. eventType == E.TeamEvent'TEAM_DELETE && decodeIdFromBS (e ^. teamId) == tid) @@ -94,7 +94,7 @@ tSuspend :: (HasCallStack, MonadIO m) => String -> Maybe E.TeamEvent -> m () tSuspend l (Just e) = liftIO $ assertEqual (l <> "eventType") E.TeamEvent'TEAM_SUSPEND (e ^. eventType) tSuspend l Nothing = liftIO $ assertFailure $ l <> ": Expected 1 TeamSuspend, got nothing" -assertTeamSuspend :: HasCallStack => String -> TeamId -> TestM () +assertTeamSuspend :: (HasCallStack) => String -> TeamId -> TestM () assertTeamSuspend l tid = assertIfWatcher l (\e -> e ^. eventType == E.TeamEvent'TEAM_SUSPEND && decodeIdFromBS (e ^. teamId) == tid) tSuspend @@ -114,7 +114,7 @@ tUpdate _ _ l Nothing = liftIO $ assertFailure $ l <> ": Expected 1 TeamUpdate, updateMatcher :: TeamId -> TeamEvent -> Bool updateMatcher tid e = e ^. eventType == E.TeamEvent'TEAM_UPDATE && decodeIdFromBS (e ^. teamId) == tid -assertTeamUpdate :: HasCallStack => String -> TeamId -> Int32 -> [UserId] -> TestM () +assertTeamUpdate :: (HasCallStack) => String -> TeamId -> Int32 -> [UserId] -> TestM () assertTeamUpdate l tid c uids = assertIfWatcher l (\e -> e ^. eventType == E.TeamEvent'TEAM_UPDATE && decodeIdFromBS (e ^. teamId) == tid) $ tUpdate c uids diff --git a/services/galley/test/integration/API/Teams.hs b/services/galley/test/integration/API/Teams.hs index 060116473e0..cad9536576d 100644 --- a/services/galley/test/integration/API/Teams.hs +++ b/services/galley/test/integration/API/Teams.hs @@ -236,7 +236,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 :: (HasCallStack) => Int -> TestM () testListTeamMembersCsv numMembers = do let teamSize = numMembers + 1 @@ -257,7 +257,7 @@ testListTeamMembersCsv numMembers = do users <- Util.getUsersByHandle (catMaybes someHandles) mbrs <- view teamMembers <$> Util.bulkGetTeamMembers owner tid (U.userId <$> users) - let check :: Eq a => String -> (TeamExportUser -> Maybe a) -> UserId -> Maybe a -> IO () + let check :: (Eq a) => String -> (TeamExportUser -> Maybe a) -> UserId -> Maybe a -> IO () check msg getTeamExportUserAttr uid userAttr = do assertBool msg (isJust userAttr) assertEqual (msg <> ": " <> show uid) 1 (countOn getTeamExportUserAttr userAttr usersInCsv) @@ -280,16 +280,16 @@ testListTeamMembersCsv numMembers = do assertEqual ("tExportUserId: " <> show (U.userId user)) (U.userId user) (tExportUserId export) assertEqual "tExportNumDevices: " (Map.findWithDefault (-1) (U.userId user) numClientMappings) (tExportNumDevices export) where - userToIdPIssuer :: HasCallStack => U.User -> Maybe HttpsUrl + userToIdPIssuer :: (HasCallStack) => U.User -> Maybe HttpsUrl userToIdPIssuer usr = case (U.userIdentity >=> U.ssoIdentity) usr of Just (U.UserSSOId (SAML.UserRef (SAML.Issuer issuer) _)) -> either (const $ error "shouldn't happen") Just $ mkHttpsUrl issuer Just _ -> Nothing Nothing -> Nothing - decodeCSV :: FromNamedRecord a => LByteString -> Either String [a] + decodeCSV :: (FromNamedRecord a) => LByteString -> Either String [a] decodeCSV bstr = decodeByName bstr <&> (snd >>> V.toList) - countOn :: Eq b => (a -> b) -> b -> [a] -> Int + countOn :: (Eq b) => (a -> b) -> b -> [a] -> Int countOn prop val xs = sum $ fmap (bool 0 1 . (== val) . prop) xs addClients :: Map.Map UserId Int -> TestM () @@ -357,7 +357,7 @@ testListTeamMembersDefaultLimitByIds = do check owner tid [phantom] [] check owner tid [owner, alien, phantom] [owner] where - check :: HasCallStack => UserId -> TeamId -> [UserId] -> [UserId] -> TestM () + check :: (HasCallStack) => UserId -> TeamId -> [UserId] -> [UserId] -> TestM () check owner tid uidsIn uidsOut = do listFromServer <- Util.bulkGetTeamMembers owner tid uidsIn liftIO $ @@ -396,12 +396,12 @@ testEnableSSOPerTeam = do owner <- Util.randomUser tid <- Util.createBindingTeamInternal "foo" owner assertTeamActivate "create team" tid - let check :: HasCallStack => String -> Public.FeatureStatus -> TestM () + let check :: (HasCallStack) => String -> Public.FeatureStatus -> TestM () check msg enabledness = do status :: Public.WithStatusNoLock Public.SSOConfig <- responseJsonUnsafe <$> (getSSOEnabledInternal tid TestM () + let putSSOEnabledInternalCheckNotImplemented :: (HasCallStack) => TestM () putSSOEnabledInternalCheckNotImplemented = do g <- viewGalley waierr <- @@ -489,7 +489,7 @@ testCreateOne2OneFailForNonTeamMembers = do const "non-binding-team-members" === (Error.label . responseJsonUnsafeWithMsg "error label") testCreateOne2OneWithMembers :: - HasCallStack => + (HasCallStack) => -- | Role of the user who creates the conversation Role -> TestM () @@ -709,7 +709,7 @@ testRemoveBindingTeamOwner = do Util.waitForMemberDeletion ownerB tid ownerWithoutEmail assertTeamUpdate "Remove ownerWithoutEmail" tid 2 [ownerB] where - check :: HasCallStack => TeamId -> UserId -> UserId -> Maybe PlainTextPassword6 -> Maybe LText -> TestM () + check :: (HasCallStack) => TeamId -> UserId -> UserId -> Maybe PlainTextPassword6 -> Maybe LText -> TestM () check tid deleter deletee pass maybeError = do g <- viewGalley delete @@ -1728,21 +1728,21 @@ newTeamMember' perms uid = Member.mkTeamMember uid perms Nothing LH.defUserLegal -- 'putTeamFeatureInternal'. Since these functions all work in slightly different monads -- and with different kinds of internal checks, it's quite tedious to do so. -getSSOEnabledInternal :: HasCallStack => TeamId -> TestM ResponseLBS +getSSOEnabledInternal :: (HasCallStack) => TeamId -> TestM ResponseLBS getSSOEnabledInternal = Util.getTeamFeatureInternal @Public.SSOConfig -putSSOEnabledInternal :: HasCallStack => TeamId -> Public.FeatureStatus -> TestM () +putSSOEnabledInternal :: (HasCallStack) => TeamId -> Public.FeatureStatus -> TestM () putSSOEnabledInternal tid statusValue = void $ Util.putTeamFeatureInternal @Public.SSOConfig expect2xx tid (Public.WithStatusNoLock statusValue Public.SSOConfig Public.FeatureTTLUnlimited) -getSearchVisibility :: HasCallStack => (Request -> Request) -> UserId -> TeamId -> MonadHttp m => m ResponseLBS +getSearchVisibility :: (HasCallStack) => (Request -> Request) -> UserId -> TeamId -> (MonadHttp m) => m ResponseLBS getSearchVisibility g uid tid = do get $ g . paths ["teams", toByteString' tid, "search-visibility"] . zUser uid -putSearchVisibility :: HasCallStack => (Request -> Request) -> UserId -> TeamId -> TeamSearchVisibility -> MonadHttp m => m ResponseLBS +putSearchVisibility :: (HasCallStack) => (Request -> Request) -> UserId -> TeamId -> TeamSearchVisibility -> (MonadHttp m) => m ResponseLBS putSearchVisibility g uid tid vis = do put $ g diff --git a/services/galley/test/integration/API/Teams/Feature.hs b/services/galley/test/integration/API/Teams/Feature.hs deleted file mode 100644 index 4e0ccdb3cca..00000000000 --- a/services/galley/test/integration/API/Teams/Feature.hs +++ /dev/null @@ -1,1401 +0,0 @@ --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- - --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module API.Teams.Feature (tests) where - -import API.SQS (assertTeamActivate) -import API.Util -import API.Util.TeamFeature hiding (getFeatureConfig, setLockStatusInternal) -import API.Util.TeamFeature qualified as Util -import Bilge -import Bilge.Assert -import Brig.Types.Test.Arbitrary (Arbitrary (arbitrary)) -import Cassandra as Cql -import Control.Lens (over, to, view, (.~), (?~)) -import Control.Lens.Operators () -import Control.Monad.Catch (MonadCatch) -import Data.Aeson (FromJSON, ToJSON) -import Data.Aeson qualified as Aeson -import Data.Aeson.Key qualified as AesonKey -import Data.Aeson.KeyMap qualified as KeyMap -import Data.ByteString.Char8 (unpack) -import Data.Domain (Domain (..)) -import Data.Id -import Data.Json.Util (fromUTCTimeMillis, readUTCTimeMillis) -import Data.List1 qualified as List1 -import Data.Schema (ToSchema) -import Data.Set qualified as Set -import Data.Timeout (TimeoutUnit (Second), (#)) -import GHC.TypeLits (KnownSymbol) -import Galley.Options (exposeInvitationURLsTeamAllowlist, featureFlags, settings) -import Galley.Types.Teams -import Imports -import Network.Wai.Utilities (label) -import Test.Hspec (expectationFailure) -import Test.QuickCheck (Gen, generate, suchThat) -import Test.Tasty -import Test.Tasty.Cannon qualified as WS -import Test.Tasty.HUnit (assertFailure, (@?=)) -import TestHelpers (test) -import TestSetup -import Wire.API.Conversation.Protocol -import Wire.API.Event.FeatureConfig qualified as FeatureConfig -import Wire.API.Internal.Notification (Notification) -import Wire.API.MLS.CipherSuite -import Wire.API.Routes.Internal.Galley.TeamFeatureNoConfigMulti as Multi -import Wire.API.Team.Feature hiding (setLockStatus) - -tests :: IO TestSetup -> TestTree -tests s = - testGroup - "Feature Config API and Team Features API" - [ test s "SSO - set with HTTP PUT" (testSSO putSSOInternal), - test s "SSO - set with HTTP PATCH" (testSSO patchSSOInternal), - test s "LegalHold - set with HTTP PUT" (testLegalHold putLegalHoldInternal), - test s "LegalHold - set with HTTP PATCH" (testLegalHold patchLegalHoldInternal), - test s "SearchVisibility" testSearchVisibility, - test s "DigitalSignatures" $ testSimpleFlag @DigitalSignaturesConfig FeatureStatusDisabled, - test s "ValidateSAMLEmails" $ testSimpleFlag @ValidateSAMLEmailsConfig FeatureStatusEnabled, - test s "FileSharing with lock status" $ testSimpleFlagWithLockStatus @FileSharingConfig FeatureStatusEnabled LockStatusUnlocked, - test s "Classified Domains (enabled)" testClassifiedDomainsEnabled, - test s "Classified Domains (disabled)" testClassifiedDomainsDisabled, - test s "All features" testAllFeatures, - test s "Feature Configs / Team Features Consistency" testFeatureConfigConsistency, - test s "ConferenceCalling" $ testSimpleFlag @ConferenceCallingConfig FeatureStatusEnabled, - test s "SelfDeletingMessages" testSelfDeletingMessages, - test s "ConversationGuestLinks - public API" testGuestLinksPublic, - test s "ConversationGuestLinks - internal API" testGuestLinksInternal, - test s "ConversationGuestLinks - lock status" $ testSimpleFlagWithLockStatus @GuestLinksConfig FeatureStatusEnabled LockStatusUnlocked, - test s "SndFactorPasswordChallenge - lock status" $ testSimpleFlagWithLockStatus @SndFactorPasswordChallengeConfig FeatureStatusDisabled LockStatusLocked, - test s "SearchVisibilityInbound - internal API" testSearchVisibilityInbound, - test s "SearchVisibilityInbound - internal multi team API" testFeatureNoConfigMultiSearchVisibilityInbound, - test s "OutlookCalIntegration" $ testSimpleFlagWithLockStatus @OutlookCalIntegrationConfig FeatureStatusDisabled LockStatusLocked, - testGroup - "TTL / Conference calling" - [ test s "ConferenceCalling unlimited TTL" $ testSimpleFlagTTL @ConferenceCallingConfig FeatureStatusEnabled FeatureTTLUnlimited, - test s "ConferenceCalling 2s TTL" $ testSimpleFlagTTL @ConferenceCallingConfig FeatureStatusEnabled (FeatureTTLSeconds 2) - ], - testGroup - "TTL / Overrides" - [ test s "increase to unlimited" $ testSimpleFlagTTLOverride @ConferenceCallingConfig FeatureStatusEnabled (FeatureTTLSeconds 2) FeatureTTLUnlimited, - test s "increase" $ testSimpleFlagTTLOverride @ConferenceCallingConfig FeatureStatusEnabled (FeatureTTLSeconds 2) (FeatureTTLSeconds 4), - test s "reduce from unlimited" $ testSimpleFlagTTLOverride @ConferenceCallingConfig FeatureStatusEnabled FeatureTTLUnlimited (FeatureTTLSeconds 2), - test s "reduce" $ testSimpleFlagTTLOverride @ConferenceCallingConfig FeatureStatusEnabled (FeatureTTLSeconds 5) (FeatureTTLSeconds 2), - test s "Unlimited to unlimited" $ testSimpleFlagTTLOverride @ConferenceCallingConfig FeatureStatusEnabled FeatureTTLUnlimited FeatureTTLUnlimited - ], - test s "MLS feature config" testMLS, - test s "SearchVisibilityInbound" $ testSimpleFlag @SearchVisibilityInboundConfig FeatureStatusDisabled, - test s "MlsE2EId feature config" $ - testNonTrivialConfigNoTTL - ( withStatus - FeatureStatusDisabled - LockStatusUnlocked - (wsConfig (defFeatureStatus @MlsE2EIdConfig)) - FeatureTTLUnlimited - ), - test s "MlsMigration feature config" $ - testNonTrivialConfigNoTTL defaultMlsMigrationConfig, - test s "EnforceFileDownloadLocation feature config" $ - testNonTrivialConfigNoTTL (defFeatureStatus @EnforceFileDownloadLocationConfig), - testGroup - "Patch" - [ -- Note: `SSOConfig` and `LegalHoldConfig` may not be able to be reset - -- (depending on prior state or configuration). Thus, they cannot be - -- tested here (setting random values), but are tested with separate - -- tests. - test s (unpack $ featureNameBS @SearchVisibilityAvailableConfig) $ - testPatch IgnoreLockStatusChange FeatureStatusEnabled SearchVisibilityAvailableConfig, - test s (unpack $ featureNameBS @ValidateSAMLEmailsConfig) $ - testPatch IgnoreLockStatusChange FeatureStatusEnabled ValidateSAMLEmailsConfig, - test s (unpack $ featureNameBS @DigitalSignaturesConfig) $ - testPatch IgnoreLockStatusChange FeatureStatusEnabled DigitalSignaturesConfig, - test s (unpack $ featureNameBS @AppLockConfig) $ - testPatchWithCustomGen IgnoreLockStatusChange FeatureStatusEnabled (AppLockConfig (EnforceAppLock False) 60) validAppLockConfigGen, - test s (unpack $ featureNameBS @ConferenceCallingConfig) $ - testPatch IgnoreLockStatusChange FeatureStatusEnabled ConferenceCallingConfig, - test s (unpack $ featureNameBS @SearchVisibilityAvailableConfig) $ - testPatch IgnoreLockStatusChange FeatureStatusEnabled SearchVisibilityAvailableConfig, - test s (unpack $ featureNameBS @MLSConfig) $ - testPatchWithCustomGen - AssertLockStatusChange - FeatureStatusDisabled - ( MLSConfig - [] - ProtocolProteusTag - [MLS_128_DHKEMX25519_AES128GCM_SHA256_Ed25519] - MLS_128_DHKEMX25519_AES128GCM_SHA256_Ed25519 - [ProtocolProteusTag, ProtocolMLSTag] - ) - validMLSConfigGen, - test s (unpack $ featureNameBS @FileSharingConfig) $ - testPatch AssertLockStatusChange FeatureStatusEnabled FileSharingConfig, - test s (unpack $ featureNameBS @GuestLinksConfig) $ - testPatch AssertLockStatusChange FeatureStatusEnabled GuestLinksConfig, - test s (unpack $ featureNameBS @SndFactorPasswordChallengeConfig) $ - testPatch AssertLockStatusChange FeatureStatusDisabled SndFactorPasswordChallengeConfig, - test s (unpack $ featureNameBS @SelfDeletingMessagesConfig) $ - testPatch AssertLockStatusChange FeatureStatusEnabled (SelfDeletingMessagesConfig 0), - test s (unpack $ featureNameBS @OutlookCalIntegrationConfig) $ - testPatch AssertLockStatusChange FeatureStatusDisabled OutlookCalIntegrationConfig, - test s (unpack $ featureNameBS @MlsE2EIdConfig) $ - testPatchWithArbitrary AssertLockStatusChange FeatureStatusDisabled (wsConfig (defFeatureStatus @MlsE2EIdConfig)), - test s (unpack $ featureNameBS @EnforceFileDownloadLocationConfig) $ - testPatchWithArbitrary AssertLockStatusChange FeatureStatusDisabled (wsConfig (defFeatureStatus @EnforceFileDownloadLocationConfig)) - ], - testGroup - "ExposeInvitationURLsToTeamAdmin" - [ test s "can be set when TeamId is in allow list" testExposeInvitationURLsToTeamAdminTeamIdInAllowList, - test s "can not be set when allow list is empty" testExposeInvitationURLsToTeamAdminEmptyAllowList, - test s "server config takes precendece over team feature config" testExposeInvitationURLsToTeamAdminServerConfigTakesPrecedence - ] - ] - --- | Provides a `Gen` with test objects that are realistic and can easily be asserted -validMLSConfigGen :: Gen (WithStatusPatch MLSConfig) -validMLSConfigGen = - arbitrary - `suchThat` ( \cfg -> - case wspConfig cfg of - Just (MLSConfig us defProtocol cTags ctag supProtocol) -> - sortedAndNoDuplicates us - && sortedAndNoDuplicates cTags - && elem ctag cTags - && notElem ProtocolMixedTag supProtocol - && elem defProtocol supProtocol - && sortedAndNoDuplicates supProtocol - _ -> True - && Just FeatureStatusEnabled == wspStatus cfg - ) - where - sortedAndNoDuplicates xs = (sort . nub) xs == xs - -validAppLockConfigGen :: Gen (WithStatusPatch AppLockConfig) -validAppLockConfigGen = - arbitrary - `suchThat` ( \cfg -> case wspConfig cfg of - Just (AppLockConfig _ secs) -> secs >= 30 - Nothing -> True - ) - --- | Binary type to prevent "boolean blindness" -data AssertLockStatusChange = AssertLockStatusChange | IgnoreLockStatusChange - deriving (Eq) - -testPatchWithArbitrary :: - forall cfg. - ( HasCallStack, - IsFeatureConfig cfg, - Typeable cfg, - ToSchema cfg, - Eq cfg, - Show cfg, - KnownSymbol (FeatureSymbol cfg), - Arbitrary (WithStatusPatch cfg) - ) => - AssertLockStatusChange -> - FeatureStatus -> - cfg -> - TestM () -testPatchWithArbitrary assertLockStatusChange featureStatus cfg = do - generatedConfig <- liftIO $ generate arbitrary - testPatch' assertLockStatusChange generatedConfig featureStatus cfg - -testPatchWithCustomGen :: - forall cfg. - ( HasCallStack, - IsFeatureConfig cfg, - Typeable cfg, - ToSchema cfg, - Eq cfg, - Show cfg, - KnownSymbol (FeatureSymbol cfg) - ) => - AssertLockStatusChange -> - FeatureStatus -> - cfg -> - Gen (WithStatusPatch cfg) -> - TestM () -testPatchWithCustomGen assertLockStatusChange featureStatus cfg gen = do - generatedConfig <- liftIO $ generate gen - testPatch' assertLockStatusChange generatedConfig featureStatus cfg - -testPatch :: - forall cfg. - ( HasCallStack, - IsFeatureConfig cfg, - Typeable cfg, - ToSchema cfg, - Eq cfg, - Show cfg, - KnownSymbol (FeatureSymbol cfg), - Arbitrary (WithStatusPatch cfg) - ) => - AssertLockStatusChange -> - FeatureStatus -> - cfg -> - TestM () -testPatch assertLockStatusChange status cfg = testPatchWithCustomGen assertLockStatusChange status cfg arbitrary - -testPatch' :: - forall cfg. - ( HasCallStack, - IsFeatureConfig cfg, - Typeable cfg, - ToSchema cfg, - Eq cfg, - Show cfg, - KnownSymbol (FeatureSymbol cfg) - ) => - AssertLockStatusChange -> - WithStatusPatch cfg -> - FeatureStatus -> - cfg -> - TestM () -testPatch' testLockStatusChange rndFeatureConfig defStatus defConfig = do - (uid, tid) <- createBindingTeam - Just original <- responseJsonMaybe <$> getTeamFeatureInternal @cfg tid - patchTeamFeatureInternal tid rndFeatureConfig !!! statusCode === const 200 - Just actual <- responseJsonMaybe <$> getTeamFeatureInternal @cfg tid - liftIO $ - if wsLockStatus actual == LockStatusLocked - then do - wsStatus actual @?= defStatus - wsConfig actual @?= defConfig - else do - wsStatus actual @?= fromMaybe (wsStatus original) (wspStatus rndFeatureConfig) - when (testLockStatusChange == AssertLockStatusChange) $ - wsLockStatus actual @?= fromMaybe (wsLockStatus original) (wspLockStatus rndFeatureConfig) - wsConfig actual @?= fromMaybe (wsConfig original) (wspConfig rndFeatureConfig) - checkTeamFeatureAllEndpoints uid tid actual - -testSSO :: (TeamId -> FeatureStatus -> TestM ()) -> TestM () -testSSO setSSOFeature = do - (_owner, tid, member : _) <- createBindingTeamWithNMembers 1 - nonMember <- randomUser - - assertFlagForbidden $ getTeamFeature @SSOConfig nonMember tid - - featureSSO <- view (tsGConf . settings . featureFlags . flagSSO) - case featureSSO of - FeatureSSODisabledByDefault -> do - -- Test default - checkTeamFeatureAllEndpoints member tid (withStatus FeatureStatusDisabled LockStatusUnlocked SSOConfig FeatureTTLUnlimited) - - -- Test override - setSSOFeature tid FeatureStatusEnabled - checkTeamFeatureAllEndpoints member tid (withStatus FeatureStatusEnabled LockStatusUnlocked SSOConfig FeatureTTLUnlimited) - FeatureSSOEnabledByDefault -> do - -- since we don't allow to disable (see 'disableSsoNotImplemented'), we can't test - -- much here. (disable failure is covered in "enable/disable SSO" above.) - checkTeamFeatureAllEndpoints member tid (withStatus FeatureStatusEnabled LockStatusUnlocked SSOConfig FeatureTTLUnlimited) - -putSSOInternal :: HasCallStack => TeamId -> FeatureStatus -> TestM () -putSSOInternal tid = - void - . putTeamFeatureInternal @SSOConfig expect2xx tid - . (\st -> WithStatusNoLock st SSOConfig FeatureTTLUnlimited) - -patchSSOInternal :: HasCallStack => TeamId -> FeatureStatus -> TestM () -patchSSOInternal tid status = void $ patchTeamFeatureInternalWithMod @SSOConfig expect2xx tid (withStatus' (Just status) Nothing Nothing (Just FeatureTTLUnlimited)) - -testLegalHold :: ((Request -> Request) -> TeamId -> FeatureStatus -> TestM ()) -> TestM () -testLegalHold setLegalHoldInternal = do - (_owner, tid, member : _) <- createBindingTeamWithNMembers 1 - nonMember <- randomUser - checkTeamFeatureAllEndpoints member tid (withStatus FeatureStatusDisabled LockStatusUnlocked LegalholdConfig FeatureTTLUnlimited) - assertFlagForbidden $ getTeamFeature @LegalholdConfig nonMember tid - - -- FUTUREWORK: run two galleys, like below for custom search visibility. - featureLegalHold <- view (tsGConf . settings . featureFlags . flagLegalHold) - case featureLegalHold of - FeatureLegalHoldDisabledByDefault -> do - -- Test default - checkTeamFeatureAllEndpoints member tid (withStatus FeatureStatusDisabled LockStatusUnlocked LegalholdConfig FeatureTTLUnlimited) - - -- Test override - setLegalHoldInternal expect2xx tid FeatureStatusEnabled - checkTeamFeatureAllEndpoints member tid (withStatus FeatureStatusEnabled LockStatusUnlocked LegalholdConfig FeatureTTLUnlimited) - - -- turned off for instance - FeatureLegalHoldDisabledPermanently -> do - setLegalHoldInternal expect4xx tid FeatureStatusEnabled - - -- turned off but for whitelisted teams with implicit consent - FeatureLegalHoldWhitelistTeamsAndImplicitConsent -> do - setLegalHoldInternal expect4xx tid FeatureStatusEnabled - -putLegalHoldInternal :: HasCallStack => (Request -> Request) -> TeamId -> FeatureStatus -> TestM () -putLegalHoldInternal expectation tid = - void - . putTeamFeatureInternal @LegalholdConfig expectation tid - . (\st -> WithStatusNoLock st LegalholdConfig FeatureTTLUnlimited) - -patchLegalHoldInternal :: HasCallStack => (Request -> Request) -> TeamId -> FeatureStatus -> TestM () -patchLegalHoldInternal expectation tid status = void $ patchTeamFeatureInternalWithMod @LegalholdConfig expectation tid (withStatus' (Just status) Nothing Nothing (Just FeatureTTLUnlimited)) - -testSearchVisibility :: TestM () -testSearchVisibility = do - let setTeamSearchVisibilityInternal :: TeamId -> FeatureStatus -> TestM () - setTeamSearchVisibilityInternal teamid val = do - putTeamSearchVisibilityAvailableInternal teamid val - - (_, tid, [member]) <- createBindingTeamWithNMembers 1 - nonMember <- randomUser - - assertFlagForbidden $ getTeamFeature @SearchVisibilityAvailableConfig nonMember tid - - withCustomSearchFeature FeatureTeamSearchVisibilityUnavailableByDefault $ do - checkTeamFeatureAllEndpoints member tid (withStatus FeatureStatusDisabled LockStatusUnlocked SearchVisibilityAvailableConfig FeatureTTLUnlimited) - - setTeamSearchVisibilityInternal tid FeatureStatusEnabled - checkTeamFeatureAllEndpoints member tid (withStatus FeatureStatusEnabled LockStatusUnlocked SearchVisibilityAvailableConfig FeatureTTLUnlimited) - - setTeamSearchVisibilityInternal tid FeatureStatusDisabled - checkTeamFeatureAllEndpoints member tid (withStatus FeatureStatusDisabled LockStatusUnlocked SearchVisibilityAvailableConfig FeatureTTLUnlimited) - - (_, tid2, team2member : _) <- createBindingTeamWithNMembers 1 - - withCustomSearchFeature FeatureTeamSearchVisibilityAvailableByDefault $ do - checkTeamFeatureAllEndpoints team2member tid2 (withStatus FeatureStatusEnabled LockStatusUnlocked SearchVisibilityAvailableConfig FeatureTTLUnlimited) - - setTeamSearchVisibilityInternal tid2 FeatureStatusDisabled - checkTeamFeatureAllEndpoints team2member tid2 (withStatus FeatureStatusDisabled LockStatusUnlocked SearchVisibilityAvailableConfig FeatureTTLUnlimited) - - setTeamSearchVisibilityInternal tid2 FeatureStatusEnabled - checkTeamFeatureAllEndpoints team2member tid2 (withStatus FeatureStatusEnabled LockStatusUnlocked SearchVisibilityAvailableConfig FeatureTTLUnlimited) - -testClassifiedDomainsEnabled :: TestM () -testClassifiedDomainsEnabled = do - (_, tid, member : _) <- createBindingTeamWithNMembers 1 - let expected = - withStatus FeatureStatusEnabled LockStatusUnlocked (ClassifiedDomainsConfig [Domain "example.com"]) FeatureTTLUnlimited - - checkTeamFeatureAllEndpoints member tid expected - -testClassifiedDomainsDisabled :: TestM () -testClassifiedDomainsDisabled = do - (_owner, tid, member : _) <- createBindingTeamWithNMembers 1 - let expected = - withStatus FeatureStatusDisabled LockStatusUnlocked (ClassifiedDomainsConfig []) FeatureTTLUnlimited - - let classifiedDomainsDisabled opts = - opts - & over - (settings . featureFlags . flagClassifiedDomains) - (\(ImplicitLockStatus s) -> ImplicitLockStatus (s & setStatus FeatureStatusDisabled & setConfig (ClassifiedDomainsConfig []))) - - withSettingsOverrides classifiedDomainsDisabled $ - checkTeamFeatureAllEndpoints member tid expected - -testSimpleFlag :: - forall cfg. - ( HasCallStack, - Typeable cfg, - IsFeatureConfig cfg, - KnownSymbol (FeatureSymbol cfg), - FeatureTrivialConfig cfg, - ToSchema cfg, - FromJSON (WithStatusNoLock cfg) - ) => - FeatureStatus -> - TestM () -testSimpleFlag defaultValue = testSimpleFlagTTL @cfg defaultValue FeatureTTLUnlimited - -testSimpleFlagTTLOverride :: - forall cfg. - ( HasCallStack, - Typeable cfg, - IsFeatureConfig cfg, - KnownSymbol (FeatureSymbol cfg), - FeatureTrivialConfig cfg, - ToSchema cfg, - Eq cfg, - Show cfg - ) => - FeatureStatus -> - FeatureTTL -> - FeatureTTL -> - TestM () -testSimpleFlagTTLOverride defaultValue ttl ttlAfter = do - (_owner, tid, member : _) <- createBindingTeamWithNMembers 1 - nonMember <- randomUser - - let setFlagInternal :: FeatureStatus -> FeatureTTL -> TestM () - setFlagInternal statusValue ttl' = - void $ putTeamFeatureInternal @cfg expect2xx tid (WithStatusNoLock statusValue (trivialConfig @cfg) ttl') - - select :: PrepQuery R (Identity TeamId) (Identity (Maybe FeatureTTL)) - select = fromString "select ttl(conference_calling) from team_features where team_id = ?" - - assertUnlimited :: TestM () - assertUnlimited = do - -- TTL should be NULL inside cassandra - cassState <- view tsCass - liftIO $ do - storedTTL <- maybe Nothing runIdentity <$> Cql.runClient cassState (Cql.query1 select $ params LocalQuorum (Identity tid)) - storedTTL @?= Nothing - - assertLimited :: Word -> TestM () - assertLimited upper = do - -- TTL should NOT be NULL inside cassandra - cassState <- view tsCass - liftIO $ do - storedTTL <- maybe Nothing runIdentity <$> Cql.runClient cassState (Cql.query1 select $ params LocalQuorum (Identity tid)) - let check = case storedTTL of - Nothing -> False - Just FeatureTTLUnlimited -> False - Just (FeatureTTLSeconds i) -> i <= upper - unless check $ error ("expected ttl <= " <> show upper <> ", got " <> show storedTTL) - - toMicros :: Word -> Int - toMicros secs = fromIntegral secs * 1000000 - - assertFlagForbidden $ getTeamFeature @cfg nonMember tid - - let otherValue = case defaultValue of - FeatureStatusDisabled -> FeatureStatusEnabled - FeatureStatusEnabled -> FeatureStatusDisabled - - -- Initial value should be the default value - checkTeamFeatureAllEndpoints member tid (defFeatureStatus @cfg & setStatus defaultValue) - - -- Setting should work - setFlagInternal otherValue ttl - checkTeamFeatureAllEndpoints member tid (defFeatureStatus @cfg & setStatus otherValue & setTTL ttl) - - case (ttl, ttlAfter) of - (FeatureTTLSeconds d, FeatureTTLSeconds d') -> do - assertLimited d -- TTL should be NULL after expiration. - -- wait less than expiration, override and recheck. - liftIO $ threadDelay (toMicros d `div` 2) -- waiting half of TTL - setFlagInternal otherValue ttlAfter - -- value is still correct - checkTeamFeatureAllEndpoints member tid (defFeatureStatus @cfg & setStatus otherValue & setTTL ttlAfter) - - liftIO $ threadDelay (toMicros d') -- waiting for new TTL - checkTeamFeatureAllEndpoints member tid (defFeatureStatus @cfg & setStatus defaultValue) - (FeatureTTLSeconds d, FeatureTTLUnlimited) -> do - assertLimited d -- TTL should be NULL after expiration. - -- wait less than expiration, override and recheck. - liftIO $ threadDelay (fromIntegral d `div` 2) -- waiting half of TTL - setFlagInternal otherValue ttlAfter - -- value is still correct - checkTeamFeatureAllEndpoints member tid (defFeatureStatus @cfg & setStatus otherValue & setTTL ttlAfter) - (FeatureTTLUnlimited, FeatureTTLUnlimited) -> do - assertUnlimited - - -- overriding in this case should have no effect. - setFlagInternal otherValue ttl - checkTeamFeatureAllEndpoints member tid (defFeatureStatus @cfg & setStatus otherValue & setTTL ttl) - (FeatureTTLUnlimited, FeatureTTLSeconds d) -> do - assertUnlimited - - setFlagInternal otherValue ttlAfter - checkTeamFeatureAllEndpoints member tid (defFeatureStatus @cfg & setStatus otherValue & setTTL ttlAfter) - - liftIO $ threadDelay (toMicros d) -- waiting it out - -- value reverts back - checkTeamFeatureAllEndpoints member tid (defFeatureStatus @cfg & setStatus defaultValue & setTTL ttl) - -testSimpleFlagTTL :: - forall cfg. - ( HasCallStack, - Typeable cfg, - IsFeatureConfig cfg, - KnownSymbol (FeatureSymbol cfg), - FeatureTrivialConfig cfg, - ToSchema cfg, - FromJSON (WithStatusNoLock cfg) - ) => - FeatureStatus -> - FeatureTTL -> - TestM () -testSimpleFlagTTL defaultValue ttl = do - (_owner, tid, member : _) <- createBindingTeamWithNMembers 1 - nonMember <- randomUser - - let getFlag :: HasCallStack => FeatureStatus -> TestM () - getFlag expected = - flip (assertFlagNoConfig @cfg) expected $ getTeamFeature @cfg member tid - - getFeatureConfig :: HasCallStack => FeatureStatus -> TestM () - getFeatureConfig expected = do - actual <- Util.getFeatureConfig @cfg member - liftIO $ wsStatus actual @?= expected - - getFlagInternal :: HasCallStack => FeatureStatus -> TestM () - getFlagInternal expected = - flip (assertFlagNoConfig @cfg) expected $ getTeamFeatureInternal @cfg tid - - setFlagInternal :: FeatureStatus -> FeatureTTL -> TestM () - setFlagInternal statusValue ttl' = - void $ putTeamFeatureInternal @cfg expect2xx tid (WithStatusNoLock statusValue (trivialConfig @cfg) ttl') - - select :: PrepQuery R (Identity TeamId) (Identity (Maybe FeatureTTL)) - select = fromString "select ttl(conference_calling) from team_features where team_id = ?" - - assertUnlimited :: TestM () - assertUnlimited = do - -- TTL should be NULL inside cassandra - cassState <- view tsCass - liftIO $ do - storedTTL <- maybe Nothing runIdentity <$> Cql.runClient cassState (Cql.query1 select $ params LocalQuorum (Identity tid)) - storedTTL @?= Nothing - - assertLimited :: Word -> TestM () - assertLimited upper = do - -- TTL should NOT be NULL inside cassandra - cassState <- view tsCass - liftIO $ do - storedTTL <- maybe Nothing runIdentity <$> Cql.runClient cassState (Cql.query1 select $ params LocalQuorum (Identity tid)) - let check = case storedTTL of - Nothing -> False - Just FeatureTTLUnlimited -> False - Just (FeatureTTLSeconds i) -> i <= upper - unless check $ error ("expected ttl <= " <> show upper <> ", got " <> show storedTTL) - - assertFlagForbidden $ getTeamFeature @cfg nonMember tid - - let otherValue = case defaultValue of - FeatureStatusDisabled -> FeatureStatusEnabled - FeatureStatusEnabled -> FeatureStatusDisabled - - -- Initial value should be the default value - getFlag defaultValue - getFlagInternal defaultValue - getFeatureConfig defaultValue - - -- Setting should work - cannon <- view tsCannon - -- should receive an event - WS.bracketR cannon member $ \ws -> do - setFlagInternal otherValue ttl - void . liftIO $ - WS.assertMatch (5 # Second) ws $ - wsAssertFeatureTrivialConfigUpdate @cfg otherValue ttl - getFlag otherValue - getFeatureConfig otherValue - getFlagInternal otherValue - - case ttl of - FeatureTTLSeconds d -> do - -- should revert back after TTL expires - assertLimited d - liftIO $ threadDelay (fromIntegral d * 1000000) - assertUnlimited - getFlag defaultValue - FeatureTTLUnlimited -> do - -- TTL should be NULL inside cassandra - assertUnlimited - - -- Clean up - setFlagInternal defaultValue FeatureTTLUnlimited - getFlag defaultValue - -testSimpleFlagWithLockStatus :: - forall cfg. - ( HasCallStack, - Typeable cfg, - Eq cfg, - Show cfg, - FeatureTrivialConfig cfg, - IsFeatureConfig cfg, - KnownSymbol (FeatureSymbol cfg), - ToSchema cfg, - ToJSON (WithStatusNoLock cfg) - ) => - FeatureStatus -> - LockStatus -> - TestM () -testSimpleFlagWithLockStatus defaultStatus defaultLockStatus = do - galley <- viewGalley - (owner, tid, member : _) <- createBindingTeamWithNMembers 1 - nonMember <- randomUser - - let getFlag :: HasCallStack => FeatureStatus -> LockStatus -> TestM () - getFlag expectedStatus expectedLockStatus = do - let flag = getTeamFeature @cfg member tid - assertFlagNoConfigWithLockStatus @cfg flag expectedStatus expectedLockStatus - - getFeatureConfig :: HasCallStack => FeatureStatus -> LockStatus -> TestM () - getFeatureConfig expectedStatus expectedLockStatus = do - actual <- Util.getFeatureConfig @cfg member - liftIO $ wsStatus actual @?= expectedStatus - liftIO $ wsLockStatus actual @?= expectedLockStatus - - getFlagInternal :: HasCallStack => FeatureStatus -> LockStatus -> TestM () - getFlagInternal expectedStatus expectedLockStatus = do - let flag = getTeamFeatureInternal @cfg tid - assertFlagNoConfigWithLockStatus @cfg flag expectedStatus expectedLockStatus - - getFlags expectedStatus expectedLockStatus = do - getFlag expectedStatus expectedLockStatus - getFeatureConfig expectedStatus expectedLockStatus - getFlagInternal expectedStatus expectedLockStatus - - setFlagWithGalley :: FeatureStatus -> TestM () - setFlagWithGalley statusValue = - putTeamFeature @cfg owner tid (WithStatusNoLock statusValue (trivialConfig @cfg) FeatureTTLUnlimited) - !!! statusCode - === const 200 - - assertSetStatusForbidden :: FeatureStatus -> TestM () - assertSetStatusForbidden statusValue = - putTeamFeature @cfg owner tid (WithStatusNoLock statusValue (trivialConfig @cfg) FeatureTTLUnlimited) - !!! statusCode - === const 409 - - setLockStatus :: LockStatus -> TestM () - setLockStatus lockStatus = - Util.setLockStatusInternal @cfg galley tid lockStatus - !!! statusCode - === const 200 - - assertFlagForbidden $ getTeamFeature @cfg nonMember tid - - let otherStatus = case defaultStatus of - FeatureStatusDisabled -> FeatureStatusEnabled - FeatureStatusEnabled -> FeatureStatusDisabled - - -- Initial status and lock status should be the defaults - getFlags defaultStatus defaultLockStatus - - -- unlock feature if it is locked - when (defaultLockStatus == LockStatusLocked) $ setLockStatus LockStatusUnlocked - - -- setting should work - cannon <- view tsCannon - -- should receive an event - WS.bracketR cannon member $ \ws -> do - setFlagWithGalley otherStatus - void . liftIO $ - WS.assertMatch (5 # Second) ws $ - wsAssertFeatureConfigWithLockStatusUpdate @cfg otherStatus LockStatusUnlocked - - getFlags otherStatus LockStatusUnlocked - - -- lock feature - setLockStatus LockStatusLocked - -- feature status should now be the default again - getFlags defaultStatus LockStatusLocked - assertSetStatusForbidden defaultStatus - -- unlock feature - setLockStatus LockStatusUnlocked - -- feature status should be the previously set value - getFlags otherStatus LockStatusUnlocked - - -- clean up - setFlagWithGalley defaultStatus - setLockStatus defaultLockStatus - getFlags defaultStatus defaultLockStatus - -testSelfDeletingMessages :: TestM () -testSelfDeletingMessages = do - defLockStatus :: LockStatus <- - view - ( tsGConf - . settings - . featureFlags - . flagSelfDeletingMessages - . unDefaults - . to wsLockStatus - ) - - -- personal users - let settingWithoutLockStatus :: FeatureStatus -> Int32 -> WithStatusNoLock SelfDeletingMessagesConfig - settingWithoutLockStatus stat tout = - WithStatusNoLock - stat - (SelfDeletingMessagesConfig tout) - FeatureTTLUnlimited - settingWithLockStatus :: FeatureStatus -> Int32 -> LockStatus -> WithStatus SelfDeletingMessagesConfig - settingWithLockStatus stat tout lockStatus = - withStatus - stat - lockStatus - (SelfDeletingMessagesConfig tout) - FeatureTTLUnlimited - - personalUser <- randomUser - do - result <- Util.getFeatureConfig @SelfDeletingMessagesConfig personalUser - liftIO $ result @?= settingWithLockStatus FeatureStatusEnabled 0 defLockStatus - - -- team users - galley <- viewGalley - (owner, tid, []) <- createBindingTeamWithNMembers 0 - - let checkSet :: FeatureStatus -> Int32 -> Int -> TestM () - checkSet stat tout expectedStatusCode = - do - putTeamFeatureInternal @SelfDeletingMessagesConfig - galley - tid - (settingWithoutLockStatus stat tout) - !!! statusCode - === const expectedStatusCode - - -- internal, public (/team/:tid/features), and team-agnostic (/feature-configs). - checkGet :: HasCallStack => FeatureStatus -> Int32 -> LockStatus -> TestM () - checkGet stat tout lockStatus = do - let expected = settingWithLockStatus stat tout lockStatus - forM_ - [ getTeamFeatureInternal @SelfDeletingMessagesConfig tid, - getTeamFeature @SelfDeletingMessagesConfig owner tid - ] - (!!! responseJsonEither === const (Right expected)) - result <- Util.getFeatureConfig @SelfDeletingMessagesConfig owner - liftIO $ result @?= expected - - checkSetLockStatus :: HasCallStack => LockStatus -> TestM () - checkSetLockStatus status = - do - Util.setLockStatusInternal @SelfDeletingMessagesConfig galley tid status - !!! statusCode - === const 200 - - -- test that the default lock status comes from `galley.yaml`. - -- use this to change `galley.integration.yaml` locally and manually test that conf file - -- parsing works as expected. - checkGet FeatureStatusEnabled 0 defLockStatus - - case defLockStatus of - LockStatusLocked -> do - checkSet FeatureStatusDisabled 0 409 - LockStatusUnlocked -> do - checkSet FeatureStatusDisabled 0 200 - checkGet FeatureStatusDisabled 0 LockStatusUnlocked - checkSet FeatureStatusEnabled 0 200 - checkGet FeatureStatusEnabled 0 LockStatusUnlocked - - -- now don't worry about what's in the config, write something to cassandra, and test with that. - checkSetLockStatus LockStatusLocked - checkGet FeatureStatusEnabled 0 LockStatusLocked - checkSet FeatureStatusDisabled 0 409 - checkGet FeatureStatusEnabled 0 LockStatusLocked - checkSet FeatureStatusEnabled 30 409 - checkGet FeatureStatusEnabled 0 LockStatusLocked - checkSetLockStatus LockStatusUnlocked - checkGet FeatureStatusEnabled 0 LockStatusUnlocked - checkSet FeatureStatusDisabled 0 200 - checkGet FeatureStatusDisabled 0 LockStatusUnlocked - checkSet FeatureStatusEnabled 30 200 - checkGet FeatureStatusEnabled 30 LockStatusUnlocked - checkSet FeatureStatusDisabled 30 200 - checkGet FeatureStatusDisabled 30 LockStatusUnlocked - checkSetLockStatus LockStatusLocked - checkGet FeatureStatusEnabled 0 LockStatusLocked - checkSet FeatureStatusEnabled 50 409 - checkSetLockStatus LockStatusUnlocked - checkGet FeatureStatusDisabled 30 LockStatusUnlocked - -testGuestLinksInternal :: TestM () -testGuestLinksInternal = do - galley <- viewGalley - testGuestLinks - (const $ getTeamFeatureInternal @GuestLinksConfig) - (const $ putTeamFeatureInternal @GuestLinksConfig galley) - (Util.setLockStatusInternal @GuestLinksConfig galley) - -testGuestLinksPublic :: TestM () -testGuestLinksPublic = do - galley <- viewGalley - testGuestLinks - (getTeamFeature @GuestLinksConfig) - (putTeamFeature @GuestLinksConfig) - (Util.setLockStatusInternal @GuestLinksConfig galley) - -testGuestLinks :: - (UserId -> TeamId -> TestM ResponseLBS) -> - (UserId -> TeamId -> WithStatusNoLock GuestLinksConfig -> TestM ResponseLBS) -> - (TeamId -> LockStatus -> TestM ResponseLBS) -> - TestM () -testGuestLinks getStatus putStatus setLockStatusInternal = do - (owner, tid, []) <- createBindingTeamWithNMembers 0 - let checkGet :: HasCallStack => FeatureStatus -> LockStatus -> TestM () - checkGet status lock = - getStatus owner tid !!! do - statusCode === const 200 - responseJsonEither === const (Right (withStatus status lock GuestLinksConfig FeatureTTLUnlimited)) - - checkSet :: HasCallStack => FeatureStatus -> Int -> TestM () - checkSet status expectedStatusCode = - putStatus owner tid (WithStatusNoLock status GuestLinksConfig FeatureTTLUnlimited) !!! statusCode === const expectedStatusCode - - checkSetLockStatusInternal :: HasCallStack => LockStatus -> TestM () - checkSetLockStatusInternal lockStatus = - setLockStatusInternal tid lockStatus !!! statusCode === const 200 - - checkGet FeatureStatusEnabled LockStatusUnlocked - checkSet FeatureStatusDisabled 200 - checkGet FeatureStatusDisabled LockStatusUnlocked - checkSet FeatureStatusEnabled 200 - checkGet FeatureStatusEnabled LockStatusUnlocked - checkSet FeatureStatusDisabled 200 - checkGet FeatureStatusDisabled LockStatusUnlocked - -- when locks status is locked the team default feature status should be returned - -- and the team feature status can not be changed - checkSetLockStatusInternal LockStatusLocked - checkGet FeatureStatusEnabled LockStatusLocked - checkSet FeatureStatusDisabled 409 - -- when lock status is unlocked again the previously set feature status is restored - checkSetLockStatusInternal LockStatusUnlocked - checkGet FeatureStatusDisabled LockStatusUnlocked - --- | Call 'GET /teams/:tid/features' and 'GET /feature-configs', and check if all --- features are there. -testAllFeatures :: TestM () -testAllFeatures = do - defLockStatus :: LockStatus <- - view - ( tsGConf - . settings - . featureFlags - . flagSelfDeletingMessages - . unDefaults - . to wsLockStatus - ) - - (_owner, tid, member : _) <- createBindingTeamWithNMembers 1 - getAllTeamFeatures member tid !!! do - statusCode === const 200 - responseJsonMaybe === const (Just (expected FeatureStatusEnabled defLockStatus {- determined by default in galley -})) - - -- This block catches potential errors in the logic that reverts to default if there is a distinction made between - -- 1. there is no row for a team_id in galley.team_features - -- 2. there is a row for team_id in galley.team_features but the feature has a no entry (null value) - galley <- viewGalley - -- this sets the guest links config to its default value thereby creating a row for the team in galley.team_features - putTeamFeatureInternal @GuestLinksConfig galley tid (WithStatusNoLock FeatureStatusEnabled GuestLinksConfig FeatureTTLUnlimited) - !!! statusCode - === const 200 - getAllTeamFeatures member tid !!! do - statusCode === const 200 - responseJsonMaybe === const (Just (expected FeatureStatusEnabled defLockStatus {- determined by default in galley -})) - - getAllFeatureConfigs member !!! do - statusCode === const 200 - responseJsonMaybe === const (Just (expected FeatureStatusEnabled defLockStatus {- determined by default in galley -})) - - randomPersonalUser <- randomUser - getAllFeatureConfigs randomPersonalUser !!! do - statusCode === const 200 - responseJsonMaybe === const (Just (expected FeatureStatusEnabled defLockStatus {- determined by 'getAfcConferenceCallingDefNew' in brig -})) - where - expected confCalling lockStateSelfDeleting = - AllFeatureConfigs - { afcLegalholdStatus = withStatus FeatureStatusDisabled LockStatusUnlocked LegalholdConfig FeatureTTLUnlimited, - afcSSOStatus = withStatus FeatureStatusDisabled LockStatusUnlocked SSOConfig FeatureTTLUnlimited, - afcTeamSearchVisibilityAvailable = withStatus FeatureStatusDisabled LockStatusUnlocked SearchVisibilityAvailableConfig FeatureTTLUnlimited, - afcValidateSAMLEmails = withStatus FeatureStatusEnabled LockStatusUnlocked ValidateSAMLEmailsConfig FeatureTTLUnlimited, - afcDigitalSignatures = withStatus FeatureStatusDisabled LockStatusUnlocked DigitalSignaturesConfig FeatureTTLUnlimited, - afcAppLock = withStatus FeatureStatusEnabled LockStatusUnlocked (AppLockConfig (EnforceAppLock False) (60 :: Int32)) FeatureTTLUnlimited, - afcFileSharing = withStatus FeatureStatusEnabled LockStatusUnlocked FileSharingConfig FeatureTTLUnlimited, - afcClassifiedDomains = withStatus FeatureStatusEnabled LockStatusUnlocked (ClassifiedDomainsConfig [Domain "example.com"]) FeatureTTLUnlimited, - afcConferenceCalling = withStatus confCalling LockStatusUnlocked ConferenceCallingConfig FeatureTTLUnlimited, - afcSelfDeletingMessages = withStatus FeatureStatusEnabled lockStateSelfDeleting (SelfDeletingMessagesConfig 0) FeatureTTLUnlimited, - afcGuestLink = withStatus FeatureStatusEnabled LockStatusUnlocked GuestLinksConfig FeatureTTLUnlimited, - afcSndFactorPasswordChallenge = withStatus FeatureStatusDisabled LockStatusLocked SndFactorPasswordChallengeConfig FeatureTTLUnlimited, - afcMLS = withStatus FeatureStatusDisabled LockStatusUnlocked (MLSConfig [] ProtocolProteusTag [MLS_128_DHKEMX25519_AES128GCM_SHA256_Ed25519] MLS_128_DHKEMX25519_AES128GCM_SHA256_Ed25519 [ProtocolProteusTag, ProtocolMLSTag]) FeatureTTLUnlimited, - afcSearchVisibilityInboundConfig = withStatus FeatureStatusDisabled LockStatusUnlocked SearchVisibilityInboundConfig FeatureTTLUnlimited, - afcExposeInvitationURLsToTeamAdmin = withStatus FeatureStatusDisabled LockStatusLocked ExposeInvitationURLsToTeamAdminConfig FeatureTTLUnlimited, - afcOutlookCalIntegration = withStatus FeatureStatusDisabled LockStatusLocked OutlookCalIntegrationConfig FeatureTTLUnlimited, - afcMlsE2EId = withStatus FeatureStatusDisabled LockStatusUnlocked (wsConfig defFeatureStatus) FeatureTTLUnlimited, - afcMlsMigration = defaultMlsMigrationConfig, - afcEnforceFileDownloadLocation = defaultEnforceFileDownloadLocationConfig, - afcLimitedEventFanout = - withStatus FeatureStatusDisabled LockStatusUnlocked LimitedEventFanoutConfig FeatureTTLUnlimited - } - -testFeatureConfigConsistency :: TestM () -testFeatureConfigConsistency = do - (_owner, tid, member : _) <- createBindingTeamWithNMembers 1 - - allFeaturesRes <- getAllFeatureConfigs member >>= parseObjectKeys - - allTeamFeaturesRes <- getAllTeamFeatures member tid >>= parseObjectKeys - - unless (allTeamFeaturesRes `Set.isSubsetOf` allFeaturesRes) $ - liftIO $ - expectationFailure (show allTeamFeaturesRes <> " is not a subset of " <> show allFeaturesRes) - where - parseObjectKeys :: ResponseLBS -> TestM (Set.Set Text) - parseObjectKeys res = do - case responseJsonEither res of - Left err -> liftIO $ assertFailure ("Did not parse as an object" <> err) - Right (val :: Aeson.Value) -> - case val of - (Aeson.Object hm) -> pure (Set.fromList . map AesonKey.toText . KeyMap.keys $ hm) - x -> liftIO $ assertFailure ("JSON was not an object, but " <> show x) - -testSearchVisibilityInbound :: TestM () -testSearchVisibilityInbound = do - let defaultValue = FeatureStatusDisabled - (_owner, tid, _) <- createBindingTeamWithNMembers 1 - - let getFlagInternal :: HasCallStack => FeatureStatus -> TestM () - getFlagInternal expected = - flip (assertFlagNoConfig @SearchVisibilityInboundConfig) expected $ getTeamFeatureInternal @SearchVisibilityInboundConfig tid - - setFlagInternal :: FeatureStatus -> TestM () - setFlagInternal statusValue = - void $ putTeamFeatureInternal @SearchVisibilityInboundConfig expect2xx tid (WithStatusNoLock statusValue SearchVisibilityInboundConfig FeatureTTLUnlimited) - - let otherValue = case defaultValue of - FeatureStatusDisabled -> FeatureStatusEnabled - FeatureStatusEnabled -> FeatureStatusDisabled - - -- Initial value should be the default value - getFlagInternal defaultValue - setFlagInternal otherValue - getFlagInternal otherValue - -testFeatureNoConfigMultiSearchVisibilityInbound :: TestM () -testFeatureNoConfigMultiSearchVisibilityInbound = do - (_owner1, team1, _) <- createBindingTeamWithNMembers 0 - (_owner2, team2, _) <- createBindingTeamWithNMembers 0 - - let setFlagInternal :: TeamId -> FeatureStatus -> TestM () - setFlagInternal tid statusValue = - void $ putTeamFeatureInternal @SearchVisibilityInboundConfig expect2xx tid (WithStatusNoLock statusValue SearchVisibilityInboundConfig FeatureTTLUnlimited) - - setFlagInternal team2 FeatureStatusEnabled - - r <- - getFeatureStatusMulti @SearchVisibilityInboundConfig (Multi.TeamFeatureNoConfigMultiRequest [team1, team2]) - - WithStatus cfg -> - TestM () -testNonTrivialConfigNoTTL defaultCfg = do - (owner, tid, member : _) <- createBindingTeamWithNMembers 1 - nonMember <- randomUser - - galley <- viewGalley - cannon <- view tsCannon - - let getForTeam :: HasCallStack => WithStatusNoLock cfg -> TestM () - getForTeam expected = - flip assertFlagWithConfig expected $ getTeamFeature @cfg member tid - - getForTeamInternal :: HasCallStack => WithStatusNoLock cfg -> TestM () - getForTeamInternal expected = - flip assertFlagWithConfig expected $ getTeamFeatureInternal @cfg tid - - getForUser :: HasCallStack => WithStatusNoLock cfg -> TestM () - getForUser expected = do - result <- Util.getFeatureConfig @cfg member - liftIO $ wsStatus result @?= wssStatus expected - liftIO $ wsConfig result @?= wssConfig expected - - getViaEndpoints :: HasCallStack => WithStatusNoLock cfg -> TestM () - getViaEndpoints expected = do - getForTeam expected - getForTeamInternal expected - getForUser expected - - setForTeam :: HasCallStack => WithStatusNoLock cfg -> TestM () - setForTeam wsnl = - putTeamFeature @cfg owner tid wsnl - !!! statusCode - === const 200 - - setForTeamInternal :: HasCallStack => WithStatusNoLock cfg -> TestM () - setForTeamInternal wsnl = - void $ putTeamFeatureInternal @cfg expect2xx tid wsnl - setLockStatus :: LockStatus -> TestM () - setLockStatus lockStatus = - Util.setLockStatusInternal @cfg galley tid lockStatus - !!! statusCode - === const 200 - - assertFlagForbidden $ getTeamFeature @cfg nonMember tid - - getViaEndpoints (forgetLock defaultCfg) - - -- unlock feature - setLockStatus LockStatusUnlocked - - let defaultMLSConfig = - WithStatusNoLock - { wssStatus = FeatureStatusEnabled, - wssConfig = - MLSConfig - { mlsProtocolToggleUsers = [], - mlsDefaultProtocol = ProtocolMLSTag, - mlsAllowedCipherSuites = [MLS_128_DHKEMX25519_AES128GCM_SHA256_Ed25519], - mlsDefaultCipherSuite = MLS_128_DHKEMX25519_AES128GCM_SHA256_Ed25519, - mlsSupportedProtocols = [ProtocolProteusTag, ProtocolMLSTag] - }, - wssTTL = FeatureTTLUnlimited - } - - config2 <- liftIO $ generate arbitrary <&> (forgetLock . setTTL FeatureTTLUnlimited) - config3 <- liftIO $ generate arbitrary <&> (forgetLock . setTTL FeatureTTLUnlimited) - - putTeamFeature @MLSConfig owner tid defaultMLSConfig - !!! statusCode - === const 200 - - WS.bracketR cannon member $ \ws -> do - setForTeam config2 - void . liftIO $ - WS.assertMatch (5 # Second) ws $ - wsAssertFeatureConfigUpdate @cfg config2 LockStatusUnlocked - getViaEndpoints config2 - - WS.bracketR cannon member $ \ws -> do - setForTeamInternal config3 - void . liftIO $ - WS.assertMatch (5 # Second) ws $ - wsAssertFeatureConfigUpdate @cfg config3 LockStatusUnlocked - getViaEndpoints config3 - - -- lock the feature - setLockStatus LockStatusLocked - -- feature status should now be the default again - getViaEndpoints (forgetLock defaultCfg) - -- unlock feature - setLockStatus LockStatusUnlocked - -- feature status should be the previously set value - getViaEndpoints config3 - -testMLS :: TestM () -testMLS = do - (owner, tid, member : _) <- createBindingTeamWithNMembers 1 - - galley <- viewGalley - cannon <- view tsCannon - - let getForTeam :: HasCallStack => WithStatusNoLock MLSConfig -> TestM () - getForTeam expected = - flip assertFlagWithConfig expected $ getTeamFeature @MLSConfig member tid - - getForTeamInternal :: HasCallStack => WithStatusNoLock MLSConfig -> TestM () - getForTeamInternal expected = - flip assertFlagWithConfig expected $ getTeamFeatureInternal @MLSConfig tid - - getForUser :: HasCallStack => WithStatusNoLock MLSConfig -> TestM () - getForUser expected = do - result <- Util.getFeatureConfig @MLSConfig member - liftIO $ wsStatus result @?= wssStatus expected - liftIO $ wsConfig result @?= wssConfig expected - - getViaEndpoints :: HasCallStack => WithStatusNoLock MLSConfig -> TestM () - getViaEndpoints expected = do - getForTeam expected - getForTeamInternal expected - getForUser expected - - setForTeamWithStatusCode :: HasCallStack => Int -> WithStatusNoLock MLSConfig -> TestM () - setForTeamWithStatusCode resStatusCode wsnl = - putTeamFeature @MLSConfig owner tid wsnl - !!! statusCode - === const resStatusCode - - setForTeam :: HasCallStack => WithStatusNoLock MLSConfig -> TestM () - setForTeam = setForTeamWithStatusCode 200 - - setForTeamInternalWithStatusCode :: HasCallStack => (Request -> Request) -> WithStatusNoLock MLSConfig -> TestM () - setForTeamInternalWithStatusCode expect wsnl = - void $ putTeamFeatureInternal @MLSConfig expect tid wsnl - - setForTeamInternal :: HasCallStack => WithStatusNoLock MLSConfig -> TestM () - setForTeamInternal = setForTeamInternalWithStatusCode expect2xx - - setLockStatus :: HasCallStack => LockStatus -> TestM () - setLockStatus lockStatus = - Util.setLockStatusInternal @MLSConfig galley tid lockStatus !!! statusCode === const 200 - - let cipherSuite = MLS_128_DHKEMX25519_AES128GCM_SHA256_Ed25519 - defaultConfig = - WithStatusNoLock - FeatureStatusDisabled - (MLSConfig [] ProtocolProteusTag [cipherSuite] cipherSuite [ProtocolProteusTag, ProtocolMLSTag]) - FeatureTTLUnlimited - config2 = - WithStatusNoLock - FeatureStatusEnabled - (MLSConfig [member] ProtocolMLSTag [] cipherSuite [ProtocolProteusTag, ProtocolMLSTag]) - FeatureTTLUnlimited - config3 = - WithStatusNoLock - FeatureStatusEnabled - (MLSConfig [] ProtocolMLSTag [cipherSuite] cipherSuite [ProtocolMLSTag]) - FeatureTTLUnlimited - invalidConfig = - WithStatusNoLock - FeatureStatusEnabled - (MLSConfig [] ProtocolMLSTag [cipherSuite] cipherSuite [ProtocolProteusTag]) - FeatureTTLUnlimited - - getViaEndpoints defaultConfig - - -- when the feature is locked it cannot be changed - setLockStatus LockStatusLocked - setForTeamWithStatusCode 409 config2 - setLockStatus LockStatusUnlocked - - WS.bracketR cannon member $ \ws -> do - setForTeam config2 - void . liftIO $ - WS.assertMatch (5 # Second) ws $ - wsAssertFeatureConfigUpdate @MLSConfig config2 LockStatusUnlocked - getViaEndpoints config2 - - -- when the feature is locked the default config is returned - setLockStatus LockStatusLocked - getViaEndpoints defaultConfig - setLockStatus LockStatusUnlocked - - WS.bracketR cannon member $ \ws -> do - setForTeamWithStatusCode 400 invalidConfig - void . liftIO $ - WS.assertNoEvent (2 # Second) [ws] - getViaEndpoints config2 - - WS.bracketR cannon member $ \ws -> do - setForTeamInternal config3 - void . liftIO $ - WS.assertMatch (5 # Second) ws $ - wsAssertFeatureConfigUpdate @MLSConfig config3 LockStatusUnlocked - getViaEndpoints config3 - - WS.bracketR cannon member $ \ws -> do - setForTeamInternalWithStatusCode expect4xx invalidConfig - void . liftIO $ - WS.assertNoEvent (2 # Second) [ws] - getViaEndpoints config3 - -testExposeInvitationURLsToTeamAdminTeamIdInAllowList :: TestM () -testExposeInvitationURLsToTeamAdminTeamIdInAllowList = do - owner <- randomUser - tid <- createBindingTeamInternal "foo" owner - assertTeamActivate "create team" tid - void $ - withSettingsOverrides (\opts -> opts & settings . exposeInvitationURLsTeamAllowlist ?~ [tid]) $ do - assertExposeInvitationURLsToTeamAdminConfigStatus owner tid FeatureStatusDisabled LockStatusUnlocked - let enabled = WithStatusNoLock FeatureStatusEnabled ExposeInvitationURLsToTeamAdminConfig FeatureTTLUnlimited - void $ - putTeamFeature @ExposeInvitationURLsToTeamAdminConfig owner tid enabled !!! do - const 200 === statusCode - assertExposeInvitationURLsToTeamAdminConfigStatus owner tid FeatureStatusEnabled LockStatusUnlocked - -testExposeInvitationURLsToTeamAdminEmptyAllowList :: TestM () -testExposeInvitationURLsToTeamAdminEmptyAllowList = do - owner <- randomUser - tid <- createBindingTeamInternal "foo" owner - assertTeamActivate "create team" tid - void $ - withSettingsOverrides (\opts -> opts & settings . exposeInvitationURLsTeamAllowlist .~ Nothing) $ do - assertExposeInvitationURLsToTeamAdminConfigStatus owner tid FeatureStatusDisabled LockStatusLocked - let enabled = WithStatusNoLock FeatureStatusEnabled ExposeInvitationURLsToTeamAdminConfig FeatureTTLUnlimited - void $ - putTeamFeature @ExposeInvitationURLsToTeamAdminConfig owner tid enabled !!! do - const 409 === statusCode - assertExposeInvitationURLsToTeamAdminConfigStatus owner tid FeatureStatusDisabled LockStatusLocked - --- | Ensure that the server config takes precedence over a saved team config. --- --- In other words: When a team id is no longer in the --- `exposeInvitationURLsTeamAllowlist` the --- `ExposeInvitationURLsToTeamAdminConfig` is always disabled (even tough it --- might have been enabled before). -testExposeInvitationURLsToTeamAdminServerConfigTakesPrecedence :: TestM () -testExposeInvitationURLsToTeamAdminServerConfigTakesPrecedence = do - owner <- randomUser - tid <- createBindingTeamInternal "foo" owner - assertTeamActivate "create team" tid - void $ - withSettingsOverrides (\opts -> opts & settings . exposeInvitationURLsTeamAllowlist ?~ [tid]) $ do - assertExposeInvitationURLsToTeamAdminConfigStatus owner tid FeatureStatusDisabled LockStatusUnlocked - let enabled = WithStatusNoLock FeatureStatusEnabled ExposeInvitationURLsToTeamAdminConfig FeatureTTLUnlimited - void $ - putTeamFeature @ExposeInvitationURLsToTeamAdminConfig owner tid enabled !!! do - const 200 === statusCode - assertExposeInvitationURLsToTeamAdminConfigStatus owner tid FeatureStatusEnabled LockStatusUnlocked - void $ - withSettingsOverrides (\opts -> opts & settings . exposeInvitationURLsTeamAllowlist .~ Nothing) $ do - assertExposeInvitationURLsToTeamAdminConfigStatus owner tid FeatureStatusDisabled LockStatusLocked - let enabled = WithStatusNoLock FeatureStatusEnabled ExposeInvitationURLsToTeamAdminConfig FeatureTTLUnlimited - void $ - putTeamFeature @ExposeInvitationURLsToTeamAdminConfig owner tid enabled !!! do - const 409 === statusCode - assertExposeInvitationURLsToTeamAdminConfigStatus owner tid FeatureStatusDisabled LockStatusLocked - -assertExposeInvitationURLsToTeamAdminConfigStatus :: UserId -> TeamId -> FeatureStatus -> LockStatus -> TestM () -assertExposeInvitationURLsToTeamAdminConfigStatus owner tid fStatus lStatus = do - getTeamFeature @ExposeInvitationURLsToTeamAdminConfig owner tid !!! do - const 200 === statusCode - const (Right (withStatus fStatus lStatus ExposeInvitationURLsToTeamAdminConfig FeatureTTLUnlimited)) === responseJsonEither - -assertFlagForbidden :: HasCallStack => TestM ResponseLBS -> TestM () -assertFlagForbidden res = do - res !!! do - statusCode === const 403 - fmap label . responseJsonMaybe === const (Just "no-team-member") - -assertFlagNoConfig :: - forall cfg. - ( HasCallStack, - Typeable cfg, - FromJSON (WithStatusNoLock cfg) - ) => - TestM ResponseLBS -> - FeatureStatus -> - TestM () -assertFlagNoConfig res expected = do - res !!! do - statusCode === const 200 - ( fmap wssStatus - . responseJsonEither @(WithStatusNoLock cfg) - ) - === const (Right expected) - -assertFlagNoConfigWithLockStatus :: - forall cfg. - ( HasCallStack, - Typeable cfg, - FeatureTrivialConfig cfg, - FromJSON (WithStatus cfg), - Eq cfg, - Show cfg - ) => - TestM ResponseLBS -> - FeatureStatus -> - LockStatus -> - TestM () -assertFlagNoConfigWithLockStatus res expectedStatus expectedLockStatus = do - res !!! do - statusCode === const 200 - responseJsonEither @(WithStatus cfg) - === const (Right (withStatus expectedStatus expectedLockStatus (trivialConfig @cfg) FeatureTTLUnlimited)) - -assertFlagWithConfig :: - forall cfg m. - ( HasCallStack, - Eq cfg, - ToSchema cfg, - Show cfg, - Typeable cfg, - IsFeatureConfig cfg, - MonadIO m, - MonadCatch m - ) => - m ResponseLBS -> - WithStatusNoLock cfg -> - m () -assertFlagWithConfig response expected = do - r <- response - let rJson = responseJsonEither @(WithStatusNoLock cfg) r - pure r !!! statusCode === const 200 - liftIO $ do - fmap wssStatus rJson @?= (Right . wssStatus $ expected) - fmap wssConfig rJson @?= (Right . wssConfig $ expected) - -wsAssertFeatureTrivialConfigUpdate :: - forall cfg. - ( IsFeatureConfig cfg, - KnownSymbol (FeatureSymbol cfg), - FeatureTrivialConfig cfg, - ToSchema cfg - ) => - FeatureStatus -> - FeatureTTL -> - Notification -> - IO () -wsAssertFeatureTrivialConfigUpdate status ttl notification = do - let e :: FeatureConfig.Event = List1.head (WS.unpackPayload notification) - FeatureConfig._eventType e @?= FeatureConfig.Update - FeatureConfig._eventFeatureName e @?= featureName @cfg - FeatureConfig._eventData e - @?= Aeson.toJSON - (withStatus status (wsLockStatus (defFeatureStatus @cfg)) (trivialConfig @cfg) ttl) - -wsAssertFeatureConfigWithLockStatusUpdate :: - forall cfg. - ( IsFeatureConfig cfg, - ToSchema cfg, - KnownSymbol (FeatureSymbol cfg), - FeatureTrivialConfig cfg - ) => - FeatureStatus -> - LockStatus -> - Notification -> - IO () -wsAssertFeatureConfigWithLockStatusUpdate status lockStatus notification = do - let e :: FeatureConfig.Event = List1.head (WS.unpackPayload notification) - FeatureConfig._eventType e @?= FeatureConfig.Update - FeatureConfig._eventFeatureName e @?= (featureName @cfg) - FeatureConfig._eventData e @?= Aeson.toJSON (withStatus status lockStatus (trivialConfig @cfg) FeatureTTLUnlimited) - -wsAssertFeatureConfigUpdate :: - forall cfg. - ( KnownSymbol (FeatureSymbol cfg), - ToJSON (WithStatus cfg) - ) => - WithStatusNoLock cfg -> - LockStatus -> - Notification -> - IO () -wsAssertFeatureConfigUpdate config lockStatus notification = do - let e :: FeatureConfig.Event = List1.head (WS.unpackPayload notification) - FeatureConfig._eventType e @?= FeatureConfig.Update - FeatureConfig._eventFeatureName e @?= featureName @cfg - FeatureConfig._eventData e @?= Aeson.toJSON (withLockStatus lockStatus config) - -defaultMlsMigrationConfig :: WithStatus MlsMigrationConfig -defaultMlsMigrationConfig = - withStatus - FeatureStatusEnabled - LockStatusLocked - MlsMigrationConfig - { startTime = fmap fromUTCTimeMillis (readUTCTimeMillis "2029-05-16T10:11:12.123Z"), - finaliseRegardlessAfter = fmap fromUTCTimeMillis (readUTCTimeMillis "2029-10-17T00:00:00.000Z") - } - FeatureTTLUnlimited - -defaultEnforceFileDownloadLocationConfig :: WithStatus EnforceFileDownloadLocationConfig -defaultEnforceFileDownloadLocationConfig = - withStatus - FeatureStatusDisabled - LockStatusLocked - (EnforceFileDownloadLocationConfig Nothing) - FeatureTTLUnlimited diff --git a/services/galley/test/integration/API/Teams/LegalHold.hs b/services/galley/test/integration/API/Teams/LegalHold.hs index c9a3118bcf6..77896207454 100644 --- a/services/galley/test/integration/API/Teams/LegalHold.hs +++ b/services/galley/test/integration/API/Teams/LegalHold.hs @@ -31,9 +31,7 @@ import Control.Concurrent.Chan import Control.Lens hiding ((#)) import Data.Id import Data.LegalHold -import Data.List.NonEmpty (NonEmpty (..)) import Data.PEM -import Data.Qualified (Qualified (..)) import Data.Range import Data.Time.Clock qualified as Time import Galley.Cassandra.LegalHold @@ -42,19 +40,16 @@ import Imports import Network.HTTP.Types.Status (status200, status404) import Network.Wai as Wai import Network.Wai.Handler.Warp qualified as Warp -import Network.Wai.Utilities.Error qualified as Error import Test.QuickCheck.Instances () import Test.Tasty import Test.Tasty.HUnit import TestHelpers import TestSetup import Wire.API.Connection qualified as Conn -import Wire.API.Conversation.Role (roleNameWireAdmin) import Wire.API.Provider.Service import Wire.API.Routes.Internal.Brig.Connection import Wire.API.Team.LegalHold import Wire.API.Team.Member -import Wire.API.Team.Member qualified as Team import Wire.API.Team.Permission import Wire.API.Team.Role import Wire.API.User.Client @@ -79,19 +74,7 @@ testsPublic s = GET /team/{tid}/members - show legal hold status of all members -} - testGroup - "settings.legalholdEnabledTeams" -- FUTUREWORK: ungroup this level - [ testGroup -- FUTUREWORK: ungroup this level - "teams listed" - [ testGroup - "Users are invited to a group conversation." - [ testGroup - "The group conversation contains legalhold activated users." - [testOnlyIfLhWhitelisted s "If any user in the invite has not given consent then the invite fails" testNoConsentCannotBeInvited] - ], - test s "bench hack" testBenchHack - ] - ] + test s "settings.legalholdEnabledTeams teams liested bench hack" testBenchHack ] testsInternal :: IO TestSetup -> TestTree @@ -102,12 +85,12 @@ testsInternal s = testWhitelistingTeams :: TestM () testWhitelistingTeams = do - let testTeamWhitelisted :: HasCallStack => TeamId -> TestM Bool + let testTeamWhitelisted :: (HasCallStack) => TeamId -> TestM Bool testTeamWhitelisted tid = do res <- getLHWhitelistedTeam tid pure (Bilge.responseStatus res == status200) - let expectWhitelisted :: HasCallStack => Bool -> TeamId -> TestM () + let expectWhitelisted :: (HasCallStack) => Bool -> TeamId -> TestM () expectWhitelisted yes tid = do let msg = if yes then "team should be whitelisted" else "team should not be whitelisted" aFewTimesAssertBool msg (== yes) (testTeamWhitelisted tid) @@ -141,18 +124,18 @@ testCreateLegalHoldTeamSettings = withTeam $ \owner tid -> do postSettings owner tid brokenService !!! testResponse 412 (Just "legalhold-unavailable") -- checks /status of legal hold service (boolean argument says whether the service is -- behaving or not) - let lhapp :: HasCallStack => IsWorking -> Chan Void -> Application + let lhapp :: (HasCallStack) => IsWorking -> Chan Void -> Application lhapp NotWorking _ _ cont = cont respondBad lhapp Working _ req cont = do if - | pathInfo req /= ["legalhold", "status"] -> cont respondBad - | requestMethod req /= "GET" -> cont respondBad - | otherwise -> cont respondOk + | pathInfo req /= ["legalhold", "status"] -> cont respondBad + | requestMethod req /= "GET" -> cont respondBad + | otherwise -> cont respondOk respondOk :: Wai.Response respondOk = responseLBS status200 mempty mempty respondBad :: Wai.Response respondBad = responseLBS status404 mempty mempty - lhtest :: HasCallStack => IsWorking -> Warp.Port -> Chan Void -> TestM () + lhtest :: (HasCallStack) => IsWorking -> Warp.Port -> Chan Void -> TestM () lhtest NotWorking _ _ = do postSettings owner tid brokenService !!! testResponse 412 (Just "legalhold-unavailable") lhtest Working lhPort _ = do @@ -234,7 +217,7 @@ testRemoveLegalHoldFromTeam = do -- fails if LH for team is disabled deleteSettings (Just defPassword) owner tid !!! testResponse 403 (Just "legalhold-disable-unimplemented") -testAddTeamUserTooLargeWithLegalholdWhitelisted :: HasCallStack => TestM () +testAddTeamUserTooLargeWithLegalholdWhitelisted :: (HasCallStack) => TestM () testAddTeamUserTooLargeWithLegalholdWhitelisted = withTeam $ \owner tid -> do o <- view tsGConf let fanoutLimit = fromIntegral @_ @Integer . fromRange $ Galley.currentFanoutLimit o @@ -273,50 +256,7 @@ testCannotCreateLegalHoldDeviceOldAPI = do data GroupConvInvCase = InviteOnlyConsenters | InviteAlsoNonConsenters deriving (Show, Eq, Ord, Bounded, Enum) -testNoConsentCannotBeInvited :: HasCallStack => TestM () -testNoConsentCannotBeInvited = do - localDomain <- viewFederationDomain - -- team that is legalhold whitelisted - (legalholder :: UserId, tid) <- createBindingTeam - userLHNotActivated <- (^. Team.userId) <$> addUserToTeam legalholder tid - putLHWhitelistTeam tid !!! const 200 === statusCode - - -- team without legalhold - (peer :: UserId, teamPeer) <- createBindingTeam - let qpeer = Qualified peer localDomain - peer2 <- (^. Team.userId) <$> addUserToTeam peer teamPeer - let qpeer2 = Qualified peer2 localDomain - - do - postConnection userLHNotActivated peer !!! const 201 === statusCode - void $ putConnection peer userLHNotActivated Conn.Accepted do - convId <- createTeamConvWithRole userLHNotActivated tid [legalholder] (Just "corp + us") Nothing Nothing roleNameWireAdmin - let qconvId = Qualified convId localDomain - - API.Util.postMembers userLHNotActivated (pure qpeer) qconvId - !!! const 200 === statusCode - - -- activate legalhold for legalholder - do - galley <- viewGalley - requestLegalHoldDevice legalholder legalholder tid !!! testResponse 201 Nothing - approveLegalHoldDevice (Just defPassword) legalholder legalholder tid !!! testResponse 200 Nothing - UserLegalHoldStatusResponse userStatus _ _ <- getUserStatusTyped' galley legalholder tid - liftIO $ assertEqual "approving should change status" UserLegalHoldEnabled userStatus - - API.Util.postMembers userLHNotActivated (pure qpeer2) qconvId - >>= errWith 403 (\err -> Error.label err == "missing-legalhold-consent") - - localdomain <- viewFederationDomain - API.Util.postQualifiedMembers userLHNotActivated (Qualified peer2 localdomain :| []) qconvId - >>= errWith 403 (\err -> Error.label err == "missing-legalhold-consent") - -testBenchHack :: HasCallStack => TestM () +testBenchHack :: (HasCallStack) => TestM () testBenchHack = do {- representative sample run on an old laptop: @@ -359,13 +299,13 @@ testBenchHack = do print =<< testBenchHack' 300 print =<< testBenchHack' 600 -testBenchHack' :: HasCallStack => Int -> TestM (Int, Time.NominalDiffTime) +testBenchHack' :: (HasCallStack) => Int -> TestM (Int, Time.NominalDiffTime) testBenchHack' numPeers = do (legalholder :: UserId, tid) <- createBindingTeam peers :: [UserId] <- replicateM numPeers randomUser galley <- viewGalley - let doEnableLH :: HasCallStack => TestM () + let doEnableLH :: (HasCallStack) => TestM () doEnableLH = do withLHWhitelist tid (requestLegalHoldDevice' galley legalholder legalholder tid) !!! testResponse 201 Nothing withLHWhitelist tid (approveLegalHoldDevice' galley (Just defPassword) legalholder legalholder tid) !!! testResponse 200 Nothing diff --git a/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs b/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs index a9315929573..0ed8319d99e 100644 --- a/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs +++ b/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs @@ -361,18 +361,18 @@ testCreateLegalHoldTeamSettings = do postSettings owner tid brokenService !!! testResponse 412 (Just "legalhold-unavailable") -- checks /status of legal hold service (boolean argument says whether the service is -- behaving or not) - let lhapp :: HasCallStack => IsWorking -> Chan Void -> Application + let lhapp :: (HasCallStack) => IsWorking -> Chan Void -> Application lhapp NotWorking _ _ cont = cont respondBad lhapp Working _ req cont = do if - | pathInfo req /= ["legalhold", "status"] -> cont respondBad - | requestMethod req /= "GET" -> cont respondBad - | otherwise -> cont respondOk + | pathInfo req /= ["legalhold", "status"] -> cont respondBad + | requestMethod req /= "GET" -> cont respondBad + | otherwise -> cont respondOk respondOk :: Wai.Response respondOk = responseLBS status200 mempty mempty respondBad :: Wai.Response respondBad = responseLBS status404 mempty mempty - lhtest :: HasCallStack => IsWorking -> Warp.Port -> Chan Void -> TestM () + lhtest :: (HasCallStack) => IsWorking -> Warp.Port -> Chan Void -> TestM () lhtest NotWorking _ _ = do postSettings owner tid brokenService !!! testResponse 412 (Just "legalhold-unavailable") lhtest Working lhPort _ = do @@ -601,7 +601,7 @@ testGetTeamMembersIncludesLHStatus = do findMemberStatus ms = ms ^? traversed . filtered (has $ Team.userId . only member) . legalHoldStatus - let check :: HasCallStack => UserLegalHoldStatus -> String -> TestM () + let check :: (HasCallStack) => UserLegalHoldStatus -> String -> TestM () check status msg = do members' <- view teamMembers <$> getTeamMembers owner tid liftIO $ @@ -640,7 +640,7 @@ testOldClientsBlockDeviceHandshake = do -- has to be a team member, granting LH consent for personal users is not supported. createBindingTeam - let doEnableLH :: HasCallStack => UserId -> UserId -> TestM ClientId + let doEnableLH :: (HasCallStack) => UserId -> UserId -> TestM ClientId doEnableLH owner uid = do requestLegalHoldDevice owner uid tid !!! testResponse 201 Nothing approveLegalHoldDevice (Just defPassword) uid uid tid !!! testResponse 200 Nothing @@ -683,7 +683,7 @@ testOldClientsBlockDeviceHandshake = do UserId -> ClientId -> TestM ResponseLBS + let runit :: (HasCallStack) => UserId -> ClientId -> TestM ResponseLBS runit sender senderClient = do postOtrMessage id sender senderClient convId rcps where @@ -718,7 +718,7 @@ testClaimKeys testcase = do (legalholder, tid) <- createBindingTeam (peer, teamPeer) <- createBindingTeam - let doEnableLH :: HasCallStack => TeamId -> UserId -> UserId -> TestM ClientId + let doEnableLH :: (HasCallStack) => TeamId -> UserId -> UserId -> TestM ClientId doEnableLH team owner uid = do requestLegalHoldDevice owner uid team !!! testResponse 201 Nothing approveLegalHoldDevice (Just defPassword) uid uid team !!! testResponse 200 Nothing @@ -772,7 +772,7 @@ testClaimKeys testcase = do -------------------------------------------------------------------- -- setup helpers -withDummyTestServiceForTeam' :: HasCallStack => UserId -> TeamId -> (Warp.Port -> Chan (Wai.Request, LByteString) -> TestM a) -> TestM a +withDummyTestServiceForTeam' :: (HasCallStack) => UserId -> TeamId -> (Warp.Port -> Chan (Wai.Request, LByteString) -> TestM a) -> TestM a withDummyTestServiceForTeam' owner tid go = do withDummyTestServiceForTeamNoService $ \lhPort chan -> do newService <- newLegalHoldService lhPort diff --git a/services/galley/test/integration/API/Teams/LegalHold/Util.hs b/services/galley/test/integration/API/Teams/LegalHold/Util.hs index 85e2e37d195..6fd3eee176b 100644 --- a/services/galley/test/integration/API/Teams/LegalHold/Util.hs +++ b/services/galley/test/integration/API/Teams/LegalHold/Util.hs @@ -65,7 +65,7 @@ import Wire.API.UserEvent qualified as Ev -- | Create a new legal hold service creation request with the URL from the integration test -- config. -newLegalHoldService :: HasCallStack => Warp.Port -> TestM NewLegalHoldService +newLegalHoldService :: (HasCallStack) => Warp.Port -> TestM NewLegalHoldService newLegalHoldService lhPort = do config <- view (tsIConf . to provider) key' <- liftIO $ readServiceKey (publicKey config) @@ -88,7 +88,7 @@ readServiceKey fp = liftIO $ do withDummyTestServiceForTeam :: forall a. - HasCallStack => + (HasCallStack) => UserId -> TeamId -> -- | the test @@ -104,7 +104,7 @@ withDummyTestServiceForTeam owner tid go = -- the config file), and see if it works as well as with our mock service. withDummyTestServiceForTeamNoService :: forall a. - HasCallStack => + (HasCallStack) => -- | the test (Warp.Port -> Chan (Wai.Request, LByteString) -> TestM a) -> TestM a @@ -151,7 +151,7 @@ withDummyTestServiceForTeamNoService go = do -- it's here for historical reason because we did this in galley.yaml -- at some point in the past rather than in an internal end-point, and that required spawning -- another galley 'Application' with 'withSettingsOverrides'. -withLHWhitelist :: forall a. HasCallStack => TeamId -> TestM a -> TestM a +withLHWhitelist :: forall a. (HasCallStack) => TeamId -> TestM a -> TestM a withLHWhitelist tid action = do void $ putLHWhitelistTeam tid opts <- view tsGConf @@ -159,7 +159,7 @@ withLHWhitelist tid action = do -- | If you play with whitelists, you should use this one. Every whitelisted team that does -- not get fully deleted will blow up the whitelist that is cached in every warp handler. -withTeam :: forall a. HasCallStack => (HasCallStack => UserId -> TeamId -> TestM a) -> TestM a +withTeam :: forall a. (HasCallStack) => ((HasCallStack) => UserId -> TeamId -> TestM a) -> TestM a withTeam action = bracket createBindingTeam @@ -173,7 +173,7 @@ withTeam action = withFreePortAnyAddr :: (MonadMask m, MonadIO m) => ((Warp.Port, Socket) -> m a) -> m a withFreePortAnyAddr = bracket openFreePortAnyAddr (liftIO . Socket.close . snd) -openFreePortAnyAddr :: MonadIO m => m (Warp.Port, Socket) +openFreePortAnyAddr :: (MonadIO m) => m (Warp.Port, Socket) openFreePortAnyAddr = liftIO $ bindRandomPortTCP "*" -- | Run a test with an mock legal hold service application. The mock service is also binding @@ -184,7 +184,7 @@ openFreePortAnyAddr = liftIO $ bindRandomPortTCP "*" -- they can be run several times if they fail the first time. this is the allow for the ssl -- service to have some time to propagate through the test system (needed on k8s). withTestService :: - HasCallStack => + (HasCallStack) => -- | the mock service (Chan e -> Application) -> -- | the test @@ -222,14 +222,14 @@ publicKeyNotMatchingService = ---------------------------------------------------------------------- -- API helpers -getEnabled :: HasCallStack => TeamId -> TestM ResponseLBS +getEnabled :: (HasCallStack) => TeamId -> TestM ResponseLBS getEnabled tid = do g <- viewGalley get $ g . paths ["i", "teams", toByteString' tid, "features", "legalhold"] -renewToken :: HasCallStack => Text -> TestM () +renewToken :: (HasCallStack) => Text -> TestM () renewToken tok = do b <- viewBrig void . post $ @@ -238,7 +238,7 @@ renewToken tok = do . cookieRaw "zuid" (toByteString' tok) . expect2xx -putEnabled :: HasCallStack => TeamId -> Public.FeatureStatus -> TestM () +putEnabled :: (HasCallStack) => TeamId -> Public.FeatureStatus -> TestM () putEnabled tid enabled = do g <- viewGalley putEnabledM g tid enabled @@ -246,7 +246,7 @@ putEnabled tid enabled = do putEnabledM :: (HasCallStack, MonadHttp m, MonadIO m) => GalleyR -> TeamId -> Public.FeatureStatus -> m () putEnabledM g tid enabled = void $ putEnabledM' g expect2xx tid enabled -putEnabled' :: HasCallStack => (Bilge.Request -> Bilge.Request) -> TeamId -> Public.FeatureStatus -> TestM ResponseLBS +putEnabled' :: (HasCallStack) => (Bilge.Request -> Bilge.Request) -> TeamId -> Public.FeatureStatus -> TestM ResponseLBS putEnabled' extra tid enabled = do g <- viewGalley putEnabledM' g extra tid enabled @@ -259,7 +259,7 @@ putEnabledM' g extra tid enabled = do . json (Public.WithStatusNoLock enabled Public.LegalholdConfig Public.FeatureTTLUnlimited) . extra -postSettings :: HasCallStack => UserId -> TeamId -> NewLegalHoldService -> TestM ResponseLBS +postSettings :: (HasCallStack) => UserId -> TeamId -> NewLegalHoldService -> TestM ResponseLBS postSettings uid tid new = -- Retry calls to this endpoint, on k8s it sometimes takes a while to establish a working -- connection. @@ -278,10 +278,10 @@ postSettings uid tid new = only412 :: RetryStatus -> ResponseLBS -> TestM Bool only412 _ resp = pure $ statusCode resp == 412 -getSettingsTyped :: HasCallStack => UserId -> TeamId -> TestM ViewLegalHoldService +getSettingsTyped :: (HasCallStack) => UserId -> TeamId -> TestM ViewLegalHoldService getSettingsTyped uid tid = responseJsonUnsafe <$> (getSettings uid tid UserId -> TeamId -> TestM ResponseLBS +getSettings :: (HasCallStack) => UserId -> TeamId -> TestM ResponseLBS getSettings uid tid = do g <- viewGalley get $ @@ -291,7 +291,7 @@ getSettings uid tid = do . zConn "conn" . zType "access" -deleteSettings :: HasCallStack => Maybe PlainTextPassword6 -> UserId -> TeamId -> TestM ResponseLBS +deleteSettings :: (HasCallStack) => Maybe PlainTextPassword6 -> UserId -> TeamId -> TestM ResponseLBS deleteSettings mPassword uid tid = do g <- viewGalley delete $ @@ -302,7 +302,7 @@ deleteSettings mPassword uid tid = do . zType "access" . json (RemoveLegalHoldSettingsRequest mPassword) -getUserStatusTyped :: HasCallStack => UserId -> TeamId -> TestM UserLegalHoldStatusResponse +getUserStatusTyped :: (HasCallStack) => UserId -> TeamId -> TestM UserLegalHoldStatusResponse getUserStatusTyped uid tid = do g <- viewGalley getUserStatusTyped' g uid tid @@ -321,7 +321,7 @@ getUserStatus' g uid tid = do . zConn "conn" . zType "access" -approveLegalHoldDevice :: HasCallStack => Maybe PlainTextPassword6 -> UserId -> UserId -> TeamId -> TestM ResponseLBS +approveLegalHoldDevice :: (HasCallStack) => Maybe PlainTextPassword6 -> UserId -> UserId -> TeamId -> TestM ResponseLBS approveLegalHoldDevice mPassword zusr uid tid = do g <- viewGalley approveLegalHoldDevice' g mPassword zusr uid tid @@ -344,7 +344,7 @@ approveLegalHoldDevice' g mPassword zusr uid tid = do . json (ApproveLegalHoldForUserRequest mPassword) disableLegalHoldForUser :: - HasCallStack => + (HasCallStack) => Maybe PlainTextPassword6 -> TeamId -> UserId -> @@ -370,7 +370,7 @@ disableLegalHoldForUser' g mPassword tid zusr uid = do . zType "access" . json (DisableLegalHoldForUserRequest mPassword) -assertExactlyOneLegalHoldDevice :: HasCallStack => UserId -> TestM () +assertExactlyOneLegalHoldDevice :: (HasCallStack) => UserId -> TestM () assertExactlyOneLegalHoldDevice uid = do clients :: [Client] <- getClients uid >>= responseJsonError @@ -378,7 +378,7 @@ assertExactlyOneLegalHoldDevice uid = do let numdevs = length $ clientType <$> clients assertEqual ("expected exactly one legal hold device for user: " <> show uid) numdevs 1 -assertZeroLegalHoldDevices :: HasCallStack => UserId -> TestM () +assertZeroLegalHoldDevices :: (HasCallStack) => UserId -> TestM () assertZeroLegalHoldDevices uid = do clients :: [Client] <- getClients uid >>= responseJsonError @@ -396,7 +396,7 @@ assertZeroLegalHoldDevices uid = do ---------------------------------------------------------------------- ---- Device helpers -grantConsent :: HasCallStack => TeamId -> UserId -> TestM () +grantConsent :: (HasCallStack) => TeamId -> UserId -> TestM () grantConsent tid zusr = do g <- viewGalley grantConsent' g tid zusr @@ -414,7 +414,7 @@ grantConsent'' expectation g tid zusr = do . zType "access" . expectation -requestLegalHoldDevice :: HasCallStack => UserId -> UserId -> TeamId -> TestM ResponseLBS +requestLegalHoldDevice :: (HasCallStack) => UserId -> UserId -> TeamId -> TestM ResponseLBS requestLegalHoldDevice zusr uid tid = do g <- viewGalley requestLegalHoldDevice' g zusr uid tid @@ -505,7 +505,7 @@ assertMatchChan c match = go [] refill buf error "Timeout" -getLHWhitelistedTeam :: HasCallStack => TeamId -> TestM ResponseLBS +getLHWhitelistedTeam :: (HasCallStack) => TeamId -> TestM ResponseLBS getLHWhitelistedTeam tid = do galleyCall <- viewGalley getLHWhitelistedTeam' galleyCall tid @@ -517,7 +517,7 @@ getLHWhitelistedTeam' g tid = do . paths ["i", "legalhold", "whitelisted-teams", toByteString' tid] ) -putLHWhitelistTeam :: HasCallStack => TeamId -> TestM ResponseLBS +putLHWhitelistTeam :: (HasCallStack) => TeamId -> TestM ResponseLBS putLHWhitelistTeam tid = do galleyCall <- viewGalley putLHWhitelistTeam' galleyCall tid @@ -529,7 +529,7 @@ putLHWhitelistTeam' g tid = do . paths ["i", "legalhold", "whitelisted-teams", toByteString' tid] ) -_deleteLHWhitelistTeam :: HasCallStack => TeamId -> TestM ResponseLBS +_deleteLHWhitelistTeam :: (HasCallStack) => TeamId -> TestM ResponseLBS _deleteLHWhitelistTeam tid = do galleyCall <- viewGalley deleteLHWhitelistTeam' galleyCall tid diff --git a/services/galley/test/integration/API/Util.hs b/services/galley/test/integration/API/Util.hs index 5f80a490368..c7b157051ae 100644 --- a/services/galley/test/integration/API/Util.hs +++ b/services/galley/test/integration/API/Util.hs @@ -192,11 +192,11 @@ instance HasBrig TestM where symmPermissions :: [Perm] -> Permissions symmPermissions p = let s = Set.fromList p in fromJust (newPermissions s s) -createBindingTeam :: HasCallStack => TestM (UserId, TeamId) +createBindingTeam :: (HasCallStack) => TestM (UserId, TeamId) createBindingTeam = do first User.userId <$> createBindingTeam' -createBindingTeam' :: HasCallStack => TestM (User, TeamId) +createBindingTeam' :: (HasCallStack) => TestM (User, TeamId) createBindingTeam' = do owner <- randomTeamCreator' teams <- getTeams (User.userId owner) [] @@ -206,7 +206,7 @@ createBindingTeam' = do refreshIndex pure (owner, tid) -createBindingTeamWithMembers :: HasCallStack => Int -> TestM (TeamId, UserId, [UserId]) +createBindingTeamWithMembers :: (HasCallStack) => Int -> TestM (TeamId, UserId, [UserId]) createBindingTeamWithMembers numUsers = do (owner, tid) <- createBindingTeam members <- forM [2 .. numUsers] $ \n -> do @@ -220,7 +220,7 @@ createBindingTeamWithMembers numUsers = do pure (tid, owner, members) -createBindingTeamWithQualifiedMembers :: HasCallStack => Int -> TestM (TeamId, Qualified UserId, [Qualified UserId]) +createBindingTeamWithQualifiedMembers :: (HasCallStack) => Int -> TestM (TeamId, Qualified UserId, [Qualified UserId]) createBindingTeamWithQualifiedMembers num = do localDomain <- viewFederationDomain (tid, owner, users) <- createBindingTeamWithMembers num @@ -256,7 +256,7 @@ createBindingTeamWithNMembersWithHandles withHandles n = do pure member1 pure (owner, tid, mems) where - mkRandomHandle :: MonadIO m => m Text + mkRandomHandle :: (MonadIO m) => m Text mkRandomHandle = liftIO $ do nrs <- replicateM 21 (randomRIO (97, 122)) -- a-z pure (cs (map chr nrs)) @@ -273,7 +273,7 @@ createBindingTeamWithNMembersWithHandles withHandles n = do !!! do const 200 === statusCode -changeTeamStatus :: HasCallStack => TeamId -> TeamStatus -> TestM () +changeTeamStatus :: (HasCallStack) => TeamId -> TeamStatus -> TestM () changeTeamStatus tid s = do g <- viewGalley put @@ -284,13 +284,13 @@ changeTeamStatus tid s = do !!! const 200 === statusCode -createBindingTeamInternal :: HasCallStack => Text -> UserId -> TestM TeamId +createBindingTeamInternal :: (HasCallStack) => Text -> UserId -> TestM TeamId createBindingTeamInternal name owner = do tid <- createBindingTeamInternalNoActivate name owner changeTeamStatus tid Active pure tid -createBindingTeamInternalNoActivate :: HasCallStack => Text -> UserId -> TestM TeamId +createBindingTeamInternalNoActivate :: (HasCallStack) => Text -> UserId -> TestM TeamId createBindingTeamInternalNoActivate name owner = do g <- viewGalley tid <- randomId @@ -301,7 +301,7 @@ createBindingTeamInternalNoActivate name owner = do const True === isJust . getHeader "Location" pure tid -createBindingTeamInternalWithCurrency :: HasCallStack => Text -> UserId -> Currency.Alpha -> TestM TeamId +createBindingTeamInternalWithCurrency :: (HasCallStack) => Text -> UserId -> Currency.Alpha -> TestM TeamId createBindingTeamInternalWithCurrency name owner cur = do g <- viewGalley tid <- createBindingTeamInternalNoActivate name owner @@ -311,33 +311,33 @@ createBindingTeamInternalWithCurrency name owner cur = do === statusCode pure tid -getTeamInternal :: HasCallStack => TeamId -> TestM TeamData +getTeamInternal :: (HasCallStack) => TeamId -> TestM TeamData getTeamInternal tid = do g <- viewGalley r <- get (g . paths ["i/teams", toByteString' tid]) UserId -> TeamId -> TestM Team +getTeam :: (HasCallStack) => UserId -> TeamId -> TestM Team getTeam usr tid = do g <- viewGalley r <- get (g . paths ["teams", toByteString' tid] . zUser usr) UserId -> TeamId -> TestM TeamMemberList +getTeamMembers :: (HasCallStack) => UserId -> TeamId -> TestM TeamMemberList getTeamMembers usr tid = do g <- viewGalley r <- get (g . paths ["teams", toByteString' tid, "members"] . zUser usr) UserId -> TeamId -> TestM ResponseLBS +getTeamMembersCsv :: (HasCallStack) => UserId -> TeamId -> TestM ResponseLBS getTeamMembersCsv usr tid = do g <- viewGalley get (g . accept "text/csv" . paths ["teams", toByteString' tid, "members/csv"] . zUser usr) UserId -> TeamId -> Int -> TestM TeamMemberList +getTeamMembersTruncated :: (HasCallStack) => UserId -> TeamId -> Int -> TestM TeamMemberList getTeamMembersTruncated usr tid n = do g <- viewGalley r <- get (g . paths ["teams", toByteString' tid, "members"] . zUser usr . queryItem "maxResults" (C.pack $ show n)) o .: "pagingState" -getTeamMembersPaginated :: HasCallStack => UserId -> TeamId -> Int -> Maybe Text -> TestM ResultPage +getTeamMembersPaginated :: (HasCallStack) => UserId -> TeamId -> Int -> Maybe Text -> TestM ResultPage getTeamMembersPaginated usr tid n mPs = do g <- viewGalley r <- @@ -374,7 +374,7 @@ getTeamMembersPaginated usr tid n mPs = do === statusCode responseJsonError r -getTeamMembersInternalTruncated :: HasCallStack => TeamId -> Int -> TestM TeamMemberList +getTeamMembersInternalTruncated :: (HasCallStack) => TeamId -> Int -> TestM TeamMemberList getTeamMembersInternalTruncated tid n = do g <- viewGalley r <- @@ -387,7 +387,7 @@ getTeamMembersInternalTruncated tid n = do === statusCode responseJsonError r -bulkGetTeamMembers :: HasCallStack => UserId -> TeamId -> [UserId] -> TestM TeamMemberList +bulkGetTeamMembers :: (HasCallStack) => UserId -> TeamId -> [UserId] -> TestM TeamMemberList bulkGetTeamMembers usr tid uids = do g <- viewGalley r <- @@ -401,7 +401,7 @@ bulkGetTeamMembers usr tid uids = do === statusCode responseJsonError r -bulkGetTeamMembersTruncated :: HasCallStack => UserId -> TeamId -> [UserId] -> Int -> TestM ResponseLBS +bulkGetTeamMembersTruncated :: (HasCallStack) => UserId -> TeamId -> [UserId] -> Int -> TestM ResponseLBS bulkGetTeamMembersTruncated usr tid uids trnc = do g <- viewGalley post @@ -412,7 +412,7 @@ bulkGetTeamMembersTruncated usr tid uids trnc = do . json (UserIdList uids) ) -getTeamMember :: HasCallStack => UserId -> TeamId -> UserId -> TestM TeamMember +getTeamMember :: (HasCallStack) => UserId -> TeamId -> UserId -> TestM TeamMember getTeamMember getter tid gettee = do g <- viewGalley getTeamMember' g getter tid gettee @@ -422,13 +422,13 @@ getTeamMember' g getter tid gettee = do r <- get (g . paths ["teams", toByteString' tid, "members", toByteString' gettee] . zUser getter) TeamId -> UserId -> TestM TeamMember +getTeamMemberInternal :: (HasCallStack) => TeamId -> UserId -> TestM TeamMember getTeamMemberInternal tid mid = do g <- viewGalley r <- get (g . paths ["i", "teams", toByteString' tid, "members", toByteString' mid]) UserId -> TeamId -> UserId -> Permissions -> Maybe (UserId, UTCTimeMillis) -> TestM () +addTeamMember :: (HasCallStack) => UserId -> TeamId -> UserId -> Permissions -> Maybe (UserId, UTCTimeMillis) -> TestM () addTeamMember usr tid muid mperms mmbinv = do g <- viewGalley let payload = json (mkNewTeamMember muid mperms mmbinv) @@ -437,23 +437,23 @@ addTeamMember usr tid muid mperms mmbinv = do === statusCode -- | FUTUREWORK: do not use this, it's broken!! use 'addUserToTeam' instead! https://wearezeta.atlassian.net/browse/SQSERVICES-471 -addTeamMemberInternal :: HasCallStack => TeamId -> UserId -> Permissions -> Maybe (UserId, UTCTimeMillis) -> TestM () +addTeamMemberInternal :: (HasCallStack) => TeamId -> UserId -> Permissions -> Maybe (UserId, UTCTimeMillis) -> TestM () addTeamMemberInternal tid muid mperms mmbinv = addTeamMemberInternal' tid muid mperms mmbinv !!! const 200 === statusCode -- | FUTUREWORK: do not use this, it's broken!! use 'addUserToTeam' instead! https://wearezeta.atlassian.net/browse/SQSERVICES-471 -addTeamMemberInternal' :: HasCallStack => TeamId -> UserId -> Permissions -> Maybe (UserId, UTCTimeMillis) -> TestM ResponseLBS +addTeamMemberInternal' :: (HasCallStack) => TeamId -> UserId -> Permissions -> Maybe (UserId, UTCTimeMillis) -> TestM ResponseLBS addTeamMemberInternal' tid muid mperms mmbinv = do g <- viewGalley let payload = json (mkNewTeamMember muid mperms mmbinv) post (g . paths ["i", "teams", toByteString' tid, "members"] . payload) -addUserToTeam :: HasCallStack => UserId -> TeamId -> TestM TeamMember +addUserToTeam :: (HasCallStack) => UserId -> TeamId -> TestM TeamMember addUserToTeam = addUserToTeamWithRole Nothing -addUserToTeam' :: HasCallStack => UserId -> TeamId -> TestM ResponseLBS +addUserToTeam' :: (HasCallStack) => UserId -> TeamId -> TestM ResponseLBS addUserToTeam' u t = snd <$> addUserToTeamWithRole' Nothing u t -addUserToTeamWithRole :: HasCallStack => Maybe Role -> UserId -> TeamId -> TestM TeamMember +addUserToTeamWithRole :: (HasCallStack) => Maybe Role -> UserId -> TeamId -> TestM TeamMember addUserToTeamWithRole role inviter tid = do (inv, rsp2) <- addUserToTeamWithRole' role inviter tid let invitee :: User = responseJsonUnsafe rsp2 @@ -465,7 +465,7 @@ addUserToTeamWithRole role inviter tid = do liftIO $ assertEqual "Wrong cookie" (Just "zuid") (setCookieName <$> zuid) pure mem -addUserToTeamWithRole' :: HasCallStack => Maybe Role -> UserId -> TeamId -> TestM (Invitation, ResponseLBS) +addUserToTeamWithRole' :: (HasCallStack) => Maybe Role -> UserId -> TeamId -> TestM (Invitation, ResponseLBS) addUserToTeamWithRole' role inviter tid = do brig <- viewBrig inviteeEmail <- randomEmail @@ -482,13 +482,13 @@ addUserToTeamWithRole' role inviter tid = do ) pure (inv, r) -addUserToTeamWithSSO :: HasCallStack => Bool -> TeamId -> TestM TeamMember +addUserToTeamWithSSO :: (HasCallStack) => Bool -> TeamId -> TestM TeamMember addUserToTeamWithSSO hasEmail tid = do let ssoid = UserSSOId mkSimpleSampleUref uid <- fmap (\(u :: User) -> User.userId u) $ responseJsonError =<< postSSOUser "SSO User" hasEmail ssoid tid getTeamMember uid tid uid -makeOwner :: HasCallStack => UserId -> TeamMember -> TeamId -> TestM () +makeOwner :: (HasCallStack) => UserId -> TeamMember -> TeamId -> TestM () makeOwner owner mem tid = do galley <- viewGalley let changeMember = mkNewTeamMember (mem ^. Team.userId) fullPermissions (mem ^. Team.invitation) @@ -528,7 +528,7 @@ zAuthAccess u conn = . zConn conn . zType "access" -getInvitationCode :: HasCallStack => TeamId -> InvitationId -> TestM InvitationCode +getInvitationCode :: (HasCallStack) => TeamId -> InvitationId -> TestM InvitationCode getInvitationCode t ref = do brig <- viewBrig @@ -554,7 +554,7 @@ getInvitationCode t ref = do -- and therefore cannot be unset. However, given that this is to test the legacy -- API (i.e., no roles) it's fine to hardcode the JSON object in the test since -- it clearly shows the API that old(er) clients use. -createTeamConvLegacy :: HasCallStack => UserId -> TeamId -> [UserId] -> Maybe Text -> TestM ConvId +createTeamConvLegacy :: (HasCallStack) => UserId -> TeamId -> [UserId] -> Maybe Text -> TestM ConvId createTeamConvLegacy u tid us name = do g <- viewGalley let tinfo = ConvTeamInfo tid @@ -575,7 +575,7 @@ createTeamConvLegacy u tid us name = do >>= \r -> fromBS (getHeader' "Location" r) createTeamConv :: - HasCallStack => + (HasCallStack) => UserId -> TeamId -> [UserId] -> @@ -586,7 +586,7 @@ createTeamConv :: createTeamConv u tid us name acc mtimer = createTeamConvAccess u tid us name acc Nothing mtimer (Just roleNameWireAdmin) createTeamConvWithRole :: - HasCallStack => + (HasCallStack) => UserId -> TeamId -> [UserId] -> @@ -598,7 +598,7 @@ createTeamConvWithRole :: createTeamConvWithRole u tid us name acc mtimer convRole = createTeamConvAccess u tid us name acc Nothing mtimer (Just convRole) createTeamConvAccess :: - HasCallStack => + (HasCallStack) => UserId -> TeamId -> [UserId] -> @@ -732,7 +732,7 @@ postConvQualified u c n = do . json n postConvWithRemoteUsersGeneric :: - HasCallStack => + (HasCallStack) => Mock LByteString -> UserId -> Maybe ClientId -> @@ -752,7 +752,7 @@ postConvWithRemoteUsersGeneric m u c n = do setName x = x postConvWithRemoteUsers :: - HasCallStack => + (HasCallStack) => UserId -> Maybe ClientId -> NewConv -> @@ -994,7 +994,7 @@ mkOtrPayload sender rec reportMissingBody ad = mkOtrMessage :: (UserId, ClientId, Text) -> (Text, HashMap.HashMap Text Text) mkOtrMessage (usr, clt, m) = (fn usr, HashMap.singleton (fn clt) m) where - fn :: ToByteString a => a -> Text + fn :: (ToByteString a) => a -> Text fn = fromJust . fromByteString . toByteString' postProtoOtrMessage :: UserId -> ClientId -> ConvId -> OtrRecipients -> TestM ResponseLBS @@ -1023,7 +1023,7 @@ mkOtrProtoMessage sender rec reportMissing ad = & Proto.newOtrMessageData ?~ fromBase64TextLenient ad & Proto.newOtrMessageReportMissing .~ rmis -getConvs :: HasCallStack => UserId -> [Qualified ConvId] -> TestM ResponseLBS +getConvs :: (HasCallStack) => UserId -> [Qualified ConvId] -> TestM ResponseLBS getConvs u cids = do g <- viewGalley post $ @@ -1033,7 +1033,7 @@ getConvs u cids = do . zConn "conn" . json (ListConversations (unsafeRange cids)) -getConvClients :: HasCallStack => GroupId -> TestM ClientList +getConvClients :: (HasCallStack) => GroupId -> TestM ClientList getConvClients gid = do g <- viewGalley responseJsonError @@ -1042,7 +1042,7 @@ getConvClients gid = do . paths ["i", "group", B64U.encode $ unGroupId gid] ) -getAllConvs :: HasCallStack => UserId -> TestM [Conversation] +getAllConvs :: (HasCallStack) => UserId -> TestM [Conversation] getAllConvs u = do g <- viewGalley cids <- do @@ -1514,7 +1514,7 @@ deleteUser u = do g <- viewGalley delete (g . path "/i/user" . zUser u) -getTeamQueue :: HasCallStack => UserId -> Maybe NotificationId -> Maybe (Int, Bool) -> Bool -> TestM [(NotificationId, UserId)] +getTeamQueue :: (HasCallStack) => UserId -> Maybe NotificationId -> Maybe (Int, Bool) -> Bool -> TestM [(NotificationId, UserId)] getTeamQueue zusr msince msize onlyLast = parseEventList . responseJsonUnsafe <$> ( getTeamQueue' zusr msince (fst <$> msize) onlyLast @@ -1542,7 +1542,7 @@ getTeamQueue zusr msince msize onlyLast = EdMemberJoin uid -> uid _ -> error ("bad event type: " <> show (TE.eventType e)) -getTeamQueue' :: HasCallStack => UserId -> Maybe NotificationId -> Maybe Int -> Bool -> TestM ResponseLBS +getTeamQueue' :: (HasCallStack) => UserId -> Maybe NotificationId -> Maybe Int -> Bool -> TestM ResponseLBS getTeamQueue' zusr msince msize onlyLast = do g <- viewGalley get @@ -1581,7 +1581,7 @@ registerRemoteConv convId originUser name othMembers = do protocol = ProtocolProteus } -getFeatureStatusMulti :: forall cfg. KnownSymbol (FeatureSymbol cfg) => Multi.TeamFeatureNoConfigMultiRequest -> TestM ResponseLBS +getFeatureStatusMulti :: forall cfg. (KnownSymbol (FeatureSymbol cfg)) => Multi.TeamFeatureNoConfigMultiRequest -> TestM ResponseLBS getFeatureStatusMulti req = do g <- viewGalley post @@ -1593,20 +1593,20 @@ getFeatureStatusMulti req = do ------------------------------------------------------------------------------- -- Common Assertions -assertConvMemberWithRole :: HasCallStack => RoleName -> ConvId -> Qualified UserId -> TestM () +assertConvMemberWithRole :: (HasCallStack) => RoleName -> ConvId -> Qualified UserId -> TestM () assertConvMemberWithRole r c u = getSelfMember (qUnqualified u) c !!! do const 200 === statusCode const (Right u) === (fmap memId <$> responseJsonEither) const (Right r) === (fmap memConvRoleName <$> responseJsonEither) -assertConvMember :: HasCallStack => Qualified UserId -> ConvId -> TestM () +assertConvMember :: (HasCallStack) => Qualified UserId -> ConvId -> TestM () assertConvMember u c = getSelfMember (qUnqualified u) c !!! do const 200 === statusCode const (Right u) === (fmap memId <$> responseJsonEither) -assertNotConvMember :: HasCallStack => UserId -> ConvId -> TestM () +assertNotConvMember :: (HasCallStack) => UserId -> ConvId -> TestM () assertNotConvMember u c = getSelfMember u c !!! do const 200 === statusCode @@ -1627,7 +1627,7 @@ assertConvEquals c1 c2 = liftIO $ do otherMembers = Set.fromList . cmOthers . cnvMembers assertConv :: - HasCallStack => + (HasCallStack) => Response (Maybe Lazy.ByteString) -> ConvType -> Maybe UserId -> @@ -1639,7 +1639,7 @@ assertConv :: assertConv r t c s us n mt = assertConvWithRole r t c s us n mt roleNameWireAdmin assertConvWithRole :: - HasCallStack => + (HasCallStack) => Response (Maybe Lazy.ByteString) -> ConvType -> Maybe UserId -> @@ -1675,7 +1675,7 @@ assertConvWithRole r t c s us n mt role = do pure (cnvQualifiedId cnv) wsAssertOtr :: - HasCallStack => + (HasCallStack) => Qualified ConvId -> Qualified UserId -> ClientId -> @@ -1686,7 +1686,7 @@ wsAssertOtr :: wsAssertOtr = wsAssertOtr' "ZXhhbXBsZQ==" wsAssertOtr' :: - HasCallStack => + (HasCallStack) => Text -> Qualified ConvId -> Qualified UserId -> @@ -1704,7 +1704,7 @@ wsAssertOtr' evData conv usr from to txt n = do evtData e @?= EdOtrMessage (OtrMessage from to txt (Just evData)) wsAssertMLSWelcome :: - HasCallStack => + (HasCallStack) => Qualified UserId -> Qualified ConvId -> ByteString -> @@ -1719,7 +1719,7 @@ wsAssertMLSWelcome u cid welcome n = do evtData e @?= EdMLSWelcome welcome wsAssertMLSMessage :: - HasCallStack => + (HasCallStack) => Qualified ConvOrSubConvId -> Qualified UserId -> ByteString -> @@ -1731,7 +1731,7 @@ wsAssertMLSMessage qcs u message n = do assertMLSMessageEvent qcs u message e wsAssertClientRemoved :: - HasCallStack => + (HasCallStack) => ClientId -> Notification -> IO () @@ -1743,7 +1743,7 @@ wsAssertClientRemoved cid n = do (fromByteString . T.encodeUtf8 =<< eclient) @?= Just cid wsAssertClientAdded :: - HasCallStack => + (HasCallStack) => ClientId -> Notification -> IO () @@ -1755,7 +1755,7 @@ wsAssertClientAdded cid n = do (fromByteString . T.encodeUtf8 =<< eclient) @?= Just cid assertMLSMessageEvent :: - HasCallStack => + (HasCallStack) => Qualified ConvOrSubConvId -> Qualified UserId -> ByteString -> @@ -1772,10 +1772,10 @@ assertMLSMessageEvent qcs u message e = do evtData e @?= EdMLSMessage message -- | This assumes the default role name -wsAssertMemberJoin :: HasCallStack => Qualified ConvId -> Qualified UserId -> [Qualified UserId] -> Notification -> IO () +wsAssertMemberJoin :: (HasCallStack) => Qualified ConvId -> Qualified UserId -> [Qualified UserId] -> Notification -> IO () wsAssertMemberJoin conv usr new = wsAssertMemberJoinWithRole conv usr new roleNameWireAdmin -wsAssertMemberJoinWithRole :: HasCallStack => Qualified ConvId -> Qualified UserId -> [Qualified UserId] -> RoleName -> Notification -> IO () +wsAssertMemberJoinWithRole :: (HasCallStack) => Qualified ConvId -> Qualified UserId -> [Qualified UserId] -> RoleName -> Notification -> IO () wsAssertMemberJoinWithRole conv usr new role n = do let e = List1.head (WS.unpackPayload n) ntfTransient n @?= False @@ -1789,7 +1789,7 @@ assertJoinEvent conv usr new role e = do fmap (sort . mMembers) (evtData e ^? _EdMembersJoin) @?= Just (sort (fmap (`SimpleMember` role) new)) wsAssertFederationDeleted :: - HasCallStack => + (HasCallStack) => Domain -> Notification -> IO () @@ -1811,7 +1811,7 @@ assertFederationDeletedEvent dom e = do -- -- or if they can be combined in general. wsAssertMembersLeave :: - HasCallStack => + (HasCallStack) => Qualified ConvId -> Qualified UserId -> [Qualified UserId] -> @@ -1877,7 +1877,7 @@ wsAssertMemberLeave conv usr old reason n = do sorted (EdMembersLeave _ (QualifiedUserIdList m)) = EdMembersLeave reason (QualifiedUserIdList (sort m)) sorted x = x -wsAssertTyping :: HasCallStack => Qualified ConvId -> Qualified UserId -> TypingStatus -> Notification -> IO () +wsAssertTyping :: (HasCallStack) => Qualified ConvId -> Qualified UserId -> TypingStatus -> Notification -> IO () wsAssertTyping conv usr ts n = do let e = List1.head (WS.unpackPayload n) ntfTransient n @?= True @@ -1886,7 +1886,7 @@ wsAssertTyping conv usr ts n = do evtFrom e @?= usr evtData e @?= EdTyping ts -assertNoMsg :: HasCallStack => WS.WebSocket -> (Notification -> Assertion) -> TestM () +assertNoMsg :: (HasCallStack) => WS.WebSocket -> (Notification -> Assertion) -> TestM () assertNoMsg ws f = do x <- WS.awaitMatch (1 # Second) ws f liftIO $ case x of @@ -1919,7 +1919,7 @@ assertLeaveUpdate req qconvId remover alreadyPresentUsers = liftIO $ do ------------------------------------------------------------------------------- -- Helpers -testResponse :: HasCallStack => Int -> Maybe TestErrorLabel -> Assertions () +testResponse :: (HasCallStack) => Int -> Maybe TestErrorLabel -> Assertions () testResponse status mlabel = do const status === statusCode case mlabel of @@ -1943,16 +1943,16 @@ decodeConvCodeEvent r = case responseJsonUnsafe r of (Event _ _ _ _ (EdConvCodeUpdate c)) -> c _ -> error "Failed to parse ConversationCode from Event" -decodeConvId :: HasCallStack => Response (Maybe Lazy.ByteString) -> ConvId +decodeConvId :: (HasCallStack) => Response (Maybe Lazy.ByteString) -> ConvId decodeConvId = qUnqualified . decodeQualifiedConvId -decodeQualifiedConvId :: HasCallStack => Response (Maybe Lazy.ByteString) -> Qualified ConvId +decodeQualifiedConvId :: (HasCallStack) => Response (Maybe Lazy.ByteString) -> Qualified ConvId decodeQualifiedConvId = cnvQualifiedId . responseJsonUnsafe -decodeConvList :: HasCallStack => Response (Maybe Lazy.ByteString) -> [Conversation] +decodeConvList :: (HasCallStack) => Response (Maybe Lazy.ByteString) -> [Conversation] decodeConvList = convList . responseJsonUnsafeWithMsg "conversations" -decodeConvIdList :: HasCallStack => Response (Maybe Lazy.ByteString) -> [ConvId] +decodeConvIdList :: (HasCallStack) => Response (Maybe Lazy.ByteString) -> [ConvId] decodeConvIdList = convList . responseJsonUnsafeWithMsg "conversation-ids" decodeQualifiedConvIdList :: Response (Maybe Lazy.ByteString) -> Either String [Qualified ConvId] @@ -2114,7 +2114,7 @@ putConnectionQualified fromQualified to r = do payload = RequestBodyLBS . encode $ object ["status" .= r] -- | A copy of `assertConnections from Brig integration tests. -assertConnections :: HasCallStack => UserId -> [ConnectionStatus] -> TestM () +assertConnections :: (HasCallStack) => UserId -> [ConnectionStatus] -> TestM () assertConnections u cstat = do brig <- view tsUnversionedBrig resp <- listConnections brig u TestM [UserId] randomUsers n = replicateM n randomUser -randomUserTuple :: HasCallStack => TestM (UserId, Qualified UserId) +randomUserTuple :: (HasCallStack) => TestM (UserId, Qualified UserId) randomUserTuple = do qUid <- randomQualifiedUser pure (qUnqualified qUid, qUid) -randomUser :: HasCallStack => TestM UserId +randomUser :: (HasCallStack) => TestM UserId randomUser = qUnqualified <$> randomUser' False True True -randomQualifiedUser :: HasCallStack => TestM (Qualified UserId) +randomQualifiedUser :: (HasCallStack) => TestM (Qualified UserId) randomQualifiedUser = randomUser' False True True -randomQualifiedId :: MonadIO m => Domain -> m (Qualified (Id a)) +randomQualifiedId :: (MonadIO m) => Domain -> m (Qualified (Id a)) randomQualifiedId domain = Qualified <$> randomId <*> pure domain -randomTeamCreator :: HasCallStack => TestM UserId +randomTeamCreator :: (HasCallStack) => TestM UserId randomTeamCreator = qUnqualified <$> randomUser' True True True -randomTeamCreator' :: HasCallStack => TestM User +randomTeamCreator' :: (HasCallStack) => TestM User randomTeamCreator' = randomUser'' True True True -randomUser' :: HasCallStack => Bool -> Bool -> Bool -> TestM (Qualified UserId) +randomUser' :: (HasCallStack) => Bool -> Bool -> Bool -> TestM (Qualified UserId) randomUser' isCreator hasPassword hasEmail = userQualifiedId <$> randomUser'' isCreator hasPassword hasEmail -randomUser'' :: HasCallStack => Bool -> Bool -> Bool -> TestM User +randomUser'' :: (HasCallStack) => Bool -> Bool -> Bool -> TestM User randomUser'' isCreator hasPassword hasEmail = selfUser <$> randomUserProfile' isCreator hasPassword hasEmail -randomUserProfile' :: HasCallStack => Bool -> Bool -> Bool -> TestM SelfProfile +randomUserProfile' :: (HasCallStack) => Bool -> Bool -> Bool -> TestM SelfProfile randomUserProfile' isCreator hasPassword hasEmail = do b <- viewBrig e <- liftIO randomEmail @@ -2168,7 +2168,7 @@ randomUserProfile' isCreator hasPassword hasEmail = do <> ["team" .= BindingNewTeam (newNewTeam (unsafeRange "teamName") DefaultIcon) | isCreator] responseJsonUnsafe <$> (post (b . path "/i/users" . json p) TestM UserId +ephemeralUser :: (HasCallStack) => TestM UserId ephemeralUser = do b <- viewBrig name <- UUID.toText <$> liftIO nextRandom @@ -2177,10 +2177,10 @@ ephemeralUser = do user <- responseJsonError r pure $ User.userId user -randomClient :: HasCallStack => UserId -> LastPrekey -> TestM ClientId +randomClient :: (HasCallStack) => UserId -> LastPrekey -> TestM ClientId randomClient uid lk = randomClientWithCaps uid lk Nothing -randomClientWithCaps :: HasCallStack => UserId -> LastPrekey -> Maybe (Set Client.ClientCapability) -> TestM ClientId +randomClientWithCaps :: (HasCallStack) => UserId -> LastPrekey -> Maybe (Set Client.ClientCapability) -> TestM ClientId randomClientWithCaps uid lk caps = do b <- viewBrig resp <- @@ -2203,12 +2203,12 @@ randomClientWithCaps uid lk caps = do newClientCapabilities = caps } -ensureDeletedState :: HasCallStack => Bool -> UserId -> UserId -> TestM () +ensureDeletedState :: (HasCallStack) => Bool -> UserId -> UserId -> TestM () ensureDeletedState check from u = do state <- getDeletedState from u liftIO $ assertEqual "Unxpected deleted state" state (Just check) -getDeletedState :: HasCallStack => UserId -> UserId -> TestM (Maybe Bool) +getDeletedState :: (HasCallStack) => UserId -> UserId -> TestM (Maybe Bool) getDeletedState from u = do b <- view tsUnversionedBrig fmap profileDeleted . responseJsonMaybe @@ -2239,7 +2239,7 @@ getInternalClientsFull userSet = do . json userSet responseJsonError res -ensureClientCaps :: HasCallStack => UserId -> ClientId -> Client.ClientCapabilityList -> TestM () +ensureClientCaps :: (HasCallStack) => UserId -> ClientId -> Client.ClientCapabilityList -> TestM () ensureClientCaps uid cid caps = do UserClientsFull (Map.lookup uid -> (Just clnts)) <- getInternalClientsFull (UserSet $ Set.singleton uid) clnt <- assertOne . filter ((== cid) . clientId) $ Set.toList clnts @@ -2264,7 +2264,7 @@ deleteClient u c pw = do ] -- TODO: Refactor, as used also in brig -isUserDeleted :: HasCallStack => UserId -> TestM Bool +isUserDeleted :: (HasCallStack) => UserId -> TestM Bool isUserDeleted u = do b <- viewBrig r <- @@ -2278,7 +2278,7 @@ isUserDeleted u = do let decoded = fromMaybe (error $ "getStatus: failed to decode status" ++ show j) st pure $ decoded == Deleted where - maybeFromJSON :: FromJSON a => Value -> Maybe a + maybeFromJSON :: (FromJSON a) => Value -> Maybe a maybeFromJSON v = case fromJSON v of Success a -> Just a _ -> Nothing @@ -2352,7 +2352,7 @@ assertBroadcastMismatch localDomain BroadcastQualified = assertBroadcastMismatch _ _ = assertMismatch assertMismatchWithMessage :: - HasCallStack => + (HasCallStack) => Maybe String -> [(UserId, Set ClientId)] -> [(UserId, Set ClientId)] -> @@ -2370,7 +2370,7 @@ assertMismatchWithMessage mmsg missing redundant deleted = do formatMessage = maybe Imports.id (\msg -> ((msg <> "\n") <>)) mmsg assertMismatch :: - HasCallStack => + (HasCallStack) => [(UserId, Set ClientId)] -> [(UserId, Set ClientId)] -> [(UserId, Set ClientId)] -> @@ -2378,7 +2378,7 @@ assertMismatch :: assertMismatch = assertMismatchWithMessage Nothing assertMismatchQualified :: - HasCallStack => + (HasCallStack) => Client.QualifiedUserClients -> Client.QualifiedUserClients -> Client.QualifiedUserClients -> @@ -2405,7 +2405,7 @@ genRandom = liftIO . Q.generate $ Q.arbitrary defPassword :: PlainTextPassword6 defPassword = plainTextPassword6Unsafe "topsecretdefaultpassword" -randomEmail :: MonadIO m => m Email +randomEmail :: (MonadIO m) => m Email randomEmail = do uid <- liftIO nextRandom pure $ Email ("success+" <> UUID.toText uid) "simulator.amazonses.com" @@ -2604,11 +2604,11 @@ getUserProfile zusr uid = do res <- get (brig . zUser zusr . paths ["v1", "users", toByteString' uid]) responseJsonError res -upgradeClientToLH :: HasCallStack => UserId -> ClientId -> TestM () +upgradeClientToLH :: (HasCallStack) => UserId -> ClientId -> TestM () upgradeClientToLH zusr cid = putCapabilities zusr cid [ClientSupportsLegalholdImplicitConsent] -putCapabilities :: HasCallStack => UserId -> ClientId -> [ClientCapability] -> TestM () +putCapabilities :: (HasCallStack) => UserId -> ClientId -> [ClientCapability] -> TestM () putCapabilities zusr cid caps = do brig <- viewBrig void $ @@ -2620,7 +2620,7 @@ putCapabilities zusr cid caps = do . expect2xx ) -getUsersPrekeysClientUnqualified :: HasCallStack => UserId -> UserId -> ClientId -> TestM ResponseLBS +getUsersPrekeysClientUnqualified :: (HasCallStack) => UserId -> UserId -> ClientId -> TestM ResponseLBS getUsersPrekeysClientUnqualified zusr uid cid = do brig <- view tsUnversionedBrig get @@ -2629,7 +2629,7 @@ getUsersPrekeysClientUnqualified zusr uid cid = do . paths ["v1", "users", toByteString' uid, "prekeys", toByteString' cid] ) -getUsersPrekeyBundleUnqualified :: HasCallStack => UserId -> UserId -> TestM ResponseLBS +getUsersPrekeyBundleUnqualified :: (HasCallStack) => UserId -> UserId -> TestM ResponseLBS getUsersPrekeyBundleUnqualified zusr uid = do brig <- view tsUnversionedBrig get @@ -2638,7 +2638,7 @@ getUsersPrekeyBundleUnqualified zusr uid = do . paths ["v1", "users", toByteString' uid, "prekeys"] ) -getMultiUserPrekeyBundleUnqualified :: HasCallStack => UserId -> UserClients -> TestM ResponseLBS +getMultiUserPrekeyBundleUnqualified :: (HasCallStack) => UserId -> UserClients -> TestM ResponseLBS getMultiUserPrekeyBundleUnqualified zusr userClients = do brig <- view tsUnversionedBrig post @@ -2691,7 +2691,7 @@ withTempMockFederator' resp action = do -- FederatedRequest against it. makeFedRequestToServant :: forall (api :: Type). - HasServer api '[] => + (HasServer api '[]) => Domain -> Server api -> FederatedRequest -> @@ -2745,12 +2745,12 @@ aFewTimes action good = do (\_ -> pure . not . good) (\_ -> runReaderT (runTestM action) env) -aFewTimesAssertBool :: HasCallStack => String -> (a -> Bool) -> TestM a -> TestM () +aFewTimesAssertBool :: (HasCallStack) => String -> (a -> Bool) -> TestM a -> TestM () aFewTimesAssertBool msg good action = do result <- aFewTimes action good liftIO $ assertBool msg (good result) -checkUserUpdateEvent :: HasCallStack => UserId -> WS.WebSocket -> TestM () +checkUserUpdateEvent :: (HasCallStack) => UserId -> WS.WebSocket -> TestM () checkUserUpdateEvent uid w = WS.assertMatch_ checkTimeout w $ \notif -> do let j = Object $ List1.head (ntfPayload notif) let etype = j ^? key "type" . _String @@ -2758,7 +2758,7 @@ checkUserUpdateEvent uid w = WS.assertMatch_ checkTimeout w $ \notif -> do etype @?= Just "user.update" euser @?= Just (UUID.toText (toUUID uid)) -checkUserDeleteEvent :: HasCallStack => UserId -> WS.Timeout -> WS.WebSocket -> TestM () +checkUserDeleteEvent :: (HasCallStack) => UserId -> WS.Timeout -> WS.WebSocket -> TestM () checkUserDeleteEvent uid timeout_ w = WS.assertMatch_ timeout_ w $ \notif -> do let j = Object $ List1.head (ntfPayload notif) let etype = j ^? key "type" . _String @@ -2766,14 +2766,14 @@ checkUserDeleteEvent uid timeout_ w = WS.assertMatch_ timeout_ w $ \notif -> do etype @?= Just "user.delete" euser @?= Just (UUID.toText (toUUID uid)) -checkTeamMemberJoin :: HasCallStack => TeamId -> UserId -> WS.WebSocket -> TestM () +checkTeamMemberJoin :: (HasCallStack) => TeamId -> UserId -> WS.WebSocket -> TestM () checkTeamMemberJoin tid uid w = WS.assertMatch_ checkTimeout w $ \notif -> do ntfTransient notif @?= True let e = List1.head (WS.unpackPayload notif) e ^. eventTeam @?= tid e ^. eventData @?= EdMemberJoin uid -checkTeamMemberLeave :: HasCallStack => TeamId -> UserId -> WS.WebSocket -> TestM () +checkTeamMemberLeave :: (HasCallStack) => TeamId -> UserId -> WS.WebSocket -> TestM () checkTeamMemberLeave tid usr w = WS.assertMatch_ checkTimeout w $ \notif -> do ntfTransient notif @?= True let e = List1.head (WS.unpackPayload notif) @@ -2787,7 +2787,7 @@ checkTeamUpdateEvent tid upd w = WS.assertMatch_ checkTimeout w $ \notif -> do e ^. eventTeam @?= tid e ^. eventData @?= EdTeamUpdate upd -checkConvCreateEvent :: (MonadIO m, MonadCatch m) => HasCallStack => ConvId -> WS.WebSocket -> m () +checkConvCreateEvent :: (MonadIO m, MonadCatch m) => (HasCallStack) => ConvId -> WS.WebSocket -> m () checkConvCreateEvent cid w = WS.assertMatch_ checkTimeout w $ \notif -> do ntfTransient notif @?= False let e = List1.head (WS.unpackPayload notif) @@ -2797,7 +2797,7 @@ checkConvCreateEvent cid w = WS.assertMatch_ checkTimeout w $ \notif -> do other -> assertFailure $ "Unexpected event data: " <> show other wsAssertConvCreate :: - HasCallStack => + (HasCallStack) => Qualified ConvId -> Qualified UserId -> Notification -> @@ -2810,7 +2810,7 @@ wsAssertConvCreate conv eventFrom n = do evtFrom e @?= eventFrom wsAssertConvCreateWithRole :: - HasCallStack => + (HasCallStack) => Qualified ConvId -> Qualified UserId -> Qualified UserId -> @@ -2828,14 +2828,14 @@ wsAssertConvCreateWithRole conv eventFrom selfMember otherMembers n = do where toOtherMember (quid, role) = OtherMember quid Nothing role -checkTeamDeleteEvent :: HasCallStack => TeamId -> WS.WebSocket -> TestM () +checkTeamDeleteEvent :: (HasCallStack) => TeamId -> WS.WebSocket -> TestM () checkTeamDeleteEvent tid w = WS.assertMatch_ checkTimeout w $ \notif -> do ntfTransient notif @?= False let e = List1.head (WS.unpackPayload notif) e ^. eventTeam @?= tid e ^. eventData @?= EdTeamDelete -checkConvDeleteEvent :: HasCallStack => Qualified ConvId -> WS.WebSocket -> TestM () +checkConvDeleteEvent :: (HasCallStack) => Qualified ConvId -> WS.WebSocket -> TestM () checkConvDeleteEvent cid w = WS.assertMatch_ checkTimeout w $ \notif -> do ntfTransient notif @?= False let e = List1.head (WS.unpackPayload notif) @@ -2843,7 +2843,7 @@ checkConvDeleteEvent cid w = WS.assertMatch_ checkTimeout w $ \notif -> do evtConv e @?= cid evtData e @?= Conv.EdConvDelete -checkConvMemberLeaveEvent :: HasCallStack => Qualified ConvId -> Qualified UserId -> WS.WebSocket -> TestM () +checkConvMemberLeaveEvent :: (HasCallStack) => Qualified ConvId -> Qualified UserId -> WS.WebSocket -> TestM () checkConvMemberLeaveEvent cid usr w = WS.assertMatch_ checkTimeout w $ \notif -> do ntfTransient notif @?= False let e = List1.head (WS.unpackPayload notif) @@ -2863,11 +2863,11 @@ mockedFederatedBrigResponse users = do guardComponent Brig mockReply [mkProfile mem (Name name) | (mem, name) <- users] -fedRequestsForDomain :: HasCallStack => Domain -> Component -> [FederatedRequest] -> [FederatedRequest] +fedRequestsForDomain :: (HasCallStack) => Domain -> Component -> [FederatedRequest] -> [FederatedRequest] fedRequestsForDomain domain component = filter $ \req -> frTargetDomain req == domain && frComponent req == component -parseFedRequest :: FromJSON a => FederatedRequest -> Either String a +parseFedRequest :: (FromJSON a) => FederatedRequest -> Either String a parseFedRequest fr = eitherDecode (frBody fr) assertOne :: (HasCallStack, MonadIO m, Show a) => [a] -> m a @@ -2895,7 +2895,7 @@ iUpsertOne2OneConversation req = do galley <- viewGalley post (galley . path "/i/conversations/one2one/upsert" . Bilge.json req) -createOne2OneConvWithRemote :: HasCallStack => Local UserId -> Remote UserId -> TestM () +createOne2OneConvWithRemote :: (HasCallStack) => Local UserId -> Remote UserId -> TestM () createOne2OneConvWithRemote localUser remoteUser = do let convId = one2OneConvId BaseProtocolProteusTag (tUntagged localUser) (tUntagged remoteUser) mkRequest actor = @@ -2927,7 +2927,7 @@ matchFedRequest domain reqpath req = frTargetDomain req == domain && frRPC req == reqpath -spawn :: HasCallStack => CreateProcess -> Maybe ByteString -> IO ByteString +spawn :: (HasCallStack) => CreateProcess -> Maybe ByteString -> IO ByteString spawn cp minput = do (mout, ex) <- withCreateProcess cp @@ -2943,7 +2943,7 @@ spawn cp minput = do (Just out, ExitSuccess) -> pure out _ -> assertFailure "Process didn't finish successfully" -decodeMLSError :: ParseMLS a => ByteString -> IO a +decodeMLSError :: (ParseMLS a) => ByteString -> IO a decodeMLSError s = case decodeMLS' s of Left e -> assertFailure ("Could not parse MLS object: " <> Text.unpack e) Right x -> pure x @@ -2957,7 +2957,7 @@ wsAssertConvReceiptModeUpdate conv usr new n = do evtFrom e @?= usr evtData e @?= EdConvReceiptModeUpdate (ConversationReceiptModeUpdate new) -wsAssertBackendRemoveProposalWithEpoch :: HasCallStack => Qualified UserId -> Qualified ConvId -> LeafIndex -> Epoch -> Notification -> IO ByteString +wsAssertBackendRemoveProposalWithEpoch :: (HasCallStack) => Qualified UserId -> Qualified ConvId -> LeafIndex -> Epoch -> Notification -> IO ByteString wsAssertBackendRemoveProposalWithEpoch fromUser convId idx epoch n = do bs <- wsAssertBackendRemoveProposal fromUser (Conv <$> convId) idx n let msg = fromRight (error "Failed to parse Message") $ decodeMLS' @Message bs @@ -2966,7 +2966,7 @@ wsAssertBackendRemoveProposalWithEpoch fromUser convId idx epoch n = do _ -> assertFailure "unexpected message content" pure bs -wsAssertBackendRemoveProposal :: HasCallStack => Qualified UserId -> Qualified ConvOrSubConvId -> LeafIndex -> Notification -> IO ByteString +wsAssertBackendRemoveProposal :: (HasCallStack) => Qualified UserId -> Qualified ConvOrSubConvId -> LeafIndex -> Notification -> IO ByteString wsAssertBackendRemoveProposal fromUser cnvOrSubCnv idx n = do let e = List1.head (WS.unpackPayload n) ntfTransient n @?= False @@ -2991,7 +2991,7 @@ wsAssertBackendRemoveProposal fromUser cnvOrSubCnv idx n = do getMLSMessageData d = error ("Expected EdMLSMessage, but got " <> show d) wsAssertAddProposal :: - HasCallStack => + (HasCallStack) => Qualified UserId -> Qualified ConvId -> Notification -> diff --git a/services/galley/test/integration/API/Util/TeamFeature.hs b/services/galley/test/integration/API/Util/TeamFeature.hs index 3191a4849ce..749ea934531 100644 --- a/services/galley/test/integration/API/Util/TeamFeature.hs +++ b/services/galley/test/integration/API/Util/TeamFeature.hs @@ -46,7 +46,7 @@ withCustomSearchFeature flag action = do Util.withSettingsOverrides (\opts -> opts & settings . featureFlags . flagTeamSearchVisibility .~ flag) action putTeamSearchVisibilityAvailableInternal :: - HasCallStack => + (HasCallStack) => TeamId -> Public.FeatureStatus -> (MonadIO m, MonadHttp m, HasGalley m) => m () @@ -232,7 +232,7 @@ patchTeamFeatureInternalWithMod reqmod tid reqBody = do . reqmod getGuestLinkStatus :: - HasCallStack => + (HasCallStack) => (Request -> Request) -> UserId -> ConvId -> diff --git a/services/galley/test/integration/TestSetup.hs b/services/galley/test/integration/TestSetup.hs index d4d8c7151b0..a6b9ba84f52 100644 --- a/services/galley/test/integration/TestSetup.hs +++ b/services/galley/test/integration/TestSetup.hs @@ -164,13 +164,14 @@ runFedClient (FedClient mgr ep) domain = Right res -> pure res Left err -> assertFailure $ "Servant client failed with: " <> show err - makeClientRequest :: Domain -> Servant.BaseUrl -> Servant.Request -> HTTP.Request - makeClientRequest originDomain burl req = - let req' = Servant.defaultMakeClientRequest burl req - in req' - { HTTP.requestHeaders = - HTTP.requestHeaders req' - <> [ (originDomainHeaderName, toByteString' originDomain), - (versionHeader, toByteString' (versionInt (maxBound :: Version))) - ] - } + makeClientRequest :: Domain -> Servant.BaseUrl -> Servant.Request -> IO HTTP.Request + makeClientRequest originDomain burl req = do + req' <- Servant.defaultMakeClientRequest burl req + pure + req' + { HTTP.requestHeaders = + HTTP.requestHeaders req' + <> [ (originDomainHeaderName, toByteString' originDomain), + (versionHeader, toByteString' (versionInt (maxBound :: Version))) + ] + } diff --git a/services/galley/test/resources/rabbitmq-ca.pem b/services/galley/test/resources/rabbitmq-ca.pem new file mode 120000 index 00000000000..ca91c2c31bd --- /dev/null +++ b/services/galley/test/resources/rabbitmq-ca.pem @@ -0,0 +1 @@ +../../../../deploy/dockerephemeral/rabbitmq-config/certificates/ca.pem \ No newline at end of file diff --git a/services/galley/test/unit/Test/Galley/Intra/User.hs b/services/galley/test/unit/Test/Galley/Intra/User.hs index f90bdc7e139..f031206d079 100644 --- a/services/galley/test/unit/Test/Galley/Intra/User.hs +++ b/services/galley/test/unit/Test/Galley/Intra/User.hs @@ -35,7 +35,7 @@ tests = [ testChunkify ] -testChunkify :: HasCallStack => TestTree +testChunkify :: (HasCallStack) => TestTree testChunkify = testGroup "chunkify" diff --git a/services/gundeck/default.nix b/services/gundeck/default.nix index 3614f31e11b..b925700365e 100644 --- a/services/gundeck/default.nix +++ b/services/gundeck/default.nix @@ -21,6 +21,7 @@ , conduit , containers , criterion +, crypton-x509-store , errors , exceptions , extended @@ -46,6 +47,7 @@ , network , network-uri , optparse-applicative +, prometheus-client , psqueues , QuickCheck , quickcheck-instances @@ -104,6 +106,7 @@ mkDerivation { bytestring-conversion cassandra-util containers + crypton-x509-store errors exceptions extended @@ -121,6 +124,7 @@ mkDerivation { metrics-wai mtl network-uri + prometheus-client psqueues raw-strings-qq resourcet @@ -166,7 +170,6 @@ mkDerivation { kan-extensions lens lens-aeson - metrics-wai network network-uri optparse-applicative diff --git a/services/gundeck/gundeck.cabal b/services/gundeck/gundeck.cabal index 52532c525ad..e2150a6251c 100644 --- a/services/gundeck/gundeck.cabal +++ b/services/gundeck/gundeck.cabal @@ -125,6 +125,7 @@ library , bytestring-conversion >=0.2 , cassandra-util >=0.16.2 , containers >=0.5 + , crypton-x509-store , errors >=2.0 , exceptions >=0.4 , extended @@ -142,6 +143,7 @@ library , metrics-wai >=0.5.7 , mtl >=2.2 , network-uri >=2.6 + , prometheus-client , psqueues >=0.2.2 , raw-strings-qq , resourcet >=1.1 @@ -308,7 +310,6 @@ executable gundeck-integration , kan-extensions , lens , lens-aeson - , metrics-wai , network , network-uri , optparse-applicative diff --git a/services/gundeck/gundeck.integration.yaml b/services/gundeck/gundeck.integration.yaml index 85ce51ef88c..6c4c2ca748a 100644 --- a/services/gundeck/gundeck.integration.yaml +++ b/services/gundeck/gundeck.integration.yaml @@ -14,9 +14,12 @@ cassandra: # filterNodesByDatacentre: datacenter1 redis: - host: 127.0.0.1 - port: 6377 + host: 172.20.0.31 + port: 6373 connectionMode: cluster # master | cluster + enableTls: true + tlsCa: ../../deploy/dockerephemeral/docker/redis-ca.pem + insecureSkipVerifyTls: false # redisAdditionalWrite: # host: 127.0.0.1 diff --git a/services/gundeck/migrate-data/src/Gundeck/DataMigration.hs b/services/gundeck/migrate-data/src/Gundeck/DataMigration.hs index 6c01b748bf7..7bb99bb3f26 100644 --- a/services/gundeck/migrate-data/src/Gundeck/DataMigration.hs +++ b/services/gundeck/migrate-data/src/Gundeck/DataMigration.hs @@ -116,5 +116,5 @@ persistVersion (MigrationVersion v) desc time = C.write cql (C.params C.LocalQuo cql :: C.QueryString C.W (Int32, Text, UTCTime) () cql = "insert into data_migration (id, version, descr, date) values (1,?,?,?)" -info :: Log.MonadLogger m => String -> m () +info :: (Log.MonadLogger m) => String -> m () info = Log.info . Log.msg diff --git a/services/gundeck/migrate-data/src/Gundeck/DataMigration/Types.hs b/services/gundeck/migrate-data/src/Gundeck/DataMigration/Types.hs index 4ad3dbb20d9..99f9d47609a 100644 --- a/services/gundeck/migrate-data/src/Gundeck/DataMigration/Types.hs +++ b/services/gundeck/migrate-data/src/Gundeck/DataMigration/Types.hs @@ -53,7 +53,7 @@ instance (MonadIO m, MonadThrow m) => C.MonadClient (MigrationActionT m) where liftClient = liftCassandra localState f = local (\env -> env {cassandraClientState = f $ cassandraClientState env}) -instance MonadIO m => MonadLogger (MigrationActionT m) where +instance (MonadIO m) => MonadLogger (MigrationActionT m) where log level f = do env <- ask Logger.log (logger env) level f @@ -67,7 +67,7 @@ runMigrationAction :: Env -> MigrationActionT m a -> m a runMigrationAction env action = runReaderT (unMigrationAction action) env -liftCassandra :: MonadIO m => C.Client a -> MigrationActionT m a +liftCassandra :: (MonadIO m) => C.Client a -> MigrationActionT m a liftCassandra m = do env <- ask lift $ C.runClient (cassandraClientState env) m diff --git a/services/gundeck/migrate-data/src/V1_DeleteApnsVoipTokens.hs b/services/gundeck/migrate-data/src/V1_DeleteApnsVoipTokens.hs index 0c7645797b8..0dba1f02102 100644 --- a/services/gundeck/migrate-data/src/V1_DeleteApnsVoipTokens.hs +++ b/services/gundeck/migrate-data/src/V1_DeleteApnsVoipTokens.hs @@ -56,14 +56,14 @@ pageSize = 1000 -- | We do not use the push token types here because they will likely be -- changed in future breaking this migration. getPushTokens :: - MonadClient m => + (MonadClient m) => ConduitM () [(UserId, Text, Text, Int32, Maybe Text)] m () getPushTokens = paginateC cql (paramsP LocalQuorum () pageSize) x5 where cql :: PrepQuery R () (UserId, Text, Text, Int32, Maybe Text) cql = "SELECT usr, ptoken, app, transport, arn FROM user_push" -deletePushToken :: MonadClient m => (UserId, Text, Text, Int32) -> m () +deletePushToken :: (MonadClient m) => (UserId, Text, Text, Int32) -> m () deletePushToken pair = retry x5 $ write cql (params LocalQuorum pair) where diff --git a/services/gundeck/src/Gundeck/Aws.hs b/services/gundeck/src/Gundeck/Aws.hs index ea5fe968866..944a9d213bf 100644 --- a/services/gundeck/src/Gundeck/Aws.hs +++ b/services/gundeck/src/Gundeck/Aws.hs @@ -216,7 +216,7 @@ mkEnv lgr opts mgr = do (pure . QueueUrl . view SQS.getQueueUrlResponse_queueUrl) x -execute :: MonadIO m => Env -> Amazon a -> m a +execute :: (MonadIO m) => Env -> Amazon a -> m a execute e m = liftIO $ runResourceT (runReaderT (unAmazon m) e) -------------------------------------------------------------------------------- @@ -479,8 +479,10 @@ listen throttleMillis callback = do err . msg $ val "Failed to parse SQS event notification" Just e -> do info $ - "sqs-event" .= toText (e ^. evType) - ~~ "arn" .= toText (e ^. evEndpoint) + "sqs-event" + .= toText (e ^. evType) + ~~ "arn" + .= toText (e ^. evEndpoint) ~~ msg (val "Received SQS event") liftIO $ callback e for_ (m ^. message_receiptHandle) (void . send awsE . SQS.newDeleteMessage url) diff --git a/services/gundeck/src/Gundeck/Aws/Arn.hs b/services/gundeck/src/Gundeck/Aws/Arn.hs index 17588d08106..0ff914c5d57 100644 --- a/services/gundeck/src/Gundeck/Aws/Arn.hs +++ b/services/gundeck/src/Gundeck/Aws/Arn.hs @@ -114,7 +114,7 @@ instance ToText EndpointTopic where instance FromText EndpointTopic where fromText = parseOnly endpointTopicParser -mkSnsArn :: ToText topic => Region -> Account -> topic -> SnsArn topic +mkSnsArn :: (ToText topic) => Region -> Account -> topic -> SnsArn topic mkSnsArn r a t = let txt = Text.intercalate ":" ["arn:aws:sns", toText r, toText a, toText t] in SnsArn txt r a t @@ -164,8 +164,13 @@ endpointTopicParser = do transportParser :: Parser Transport transportParser = - string "GCM" $> GCM - <|> string "APNS_VOIP_SANDBOX" $> APNSVoIPSandbox - <|> string "APNS_VOIP" $> APNSVoIP - <|> string "APNS_SANDBOX" $> APNSSandbox - <|> string "APNS" $> APNS + string "GCM" + $> GCM + <|> string "APNS_VOIP_SANDBOX" + $> APNSVoIPSandbox + <|> string "APNS_VOIP" + $> APNSVoIP + <|> string "APNS_SANDBOX" + $> APNSSandbox + <|> string "APNS" + $> APNS diff --git a/services/gundeck/src/Gundeck/Env.hs b/services/gundeck/src/Gundeck/Env.hs index c9e8a4d286b..8fc8b78abaf 100644 --- a/services/gundeck/src/Gundeck/Env.hs +++ b/services/gundeck/src/Gundeck/Env.hs @@ -27,11 +27,11 @@ import Control.Concurrent.Async (Async) import Control.Lens (makeLenses, (^.)) import Control.Retry (capDelay, exponentialBackoff) import Data.ByteString.Char8 qualified as BSChar8 -import Data.Metrics.Middleware (Metrics) import Data.Misc (Milliseconds (..)) -import Data.Text (unpack) +import Data.Text qualified as Text import Data.Time.Clock import Data.Time.Clock.POSIX +import Data.X509.CertificateStore as CertStore import Database.Redis qualified as Redis import Gundeck.Aws qualified as Aws import Gundeck.Options as Opt hiding (host, port) @@ -42,12 +42,13 @@ import Gundeck.ThreadBudget import Imports import Network.HTTP.Client (responseTimeoutMicro) import Network.HTTP.Client.TLS (tlsManagerSettings) +import Network.TLS as TLS +import Network.TLS.Extra qualified as TLS import System.Logger qualified as Log import System.Logger.Extended qualified as Logger data Env = Env { _reqId :: !RequestId, - _monitor :: !Metrics, _options :: !Opts, _applog :: !Logger.Logger, _manager :: !Manager, @@ -64,8 +65,8 @@ makeLenses ''Env schemaVersion :: Int32 schemaVersion = 7 -createEnv :: Metrics -> Opts -> IO ([Async ()], Env) -createEnv m o = do +createEnv :: Opts -> IO ([Async ()], Env) +createEnv o = do l <- Logger.mkLogger (o ^. logLevel) (o ^. logNetStrings) (o ^. logFormat) n <- newManager @@ -102,7 +103,7 @@ createEnv m o = do { updateAction = Ms . round . (* 1000) <$> getPOSIXTime } mtbs <- mkThreadBudgetState `mapM` (o ^. settings . maxConcurrentNativePushes) - pure $! (rThread : rAdditionalThreads,) $! Env (RequestId "N/A") m o l n p r rAdditional a io mtbs + pure $! (rThread : rAdditionalThreads,) $! Env (RequestId "N/A") o l n p r rAdditional a io mtbs reqIdMsg :: RequestId -> Logger.Msg -> Logger.Msg reqIdMsg = ("request" Logger..=) . unRequestId @@ -110,14 +111,36 @@ reqIdMsg = ("request" Logger..=) . unRequestId createRedisPool :: Logger.Logger -> RedisEndpoint -> Maybe ByteString -> Maybe ByteString -> ByteString -> IO (Async (), Redis.RobustConnection) createRedisPool l ep username password identifier = do + customCertStore <- case ep._tlsCa of + Nothing -> pure Nothing + Just caPath -> CertStore.readCertificateStore caPath + let defClientParams = defaultParamsClient (Text.unpack ep._host) "" + tlsParams = + guard ep._enableTls + $> defClientParams + { clientHooks = + if ep._insecureSkipVerifyTls + then defClientParams.clientHooks {onServerCertificate = \_ _ _ _ -> pure []} + else defClientParams.clientHooks, + clientShared = + case customCertStore of + Nothing -> defClientParams.clientShared + Just sharedCAStore -> defClientParams.clientShared {sharedCAStore}, + clientSupported = + defClientParams.clientSupported + { supportedVersions = [TLS.TLS13, TLS.TLS12], + supportedCiphers = TLS.ciphersuite_strong + } + } let redisConnInfo = Redis.defaultConnectInfo - { Redis.connectHost = unpack $ ep ^. O.host, + { Redis.connectHost = Text.unpack $ ep ^. O.host, Redis.connectPort = Redis.PortNumber (fromIntegral $ ep ^. O.port), Redis.connectUsername = username, Redis.connectAuth = password, Redis.connectTimeout = Just (secondsToNominalDiffTime 5), - Redis.connectMaxConnections = 100 + Redis.connectMaxConnections = 100, + Redis.connectTLSParams = tlsParams } Log.info l $ diff --git a/services/gundeck/src/Gundeck/Monad.hs b/services/gundeck/src/Gundeck/Monad.hs index 66b234569d3..5320f725501 100644 --- a/services/gundeck/src/Gundeck/Monad.hs +++ b/services/gundeck/src/Gundeck/Monad.hs @@ -21,7 +21,6 @@ module Gundeck.Monad ( -- * Environment Env, reqId, - monitor, options, applog, manager, @@ -61,6 +60,7 @@ import Imports import Network.HTTP.Types import Network.Wai import Network.Wai.Utilities +import Prometheus import System.Logger qualified as Log import System.Logger qualified as Logger import System.Logger.Class @@ -84,6 +84,10 @@ newtype Gundeck a = Gundeck MonadUnliftIO ) +-- This can be derived if we resolve the TODO above. +instance MonadMonitor Gundeck where + doIO = liftIO + -- | 'Gundeck' doesn't have an instance for 'MonadRedis' because it contains two -- connections to two redis instances. When using 'WithDefaultRedis', any redis -- operation will only target the default redis instance (configured under @@ -110,7 +114,7 @@ instance Redis.MonadRedis WithDefaultRedis where Redis.runRobust defaultConn action instance Redis.RedisCtx WithDefaultRedis (Either Redis.Reply) where - returnDecode :: Redis.RedisResult a => Redis.Reply -> WithDefaultRedis (Either Redis.Reply a) + returnDecode :: (Redis.RedisResult a) => Redis.Reply -> WithDefaultRedis (Either Redis.Reply a) returnDecode = Redis.liftRedis . Redis.returnDecode -- | 'Gundeck' doesn't have an instance for 'MonadRedis' because it contains two @@ -147,7 +151,7 @@ instance Redis.MonadRedis WithAdditionalRedis where pure ret instance Redis.RedisCtx WithAdditionalRedis (Either Redis.Reply) where - returnDecode :: Redis.RedisResult a => Redis.Reply -> WithAdditionalRedis (Either Redis.Reply a) + returnDecode :: (Redis.RedisResult a) => Redis.Reply -> WithAdditionalRedis (Either Redis.Reply a) returnDecode = Redis.liftRedis . Redis.returnDecode instance MonadLogger Gundeck where @@ -189,13 +193,16 @@ lookupReqId l r = case lookup requestIdName (requestHeaders r) of Nothing -> do localRid <- RequestId . UUID.toASCIIBytes <$> UUID.nextRandom Log.info l $ - "request-id" .= localRid - ~~ "method" .= requestMethod r - ~~ "path" .= rawPathInfo r + "request-id" + .= localRid + ~~ "method" + .= requestMethod r + ~~ "path" + .= rawPathInfo r ~~ msg (val "generated a new request id for local request") pure localRid -fromJsonBody :: FromJSON a => JsonRequest a -> Gundeck a +fromJsonBody :: (FromJSON a) => JsonRequest a -> Gundeck a fromJsonBody r = exceptT (throwM . mkError status400 "bad-request") pure (parseBody r) {-# INLINE fromJsonBody #-} diff --git a/services/gundeck/src/Gundeck/Notification.hs b/services/gundeck/src/Gundeck/Notification.hs index a64e3477982..f5c1c2a5082 100644 --- a/services/gundeck/src/Gundeck/Notification.hs +++ b/services/gundeck/src/Gundeck/Notification.hs @@ -21,12 +21,11 @@ module Gundeck.Notification ) where -import Bilge.IO hiding (options) +import Bilge.IO (post) import Bilge.Request import Bilge.Response import Control.Lens (view) import Control.Monad.Catch -import Control.Monad.Except import Data.ByteString.Conversion import Data.Id import Data.Misc (Milliseconds (..)) @@ -35,13 +34,13 @@ import Data.Time.Clock.POSIX import Data.UUID qualified as UUID import Gundeck.Monad import Gundeck.Notification.Data qualified as Data -import Gundeck.Options hiding (host, port) +import Gundeck.Options (brig) import Imports hiding (getLast) -import Network.HTTP.Types hiding (statusCode) +import Network.HTTP.Types (status400) import Network.Wai.Utilities.Error import System.Logger.Class import System.Logger.Class qualified as Log -import Util.Options hiding (host, port) +import Util.Options (Endpoint (Endpoint)) import Wire.API.Internal.Notification import Wire.API.Notification @@ -84,5 +83,7 @@ updateActivity uid clt = do when (statusCode r /= 200) $ do Log.warn $ Log.msg ("Could not update client activity" :: ByteString) - ~~ "user" .= UUID.toASCIIBytes (toUUID uid) - ~~ "client" .= clientToText clt + ~~ "user" + .= UUID.toASCIIBytes (toUUID uid) + ~~ "client" + .= clientToText clt diff --git a/services/gundeck/src/Gundeck/Notification/Data.hs b/services/gundeck/src/Gundeck/Notification/Data.hs index de18c7f5eaf..a240f37df03 100644 --- a/services/gundeck/src/Gundeck/Notification/Data.hs +++ b/services/gundeck/src/Gundeck/Notification/Data.hs @@ -106,7 +106,7 @@ add n tgts (JSON.encode -> payload) (notificationTTLSeconds -> t) = do \(? , ?) \ \USING TTL ?" -fetchId :: MonadClient m => UserId -> NotificationId -> Maybe ClientId -> m (Maybe QueuedNotification) +fetchId :: (MonadClient m) => UserId -> NotificationId -> Maybe ClientId -> m (Maybe QueuedNotification) fetchId u n c = runMaybeT $ do row <- MaybeT $ retry x1 $ query1 cqlById (params LocalQuorum (u, n)) MaybeT $ fetchPayload c row @@ -158,7 +158,7 @@ fetchLast u c = do \WHERE user = ? AND id < ? \ \ORDER BY id DESC" -fetchPayload :: MonadClient m => Maybe ClientId -> NotifRow -> m (Maybe QueuedNotification) +fetchPayload :: (MonadClient m) => Maybe ClientId -> NotifRow -> m (Maybe QueuedNotification) fetchPayload c (id_, mbPayload, mbPayloadRef, _mbPayloadRefSize, mbClients) = case (mbPayload, mbPayloadRef) of (Just payload, _) -> pure $ toNotifSingle c (id_, payload, mbClients) @@ -261,7 +261,7 @@ fetch u c (Just since) (fromIntegral . fromRange -> size) = do \WHERE user = ? AND id >= ? \ \ORDER BY id ASC" -deleteAll :: MonadClient m => UserId -> m () +deleteAll :: (MonadClient m) => UserId -> m () deleteAll u = write cql (params LocalQuorum (Identity u)) & retry x5 where cql :: PrepQuery W (Identity UserId) () diff --git a/services/gundeck/src/Gundeck/Options.hs b/services/gundeck/src/Gundeck/Options.hs index 2be1f5d2cca..f5882a2a708 100644 --- a/services/gundeck/src/Gundeck/Options.hs +++ b/services/gundeck/src/Gundeck/Options.hs @@ -110,7 +110,13 @@ deriveJSON defaultOptions {constructorTagModifier = map toLower} ''RedisConnecti data RedisEndpoint = RedisEndpoint { _host :: !Text, _port :: !Word16, - _connectionMode :: !RedisConnectionMode + _connectionMode :: !RedisConnectionMode, + _enableTls :: !Bool, + -- | When not specified, use system CA bundle + _tlsCa :: !(Maybe FilePath), + -- | When 'True', uses TLS but does not verify hostname or CA or validity of + -- the cert. Not recommended to set to 'True'. + _insecureSkipVerifyTls :: !Bool } deriving (Show, Generic) diff --git a/services/gundeck/src/Gundeck/Presence/Data.hs b/services/gundeck/src/Gundeck/Presence/Data.hs index 158e8982217..bfe1773ba9c 100644 --- a/services/gundeck/src/Gundeck/Presence/Data.hs +++ b/services/gundeck/src/Gundeck/Presence/Data.hs @@ -24,7 +24,6 @@ module Gundeck.Presence.Data where import Control.Monad.Catch -import Control.Monad.Except import Data.Aeson as Aeson import Data.ByteString qualified as Strict import Data.ByteString.Builder (byteString) @@ -122,9 +121,13 @@ instance ToJSON PresenceData where instance FromJSON PresenceData where parseJSON = withObject "PresenceData" $ \o -> PresenceData - <$> o .: "r" - <*> o .:? "c" - <*> o .:? "t" .!= 0 + <$> o + .: "r" + <*> o + .:? "c" + <*> o + .:? "t" + .!= 0 toKey :: UserId -> ByteString toKey u = Lazy.toStrict $ runBuilder (byteString "user:" <> builder u) diff --git a/services/gundeck/src/Gundeck/Push.hs b/services/gundeck/src/Gundeck/Push.hs index b11785fa770..6f3bcbcf684 100644 --- a/services/gundeck/src/Gundeck/Push.hs +++ b/services/gundeck/src/Gundeck/Push.hs @@ -85,7 +85,7 @@ push ps = do throwM (mkError status500 "server-error" "Server Error") -- | Abstract over all effects in 'pushAll' (for unit testing). -class MonadThrow m => MonadPushAll m where +class (MonadThrow m) => MonadPushAll m where mpaNotificationTTL :: m NotificationTTL mpaMkNotificationId :: m NotificationId mpaListAllPresences :: [UserId] -> m [[Presence]] @@ -108,13 +108,12 @@ instance MonadPushAll Gundeck where -- | Another layer of wrap around 'runWithBudget'. runWithBudget'' :: Int -> a -> Gundeck a -> Gundeck a runWithBudget'' budget fallback action = do - metrics <- view monitor view threadBudgetState >>= \case Nothing -> action - Just tbs -> runWithBudget' metrics tbs budget fallback action + Just tbs -> runWithBudget' tbs budget fallback action -- | Abstract over all effects in 'nativeTargets' (for unit testing). -class Monad m => MonadNativeTargets m where +class (Monad m) => MonadNativeTargets m where mntgtLogErr :: SomeException -> m () mntgtLookupAddresses :: UserId -> m [Address] @@ -122,7 +121,7 @@ instance MonadNativeTargets Gundeck where mntgtLogErr e = Log.err (msg (val "Failed to get native push address: " +++ show e)) mntgtLookupAddresses rcp = Data.lookup rcp Data.One -class Monad m => MonadMapAsync m where +class (Monad m) => MonadMapAsync m where mntgtMapAsync :: (a -> m b) -> [a] -> m [Either SomeException b] mntgtPerPushConcurrency :: m (Maybe Int) @@ -224,7 +223,7 @@ data NewNotification = NewNotification nnRecipients :: List1 Recipient } -mkNewNotification :: forall m. MonadPushAll m => Push -> m NewNotification +mkNewNotification :: forall m. (MonadPushAll m) => Push -> m NewNotification mkNewNotification psh = NewNotification psh <$> mkNotif <*> rcps where mkNotif :: m Notification @@ -267,12 +266,12 @@ data WSTargets = WSTargets wstPresences :: List1 (Recipient, [Presence]) } -mkWSTargets :: MonadPushAll m => NewNotification -> m WSTargets +mkWSTargets :: (MonadPushAll m) => NewNotification -> m WSTargets mkWSTargets NewNotification {..} = do withPresences <- addPresences nnRecipients pure $ WSTargets nnPush nnNotification withPresences where - addPresences :: forall m. MonadPushAll m => List1 Recipient -> m (List1 (Recipient, [Presence])) + addPresences :: forall m. (MonadPushAll m) => List1 Recipient -> m (List1 (Recipient, [Presence])) addPresences (toList -> rcps) = do presences <- mpaListAllPresences $ fmap (view recipientId) rcps zip1 rcps presences @@ -389,7 +388,7 @@ addToken uid cid newtok = mpaRunWithBudget 1 (Left Public.AddTokenErrorNoBudget) "user" .= UUID.toASCIIBytes (toUUID uid) ~~ "token" - .= Text.take 16 (tokenText (newtok ^. token)) + .= Text.take 16 (tokenText (newtok ^. token)) ~~ msg (val "Registering push token") addr <- continue newtok cur lift $ Native.deleteTokens old (Just addr) @@ -515,19 +514,19 @@ updateEndpoint uid t arn e = do "user" .= UUID.toASCIIBytes (toUUID uid) ~~ "token" - .= Text.take 16 (t ^. token . to tokenText) + .= Text.take 16 (t ^. token . to tokenText) ~~ "tokenTransport" - .= show (t ^. tokenTransport) + .= show (t ^. tokenTransport) ~~ "tokenApp" - .= (t ^. tokenApp . to appNameText) + .= (t ^. tokenApp . to appNameText) ~~ "arn" - .= toText arn + .= toText arn ~~ "endpointTransport" - .= show (arn ^. snsTopic . endpointTransport) + .= show (arn ^. snsTopic . endpointTransport) ~~ "endpointAppName" - .= (arn ^. snsTopic . endpointAppName . to appNameText) + .= (arn ^. snsTopic . endpointAppName . to appNameText) ~~ "request" - .= unRequestId requestId + .= unRequestId requestId ~~ msg (val m) deleteToken :: UserId -> Token -> Gundeck (Maybe ()) diff --git a/services/gundeck/src/Gundeck/Push/Data.hs b/services/gundeck/src/Gundeck/Push/Data.hs index c688f64f4db..5c3fc33cd34 100644 --- a/services/gundeck/src/Gundeck/Push/Data.hs +++ b/services/gundeck/src/Gundeck/Push/Data.hs @@ -42,25 +42,25 @@ lookup u c = foldM mk [] =<< retry x1 (query q (params c (Identity u))) q = "select usr, transport, app, ptoken, arn, connection, client from user_push where usr = ?" mk as r = maybe as (: as) <$> mkAddr r -insert :: MonadClient m => UserId -> Transport -> AppName -> Token -> EndpointArn -> ConnId -> ClientId -> m () +insert :: (MonadClient m) => UserId -> Transport -> AppName -> Token -> EndpointArn -> ConnId -> ClientId -> m () insert u t a p e o c = retry x5 $ write q (params LocalQuorum (u, t, a, p, e, o, c)) where q :: PrepQuery W (UserId, Transport, AppName, Token, EndpointArn, ConnId, ClientId) () q = "insert into user_push (usr, transport, app, ptoken, arn, connection, client) values (?, ?, ?, ?, ?, ?, ?)" -updateArn :: MonadClient m => UserId -> Transport -> AppName -> Token -> EndpointArn -> m () +updateArn :: (MonadClient m) => UserId -> Transport -> AppName -> Token -> EndpointArn -> m () updateArn uid transport app token arn = retry x5 $ write q (params LocalQuorum (arn, uid, transport, app, token)) where q :: PrepQuery W (EndpointArn, UserId, Transport, AppName, Token) () q = {- `IF EXISTS`, but that requires benchmarking -} "update user_push set arn = ? where usr = ? and transport = ? and app = ? and ptoken = ?" -delete :: MonadClient m => UserId -> Transport -> AppName -> Token -> m () +delete :: (MonadClient m) => UserId -> Transport -> AppName -> Token -> m () delete u t a p = retry x5 $ write q (params LocalQuorum (u, t, a, p)) where q :: PrepQuery W (UserId, Transport, AppName, Token) () q = "delete from user_push where usr = ? and transport = ? and app = ? and ptoken = ?" -erase :: MonadClient m => UserId -> m () +erase :: (MonadClient m) => UserId -> m () erase u = retry x5 $ write q (params LocalQuorum (Identity u)) where q :: PrepQuery W (Identity UserId) () diff --git a/services/gundeck/src/Gundeck/Push/Native.hs b/services/gundeck/src/Gundeck/Push/Native.hs index 752351340d4..917960c4e7e 100644 --- a/services/gundeck/src/Gundeck/Push/Native.hs +++ b/services/gundeck/src/Gundeck/Push/Native.hs @@ -28,7 +28,6 @@ import Control.Monad.Catch import Data.ByteString.Conversion.To import Data.Id import Data.List1 -import Data.Metrics (counterIncr, path) import Data.Set qualified as Set import Data.Text qualified as Text import Data.UUID qualified as UUID @@ -43,6 +42,7 @@ import Gundeck.Push.Native.Types as Types import Gundeck.Types import Gundeck.Util import Imports +import Prometheus qualified as Prom import System.Logger.Class (MonadLogger, field, msg, val, (.=), (~~)) import System.Logger.Class qualified as Log import UnliftIO (handleAny, mapConcurrently, pooledMapConcurrentlyN_) @@ -60,6 +60,66 @@ push m addrs = do -- parallelizing only chunkSize native pushes at a time Just chunkSize -> pooledMapConcurrentlyN_ chunkSize (push1 m) addrs +{-# NOINLINE nativePushSuccessCounter #-} +nativePushSuccessCounter :: Prom.Counter +nativePushSuccessCounter = + Prom.unsafeRegister $ + Prom.counter + Prom.Info + { Prom.metricName = "push.native.success", + Prom.metricHelp = "Number of times native pushes were successfully pushed" + } + +{-# NOINLINE nativePushDisabledCounter #-} +nativePushDisabledCounter :: Prom.Counter +nativePushDisabledCounter = + Prom.unsafeRegister $ + Prom.counter + Prom.Info + { Prom.metricName = "push.native.disabled", + Prom.metricHelp = "Number of times native pushes were not pushed due to a disabled endpoint" + } + +{-# NOINLINE nativePushInvalidCounter #-} +nativePushInvalidCounter :: Prom.Counter +nativePushInvalidCounter = + Prom.unsafeRegister $ + Prom.counter + Prom.Info + { Prom.metricName = "push.native.invalid", + Prom.metricHelp = "Number of times native pushes were not pushed due to an invalid endpoint" + } + +{-# NOINLINE nativePushTooLargeCounter #-} +nativePushTooLargeCounter :: Prom.Counter +nativePushTooLargeCounter = + Prom.unsafeRegister $ + Prom.counter + Prom.Info + { Prom.metricName = "push.native.too_large", + Prom.metricHelp = "Number of times native pushes were not pushed due to payload being too large" + } + +{-# NOINLINE nativePushUnauthorizedCounter #-} +nativePushUnauthorizedCounter :: Prom.Counter +nativePushUnauthorizedCounter = + Prom.unsafeRegister $ + Prom.counter + Prom.Info + { Prom.metricName = "push.native.unauthorized", + Prom.metricHelp = "Number of times native pushes were not pushed due to an unauthorized endpoint" + } + +{-# NOINLINE nativePushErrorCounter #-} +nativePushErrorCounter :: Prom.Counter +nativePushErrorCounter = + Prom.unsafeRegister $ + Prom.counter + Prom.Info + { Prom.metricName = "push.native.errors", + Prom.metricHelp = "Number of times native pushes were not pushed due to an unexpected error" + } + push1 :: NativePush -> Address -> Gundeck () push1 = push1' 0 where @@ -86,7 +146,7 @@ push1 = push1' 0 field "user" (toByteString (a ^. addrUser)) ~~ field "notificationId" (toText (npNotificationid m)) ~~ Log.msg (val "Native push success") - view monitor >>= counterIncr (path "push.native.success") + Prom.incCounter nativePushSuccessCounter onDisabled = handleAny (logError a "Failed to cleanup disabled endpoint") $ do Log.info $ @@ -94,13 +154,13 @@ push1 = push1' 0 ~~ field "arn" (toText (a ^. addrEndpoint)) ~~ field "cause" ("EndpointDisabled" :: Text) ~~ msg (val "Removing disabled endpoint and token") - view monitor >>= counterIncr (path "push.native.disabled") + Prom.incCounter nativePushDisabledCounter Data.delete (a ^. addrUser) (a ^. addrTransport) (a ^. addrApp) (a ^. addrToken) onTokenRemoved e <- view awsEnv Aws.execute e (Aws.deleteEndpoint (a ^. addrEndpoint)) onPayloadTooLarge = do - view monitor >>= counterIncr (path "push.native.too_large") + Prom.incCounter nativePushTooLargeCounter Log.warn $ field "user" (toByteString (a ^. addrUser)) ~~ field "arn" (toText (a ^. addrEndpoint)) @@ -112,7 +172,7 @@ push1 = push1' 0 ~~ field "arn" (toText (a ^. addrEndpoint)) ~~ field "cause" ("InvalidEndpoint" :: Text) ~~ msg (val "Invalid ARN. Deleting orphaned push token") - view monitor >>= counterIncr (path "push.native.invalid") + Prom.incCounter nativePushInvalidCounter Data.delete (a ^. addrUser) (a ^. addrTransport) (a ^. addrApp) (a ^. addrToken) onTokenRemoved retryUnauthorisedThreshold = 1 @@ -147,10 +207,10 @@ push1 = push1' 0 ~~ field "arn" (toText (a ^. addrEndpoint)) ~~ field "cause" ("UnauthorisedEndpoint" :: Text) ~~ msg (val "Invalid ARN. Dropping push message.") - view monitor >>= counterIncr (path "push.native.unauthorized") + Prom.incCounter nativePushUnauthorizedCounter onPushException ex = do logError a "Native push failed" ex - view monitor >>= counterIncr (path "push.native.errors") + Prom.incCounter nativePushErrorCounter onTokenRemoved = do i <- mkNotificationId let c = a ^. addrClient diff --git a/services/gundeck/src/Gundeck/Push/Native/Serialise.hs b/services/gundeck/src/Gundeck/Push/Native/Serialise.hs index bf9e0e491cc..648a888f834 100644 --- a/services/gundeck/src/Gundeck/Push/Native/Serialise.hs +++ b/services/gundeck/src/Gundeck/Push/Native/Serialise.hs @@ -35,7 +35,7 @@ import Gundeck.Push.Native.Types import Gundeck.Types import Imports -serialise :: HasCallStack => NativePush -> UserId -> Transport -> Either Failure LT.Text +serialise :: (HasCallStack) => NativePush -> UserId -> Transport -> Either Failure LT.Text serialise (NativePush nid prio _aps) uid transport = do case renderText transport prio o of Nothing -> Left PayloadTooLarge diff --git a/services/gundeck/src/Gundeck/Push/Websocket.hs b/services/gundeck/src/Gundeck/Push/Websocket.hs index 64a51c5f9d9..a706d6cb5d9 100644 --- a/services/gundeck/src/Gundeck/Push/Websocket.hs +++ b/services/gundeck/src/Gundeck/Push/Websocket.hs @@ -36,7 +36,6 @@ import Data.ByteString.Lazy qualified as L import Data.Id import Data.List1 import Data.Map qualified as Map -import Data.Metrics qualified as Metrics import Data.Misc (Milliseconds (..)) import Data.Set qualified as Set import Data.Time.Clock.POSIX @@ -49,6 +48,7 @@ import Network.HTTP.Client (HttpExceptionContent (..)) import Network.HTTP.Client.Internal qualified as Http import Network.HTTP.Types (StdMethod (POST), status200, status410) import Network.URI qualified as URI +import Prometheus qualified as Prom import System.Logger.Class (val, (+++), (~~)) import System.Logger.Class qualified as Log import UnliftIO (handleAny, mapConcurrently) @@ -59,7 +59,7 @@ class (Monad m, MonadThrow m, Log.MonadLogger m) => MonadBulkPush m where mbpBulkSend :: URI -> BulkPushRequest -> m (URI, Either SomeException BulkPushResponse) mbpDeleteAllPresences :: [Presence] -> m () mbpPosixTime :: m Milliseconds - mbpMapConcurrently :: Traversable t => (a -> m b) -> t a -> m (t b) + mbpMapConcurrently :: (Traversable t) => (a -> m b) -> t a -> m (t b) mbpMonitorBadCannons :: (URI, (SomeException, [Presence])) -> m () instance MonadBulkPush Gundeck where @@ -71,7 +71,7 @@ instance MonadBulkPush Gundeck where -- | Send a 'Notification's to associated 'Presence's. Send at most one request to each Cannon. -- Return the lists of 'Presence's successfully reached for each resp. 'Notification'. -bulkPush :: forall m. MonadBulkPush m => [(Notification, [Presence])] -> m [(NotificationId, [Presence])] +bulkPush :: forall m. (MonadBulkPush m) => [(Notification, [Presence])] -> m [(NotificationId, [Presence])] -- REFACTOR: make presences lists (and notification list) non-empty where applicable? are there -- better types to express more of our semantics / invariants? (what about duplicates in presence -- lists?) @@ -101,16 +101,23 @@ bulkPush notifs = do -- | log all cannons with response status @/= 200@. monitorBadCannons :: - (MonadIO m, MonadReader Env m) => + (Prom.MonadMonitor m) => (uri, (error, [Presence])) -> m () -monitorBadCannons (_uri, (_err, prcs)) = do - view monitor - >>= Metrics.counterAdd - (fromIntegral $ length prcs) - (Metrics.path "push.ws.unreachable") +monitorBadCannons (_uri, (_err, prcs)) = + void $ Prom.addCounter pushWsUnreachableCounter (fromIntegral $ length prcs) -logBadCannons :: Log.MonadLogger m => (URI, (SomeException, [Presence])) -> m () +{-# NOINLINE pushWsUnreachableCounter #-} +pushWsUnreachableCounter :: Prom.Counter +pushWsUnreachableCounter = + Prom.unsafeRegister $ + Prom.counter + Prom.Info + { Prom.metricName = "push.ws.unreachable", + Prom.metricHelp = "Number of times websocket pushes were not pushed due cannon being unreachable" + } + +logBadCannons :: (Log.MonadLogger m) => (URI, (SomeException, [Presence])) -> m () logBadCannons (uri, (err, prcs)) = do forM_ prcs $ \prc -> Log.warn $ @@ -121,10 +128,10 @@ logBadCannons (uri, (err, prcs)) = do ~~ Log.field "http_exception" (intercalate " | " . lines . show $ err) ~~ Log.msg (val "WebSocket presence unreachable: ") -logPrcsGone :: Log.MonadLogger m => Presence -> m () +logPrcsGone :: (Log.MonadLogger m) => Presence -> m () logPrcsGone prc = Log.debug $ logPresence prc ~~ Log.msg (val "WebSocket presence gone") -logSuccesses :: Log.MonadLogger m => (a, Presence) -> m () +logSuccesses :: (Log.MonadLogger m) => (a, Presence) -> m () logSuccesses (_, prc) = Log.debug $ logPresence prc ~~ Log.msg (val "WebSocket push success") fanOut :: [(Notification, [Presence])] -> [(URI, BulkPushRequest)] @@ -249,7 +256,7 @@ flowBack rawresps = FlowBack broken gone delivered lefts' ((_, Right _) : xs) = lefts' xs {-# INLINE mkPresencesByCannon #-} -mkPresencesByCannon :: MonadThrow m => [Presence] -> URI -> m [Presence] +mkPresencesByCannon :: (MonadThrow m) => [Presence] -> URI -> m [Presence] mkPresencesByCannon prcs uri = maybe (throwM err) pure $ Map.lookup uri mp where err = ErrorCall "internal error in Gundeck: invalid URL in bulkpush result" @@ -262,7 +269,7 @@ mkPresencesByCannon prcs uri = maybe (throwM err) pure $ Map.lookup uri mp go prc (Just prcs') = Just $ prc : prcs' {-# INLINE mkPresenceByPushTarget #-} -mkPresenceByPushTarget :: MonadThrow m => [Presence] -> PushTarget -> m Presence +mkPresenceByPushTarget :: (MonadThrow m) => [Presence] -> PushTarget -> m Presence mkPresenceByPushTarget prcs ptarget = maybe (throwM err) pure $ Map.lookup ptarget mp where err = ErrorCall "internal error in Cannon: invalid PushTarget in bulkpush response" @@ -276,7 +283,7 @@ bulkresource = URI . (\x -> x {URI.uriPath = "/i/bulkpush"}) . fromURI . resourc -- TODO: a Map-based implementation would be faster for sufficiently large inputs. do we want to -- take the time and benchmark the difference? move it to types-common? {-# INLINE groupAssoc #-} -groupAssoc :: Ord a => [(a, b)] -> [(a, [b])] +groupAssoc :: (Ord a) => [(a, b)] -> [(a, [b])] groupAssoc = groupAssoc' compare -- TODO: Also should we give 'Notification' an 'Ord' instance? @@ -343,7 +350,7 @@ push notif (toList -> tgts) originUser originConn conns = do Log.debug $ logPresence p ~~ Log.msg (val "WebSocket presence gone") pure (ok, p : gone) onResult (ok, gone) (PushFailure p _) = do - view monitor >>= Metrics.counterIncr (Metrics.path "push.ws.unreachable") + Prom.incCounter pushWsUnreachableCounter Log.info $ logPresence p ~~ Log.field "created_at" (ms $ createdAt p) diff --git a/services/gundeck/src/Gundeck/React.hs b/services/gundeck/src/Gundeck/React.hs index d97f4312ccc..9ffdf521cca 100644 --- a/services/gundeck/src/Gundeck/React.hs +++ b/services/gundeck/src/Gundeck/React.hs @@ -78,9 +78,9 @@ onUpdated ev = withEndpoint ev $ \e as -> logUserEvent (a ^. addrUser) ev $ msg (val "Removing superseded token") deleteToken (a ^. addrUser) ev (a ^. addrToken) (a ^. addrClient) if - | null sup -> pure () - | null cur -> deleteEndpoint ev - | otherwise -> updateEndpoint ev e (map (view addrUser) cur) + | null sup -> pure () + | null cur -> deleteEndpoint ev + | otherwise -> updateEndpoint ev e (map (view addrUser) cur) onFailure :: Event -> Gundeck () onFailure ev = withEndpoint ev $ \e as -> @@ -100,22 +100,28 @@ onPermFailure ev = withEndpoint ev $ \_ as -> do onTTLExpired :: Event -> Gundeck () onTTLExpired ev = Log.warn $ - "arn" .= toText (ev ^. evEndpoint) - ~~ "cause" .= toText (ev ^. evType) + "arn" + .= toText (ev ^. evEndpoint) + ~~ "cause" + .= toText (ev ^. evType) ~~ msg (val "Notification TTL expired") onUnknownFailure :: Event -> Text -> Gundeck () onUnknownFailure ev r = Log.warn $ - "arn" .= toText (ev ^. evEndpoint) - ~~ "cause" .= toText (ev ^. evType) + "arn" + .= toText (ev ^. evEndpoint) + ~~ "cause" + .= toText (ev ^. evType) ~~ msg (val "Unknown failure, reason: " +++ r) onUnhandledEventType :: Event -> Gundeck () onUnhandledEventType ev = Log.warn $ - "arn" .= toText (ev ^. evEndpoint) - ~~ "cause" .= toText (ev ^. evType) + "arn" + .= toText (ev ^. evEndpoint) + ~~ "cause" + .= toText (ev ^. evType) ~~ msg (val "Unhandled event type") ------------------------------------------------------------------------------- @@ -134,7 +140,8 @@ withEndpoint ev f = do case filter ((== (ev ^. evEndpoint)) . view addrEndpoint) as of [] -> do logEvent ev $ - "token" .= Text.take 16 (tokenText (ep ^. endpointToken)) + "token" + .= Text.take 16 (tokenText (ep ^. endpointToken)) ~~ msg (val "Deleting orphaned SNS endpoint") Aws.execute v (Aws.deleteEndpoint (ev ^. evEndpoint)) as' -> f ep as' @@ -154,7 +161,8 @@ updateEndpoint ev ep us = do deleteToken :: UserId -> Event -> Token -> ClientId -> Gundeck () deleteToken u ev tk cl = do logUserEvent u ev $ - "token" .= Text.take 16 (tokenText tk) + "token" + .= Text.take 16 (tokenText tk) ~~ msg (val "Deleting push token") i <- mkNotificationId let t = mkPushToken ev tk cl @@ -173,12 +181,15 @@ mkPushToken ev tk cl = logEvent :: Event -> (Msg -> Msg) -> Gundeck () logEvent ev f = Log.info $ - "arn" .= toText (ev ^. evEndpoint) - ~~ "cause" .= toText (ev ^. evType) + "arn" + .= toText (ev ^. evEndpoint) + ~~ "cause" + .= toText (ev ^. evType) ~~ f logUserEvent :: UserId -> Event -> (Msg -> Msg) -> Gundeck () logUserEvent u ev f = logEvent ev $ - "user" .= toByteString u + "user" + .= toByteString u ~~ f diff --git a/services/gundeck/src/Gundeck/Redis.hs b/services/gundeck/src/Gundeck/Redis.hs index a4784349db2..5a8ba319caa 100644 --- a/services/gundeck/src/Gundeck/Redis.hs +++ b/services/gundeck/src/Gundeck/Redis.hs @@ -85,7 +85,7 @@ connectRobust l retryStrategy connectLowLevel = do const $ Catch.Handler (\(e :: IOException) -> logEx (Log.err l) e "network error when connecting to Redis" >> pure True) ] . const -- ignore RetryStatus - logEx :: Show e => ((Msg -> Msg) -> IO ()) -> e -> ByteString -> IO () + logEx :: (Show e) => ((Msg -> Msg) -> IO ()) -> e -> ByteString -> IO () logEx lLevel e description = lLevel $ Log.msg (Log.val description) . Log.field "error" (show e) -- | Run a 'Redis' action through a 'RobustConnection'. diff --git a/services/gundeck/src/Gundeck/Redis/HedisExtensions.hs b/services/gundeck/src/Gundeck/Redis/HedisExtensions.hs index 0dee66eee8e..7842fc98822 100644 --- a/services/gundeck/src/Gundeck/Redis/HedisExtensions.hs +++ b/services/gundeck/src/Gundeck/Redis/HedisExtensions.hs @@ -164,7 +164,7 @@ instance RedisResult ClusterInfoResponse where $ Char8.lines bulkData decode r = Left r -clusterInfo :: RedisCtx m f => m (f ClusterInfoResponse) +clusterInfo :: (RedisCtx m f) => m (f ClusterInfoResponse) clusterInfo = sendRequest ["CLUSTER", "INFO"] checkedConnectCluster :: ConnectInfo -> IO Connection diff --git a/services/gundeck/src/Gundeck/Run.hs b/services/gundeck/src/Gundeck/Run.hs index 4a919bd0ba7..4780f1142a9 100644 --- a/services/gundeck/src/Gundeck/Run.hs +++ b/services/gundeck/src/Gundeck/Run.hs @@ -26,15 +26,10 @@ import Control.Error (ExceptT (ExceptT)) import Control.Exception (finally) import Control.Lens ((.~), (^.)) import Control.Monad.Extra -import Data.Id (RequestId (..)) -import Data.Metrics (Metrics) import Data.Metrics.AWS (gaugeTokenRemaing) -import Data.Metrics.Middleware (metrics) import Data.Metrics.Middleware.Prometheus (waiPrometheusMiddleware) import Data.Proxy (Proxy (Proxy)) import Data.Text (unpack) -import Data.UUID qualified as UUID -import Data.UUID.V4 qualified as UUID import Database.Redis qualified as Redis import Gundeck.API (sitemap) import Gundeck.API.Public (servantSitemap) @@ -49,11 +44,10 @@ import Imports hiding (head) import Network.Wai as Wai import Network.Wai.Middleware.Gunzip qualified as GZip import Network.Wai.Middleware.Gzip qualified as GZip -import Network.Wai.Utilities (lookupRequestId) +import Network.Wai.Utilities.Request import Network.Wai.Utilities.Server hiding (serverPort) import Servant (Handler (Handler), (:<|>) (..)) import Servant qualified -import System.Logger ((.=), (~~)) import System.Logger qualified as Log import UnliftIO.Async qualified as Async import Util.Options @@ -63,19 +57,18 @@ import Wire.API.Routes.Version.Wai run :: Opts -> IO () run o = do - m <- metrics - (rThreads, e) <- createEnv m o + (rThreads, e) <- createEnv o runClient (e ^. cstate) $ versionCheck schemaVersion let l = e ^. applog - s <- newSettings $ defaultServer (unpack $ o ^. gundeck . host) (o ^. gundeck . port) l m + s <- newSettings $ defaultServer (unpack $ o ^. gundeck . host) (o ^. gundeck . port) l let throttleMillis = fromMaybe defSqsThrottleMillis $ o ^. (settings . sqsThrottleMillis) lst <- Async.async $ Aws.execute (e ^. awsEnv) (Aws.listen throttleMillis (runDirect e . onEvent)) - wtbs <- forM (e ^. threadBudgetState) $ \tbs -> Async.async $ runDirect e $ watchThreadBudgetState m tbs 10 - wCollectAuth <- Async.async (collectAuthMetrics m (Aws._awsEnv (Env._awsEnv e))) + wtbs <- forM (e ^. threadBudgetState) $ \tbs -> Async.async $ runDirect e $ watchThreadBudgetState tbs 10 + wCollectAuth <- Async.async (collectAuthMetrics (Aws._awsEnv (Env._awsEnv e))) - let app = middleware e (\requestId -> mkApp (e & reqId .~ requestId)) + let app = middleware e $ mkApp e runSettingsWithShutdown s app Nothing `finally` do Log.info l $ Log.msg (Log.val "Shutting down ...") shutdown (e ^. cstate) @@ -87,36 +80,26 @@ run o = do whenJust (e ^. rstateAdditionalWrite) $ (=<<) Redis.disconnect . takeMVar Log.close (e ^. applog) where - middleware :: Env -> (RequestId -> Wai.Application) -> Wai.Application + middleware :: Env -> Middleware middleware e = versionMiddleware (foldMap expandVersionExp (o ^. settings . disabledAPIVersions)) + . requestIdMiddleware (e ^. applog) defaultRequestIdHeaderName . waiPrometheusMiddleware sitemap . GZip.gunzip . GZip.gzip GZip.def - . catchErrors (e ^. applog) [Right $ e ^. monitor] - . lookupRequestIdMiddleware (e ^. applog) - - lookupRequestIdMiddleware :: Log.Logger -> (RequestId -> Wai.Application) -> Wai.Application - lookupRequestIdMiddleware logger mkapp req cont = do - case lookupRequestId req of - Just rid -> do - mkapp (RequestId rid) req cont - Nothing -> do - localRid <- RequestId . UUID.toASCIIBytes <$> UUID.nextRandom - Log.info logger $ - "request-id" .= localRid - ~~ "method" .= Wai.requestMethod req - ~~ "path" .= Wai.rawPathInfo req - ~~ Log.msg (Log.val "generated a new request id for local request") - mkapp localRid req cont + . catchErrors (e ^. applog) defaultRequestIdHeaderName type CombinedAPI = GundeckAPI :<|> Servant.Raw mkApp :: Env -> Wai.Application -mkApp env = +mkApp env0 req cont = do + let rid = getRequestId defaultRequestIdHeaderName req + env = reqId .~ rid $ env0 Servant.serve (Proxy @CombinedAPI) (servantSitemap' env :<|> Servant.Tagged (runGundeckWithRoutes env)) + req + cont where runGundeckWithRoutes :: Env -> Wai.Application runGundeckWithRoutes e r k = runGundeck e r (route (compile sitemap) r k) @@ -127,10 +110,10 @@ servantSitemap' env = Servant.hoistServer (Proxy @GundeckAPI) toServantHandler s toServantHandler :: Gundeck a -> Handler a toServantHandler m = Handler . ExceptT $ Right <$> runDirect env m -collectAuthMetrics :: MonadIO m => Metrics -> AWS.Env -> m () -collectAuthMetrics m env = do +collectAuthMetrics :: (MonadIO m) => AWS.Env -> m () +collectAuthMetrics env = do liftIO $ forever $ do mbRemaining <- readAuthExpiration env - gaugeTokenRemaing m mbRemaining + gaugeTokenRemaing mbRemaining threadDelay 1_000_000 diff --git a/services/gundeck/src/Gundeck/ThreadBudget/Internal.hs b/services/gundeck/src/Gundeck/ThreadBudget/Internal.hs index 4f311bb072c..12f0a36a8dd 100644 --- a/services/gundeck/src/Gundeck/ThreadBudget/Internal.hs +++ b/services/gundeck/src/Gundeck/ThreadBudget/Internal.hs @@ -25,14 +25,14 @@ import Control.Exception.Safe (catchAny) import Control.Lens import Control.Monad.Catch (MonadCatch) import Data.HashMap.Strict qualified as HM -import Data.Metrics (Metrics, counterIncr) -import Data.Metrics.Middleware (gaugeSet, path) import Data.Set qualified as Set import Data.Time import Data.UUID (UUID, toText) import Data.UUID.V4 (nextRandom) import Gundeck.Options import Imports +import Prometheus (MonadMonitor) +import Prometheus qualified as Prom import System.Logger.Class qualified as LC import UnliftIO.Async import UnliftIO.Exception (finally) @@ -66,12 +66,12 @@ cancelAllThreads (ThreadBudgetState _ ref) = readIORef ref >>= mapM_ cancel . mapMaybe snd . HM.elems . bmap -mkThreadBudgetState :: HasCallStack => MaxConcurrentNativePushes -> IO ThreadBudgetState +mkThreadBudgetState :: (HasCallStack) => MaxConcurrentNativePushes -> IO ThreadBudgetState mkThreadBudgetState limits = ThreadBudgetState limits <$> newIORef (BudgetMap 0 HM.empty) -- | Allocate the resources for a new action to be called (but don't call the action yet). allocate :: - IORef BudgetMap -> UUID -> Int -> MonadIO m => m Int + IORef BudgetMap -> UUID -> Int -> (MonadIO m) => m Int allocate ref key newspent = atomicModifyIORef' ref $ \(BudgetMap spent hm) -> @@ -81,7 +81,7 @@ allocate ref key newspent = -- | Register an already-allocated action with its 'Async'. register :: - IORef BudgetMap -> UUID -> Async () -> MonadIO m => m Int + IORef BudgetMap -> UUID -> Async () -> (MonadIO m) => m Int register ref key handle = atomicModifyIORef' ref $ \(BudgetMap spent hm) -> @@ -91,7 +91,7 @@ register ref key handle = -- | Remove an registered and/or allocated action from a 'BudgetMap'. unregister :: - IORef BudgetMap -> UUID -> MonadIO m => m () + IORef BudgetMap -> UUID -> (MonadIO m) => m () unregister ref key = atomicModifyIORef' ref $ \bhm@(BudgetMap spent hm) -> @@ -112,26 +112,24 @@ unregister ref key = -- update the budget. runWithBudget :: forall m. - (LC.MonadLogger m, MonadUnliftIO m) => - Metrics -> + (LC.MonadLogger m, MonadUnliftIO m, MonadMonitor m) => ThreadBudgetState -> Int -> m () -> m () -runWithBudget metrics tbs spent = runWithBudget' metrics tbs spent () +runWithBudget tbs spent = runWithBudget' tbs spent () -- | More flexible variant of 'runWithBudget' that allows the action to return a value. With -- a default in case of budget exhaustion. runWithBudget' :: forall m a. - (MonadIO m, LC.MonadLogger m, MonadUnliftIO m) => - Metrics -> + (MonadIO m, LC.MonadLogger m, MonadUnliftIO m, MonadMonitor m) => ThreadBudgetState -> Int -> a -> m a -> m a -runWithBudget' metrics (ThreadBudgetState limits ref) spent fallback action = do +runWithBudget' (ThreadBudgetState limits ref) spent fallback action = do key <- liftIO nextRandom (`finally` unregister ref key) $ do oldsize <- allocate ref key spent @@ -145,8 +143,10 @@ runWithBudget' metrics (ThreadBudgetState limits ref) spent fallback action = do go :: UUID -> Int -> m a go key oldsize = do LC.debug $ - "key" LC..= toText key - LC.~~ "spent" LC..= oldsize + "key" + LC..= toText key + LC.~~ "spent" + LC..= oldsize LC.~~ LC.msg (LC.val "runWithBudget: go") handle <- async action _ <- register ref key (void handle) @@ -155,13 +155,19 @@ runWithBudget' metrics (ThreadBudgetState limits ref) spent fallback action = do warnNoBudget :: Bool -> Bool -> Int -> m () warnNoBudget False False _ = pure () warnNoBudget soft' hard' oldsize = do - let limit = if hard' then "hard" else "soft" - metric = "net.nativepush." <> limit <> "_limit_breached" - counterIncr (path metric) metrics + let limit :: ByteString = if hard' then "hard" else "soft" + counter = + if hard' + then threadBudgetHardLimitBreachedCounter + else threadBudgetSoftLimitBreachedCounter + Prom.incCounter counter LC.warn $ - "spent" LC..= show oldsize - LC.~~ "soft-breach" LC..= soft' - LC.~~ "hard-breach" LC..= hard' + "spent" + LC..= show oldsize + LC.~~ "soft-breach" + LC..= soft' + LC.~~ "hard-breach" + LC..= hard' LC.~~ LC.msg ("runWithBudget: " <> limit <> " limit reached") -- | Fork a thread that checks with the given frequency if any async handles stored in the @@ -174,32 +180,80 @@ runWithBudget' metrics (ThreadBudgetState limits ref) spent fallback action = do -- Also, issue some metrics. watchThreadBudgetState :: forall m. - (MonadIO m, LC.MonadLogger m, MonadCatch m) => - Metrics -> + (MonadIO m, LC.MonadLogger m, MonadCatch m, MonadMonitor m) => ThreadBudgetState -> NominalDiffTime -> m () -watchThreadBudgetState metrics (ThreadBudgetState limits ref) freq = safeForever $ do - recordMetrics metrics limits ref +watchThreadBudgetState (ThreadBudgetState limits ref) freq = safeForever $ do + recordMetrics limits ref removeStaleHandles ref threadDelayNominalDiffTime freq recordMetrics :: forall m. - MonadIO m => - Metrics -> + (MonadIO m, MonadMonitor m) => MaxConcurrentNativePushes -> IORef BudgetMap -> m () -recordMetrics metrics limits ref = do +recordMetrics limits ref = do (BudgetMap spent _) <- readIORef ref - gaugeSet (fromIntegral spent) (path "net.nativepush.thread_budget_allocated") metrics + Prom.setGauge threadBudgetAllocatedGauge (fromIntegral spent) forM_ (limits ^. hard) $ \lim -> - gaugeSet (fromIntegral lim) (path "net.nativepush.thread_budget_hard_limit") metrics + Prom.setGauge threadBudgetHardLimitGauge (fromIntegral lim) forM_ (limits ^. soft) $ \lim -> - gaugeSet (fromIntegral lim) (path "net.nativepush.thread_budget_soft_limit") metrics + Prom.setGauge threadBudgetSoftLimitGauge (fromIntegral lim) + +{-# NOINLINE threadBudgetAllocatedGauge #-} +threadBudgetAllocatedGauge :: Prom.Gauge +threadBudgetAllocatedGauge = + Prom.unsafeRegister $ + Prom.gauge + Prom.Info + { Prom.metricName = "net.nativepush.thread_budget_allocated", + Prom.metricHelp = "Number of allocated threads for native pushes" + } + +{-# NOINLINE threadBudgetHardLimitGauge #-} +threadBudgetHardLimitGauge :: Prom.Gauge +threadBudgetHardLimitGauge = + Prom.unsafeRegister $ + Prom.gauge + Prom.Info + { Prom.metricName = "net.nativepush.thread_budget_hard_limit", + Prom.metricHelp = "Hard limit for threads for native pushes" + } + +{-# NOINLINE threadBudgetSoftLimitGauge #-} +threadBudgetSoftLimitGauge :: Prom.Gauge +threadBudgetSoftLimitGauge = + Prom.unsafeRegister $ + Prom.gauge + Prom.Info + { Prom.metricName = "net.nativepush.thread_budget_soft_limit", + Prom.metricHelp = "Soft limit for threads for native pushes" + } + +{-# NOINLINE threadBudgetHardLimitBreachedCounter #-} +threadBudgetHardLimitBreachedCounter :: Prom.Counter +threadBudgetHardLimitBreachedCounter = + Prom.unsafeRegister $ + Prom.counter + Prom.Info + { Prom.metricName = "net.nativepush.thread_budget_hard_limit_breached", + Prom.metricHelp = "Number of times hard limit for threads for native pushes was breached" + } + +{-# NOINLINE threadBudgetSoftLimitBreachedCounter #-} +threadBudgetSoftLimitBreachedCounter :: Prom.Counter +threadBudgetSoftLimitBreachedCounter = + Prom.unsafeRegister $ + Prom.counter + Prom.Info + { Prom.metricName = "net.nativepush.thread_budget_soft_limit_breached", + Prom.metricHelp = "Number of times soft limit for threads for native pushes was breached" + } -threadDelayNominalDiffTime :: NominalDiffTime -> MonadIO m => m () +threadDelayNominalDiffTime :: NominalDiffTime -> (MonadIO m) => m () threadDelayNominalDiffTime = threadDelay . round . (* 1000000) . toRational staleTolerance :: NominalDiffTime @@ -242,7 +296,8 @@ removeStaleHandles ref = do warnStaleHandles :: Int -> BudgetMap -> m () warnStaleHandles num (BudgetMap spent _) = LC.warn $ - "spent" LC..= show spent + "spent" + LC..= show spent LC.~~ LC.msg ("watchThreadBudgetState: removed " <> show num <> " stale handles.") safeForever :: diff --git a/services/gundeck/src/Gundeck/Util.hs b/services/gundeck/src/Gundeck/Util.hs index bbcc42fba94..9b210881463 100644 --- a/services/gundeck/src/Gundeck/Util.hs +++ b/services/gundeck/src/Gundeck/Util.hs @@ -48,7 +48,7 @@ mapAsync :: mapAsync f = mapM waitCatch <=< mapM (async . f) {-# INLINE mapAsync #-} -maybeEqual :: Eq a => Maybe a -> Maybe a -> Bool +maybeEqual :: (Eq a) => Maybe a -> Maybe a -> Bool maybeEqual (Just x) (Just y) = x == y maybeEqual _ _ = False {-# INLINE maybeEqual #-} diff --git a/services/gundeck/src/Gundeck/Util/DelayQueue.hs b/services/gundeck/src/Gundeck/Util/DelayQueue.hs index f63781e8e94..0e160b1965d 100644 --- a/services/gundeck/src/Gundeck/Util/DelayQueue.hs +++ b/services/gundeck/src/Gundeck/Util/DelayQueue.hs @@ -54,7 +54,7 @@ new c d l = do queue <- newIORef PSQ.empty pure $! DelayQueue queue c d l -enqueue :: Ord k => DelayQueue k v -> k -> v -> IO Bool +enqueue :: (Ord k) => DelayQueue k v -> k -> v -> IO Bool enqueue (DelayQueue queue clock d l) k v = do time <- getTime clock let !p = time + delayTime d @@ -71,7 +71,7 @@ enqueue (DelayQueue queue clock d l) k v = do k q -dequeue :: Ord k => DelayQueue k v -> IO (Maybe (Either Delay v)) +dequeue :: (Ord k) => DelayQueue k v -> IO (Maybe (Either Delay v)) dequeue (DelayQueue queue clock _ _) = do time <- getTime clock atomicModifyIORef' queue $ \q -> @@ -80,7 +80,7 @@ dequeue (DelayQueue queue clock _ _) = do Just (_, p, v, q') | p <= time -> (q', Just (Right v)) Just (_, p, _, _) -> (q, Just (Left (Delay (p - time)))) -cancel :: Ord k => DelayQueue k v -> k -> IO Bool +cancel :: (Ord k) => DelayQueue k v -> k -> IO Bool cancel (DelayQueue queue _ _ _) k = atomicModifyIORef' queue $ swap . PSQ.alter (\pv -> (isJust pv, Nothing)) k diff --git a/services/gundeck/src/Gundeck/Util/Redis.hs b/services/gundeck/src/Gundeck/Util/Redis.hs index 5ae9c1b1886..891505c39ae 100644 --- a/services/gundeck/src/Gundeck/Util/Redis.hs +++ b/services/gundeck/src/Gundeck/Util/Redis.hs @@ -35,7 +35,7 @@ x1 = limitRetries 1 <> exponentialBackoff 100000 x3 :: RetryPolicy x3 = limitRetries 3 <> exponentialBackoff 100000 -handlers :: MonadLogger m => [a -> Handler m Bool] +handlers :: (MonadLogger m) => [a -> Handler m Bool] handlers = [ const . Handler $ \case RedisSimpleError (Error err) -> pure $ "READONLY" `BS.isPrefixOf` err @@ -57,7 +57,7 @@ data RedisError instance Exception RedisError -fromTxResult :: MonadThrow m => TxResult a -> m a +fromTxResult :: (MonadThrow m) => TxResult a -> m a fromTxResult = \case TxSuccess a -> pure a TxAborted -> throwM RedisTxAborted diff --git a/services/gundeck/test/integration/API.hs b/services/gundeck/test/integration/API.hs index a91a075ac00..e5e3a3cdbcc 100644 --- a/services/gundeck/test/integration/API.hs +++ b/services/gundeck/test/integration/API.hs @@ -410,12 +410,18 @@ storeNotificationsEvenWhenRedisIsDown = do origRedisEndpoint <- view $ tsOpts . redis let proxyPort = 10112 redisProxyServer <- liftIO . async $ runRedisProxy (origRedisEndpoint ^. O.host) (origRedisEndpoint ^. O.port) proxyPort - withSettingsOverrides (redis .~ RedisEndpoint "localhost" proxyPort (origRedisEndpoint ^. connectionMode)) $ do - let pload = textPayload "hello" - push = buildPush ally [(ally, RecipientClientsAll)] pload - gu <- view tsGundeck - liftIO $ Async.cancel redisProxyServer - post (runGundeckR gu . path "i/push/v2" . json [push]) !!! const 200 === statusCode + withSettingsOverrides + ( \gundeckSettings -> + gundeckSettings + & redis . Gundeck.Options.host .~ "localhost" + & redis . Gundeck.Options.port .~ proxyPort + ) + $ do + let pload = textPayload "hello" + push = buildPush ally [(ally, RecipientClientsAll)] pload + gu <- view tsGundeck + liftIO $ Async.cancel redisProxyServer + post (runGundeckR gu . path "i/push/v2" . json [push]) !!! const 200 === statusCode ns <- listNotifications ally Nothing liftIO $ assertEqual ("Expected 1 notification, got: " <> show ns) 1 (length ns) @@ -891,19 +897,19 @@ testRedisMigration = do -- * Helpers -ensurePresent :: HasCallStack => UserId -> Int -> TestM () +ensurePresent :: (HasCallStack) => UserId -> Int -> TestM () ensurePresent u n = do gu <- view tsGundeck retryWhile ((n /=) . length . decodePresence) (getPresence gu (showUser u)) !!! (const n === length . decodePresence) -connectUser :: HasCallStack => CannonR -> UserId -> ConnId -> TestM (TChan ByteString) +connectUser :: (HasCallStack) => CannonR -> UserId -> ConnId -> TestM (TChan ByteString) connectUser ca uid con = do [(_, [ch])] <- connectUsersAndDevices ca [(uid, [con])] pure ch connectUsersAndDevices :: - HasCallStack => + (HasCallStack) => CannonR -> [(UserId, [ConnId])] -> TestM [(UserId, [TChan ByteString])] @@ -913,7 +919,7 @@ connectUsersAndDevices ca uidsAndConnIds = do strip = fmap (_2 %~ fmap fst) connectUsersAndDevicesWithSendingClients :: - HasCallStack => + (HasCallStack) => CannonR -> [(UserId, [ConnId])] -> TestM [(UserId, [(TChan ByteString, TChan ByteString)])] @@ -933,7 +939,7 @@ connectUsersAndDevicesWithSendingClients ca uidsAndConnIds = do -- in a Ping Writer and gives access to 'WS.Message's -- this can be used to test Ping/Pong behaviour on the control channel connectUsersAndDevicesWithSendingClientsRaw :: - HasCallStack => + (HasCallStack) => CannonR -> [(UserId, [ConnId])] -> TestM [(UserId, [(TChan WS.Message, TChan ByteString)])] @@ -952,7 +958,7 @@ connectUsersAndDevicesWithSendingClientsRaw ca uidsAndConnIds = do assertPresences :: (UserId, [ConnId]) -> TestM () assertPresences (uid, conns) = wsAssertPresences uid (length conns) -wsRun :: HasCallStack => CannonR -> UserId -> ConnId -> WS.ClientApp () -> TestM (Async ()) +wsRun :: (HasCallStack) => CannonR -> UserId -> ConnId -> WS.ClientApp () -> TestM (Async ()) wsRun ca uid (ConnId con) app = do liftIO $ async $ WS.runClientWith caHost caPort caPath caOpts caHdrs app where @@ -963,7 +969,7 @@ wsRun ca uid (ConnId con) app = do caOpts = WS.defaultConnectionOptions caHdrs = [("Z-User", showUser uid), ("Z-Connection", con)] -wsAssertPresences :: HasCallStack => UserId -> Int -> TestM () +wsAssertPresences :: (HasCallStack) => UserId -> Int -> TestM () wsAssertPresences uid numPres = do gu <- view tsGundeck retryWhile ((numPres /=) . length . decodePresence) (getPresence gu $ showUser uid) @@ -997,10 +1003,10 @@ retryWhileN n f m = waitForMessageRaw :: TChan WS.Message -> IO (Maybe WS.Message) waitForMessageRaw = System.Timeout.timeout 3000000 . liftIO . atomically . readTChan -waitForMessage :: ToByteString a => TChan a -> IO (Maybe a) +waitForMessage :: (ToByteString a) => TChan a -> IO (Maybe a) waitForMessage = waitForMessage' 1000000 -waitForMessage' :: ToByteString a => Int -> TChan a -> IO (Maybe a) +waitForMessage' :: (ToByteString a) => Int -> TChan a -> IO (Maybe a) waitForMessage' musecs = System.Timeout.timeout musecs . liftIO . atomically . readTChan unregisterClient :: GundeckR -> UserId -> ClientId -> TestM (Response (Maybe BL.ByteString)) @@ -1056,7 +1062,7 @@ listPushTokens u = do (pure . pushTokens) (responseBody rs >>= decode) -listNotifications :: HasCallStack => UserId -> Maybe ClientId -> TestM [QueuedNotification] +listNotifications :: (HasCallStack) => UserId -> Maybe ClientId -> TestM [QueuedNotification] listNotifications u c = do rs <- getNotifications u c >= decode of @@ -1085,16 +1091,16 @@ getLastNotification u c = . paths ["notifications", "last"] . maybe id (queryItem "client" . toByteString') c -sendPush :: HasCallStack => Push -> TestM () +sendPush :: (HasCallStack) => Push -> TestM () sendPush push = sendPushes [push] -sendPushes :: HasCallStack => [Push] -> TestM () +sendPushes :: (HasCallStack) => [Push] -> TestM () sendPushes push = do gu <- view tsGundeck post (runGundeckR gu . path "i/push/v2" . json push) !!! const 200 === statusCode buildPush :: - HasCallStack => + (HasCallStack) => UserId -> [(UserId, RecipientClients)] -> List1 Object -> @@ -1116,7 +1122,7 @@ gcmToken = TokenSpec GCM 16 appName apnsToken :: TokenSpec apnsToken = TokenSpec APNSSandbox 32 appName -randomToken :: MonadIO m => ClientId -> TokenSpec -> m PushToken +randomToken :: (MonadIO m) => ClientId -> TokenSpec -> m PushToken randomToken c ts = liftIO $ do tok <- (Token . T.decodeUtf8) Prelude.. B16.encode Prelude.<$> randomBytes (tSize ts) pure $ pushToken (trans ts) (tName ts) tok c @@ -1162,17 +1168,17 @@ randomUser = do toRecipients :: [UserId] -> Range 1 1024 (Set Recipient) toRecipients = unsafeRange . Set.fromList . map (`recipient` RouteAny) -randomConnId :: MonadIO m => m ConnId +randomConnId :: (MonadIO m) => m ConnId randomConnId = liftIO $ ConnId <$> do r <- randomIO :: IO Word32 pure $ C.pack $ show r -randomClientId :: MonadIO m => m ClientId +randomClientId :: (MonadIO m) => m ClientId randomClientId = liftIO $ ClientId <$> (randomIO :: IO Word64) -randomBytes :: MonadIO m => Int -> m ByteString +randomBytes :: (MonadIO m) => Int -> m ByteString randomBytes n = liftIO $ BS.pack <$> replicateM n (randomIO :: IO Word8) textPayload :: Text -> List1 Object @@ -1187,7 +1193,7 @@ parseNotifications = responseBody >=> (^? key "notifications") >=> fromJSON' parseNotificationIds :: Response (Maybe BL.ByteString) -> Maybe [NotificationId] parseNotificationIds r = map (view queuedNotificationId) <$> parseNotifications r -fromJSON' :: FromJSON a => Value -> Maybe a +fromJSON' :: (FromJSON a) => Value -> Maybe a fromJSON' v = case fromJSON v of Success a -> Just a _ -> Nothing diff --git a/services/gundeck/test/integration/Util.hs b/services/gundeck/test/integration/Util.hs index b28aa32b50a..0bce9203d72 100644 --- a/services/gundeck/test/integration/Util.hs +++ b/services/gundeck/test/integration/Util.hs @@ -8,7 +8,6 @@ import Control.Lens import Control.Monad.Catch import Control.Monad.Codensity import Data.ByteString qualified as S -import Data.Metrics.Middleware (metrics) import Data.Text qualified as Text import Gundeck.Env (createEnv) import Gundeck.Options @@ -23,8 +22,7 @@ withSettingsOverrides :: (Opts -> Opts) -> TestM a -> TestM a withSettingsOverrides f action = do ts <- ask let opts = f (view tsOpts ts) - m <- metrics - (_rThreads, env) <- liftIO $ createEnv m opts + (_rThreads, env) <- liftIO $ createEnv opts liftIO . lowerCodensity $ do let app = mkApp env p <- withMockServer app diff --git a/services/gundeck/test/unit/Aws/Arn.hs b/services/gundeck/test/unit/Aws/Arn.hs index ca661c8d0de..9d20bfaeec0 100644 --- a/services/gundeck/test/unit/Aws/Arn.hs +++ b/services/gundeck/test/unit/Aws/Arn.hs @@ -22,7 +22,7 @@ tests = ] ] -realWorldArnTest :: HasCallStack => (String -> IO ()) -> Assertion +realWorldArnTest :: (HasCallStack) => (String -> IO ()) -> Assertion realWorldArnTest step = do step "Given an ARN from a test environment" let arnText :: Text = "arn:aws:sns:eu-central-1:091205192927:endpoint/GCM/sven-test-782078216207/ded226c7-45b8-3f6c-9e89-f253340bbb60" @@ -39,7 +39,7 @@ realWorldArnTest step = do step "Expect values to be de-serialized correctly" (toText arnData) @?= arnText -madeUpArnTest :: HasCallStack => (String -> IO ()) -> Assertion +madeUpArnTest :: (HasCallStack) => (String -> IO ()) -> Assertion madeUpArnTest step = do step "Given an ARN with data to cover untested cases" let arnText :: Text = "arn:aws:sns:us-east-2:000000000001:endpoint/APNS/nodash-000000000002/8ffd8d14-db06-4f3a-a3bb-08264b9dbfb0" diff --git a/services/gundeck/test/unit/Json.hs b/services/gundeck/test/unit/Json.hs index d502874e32f..b83dbf006be 100644 --- a/services/gundeck/test/unit/Json.hs +++ b/services/gundeck/test/unit/Json.hs @@ -107,7 +107,7 @@ genPushTarget = PushTarget <$> arbitrary <*> (ConnId <$> genAlphaNum) genObject :: Gen Object genObject = fromList <$> listOf ((,) <$> genAlphaNum <*> (String <$> genAlphaNum)) -genAlphaNum :: IsString s => Gen s +genAlphaNum :: (IsString s) => Gen s genAlphaNum = fromString <$> listOf (elements (['a' .. 'z'] <> ['A' .. 'Z'] <> ['0' .. '9'])) shortListOf :: Gen a -> Gen [a] diff --git a/services/gundeck/test/unit/MockGundeck.hs b/services/gundeck/test/unit/MockGundeck.hs index 19d35241dbd..d662a62aa10 100644 --- a/services/gundeck/test/unit/MockGundeck.hs +++ b/services/gundeck/test/unit/MockGundeck.hs @@ -199,11 +199,11 @@ mkFakeAddrEndpoint (epid, transport, app) = Aws.mkSnsArn Tokyo (Account "acc") e -- 2. web socket delivery will NOT work, native push token registered, push will succeed -- 3. web socket delivery will NOT work, native push token registered, push will fail -- 4. web socket delivery will NOT work, no native push token registered -genMockEnv :: HasCallStack => Gen MockEnv +genMockEnv :: (HasCallStack) => Gen MockEnv genMockEnv = do -- This function generates a 'ClientInfo' that corresponds to one of the -- four scenarios above - let genClientInfo :: HasCallStack => UserId -> ClientId -> Gen ClientInfo + let genClientInfo :: (HasCallStack) => UserId -> ClientId -> Gen ClientInfo genClientInfo uid cid = do _ciNativeAddress <- QC.oneof @@ -250,12 +250,12 @@ genMockEnv = do validateMockEnv env & either error (const $ pure env) -- Try to shrink a 'MockEnv' by removing some users from '_meClientInfos'. -shrinkMockEnv :: HasCallStack => MockEnv -> [MockEnv] +shrinkMockEnv :: (HasCallStack) => MockEnv -> [MockEnv] shrinkMockEnv (MockEnv cis) = MockEnv . Map.fromList <$> filter (not . null) (shrinkList (const []) (Map.toList cis)) -validateMockEnv :: forall m. MonadError String m => MockEnv -> m () +validateMockEnv :: forall m. (MonadError String m) => MockEnv -> m () validateMockEnv env = do checkIdsInNativeAddresses where @@ -270,17 +270,17 @@ validateMockEnv env = do unless (uid == adr ^. addrUser && cid == adr ^. addrClient) $ do throwError (show (uid, cid, adr)) -genRecipients :: HasCallStack => Int -> MockEnv -> Gen [Recipient] +genRecipients :: (HasCallStack) => Int -> MockEnv -> Gen [Recipient] genRecipients numrcp env = do uids <- take numrcp <$> shuffle (allUsers env) genRecipient' env `mapM` uids -genRecipient :: HasCallStack => MockEnv -> Gen Recipient +genRecipient :: (HasCallStack) => MockEnv -> Gen Recipient genRecipient env = do uid <- QC.elements (allUsers env) genRecipient' env uid -genRecipient' :: HasCallStack => MockEnv -> UserId -> Gen Recipient +genRecipient' :: (HasCallStack) => MockEnv -> UserId -> Gen Recipient genRecipient' env uid = do route <- genRoute cids <- @@ -290,7 +290,7 @@ genRecipient' env uid = do ] pure $ Recipient uid route cids -genRoute :: HasCallStack => Gen Route +genRoute :: (HasCallStack) => Gen Route genRoute = QC.elements [minBound ..] genId :: Gen (Id a) @@ -301,7 +301,7 @@ genId = do genClientId :: Gen ClientId genClientId = ClientId <$> arbitrary -genProtoAddress :: HasCallStack => UserId -> ClientId -> Gen Address +genProtoAddress :: (HasCallStack) => UserId -> ClientId -> Gen Address genProtoAddress _addrUser _addrClient = do _addrTransport :: Transport <- QC.elements [minBound ..] arnEpId :: Text <- arbitrary @@ -314,7 +314,7 @@ genProtoAddress _addrUser _addrClient = do genPushes :: MockEnv -> Gen [Push] genPushes = listOf . genPush -genPush :: HasCallStack => MockEnv -> Gen Push +genPush :: (HasCallStack) => MockEnv -> Gen Push genPush env = do let alluids = allUsers env sender <- QC.elements alluids @@ -373,14 +373,14 @@ dropSomeDevices = RecipientClientsSome . unsafeList1 . take numdevs <$> QC.shuffle (toList cids) -shrinkPushes :: HasCallStack => [Push] -> [[Push]] +shrinkPushes :: (HasCallStack) => [Push] -> [[Push]] shrinkPushes = shrinkList shrinkPush where - shrinkPush :: HasCallStack => Push -> [Push] + shrinkPush :: (HasCallStack) => Push -> [Push] shrinkPush psh = (\rcps -> psh & pushRecipients .~ rcps) <$> shrinkRecipients (psh ^. pushRecipients) - shrinkRecipients :: HasCallStack => Range 1 1024 (Set Recipient) -> [Range 1 1024 (Set Recipient)] + shrinkRecipients :: (HasCallStack) => Range 1 1024 (Set Recipient) -> [Range 1 1024 (Set Recipient)] shrinkRecipients = fmap unsafeRange . map Set.fromList . filter (not . null) . shrinkList shrinkRecipient . Set.toList . fromRange - shrinkRecipient :: HasCallStack => Recipient -> [Recipient] + shrinkRecipient :: (HasCallStack) => Recipient -> [Recipient] shrinkRecipient _ = [] -- | See 'Payload'. @@ -400,7 +400,7 @@ genNotifs env = fmap uniqNotifs . listOf $ do where uniqNotifs = nubBy ((==) `on` (ntfId . fst)) -shrinkNotifs :: HasCallStack => [(Notification, [Presence])] -> [[(Notification, [Presence])]] +shrinkNotifs :: (HasCallStack) => [(Notification, [Presence])] -> [[(Notification, [Presence])]] shrinkNotifs = shrinkList (\(notif, prcs) -> (notif,) <$> shrinkList (const []) prcs) ---------------------------------------------------------------------- @@ -698,20 +698,20 @@ mockOldSimpleWebPush notif tgts _senderid mconnid connWhitelist = do newtype Pretty a = Pretty a deriving (Eq, Ord) -instance Aeson.ToJSON a => Show (Pretty a) where +instance (Aeson.ToJSON a) => Show (Pretty a) where show (Pretty a) = cs $ Aeson.encodePretty a -shrinkPretty :: HasCallStack => (a -> [a]) -> Pretty a -> [Pretty a] +shrinkPretty :: (HasCallStack) => (a -> [a]) -> Pretty a -> [Pretty a] shrinkPretty shrnk (Pretty xs) = Pretty <$> shrnk xs -sublist1Of :: HasCallStack => [a] -> Gen (List1 a) +sublist1Of :: (HasCallStack) => [a] -> Gen (List1 a) sublist1Of [] = error "sublist1Of: empty list" sublist1Of xs = sublistOf xs >>= \case [] -> sublist1Of xs c : cc -> pure (list1 c cc) -unsafeList1 :: HasCallStack => [a] -> List1 a +unsafeList1 :: (HasCallStack) => [a] -> List1 a unsafeList1 [] = error "unsafeList1: empty list" unsafeList1 (x : xs) = list1 x xs @@ -754,7 +754,7 @@ allUsers = fmap fst . allRecipients allRecipients :: MockEnv -> [(UserId, [ClientId])] allRecipients (MockEnv mp) = (_2 %~ Map.keys) <$> Map.toList mp -clientIdsOfUser :: HasCallStack => MockEnv -> UserId -> [ClientId] +clientIdsOfUser :: (HasCallStack) => MockEnv -> UserId -> [ClientId] clientIdsOfUser (MockEnv mp) uid = maybe (error "unknown UserId") Map.keys $ Map.lookup uid mp diff --git a/services/gundeck/test/unit/ThreadBudget.hs b/services/gundeck/test/unit/ThreadBudget.hs index f9f21656aa3..7715d8c8a7c 100644 --- a/services/gundeck/test/unit/ThreadBudget.hs +++ b/services/gundeck/test/unit/ThreadBudget.hs @@ -29,7 +29,6 @@ module ThreadBudget where import Control.Concurrent.Async import Control.Lens import Control.Monad.Catch (MonadCatch, catch) -import Data.Metrics.Middleware (metrics) import Data.String.Conversions import Data.Time import GHC.Generics @@ -120,24 +119,22 @@ delay' :: (MonadCatch m, MonadIO m) => Int -> m () delay' microsecs = threadDelay microsecs `catch` \AsyncCancelled -> pure () burstActions :: - HasCallStack => + (HasCallStack) => ThreadBudgetState -> LogHistory -> MilliSeconds -> NumberOfThreads -> (MonadIO m) => m () burstActions tbs logHistory howlong (NumberOfThreads howmany) = do - mtr <- metrics - let budgeted = runWithBudget mtr tbs 1 (delayms howlong) + let budgeted = runWithBudget tbs 1 (delayms howlong) liftIO . replicateM_ howmany . forkIO $ runReaderT budgeted logHistory -- | Start a watcher with given params and a frequency of 10 milliseconds, so we are more -- likely to find weird race conditions. mkWatcher :: ThreadBudgetState -> LogHistory -> IO (Async ()) mkWatcher tbs logHistory = do - mtr <- metrics async $ - runReaderT (watchThreadBudgetState mtr tbs 0.01) logHistory + runReaderT (watchThreadBudgetState tbs 0.01) logHistory `catch` \AsyncCancelled -> pure () ---------------------------------------------------------------------- @@ -214,7 +211,7 @@ data Response r | MeasureResponse Int -- concrete running threads deriving (Show, Generic, Generic1, Rank2.Functor, Rank2.Foldable, Rank2.Traversable) -generator :: HasCallStack => Model Symbolic -> Maybe (Gen (Command Symbolic)) +generator :: (HasCallStack) => Model Symbolic -> Maybe (Gen (Command Symbolic)) generator (Model Nothing) = Just $ Init <$> arbitrary generator (Model (Just st)) = Just $ @@ -224,16 +221,16 @@ generator (Model (Just st)) = pure $ Measure st ] -shrinker :: HasCallStack => Model Symbolic -> Command Symbolic -> [Command Symbolic] +shrinker :: (HasCallStack) => Model Symbolic -> Command Symbolic -> [Command Symbolic] shrinker _ (Init _) = [] shrinker _ (Run st n m) = Wait st (MilliSeconds 1) : (Run st <$> shrink n <*> shrink m) shrinker _ (Wait st n) = Wait st <$> shrink n shrinker _ (Measure _) = [] -initModel :: HasCallStack => Model r +initModel :: (HasCallStack) => Model r initModel = Model Nothing -semantics :: HasCallStack => Command Concrete -> IO (Response Concrete) +semantics :: (HasCallStack) => Command Concrete -> IO (Response Concrete) semantics (Init (NumberOfThreads limit)) = do tbs <- mkThreadBudgetState (MaxConcurrentNativePushes (Just limit) (Just limit)) @@ -257,17 +254,17 @@ semantics (Measure (opaque -> (tbs, _, _))) = concreteRunning <- budgetSpent tbs pure (MeasureResponse concreteRunning) -transition :: HasCallStack => Model r -> Command r -> Response r -> Model r +transition :: (HasCallStack) => Model r -> Command r -> Response r -> Model r transition (Model Nothing) (Init _) (InitResponse st) = Model (Just st) transition (Model (Just st)) Run {} RunResponse = Model (Just st) transition (Model (Just st)) Wait {} WaitResponse = Model (Just st) transition (Model (Just st)) Measure {} MeasureResponse {} = Model (Just st) transition _ _ _ = error "impossible." -precondition :: HasCallStack => Model Symbolic -> Command Symbolic -> Logic +precondition :: (HasCallStack) => Model Symbolic -> Command Symbolic -> Logic precondition _ _ = Top -postcondition :: HasCallStack => Model Concrete -> Command Concrete -> Response Concrete -> Logic +postcondition :: (HasCallStack) => Model Concrete -> Command Concrete -> Response Concrete -> Logic postcondition (Model Nothing) Init {} InitResponse {} = Top postcondition (Model (Just _)) Run {} RunResponse {} = Top postcondition (Model (Just _)) Wait {} WaitResponse {} = Top @@ -287,7 +284,7 @@ postcondition model@(Model (Just _)) cmd@Measure {} resp@(MeasureResponse concre postcondition m c r = error $ "impossible: " <> show (m, c, r) -mock :: HasCallStack => Model Symbolic -> Command Symbolic -> GenSym (Response Symbolic) +mock :: (HasCallStack) => Model Symbolic -> Command Symbolic -> GenSym (Response Symbolic) mock (Model Nothing) (Init _) = InitResponse <$> genSym mock (Model (Just _)) Run {} = pure RunResponse @@ -319,7 +316,7 @@ sm = -- | Remove resources created by the concrete 'STM.Commands', namely watcher and budgeted -- async threads. -shutdown :: Model Concrete -> MonadIO m => m () +shutdown :: Model Concrete -> (MonadIO m) => m () shutdown (Model Nothing) = pure () shutdown (Model (Just (opaque -> (tbs, watcher, _)))) = liftIO $ do cancelAllThreads tbs diff --git a/services/integration.yaml b/services/integration.yaml index dbfc516bf87..b33259f873a 100644 --- a/services/integration.yaml +++ b/services/integration.yaml @@ -122,6 +122,8 @@ redis2: host: 127.0.0.1 port: 6379 connectionMode: master + enableTls: false + insecureSkipVerifyTls: false dynamicBackends: dynamic-backend-1: @@ -136,7 +138,7 @@ dynamicBackends: rabbitmq: host: localhost - adminPort: 15672 + adminPort: 15671 cassandra: host: 127.0.0.1 diff --git a/services/nginz/integration-test/conf/nginz/README.md b/services/nginz/integration-test/conf/nginz/README.md index c8e81957c62..8e614e99d1b 100644 --- a/services/nginz/integration-test/conf/nginz/README.md +++ b/services/nginz/integration-test/conf/nginz/README.md @@ -3,5 +3,5 @@ Run from this directory: ```bash -../../../../../hack/bin/selfsigned.sh +../../../../../hack/bin/gen-certs.sh ``` diff --git a/services/nginz/integration-test/conf/nginz/integration-ca-key.pem b/services/nginz/integration-test/conf/nginz/integration-ca-key.pem index 0bd38214cc7..812d4ddc4a1 100644 --- a/services/nginz/integration-test/conf/nginz/integration-ca-key.pem +++ b/services/nginz/integration-test/conf/nginz/integration-ca-key.pem @@ -1,27 +1,28 @@ ------BEGIN RSA PRIVATE KEY----- -MIIEogIBAAKCAQEAlq2bCpvwVptvslD3Xq/tAjm58wQHGEpVSyefl+vGQAD30ukV -FiqzjJw9ZCTbS1to2k7YTukabQAu4pHlhHk4/r2JHr7olmUf5zjyKvJUBekFl788 -ZXW9lEOw5x7lgBLSYI20sSHbUVX7pC2dB2AQZt15sGF1DmVU39/yF2RII92bnqPY -r8tS7A6JslhHLnPAnCOaHC4VK6tMU3Zjh/p/sBgKBqbarXAPl2TckXxFEHK8l0lD -yU2a5ltK0YuAxOv4iXwK76G4VQJwbF0NCMzjAovBLcOA7BVRd8ywVjFpzQjhn+gy -yATdZUOlOpMXIEa7Hmc5TMB4KjiJYwocjKl66QIDAQABAoIBAFYPolZU6tkMvqdi -h2eVpBF5VzPuQP8mtcDPSOBE0l8MLoBQkLKwgQz20Dm6s2Y/N4w5LGMl0OohCKZw -Hl+jvWICb6cX81CzQZ2XcPoGnuchSQh7OcvZjAZ7Azd+9iZImdB8H5Bsfg/exHPp -eZ8Ux0l5hl+vymQGjIuyJVwm8u1IbZbW3+yTJ/oFqa/j91Yw7Llsa7VaLs+NiJkY -Ng7AtAd/zz6BN4x93AMCbs6KgLQcKK1WyIkCqoUsZG5orzIKlpmBnmv4EeQwvem9 -/rt3LlKFzHXBPG47BECQsyPYli1Z3Gnp/XTNMteeqDicj4CI9icU1QRxTyUmIMFB -Wd81qAECgYEAxClEt4tteo1kPuiiajHSR1PApPG40Zlc9GovQl/JQnr+MSaexD/M -gMtZlhQYrdThmGYcdzmpWaS5YCKesB82ca3QwaJK3+q3/MclvNt7hoIQoWm53eAK -J4CabtUiyzmG1iaYulEkqFtlg8nK0SwFNr8UEGHyerSHFtTiUXw47mECgYEAxKRy -1Z16pcesupUXzdET6ZdwN70oJT+3D+s98ZBtn2pBW7RQKEe9pvlbTrClTkFxUhXu -jPyNama8KvON57ekgb3nanlyp2sX8AtydEb+BZtRDp3PMF+J6nl828Mt2LHtivul -iacBM4dCM3IsEXMvlJElxm0ILgAUb9LqKl6giYkCgYAbqNoIq39XbYJ6IGFuafIF -nrimSXNPErn5uNNLH6iIWEFpetGeSIS0kHfkYpcMQ90/mP5gjV/kxQZimN8ZZH1P -0DuEYjb+leE1onsewzAKymI/8GGF+KZV5ZthD2qlj0oE/lJAy1pI5wJMb/LKRdPC -YXUZzkXbqYL25DO5W7PHYQKBgFz/9XuHziCnjc50gtyJPGSmhaEm6dysBJUXyaT8 -jIvvgdewMJTMUSquFfviWVvoYYLT8o1lSDCBRA8APyXO2ZOuz8qwg4QghyK1Fz1c -8fiO20gRZJLZLG3jZSS+a2lnxRONLl4qyMuo9atFHQhntKIL/5SXrl2rFf9I/gxp -0n0ZAoGAf3Om0O1td3EfemGzJs3YJOKiwltDZNtwF5G4VG9c9YjlevaLJoNhgBw9 -u16e/mQNU/yr/qqRp+aE6HGcXXBp0ckJcKqKFQ2pUVhMb/T8OfPpT2n7RF1k0Xss -5vrEUSfif9VPCEnjMI7AtZcXQT1yqMQuTW+IhP15dGuofWdDsHQ= ------END RSA PRIVATE KEY----- +-----BEGIN PRIVATE KEY----- +MIIEvQIBADANBgkqhkiG9w0BAQEFAASCBKcwggSjAgEAAoIBAQCUJVDizZney5e4 +rJHEp7L/cXMf/k5zMKrapCte8OePyraPjSSQJA9S/l+RJEj2exQyqrdmxn6BE1hp +5aR/87FE1KXIZX+iX8OkyTno0Hq+RUDSwrUEpziHIZQBSsxcYRkr3Dq0VogQD401 +SJL/XogjV3CeTxPUpPPm5p9s7c+y1R3L+Oj5k//ooUcSidNU+QrF1j1BzmUEXxry +mZshn/okwboXMTD2Ap12+/zN62AkFy/BUGYmqmyFTKjUaTAVZAKlN5diZ0q5TSIy +IejaqMI6IPEGBriM+n8cFpMOhFOWQcByK9qzmpAp0KCnl1agSXVmTUTF9Vbanoez +vcw6FuP9AgMBAAECggEACB7IgXoMEFiAAz0gS1N23gYRraQCmFFHWC8t+mkBhFHz +8kfmBGmZlm6/fcTro+kIqSNO5LkGF5ygGMPf4ayRn6h5QtP/bD7MCkUGYdLFm5bP +sA3AntXspQmL44s+SuT+nHcYl6hzkk/L6WsGNa2wkCFbmK3UdDArd1FWVUHuw8pR +2s2V1KpVR6/3Wdw86l3khcDbY3CHimenmGSxxjFPixHMpcni3cTPdnULo+vZT3fh +MMmsRMwQvcZXNFtUjzwelx+/e0MB+AyoEYPaKa+afKKQBxlVmldrn9q/m3++fkiT +PWLg4yNcG+M+78vldoJb3kHANYCNxn438LDUrgNvAQKBgQDGNoSjC6Zmt7OwmO0H +kszLTbzbtNBmV5aFNRtopSL5H/DcMpq1MUXxsCpEK8cRHlbDLaEV/lrADjFN7KNg +Hvy0B77iiHGLm2rB6psZpSafapFjFC24q0VKS95Z6UyTIUiajIj2aYEPz0HOrgFC +lw2Ba7VTV2OxWUegVLoxbaV2/QKBgQC/VhGUf53klmi2XEfh5X+CtvH6v5P48VyZ +8P8e4PcZVBvgAbuMPMT+EW6+46J73GMJ2ISs0kDZEge0k+RRzUVqWvUlBWV9nt04 +BUGZT//w8bqD8Dfo1TeRwiLYuYMUNWaAdYvs0nt49dFpX5hyd+KUB+A5v1QbjTSY +PQT3yscxAQKBgQCE4DteigrNRU0ikAImV5UOnViD+NzUHtd7CTUMm9esJmtzUkFA +Qn3fHffXp3lV0n7bbRVWByOTKHCJCqAjaeKCVcbzWgC0VEXnJX1AXeRcbjZ0syxL +ZhWXTvEKWUnKQD/Jy3htqCCrFofJJAEYQOb+4dO2wRjF5VIM+3+ubxDDiQKBgFIn +tqy4jydTneqPfR312OZbf1NXZ0YA/O3smN69YdwyTTXGCK2SelNNUOwN+fqNCslz +eqRqMwYBw+U5i1PEfAXKwHAA/S8PQ5WGTEB0JUVjxd5ZCuiihJXFcgj0vt+yfiyy +TD6HshSiGCTSszaTW2qMZy7khEzAONEVgkiTfSwBAoGAb48KvxQtxW+2RXkNWzMv +D7DyHm9jTTcTARTf7WtY0KMWQa//MPWofieD6KdzRd65lea2Z8wX5vcPVIEUp803 +zQrZMeLTcAQjsTsSP3qBWBi8F/Vd3JKc++F9+7dNfMEhN/fElxDqFrMbXeWtn/Xr +meIImb/2qCWt45/YjQGL8Do= +-----END PRIVATE KEY----- diff --git a/services/nginz/integration-test/conf/nginz/integration-ca.pem b/services/nginz/integration-test/conf/nginz/integration-ca.pem index 10a906c111b..304fc892245 100644 --- a/services/nginz/integration-test/conf/nginz/integration-ca.pem +++ b/services/nginz/integration-test/conf/nginz/integration-ca.pem @@ -1,19 +1,19 @@ -----BEGIN CERTIFICATE----- -MIIDAjCCAeqgAwIBAgIUdsGG4S0KMPKYzS6UNoDuNpvkRFcwDQYJKoZIhvcNAQEL -BQAwGTEXMBUGA1UEAxMOY2EuZXhhbXBsZS5jb20wHhcNMjQwNDIyMTIwNDAwWhcN -MjkwNDIxMTIwNDAwWjAZMRcwFQYDVQQDEw5jYS5leGFtcGxlLmNvbTCCASIwDQYJ -KoZIhvcNAQEBBQADggEPADCCAQoCggEBAJatmwqb8Fabb7JQ916v7QI5ufMEBxhK -VUsnn5frxkAA99LpFRYqs4ycPWQk20tbaNpO2E7pGm0ALuKR5YR5OP69iR6+6JZl -H+c48iryVAXpBZe/PGV1vZRDsOce5YAS0mCNtLEh21FV+6QtnQdgEGbdebBhdQ5l -VN/f8hdkSCPdm56j2K/LUuwOibJYRy5zwJwjmhwuFSurTFN2Y4f6f7AYCgam2q1w -D5dk3JF8RRByvJdJQ8lNmuZbStGLgMTr+Il8Cu+huFUCcGxdDQjM4wKLwS3DgOwV -UXfMsFYxac0I4Z/oMsgE3WVDpTqTFyBGux5nOUzAeCo4iWMKHIypeukCAwEAAaNC -MEAwDgYDVR0PAQH/BAQDAgEGMA8GA1UdEwEB/wQFMAMBAf8wHQYDVR0OBBYEFDnH -CL3yIYkqK51ynDHRQcc6Xc/rMA0GCSqGSIb3DQEBCwUAA4IBAQCUzI4edToGsBTp -qnV2MtXwhoBFnmAa4O8RMsbRZqE+DCzBhPSIl9UMaeIEMoIvXL2KOO+rEw2M1uQc -D4r+dAdUhLbIFEyMNIA5EZfJfimEE0qaLGJqI5X1FFVeCvlvI1UDoSj0KQD9GEsg -VidDnhzg712cGdBY2K4U/BmpLMn8+WZ7+TSVIX8fGylzDCRtCQ36vrD5pkQzblqU -sjO8Apwej/t+BI/Y+T1MFvZhstbJ3mSQpHhnmARXLOrwjcOmLzWVlQa1IJxtxaf9 -gRxVchzH7fQxNlR6/zWtd2av07pFR9k2o9WUn/A5lpoUcVrokvCsOooqqG3UwALU -fZm6IO1I +MIIDEzCCAfugAwIBAgIUQ35aUV70pJjvDTbfgFUj5YmchHQwDQYJKoZIhvcNAQEL +BQAwGTEXMBUGA1UEAwwOY2EuZXhhbXBsZS5jb20wHhcNMjQwNjE3MTMxNTMxWhcN +MzQwNjE1MTMxNTMxWjAZMRcwFQYDVQQDDA5jYS5leGFtcGxlLmNvbTCCASIwDQYJ +KoZIhvcNAQEBBQADggEPADCCAQoCggEBAJQlUOLNmd7Ll7iskcSnsv9xcx/+TnMw +qtqkK17w54/Kto+NJJAkD1L+X5EkSPZ7FDKqt2bGfoETWGnlpH/zsUTUpchlf6Jf +w6TJOejQer5FQNLCtQSnOIchlAFKzFxhGSvcOrRWiBAPjTVIkv9eiCNXcJ5PE9Sk +8+bmn2ztz7LVHcv46PmT/+ihRxKJ01T5CsXWPUHOZQRfGvKZmyGf+iTBuhcxMPYC +nXb7/M3rYCQXL8FQZiaqbIVMqNRpMBVkAqU3l2JnSrlNIjIh6Nqowjog8QYGuIz6 +fxwWkw6EU5ZBwHIr2rOakCnQoKeXVqBJdWZNRMX1Vtqeh7O9zDoW4/0CAwEAAaNT +MFEwHQYDVR0OBBYEFHNgZ4nZQoNKnb0AnDkefTXxxYDqMB8GA1UdIwQYMBaAFHNg +Z4nZQoNKnb0AnDkefTXxxYDqMA8GA1UdEwEB/wQFMAMBAf8wDQYJKoZIhvcNAQEL +BQADggEBAIuLuyF7m1SP6PBu29jXnfGtaGi7j0jlqfcAysn7VmAU3StgWvSatlAl +AO6MIasjSQ+ygAbfIQW6W2Wc/U+NLQq5fRVi1cnmlxH5OULOFeQZCVyux8Maq0fT +jj4mmsz62b/iiA4tyS5r+foY4v1u2siSViBJSbfYbMp/VggIimt26RNV2u/ZV6Kf +UrOxazMx1yyuqARiqoA3VOMV8Byv8SEIiteWUSYni6u7xOT4gucPORhbM1HOSQ/S +CVq95x4FeKQnbEMykHI+bpBdkoadMVtrjCbskU49mOrvl/pli9V44R8KK6C1Nv3E +VLLcoOctdw90aT3sIjaXBcZtDTE6p6g= -----END CERTIFICATE----- diff --git a/services/nginz/integration-test/conf/nginz/integration-leaf-key.pem b/services/nginz/integration-test/conf/nginz/integration-leaf-key.pem index 1a45ba1ea46..1e7a83068de 100644 --- a/services/nginz/integration-test/conf/nginz/integration-leaf-key.pem +++ b/services/nginz/integration-test/conf/nginz/integration-leaf-key.pem @@ -1,27 +1,28 @@ ------BEGIN RSA PRIVATE KEY----- -MIIEowIBAAKCAQEAukRPdjUjKs7P2TgP4VDpb77Rb7KjMMBtcRP525qEnUQzFHPk -Va4cqh6xacgh2NJCyFyDEWDI9pQ03i0HISIldoBngDVvM6kwvbs+kjZ+/t/Jx3aH -zC9dmsLqmCqU+OmofpD1pt8hZWwOtYj58pfqdhrP+M6qQ92/tgmkk9njLFwsAjxY -gMXZCo0IiSIE9BE9NGvR9bp6hvEekCqREPdHi44iFca/5V4A8fSZwBlTHod5Z83r -MpHLnR1ReVVOQgzbIBGcLdmtH8IA9ZgUHy1/HOmf9e0MYOYOKbKvH3cry7WSscPL -47x+JQyFLimidfsJQCY+022rdPg9CdrCWFGxgQIDAQABAoIBAGjeBqK1fewe7XQN -FRu0cwh/tOge+bN70uHj7jrN/rWP7PYp3TbDxM2eZCH7E9s/XWvycbQ5+kqg3Dbt -wOLNl6vk1OCgtM+wBIn9PlgRKGSUV8Tdncy+KgP0kyFCcAbHfh5rvHHLk8DHGmzo -BlinYNBHfilFKST2VnXFbgvzkuuorS1BRAzlVpyJnaen04emBJ+KPIwNyguPQrlv -5duBIO1bzlEjFVufrLkI0IumWqBAPOvHcRy1geSz/MG7LssB9r25k5LA5OEDxqwx -ykSzuniaLL6BGMSCAMpTM3/hF1ijrkTd74cI4cp7k2ufcYT74ZU2lyDKEjBukG/p -H0/1Q8ECgYEAwL7VWIpySGtrJEPZH1FxtpJYg8SE0F4lUxIbIQcc6rzLJfLOLQO5 -ruTVONPTlue6PHrRO8pQTbW9AnjZvHMIiwxidY/RwUVKFuxzfrYZ9ZbKXyVOh48a -WXe5OnpuVodPEHQrKzkl93YWMgMCXNPri1h0jr0fMGXy9jZzoKK5f1kCgYEA92Uw -P4WyBL2hm/5BNUoxCiLyd1dDdQt1h6VByxYM7OXDhXq1iHnhX+NbjMT0QfOFyXBP -uQQCB9IQElmMmWsoEv6uEQCeuCvOxq+Evoz+3fP2te89HjZ1C5SXUMfG7qKfFzbt -WP6e/CqAeQPnnqI89ghw/IerQkeVMoVvHbSXZmkCgYBZPgJ6JGAVt+a7u85j+cm0 -xr3FBNCZyX1uoQt+l1SEOzW0NF/R58+pcrpmvW1SiahpKFSIYnwb/vGsm1f1MS3b -c7iCxjxQSEytoH05Rgdu9ops01Ew4slIc26H7Pf5iFzLOX5jXOp/UWWlck89u8Fr -m2EcVeSC/DEqXrvavH02wQKBgBzVKDhfBo5S44DgswzY5ro9tHCANRZxDXOPqQlY -Oo1pgc4OrRWIzuF0B/lyAt2k2hTOCBySAQKUUtcwpJhEytjb4cGNhvID+Qdi8V+b -4yBPDJPLnB3nTuDYooIBpoetYEk+V48lrbXJ5ks0T0xHsD8kYLatwSHqYdMPhhG6 -OGLxAoGBALZQSuO4fHew4ksMcBy891ZSOFUV9xAtR490EdEQdOiPrQj5vmnSpxEx -QsSVbn+49OYwzjBP+sHtpiTMF4ZlafHvjcNZ5dFIImqyuEugEdnD5UnFd92AQ9Gv -ufa7BMs99BRdkkolCXBZC+Dq4t4Z/+MDSMtjO5mh9V0boDakdJPb ------END RSA PRIVATE KEY----- +-----BEGIN PRIVATE KEY----- +MIIEvwIBADANBgkqhkiG9w0BAQEFAASCBKkwggSlAgEAAoIBAQCZjOHeUnlauuxD +WgrRnh3hj5Fs+uh9vyddMX8rSWJIbWFw4QuYzYKY8CQa3MBb6qK1uUwoJ0W1w47I +RgA5VLvGxI+T1wX8E5vljVgfT3CAXHKRB88NrT8A1urQnWpzlq5sNerL6dqgBrjG +QBmFF7NxrvjGgerC2D8+srWfpQ6Jbl9by8c3JDu+T79PM+pW9ycUgdF1AJQBTz9K +zNQ7ZTlBQvJG8WhTMKioJgQsE60oEXD0C8M5yKBBb7DrqkeZInXqCw2y7DZLWzog +D+jgoAD5/9sk3d/gGNqDibzjjwMiJnH/IqBTkZsQ9OdZZPfx5v/p062hQBlM656P +2jMpJ1xxAgMBAAECggEAS3NBjWgDP4T4EUROaqACWNKeB+nmkdt68T0gGtoNVD+D +EN9UPnpFQPdHFngAgWnzF858UIKzq1Pzdg+HjqRHPK1bS67tvua3xP1GHuR/CGPk +28T1hefqPHRen7GqHDAfdwarYBWCGv4Sjz/yCkcSIrtyfMBb5fAya5GO02pckUSK +19sl7XhkPtHJVirRkjQL29R2TCpkNNpQMjkuYLk7mox+6pNTbxgbk0cnT3eGj1pV +mlPqpwzC5GevRziE/VE/WXFLChY+8KB4fDLRqWnyvabDvQ4coaXgzwbdScJyM5hX ++Dxdfni/P2m7xAZXUyfBsr0VUzqUkJfK3WWvvAGTDQKBgQDNi3RUEjVnU/MN4aDz +iZB2VYGfo/K69xTPNEbLQWs1F4ZMpHVtUVXzTfx/xG9ug989ijEm6ncL9OsnhThn +UldSz2ojSJUxLmhgCHZGYHT72v/9rEqfT9JisWpIj44KXufUHCcl3Cozj1ae3EUp +NVhN1HphB2LsCIJvLYfLIGdBNwKBgQC/PhHQMm/MQe4pOHAbdzDrRZWdG2KSRVxp +9mmJ/aT8LOp7BDjq+Dkct6a56JGqlOTeJirMTTmCKiOiTInuB9S+K7kWJJiYg9g4 +UCiuMU+40Px/1Z4/uxRj3DSdGLXG7S6kPeADx9f9BUNpAytGqOnSnfbDiDVvQVbp +0N0+nIXDlwKBgQC2uZOXrXxGOE4pd/ySpCeF2yvZ1HDTnxWjwlBxHt4Em74rYkR2 +A0mKezjOCL4bHCaYWcKqWuOsAHYQcxEaYQv6NSOg7ESdLSlivgMPO26j+yN5yvGn +wNlCHYBjsyLNu2MSoFh5AsmNfo69uQnOwXqX7h1BJsTdGg+CcJJ4lHzWbwKBgQCD +/CRzGbwKrh3eGPNWIUaDuTxudy3qYTBMeSGReJpa5+zUBa/6imFwLldEyvttTOE/ +Z/v1j/52lPqO0mAHBSSQMsDERXGDIMsi4j+RKLsqhCEfYKCcv1JtMNam7RzXM24T +MBjgwxWPrAg/+03ssDrffuGFRQYLyH5hVCK9SW0P9QKBgQDJ1ZSto+RWxv/uOKNr +7FYeQoKpMb2IvNvnGlnYHC8KS9qRq6wUE+FtuKcdLBQP4M9Cgq71VD/dsawrhEw7 +1rAYk3OqmHxBOU5Dcb152NxYHEf53pfEfWc0x4AEVe+Jzynj2EYixRKNWwODNTEx +LKJOYd0CuWywxg6d9G7A7XbgWQ== +-----END PRIVATE KEY----- diff --git a/services/nginz/integration-test/conf/nginz/integration-leaf.pem b/services/nginz/integration-test/conf/nginz/integration-leaf.pem index 2247758aafd..635d332de70 100644 --- a/services/nginz/integration-test/conf/nginz/integration-leaf.pem +++ b/services/nginz/integration-test/conf/nginz/integration-leaf.pem @@ -1,21 +1,20 @@ -----BEGIN CERTIFICATE----- -MIIDcjCCAlqgAwIBAgIUK9Dix5VZpBYOby63cdmjtfg6RpwwDQYJKoZIhvcNAQEL -BQAwGTEXMBUGA1UEAxMOY2EuZXhhbXBsZS5jb20wHhcNMjQwNDIyMTIwNDAwWhcN -MjUwNDIyMTIwNDAwWjAAMIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEA -ukRPdjUjKs7P2TgP4VDpb77Rb7KjMMBtcRP525qEnUQzFHPkVa4cqh6xacgh2NJC -yFyDEWDI9pQ03i0HISIldoBngDVvM6kwvbs+kjZ+/t/Jx3aHzC9dmsLqmCqU+Omo -fpD1pt8hZWwOtYj58pfqdhrP+M6qQ92/tgmkk9njLFwsAjxYgMXZCo0IiSIE9BE9 -NGvR9bp6hvEekCqREPdHi44iFca/5V4A8fSZwBlTHod5Z83rMpHLnR1ReVVOQgzb -IBGcLdmtH8IA9ZgUHy1/HOmf9e0MYOYOKbKvH3cry7WSscPL47x+JQyFLimidfsJ -QCY+022rdPg9CdrCWFGxgQIDAQABo4HKMIHHMA4GA1UdDwEB/wQEAwIFoDAdBgNV -HSUEFjAUBggrBgEFBQcDAQYIKwYBBQUHAwIwDAYDVR0TAQH/BAIwADAdBgNVHQ4E -FgQUaJdzHC5JsdIEKTYxqAWoSHvFCNgwHwYDVR0jBBgwFoAUOccIvfIhiSornXKc -MdFBxzpdz+swSAYDVR0RAQH/BD4wPIIZKi5pbnRlZ3JhdGlvbi5leGFtcGxlLmNv -bYIUaG9zdC5kb2NrZXIuaW50ZXJuYWyCCWxvY2FsaG9zdDANBgkqhkiG9w0BAQsF -AAOCAQEAcoUcdwgoAiFJcoS/t1IU2axEJeWncctYyVHt/ZfoZ8y/23XDA+kIfgSt -DZEqteGyVDSBbI/B45IzrKQuJzdT8B+9iDcOzLrA2R1432ASlMhHC5l3STBru0jl -oL9M8fJU6BwciCqY0Y2wFcCfVthN1rC8vNNSpwSwF74q87MMLZ/65Mi3hAB4177s -uNL6MXGta9fBK9MQxM3S/Kr7fmxOTQBlQtcA2Ha3Yog2+dkMXosoapjoMwWj36DS -j9v25/dFmS3dnCfhRHBSh9iUSnbOVZ/M+5Bv5hBPYbeSw24DXD1w9soEYL941D+c -enXV719UPw5bpBxhXjl9Hu0TQ2uoIw== +MIIDQTCCAimgAwIBAgIBADANBgkqhkiG9w0BAQsFADAZMRcwFQYDVQQDDA5jYS5l +eGFtcGxlLmNvbTAeFw0yNDA2MTcxMzE1MzFaFw0yNDA3MTcxMzE1MzFaMAAwggEi +MA0GCSqGSIb3DQEBAQUAA4IBDwAwggEKAoIBAQCZjOHeUnlauuxDWgrRnh3hj5Fs ++uh9vyddMX8rSWJIbWFw4QuYzYKY8CQa3MBb6qK1uUwoJ0W1w47IRgA5VLvGxI+T +1wX8E5vljVgfT3CAXHKRB88NrT8A1urQnWpzlq5sNerL6dqgBrjGQBmFF7NxrvjG +gerC2D8+srWfpQ6Jbl9by8c3JDu+T79PM+pW9ycUgdF1AJQBTz9KzNQ7ZTlBQvJG +8WhTMKioJgQsE60oEXD0C8M5yKBBb7DrqkeZInXqCw2y7DZLWzogD+jgoAD5/9sk +3d/gGNqDibzjjwMiJnH/IqBTkZsQ9OdZZPfx5v/p062hQBlM656P2jMpJ1xxAgMB +AAGjgawwgakwHQYDVR0lBBYwFAYIKwYBBQUHAwEGCCsGAQUFBwMCMEgGA1UdEQEB +/wQ+MDyCGSouaW50ZWdyYXRpb24uZXhhbXBsZS5jb22CFGhvc3QuZG9ja2VyLmlu +dGVybmFsgglsb2NhbGhvc3QwHQYDVR0OBBYEFPowAfmLPCmdCMdSxQjsR6UQSoyH +MB8GA1UdIwQYMBaAFHNgZ4nZQoNKnb0AnDkefTXxxYDqMA0GCSqGSIb3DQEBCwUA +A4IBAQCMJwbLzUsrkQkgdGKVi/Mb5XAAV0sfkwZch1Fx0vhJI072cZSow5A2ZUHa +LScFNTPmilPKEr6MS4xIKtRQaMHInbfxSsyNViKhpzkSOKoAiJjIJ2xPKFPnbTDI +uV74nxxyf9q/p3SLQfJFk7fxbvNeLqg5bYSrMeklHj4bpMJ9fybS8/mZVc8AkTFK +fsXSu9CW1B3GF+jP3E2GrFF3Zh9MgvWjMlSYg4ljPf5FoMCUq6GmQ17hQeJFvb5h +Jqk6TcgUrp082bcVlPW17XzFwVe3n6uzvWMtwI62EztVUj98+YkBiFL3i4+OQwAU +/noc22fq20OyJtCPJY4FIK7xUcgD -----END CERTIFICATE----- diff --git a/services/nginz/integration-test/conf/nginz/nginx.conf b/services/nginz/integration-test/conf/nginz/nginx.conf index 6485d34a58d..41be5df60bf 100644 --- a/services/nginz/integration-test/conf/nginz/nginx.conf +++ b/services/nginz/integration-test/conf/nginz/nginx.conf @@ -108,7 +108,7 @@ http { server { include integration.conf; - # self-signed certificates generated using wire-server/hack/bin/selfsigned.sh + # self-signed certificates generated using wire-server/hack/bin/gen-certs.sh ssl_certificate integration-leaf.pem; ssl_certificate_key integration-leaf-key.pem; @@ -336,7 +336,7 @@ http { proxy_pass http://cargohold; } - location /provider/assets { + location ~* ^(/v[0-9]+)?/provider/assets$ { include common_response_with_zauth.conf; proxy_pass http://cargohold; } diff --git a/services/proxy/src/Proxy/API/Public.hs b/services/proxy/src/Proxy/API/Public.hs index de0bf2ccdd1..03fd4b65bd1 100644 --- a/services/proxy/src/Proxy/API/Public.hs +++ b/services/proxy/src/Proxy/API/Public.hs @@ -124,9 +124,12 @@ spotifyToken rq = do when (isError (Client.responseStatus res)) $ debug $ msg (val "unexpected upstream response") - ~~ "upstream" .= val "spotify::token" - ~~ "status" .= S (Client.responseStatus res) - ~~ "body" .= B.take 256 (Client.responseBody res) + ~~ "upstream" + .= val "spotify::token" + ~~ "status" + .= S (Client.responseStatus res) + ~~ "body" + .= B.take 256 (Client.responseBody res) pure $ plain (Client.responseBody res) & setStatus (Client.responseStatus res) @@ -149,9 +152,12 @@ soundcloudResolve url = do when (isError (Client.responseStatus res)) $ debug $ msg (val "unexpected upstream response") - ~~ "upstream" .= val "soundcloud::resolve" - ~~ "status" .= S (Client.responseStatus res) - ~~ "body" .= B.take 256 (Client.responseBody res) + ~~ "upstream" + .= val "soundcloud::resolve" + ~~ "status" + .= S (Client.responseStatus res) + ~~ "body" + .= B.take 256 (Client.responseBody res) pure $ plain (Client.responseBody res) & setStatus (Client.responseStatus res) @@ -176,9 +182,12 @@ soundcloudStream url = do unless (status302 == Client.responseStatus res) $ do debug $ msg (val "unexpected upstream response") - ~~ "upstream" .= val "soundcloud::stream" - ~~ "status" .= S (Client.responseStatus res) - ~~ "body" .= B.take 256 (Client.responseBody res) + ~~ "upstream" + .= val "soundcloud::stream" + ~~ "status" + .= S (Client.responseStatus res) + ~~ "body" + .= B.take 256 (Client.responseBody res) failWith "unexpected upstream response" case Res.getHeader hLocation res of Nothing -> failWith "missing location header" @@ -187,7 +196,7 @@ soundcloudStream url = do x2 :: RetryPolicy x2 = exponentialBackoff 5000 <> limitRetries 2 -handler :: MonadIO m => RetryStatus -> Handler m Bool +handler :: (MonadIO m) => RetryStatus -> Handler m Bool handler = const . Handler $ \case Client.HttpExceptionRequest _ Client.NoResponseDataReceived -> pure True Client.HttpExceptionRequest _ Client.IncompleteHeaders -> pure True diff --git a/services/proxy/src/Proxy/Env.hs b/services/proxy/src/Proxy/Env.hs index d8850dab273..d429787d1be 100644 --- a/services/proxy/src/Proxy/Env.hs +++ b/services/proxy/src/Proxy/Env.hs @@ -22,7 +22,6 @@ module Proxy.Env createEnv, destroyEnv, reqId, - monitor, options, applog, manager, @@ -34,7 +33,6 @@ import Control.Lens (makeLenses, (^.)) import Data.Configurator import Data.Configurator.Types import Data.Id (RequestId (..)) -import Data.Metrics.Middleware (Metrics) import Imports import Network.HTTP.Client import Network.HTTP.Client.TLS (tlsManagerSettings) @@ -43,7 +41,6 @@ import System.Logger.Extended qualified as Logger data Env = Env { _reqId :: !RequestId, - _monitor :: !Metrics, _options :: !Opts, _applog :: !Logger.Logger, _manager :: !Manager, @@ -53,8 +50,8 @@ data Env = Env makeLenses ''Env -createEnv :: Metrics -> Opts -> IO Env -createEnv m o = do +createEnv :: Opts -> IO Env +createEnv o = do g <- Logger.mkLogger (o ^. logLevel) (o ^. logNetStrings) (o ^. logFormat) n <- newManager @@ -66,7 +63,7 @@ createEnv m o = do let ac = AutoConfig 60 (reloadError g) (c, t) <- autoReload ac [Required $ o ^. secretsConfig] let rid = RequestId "N/A" - pure $! Env rid m o g n c t + pure $! Env rid o g n c t where reloadError g x = Logger.err g (Logger.msg $ Logger.val "Failed reloading config: " Logger.+++ show x) diff --git a/services/proxy/src/Proxy/Proxy.hs b/services/proxy/src/Proxy/Proxy.hs index cc7f6c5f8fc..fe65dc4b920 100644 --- a/services/proxy/src/Proxy/Proxy.hs +++ b/services/proxy/src/Proxy/Proxy.hs @@ -66,8 +66,11 @@ lookupReqId l r = case lookup requestIdName (requestHeaders r) of Nothing -> do localRid <- RequestId . UUID.toASCIIBytes <$> UUID.nextRandom Log.info l $ - "request-id" .= localRid - ~~ "method" .= requestMethod r - ~~ "path" .= rawPathInfo r + "request-id" + .= localRid + ~~ "method" + .= requestMethod r + ~~ "path" + .= rawPathInfo r ~~ msg (val "generated a new request id for local request") pure localRid diff --git a/services/proxy/src/Proxy/Run.hs b/services/proxy/src/Proxy/Run.hs index 7a32829f5d5..16d43994006 100644 --- a/services/proxy/src/Proxy/Run.hs +++ b/services/proxy/src/Proxy/Run.hs @@ -22,7 +22,6 @@ where import Control.Lens hiding ((.=)) import Control.Monad.Catch -import Data.Metrics.Middleware hiding (path) import Data.Metrics.Middleware.Prometheus (waiPrometheusMiddleware) import Imports hiding (head) import Network.Wai.Middleware.Gunzip qualified as GZip @@ -36,14 +35,14 @@ import Wire.API.Routes.Version.Wai run :: Opts -> IO () run o = do - m <- metrics - e <- createEnv m o - s <- newSettings $ defaultServer (o ^. host) (o ^. port) (e ^. applog) m + e <- createEnv o + s <- newSettings $ defaultServer (o ^. host) (o ^. port) (e ^. applog) let rtree = compile (sitemap e) let app r k = runProxy e r (route rtree r k) let middleware = versionMiddleware (foldMap expandVersionExp (o ^. disabledAPIVersions)) + . requestIdMiddleware (e ^. applog) defaultRequestIdHeaderName . waiPrometheusMiddleware (sitemap e) . GZip.gunzip - . catchErrors (e ^. applog) [Right m] + . catchErrors (e ^. applog) defaultRequestIdHeaderName runSettingsWithShutdown s (middleware app) Nothing `finally` destroyEnv e diff --git a/services/spar/default.nix b/services/spar/default.nix index afbe67eb872..fe5d88485e7 100644 --- a/services/spar/default.nix +++ b/services/spar/default.nix @@ -54,6 +54,7 @@ , raw-strings-qq , retry , saml2-web-sso +, semigroupoids , servant , servant-multipart , servant-openapi3 @@ -119,6 +120,7 @@ mkDerivation { QuickCheck raw-strings-qq saml2-web-sso + semigroupoids servant-multipart servant-server text diff --git a/services/spar/migrate-data/src/Spar/DataMigration/V2_UserV2.hs b/services/spar/migrate-data/src/Spar/DataMigration/V2_UserV2.hs index ac7d49efca6..59c30b74b1f 100644 --- a/services/spar/migrate-data/src/Spar/DataMigration/V2_UserV2.hs +++ b/services/spar/migrate-data/src/Spar/DataMigration/V2_UserV2.hs @@ -68,7 +68,7 @@ type CollisionResolver = -- | Use this if you want to paginate without crashing newtype CqlSafe a = CqlSafe {unCqlSafe :: Either String a} -instance Cql a => Cql (CqlSafe a) where +instance (Cql a) => Cql (CqlSafe a) where ctype = Tagged $ untag (ctype @a) toCql _ = error "CqlSafe is not meant for serialization" fromCql val = diff --git a/services/spar/spar.cabal b/services/spar/spar.cabal index 87b8fe0c455..1e161ee0560 100644 --- a/services/spar/spar.cabal +++ b/services/spar/spar.cabal @@ -180,6 +180,7 @@ library , QuickCheck , raw-strings-qq , saml2-web-sso >=0.20 + , semigroupoids , servant-multipart , servant-server , text @@ -251,8 +252,7 @@ executable spar -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -j -Wno-redundant-constraints -Werror -threaded -rtsopts - -with-rtsopts=-N -with-rtsopts=-T -Wredundant-constraints - -Wunused-packages + "-with-rtsopts=-N -T" -Wredundant-constraints -Wunused-packages build-depends: base @@ -276,6 +276,7 @@ executable spar-integration Test.Spar.Scim.AuthSpec Test.Spar.Scim.UserSpec Util + Util.Activation Util.Core Util.Email Util.Invitation diff --git a/services/spar/src/Spar/API.hs b/services/spar/src/Spar/API.hs index ae3a3d94d90..12a53e10b96 100644 --- a/services/spar/src/Spar/API.hs +++ b/services/spar/src/Spar/API.hs @@ -47,8 +47,7 @@ where import Brig.Types.Intra import Cassandra as Cas -import Control.Lens -import Control.Monad.Except +import Control.Lens hiding ((.=)) import qualified Data.ByteString as SBS import Data.ByteString.Builder (toLazyByteString) import Data.Id @@ -60,6 +59,8 @@ import qualified Data.Text.Lazy as T import Data.Text.Lazy.Encoding import Data.Time import Imports +import Network.Wai.Utilities.Request +import Network.Wai.Utilities.Server (defaultRequestIdHeaderName) import Polysemy import Polysemy.Error import Polysemy.Input @@ -114,9 +115,16 @@ import Wire.Sem.Random (Random) import qualified Wire.Sem.Random as Random app :: Env -> Application -app ctx = - SAML.setHttpCachePolicy $ - serve (Proxy @SparAPI) (hoistServer (Proxy @SparAPI) (runSparToHandler ctx) (api $ sparCtxOpts ctx) :: Server SparAPI) +app ctx0 req cont = do + let rid = getRequestId defaultRequestIdHeaderName req + let ctx = ctx0 {sparCtxRequestId = rid} + SAML.setHttpCachePolicy + ( serve + (Proxy @SparAPI) + (hoistServer (Proxy @SparAPI) (runSparToHandler ctx) (api $ sparCtxOpts ctx) :: Server SparAPI) + ) + req + cont api :: ( Member GalleyAccess r, @@ -235,7 +243,7 @@ authreqPrecheck :: authreqPrecheck msucc merr idpid = validateAuthreqParams msucc merr *> IdPConfigStore.getConfig idpid - $> NoContent + $> NoContent authreq :: ( Member Random r, @@ -269,7 +277,7 @@ authreq authreqttl msucc merr idpid = do redirectURLMaxLength :: Int redirectURLMaxLength = 140 -validateAuthreqParams :: Member (Error SparError) r => Maybe URI.URI -> Maybe URI.URI -> Sem r VerdictFormat +validateAuthreqParams :: (Member (Error SparError) r) => Maybe URI.URI -> Maybe URI.URI -> Sem r VerdictFormat validateAuthreqParams msucc merr = case (msucc, merr) of (Nothing, Nothing) -> pure VerdictFormatWeb (Just ok, Just err) -> do @@ -277,7 +285,7 @@ validateAuthreqParams msucc merr = case (msucc, merr) of pure $ VerdictFormatMobile ok err _ -> throwSparSem $ SparBadInitiateLoginQueryParams "need-both-redirect-urls" -validateRedirectURL :: Member (Error SparError) r => URI.URI -> Sem r () +validateRedirectURL :: (Member (Error SparError) r) => URI.URI -> Sem r () validateRedirectURL uri = do unless ((SBS.take 4 . URI.schemeBS . URI.uriScheme $ uri) == "wire") $ do throwSparSem $ SparBadInitiateLoginQueryParams "invalid-schema" @@ -316,12 +324,13 @@ authresp mbtid arbody = logErrors $ SAML2.authResp mbtid (SamlProtocolSettings.s logErrors action = catch @SparError action $ \case e@(SAML.CustomServant _) -> throw e e -> do - throw @SparError . SAML.CustomServant $ - errorPage + throw @SparError + . SAML.CustomServant + $ errorPage e (Multipart.inputs (SAML.authnResponseBodyRaw arbody)) -ssoSettings :: Member DefaultSsoCode r => Sem r SsoSettings +ssoSettings :: (Member DefaultSsoCode r) => Sem r SsoSettings ssoSettings = SsoSettings <$> DefaultSsoCode.get @@ -433,7 +442,8 @@ idpDelete mbzusr idpid (fromMaybe False -> purge) = withDebugLog "idpDelete" (co else do throwSparSem SparIdPHasBoundUsers when (Cas.hasMore page) $ - SAMLUserStore.nextPage page >>= assertEmptyOrPurge teamId + SAMLUserStore.nextPage page + >>= assertEmptyOrPurge teamId updateOldIssuers :: IdP -> Sem r () updateOldIssuers _ = pure () @@ -710,7 +720,7 @@ validateIdPUpdate zusr _idpMetadata _idpId = withDebugLog "validateIdPUpdate" (J . URI.serializeURIRef uri = _idpMetadata ^. SAML.edIssuer . SAML.fromIssuer -withDebugLog :: Member (Logger String) r => String -> (a -> Maybe String) -> Sem r a -> Sem r a +withDebugLog :: (Member (Logger String) r) => String -> (a -> Maybe String) -> Sem r a -> Sem r a withDebugLog msg showval action = do Logger.log Logger.Debug $ "entering " ++ msg val <- action @@ -738,7 +748,7 @@ authorizeIdP (Just zusr) idp = do GalleyAccess.assertHasPermission teamid CreateUpdateDeleteIdp zusr pure (zusr, teamid) -enforceHttps :: Member (Error SparError) r => URI.URI -> Sem r () +enforceHttps :: (Member (Error SparError) r) => URI.URI -> Sem r () enforceHttps uri = unless ((uri ^. URI.uriSchemeL . URI.schemeBSL) == "https") $ do throwSparSem . SparNewIdPWantHttps . T.fromStrict . SAML.renderURI $ uri @@ -778,9 +788,9 @@ internalPutSsoSettings SsoSettings {defaultSsoCode = Just code} = -- "Could not find IdP". IdPConfigStore.getConfig code *> DefaultSsoCode.store code - $> NoContent + $> NoContent -internalGetScimUserInfo :: Member ScimUserTimesStore r => UserSet -> Sem r ScimUserInfos +internalGetScimUserInfo :: (Member 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)) diff --git a/services/spar/src/Spar/App.hs b/services/spar/src/Spar/App.hs index 722b65ab91c..ee2c61ccbfe 100644 --- a/services/spar/src/Spar/App.hs +++ b/services/spar/src/Spar/App.hs @@ -40,7 +40,6 @@ import Bilge import qualified Cassandra as Cas import Control.Exception (assert) import Control.Lens hiding ((.=)) -import Control.Monad.Except import Data.Aeson as Aeson (encode, object, (.=)) import Data.Aeson.Text as Aeson (encodeToLazyText) import Data.ByteString (toStrict) @@ -104,7 +103,7 @@ import qualified Wire.Sem.Logger as Logger import Wire.Sem.Random (Random) import qualified Wire.Sem.Random as Random -throwSparSem :: Member (Error SparError) r => SparCustomError -> Sem r a +throwSparSem :: (Member (Error SparError) r) => SparCustomError -> Sem r a throwSparSem = throw . SAML.CustomError data Env = Env @@ -270,7 +269,7 @@ validateEmail mbTid uid email = do -- 'SAML.Response', and fills in the response id in the header if missing, we can just go for the -- latter. verdictHandler :: - HasCallStack => + (HasCallStack) => ( Member Random r, Member (Logger String) r, Member GalleyAccess r, @@ -312,7 +311,7 @@ data VerdictHandlerResult deriving (Eq, Show) verdictHandlerResult :: - HasCallStack => + (HasCallStack) => ( Member Random r, Member (Logger String) r, Member GalleyAccess r, @@ -395,7 +394,7 @@ moveUserToNewIssuer oldUserRef newUserRef uid = do SAMLUserStore.delete uid oldUserRef verdictHandlerResultCore :: - HasCallStack => + (HasCallStack) => ( Member Random r, Member (Logger String) r, Member GalleyAccess r, @@ -444,7 +443,7 @@ verdictHandlerResultCore idp = \case -- - A title element with contents @wire:sso:@. This is chosen to be easily parseable and -- not be the title of any page sent by the IdP while it negotiates with the user. -- - The page broadcasts a message to '*', to be picked up by the app. -verdictHandlerWeb :: HasCallStack => VerdictHandlerResult -> Sem r SAML.ResponseVerdict +verdictHandlerWeb :: (HasCallStack) => VerdictHandlerResult -> Sem r SAML.ResponseVerdict verdictHandlerWeb = pure . \case VerifyHandlerGranted cky _uid -> successPage cky @@ -610,13 +609,13 @@ deleteTeam team' = do SAMLUserStore.deleteByIssuer issuer IdPConfigStore.deleteConfig idp -sparToServerErrorWithLogging :: Member Reporter r => SparError -> Sem r ServerError +sparToServerErrorWithLogging :: (Member Reporter r) => SparError -> Sem r ServerError sparToServerErrorWithLogging err = do let errServant = sparToServerError err Reporter.report Nothing (servantToWaiError errServant) pure errServant -renderSparErrorWithLogging :: Member Reporter r => SparError -> Sem r (Either ServerError Wai.Error) +renderSparErrorWithLogging :: (Member Reporter r) => SparError -> Sem r (Either ServerError Wai.Error) renderSparErrorWithLogging err = do let errPossiblyWai = renderSparError err Reporter.report Nothing (either servantToWaiError id $ errPossiblyWai) diff --git a/services/spar/src/Spar/Data.hs b/services/spar/src/Spar/Data.hs index ad8915c45c1..fc79c7dfb7b 100644 --- a/services/spar/src/Spar/Data.hs +++ b/services/spar/src/Spar/Data.hs @@ -72,13 +72,13 @@ mkEnv opts now = dataEnvMaxTTLAssertions = maxttlAuthresp opts } -mkTTLAuthnRequests :: MonadError TTLError m => Env -> UTCTime -> m (TTL "authreq") +mkTTLAuthnRequests :: (MonadError TTLError m) => Env -> UTCTime -> m (TTL "authreq") mkTTLAuthnRequests (Env now maxttl _) = mkTTL now maxttl -mkTTLAuthnRequestsNDT :: MonadError TTLError m => Env -> NominalDiffTime -> m (TTL "authreq") +mkTTLAuthnRequestsNDT :: (MonadError TTLError m) => Env -> NominalDiffTime -> m (TTL "authreq") mkTTLAuthnRequestsNDT (Env _ maxttl _) = mkTTLNDT maxttl -mkTTLAssertions :: MonadError TTLError m => Env -> UTCTime -> m (TTL "authresp") +mkTTLAssertions :: (MonadError TTLError m) => Env -> UTCTime -> m (TTL "authresp") mkTTLAssertions (Env now _ maxttl) = mkTTL now maxttl mkTTL :: (MonadError TTLError m, KnownSymbol a) => UTCTime -> TTL a -> UTCTime -> m (TTL a) @@ -87,9 +87,9 @@ mkTTL now maxttl endOfLife = mkTTLNDT maxttl $ endOfLife `diffUTCTime` now mkTTLNDT :: (MonadError TTLError m, KnownSymbol a) => TTL a -> NominalDiffTime -> m (TTL a) mkTTLNDT maxttl ttlNDT = if - | actualttl > maxttl -> throwError $ TTLTooLong (showTTL actualttl) (showTTL maxttl) - | actualttl <= 0 -> throwError $ TTLNegative (showTTL actualttl) - | otherwise -> pure actualttl + | actualttl > maxttl -> throwError $ TTLTooLong (showTTL actualttl) (showTTL maxttl) + | actualttl <= 0 -> throwError $ TTLNegative (showTTL actualttl) + | otherwise -> pure actualttl where actualttl = TTL . nominalDiffToSeconds $ ttlNDT diff --git a/services/spar/src/Spar/Data/Instances.hs b/services/spar/src/Spar/Data/Instances.hs index ebcd75da449..ac5ae4a9cb6 100644 --- a/services/spar/src/Spar/Data/Instances.hs +++ b/services/spar/src/Spar/Data/Instances.hs @@ -34,6 +34,7 @@ where import Cassandra as Cas import Data.ByteString (toStrict) import Data.ByteString.Conversion (fromByteString, toByteString) +import Data.Functor.Alt (Alt (())) import qualified Data.Text.Encoding as T import Data.Text.Encoding.Error import qualified Data.Text.Lazy as LT @@ -125,7 +126,8 @@ instance Cql ScimTokenLookupKey where ScimTokenLookupKeyHashed h -> toCql h ScimTokenLookupKeyPlaintext t -> toCql t fromCql s@(CqlText _) = - ScimTokenLookupKeyHashed <$> fromCql s <|> ScimTokenLookupKeyPlaintext <$> fromCql s + (ScimTokenLookupKeyHashed <$> fromCql s) + (ScimTokenLookupKeyPlaintext <$> fromCql s) fromCql _ = Left "ScimTokenLookupKey: expected CqlText" instance Cql ScimUserCreationStatus where diff --git a/services/spar/src/Spar/Error.hs b/services/spar/src/Spar/Error.hs index 8e3f516abdf..1f90640df73 100644 --- a/services/spar/src/Spar/Error.hs +++ b/services/spar/src/Spar/Error.hs @@ -68,7 +68,7 @@ type SparError = SAML.Error SparCustomError -- FUTUREWORK: This instance should probably be inside saml2-web-sso instead. instance Exception SparError -throwSpar :: MonadError SparError m => SparCustomError -> m a +throwSpar :: (MonadError SparError m) => SparCustomError -> m a throwSpar = throwError . SAML.CustomError data SparCustomError @@ -130,7 +130,7 @@ data IdpDbError | IdpNotFound -- like 'SparIdPNotFound', but a database consistency error. (should we consolidate something anyway?) deriving (Eq, Show) -sparToServerErrorWithLogging :: MonadIO m => Log.Logger -> SparError -> m ServerError +sparToServerErrorWithLogging :: (MonadIO m) => Log.Logger -> SparError -> m ServerError sparToServerErrorWithLogging logger err = do let errServant = sparToServerError err liftIO $ Wai.logError logger (Nothing :: Maybe Wai.Request) (servantToWaiError errServant) diff --git a/services/spar/src/Spar/Intra/Brig.hs b/services/spar/src/Spar/Intra/Brig.hs index d2a97b56dcc..aaac39be64b 100644 --- a/services/spar/src/Spar/Intra/Brig.hs +++ b/services/spar/src/Spar/Intra/Brig.hs @@ -62,6 +62,7 @@ import qualified SAML2.WebSSO as SAML import Spar.Error import qualified System.Logger.Class as Log import Web.Cookie +import Wire.API.Locale import Wire.API.Team.Role (Role) import Wire.API.User import Wire.API.User.Auth.ReAuth @@ -331,12 +332,12 @@ checkHandleAvailable hnd = do . paths ["/i/users/handles", toByteString' hnd] let sCode = statusCode resp if - | sCode == 200 -> -- handle exists - pure False - | sCode == 404 -> -- handle not found - pure True - | otherwise -> - rethrow "brig" resp + | sCode == 200 -> -- handle exists + pure False + | sCode == 404 -> -- handle not found + pure True + | otherwise -> + rethrow "brig" resp -- | Call brig to delete a user. -- If the user wasn't deleted completely before, another deletion attempt will be made. diff --git a/services/spar/src/Spar/Intra/BrigApp.hs b/services/spar/src/Spar/Intra/BrigApp.hs index 78c66c2997a..acca8893826 100644 --- a/services/spar/src/Spar/Intra/BrigApp.hs +++ b/services/spar/src/Spar/Intra/BrigApp.hs @@ -50,7 +50,7 @@ import Control.Lens import Control.Monad.Except import Data.ByteString.Conversion import qualified Data.CaseInsensitive as CI -import Data.Handle (Handle (Handle)) +import Data.Handle (Handle, parseHandle) import Data.Id (TeamId, UserId) import Data.Text.Encoding import Data.Text.Encoding.Error @@ -73,7 +73,7 @@ import Wire.API.User.Scim (ValidExternalId (..), runValidExternalIdEither) veidToUserSSOId :: ValidExternalId -> UserSSOId veidToUserSSOId = runValidExternalIdEither UserSSOId (UserScimExternalId . fromEmail) -veidFromUserSSOId :: MonadError String m => UserSSOId -> m ValidExternalId +veidFromUserSSOId :: (MonadError String m) => UserSSOId -> m ValidExternalId veidFromUserSSOId = \case UserSSOId uref -> case urefToEmail uref of @@ -93,7 +93,7 @@ veidFromUserSSOId = \case -- Note: the saml issuer is only needed in the case where a user has been invited via team -- settings and is now onboarded to saml/scim. If this case can safely be ruled out, it's ok -- to just set it to 'Nothing'. -veidFromBrigUser :: MonadError String m => User -> Maybe SAML.Issuer -> m ValidExternalId +veidFromBrigUser :: (MonadError String m) => User -> Maybe SAML.Issuer -> m ValidExternalId veidFromBrigUser usr mIssuer = case (userSSOId usr, userEmail usr, mIssuer) of (Just ssoid, _, _) -> veidFromUserSSOId ssoid (Nothing, Just email, Just issuer) -> pure $ EmailAndUref email (SAML.UserRef issuer (emailToSAMLNameID email)) @@ -180,7 +180,7 @@ giveDefaultHandle :: (HasCallStack, Member BrigAccess r) => User -> Sem r Handle giveDefaultHandle usr = case userHandle usr of Just handle -> pure handle Nothing -> do - let handle = Handle . decodeUtf8With lenientDecode . toByteString' $ uid + let handle = fromJust . parseHandle . decodeUtf8With lenientDecode . toByteString' $ uid uid = userId usr BrigAccess.setHandle uid handle pure handle diff --git a/services/spar/src/Spar/Options.hs b/services/spar/src/Spar/Options.hs index 41279364bd0..32c11360b13 100644 --- a/services/spar/src/Spar/Options.hs +++ b/services/spar/src/Spar/Options.hs @@ -32,7 +32,6 @@ where import Control.Exception import Control.Lens -import Control.Monad.Except import Data.Aeson hiding (fieldLabelModifier) import qualified Data.ByteString as SBS import Data.Time diff --git a/services/spar/src/Spar/Run.hs b/services/spar/src/Spar/Run.hs index 137ef209d1d..f07ca3ce871 100644 --- a/services/spar/src/Spar/Run.hs +++ b/services/spar/src/Spar/Run.hs @@ -36,14 +36,12 @@ import Data.Id import Data.Metrics.Servant (servantPrometheusMiddleware) import Data.Proxy (Proxy (Proxy)) import Data.Text.Encoding -import qualified Data.UUID as UUID -import Data.UUID.V4 as UUID import Imports import Network.Wai (Application) import qualified Network.Wai as Wai import qualified Network.Wai.Handler.Warp as Warp import qualified Network.Wai.Middleware.Gunzip as GZip -import Network.Wai.Utilities.Request (lookupRequestId) +import Network.Wai.Utilities.Server import qualified Network.Wai.Utilities.Server as WU import qualified SAML2.WebSSO as SAML import Spar.API (SparAPI, app) @@ -52,7 +50,7 @@ import qualified Spar.Data as Data import Spar.Data.Instances () import Spar.Options as Opt import Spar.Orphans () -import System.Logger (Logger, msg, val, (.=), (~~)) +import System.Logger (Logger) import qualified System.Logger as Log import qualified System.Logger.Extended as Log import Util.Options @@ -101,33 +99,24 @@ mkApp sparCtxOpts = do Bilge.host (sparCtxOpts ^. to galley . host . to encodeUtf8) . Bilge.port (sparCtxOpts ^. to galley . port) $ Bilge.empty - let wrappedApp = + let sparCtxRequestId = RequestId "N/A" + let ctx0 = Env {..} + let heavyLogOnly :: (Wai.Request, LByteString) -> Maybe (Wai.Request, LByteString) + heavyLogOnly out@(req, _) = + if Wai.requestMethod req == "POST" && Wai.pathInfo req == ["sso", "finalize-login"] + then Just out + else Nothing + let middleware = versionMiddleware (foldMap expandVersionExp (disabledAPIVersions sparCtxOpts)) - . WU.heavyDebugLogging heavyLogOnly logLevel sparCtxLogger + . requestIdMiddleware (ctx0.sparCtxLogger) defaultRequestIdHeaderName + . WU.heavyDebugLogging heavyLogOnly logLevel sparCtxLogger defaultRequestIdHeaderName . servantPrometheusMiddleware (Proxy @SparAPI) . GZip.gunzip - . WU.catchErrors sparCtxLogger [] + . WU.catchErrors sparCtxLogger defaultRequestIdHeaderName -- Error 'Response's are usually not thrown as exceptions, but logged in -- 'renderSparErrorWithLogging' before the 'Application' can construct a 'Response' -- value, when there is still all the type information around. 'WU.catchErrors' is -- still here for errors outside the power of the 'Application', like network -- outages. . SAML.setHttpCachePolicy - . lookupRequestIdMiddleware sparCtxLogger - $ \sparCtxRequestId -> app Env {..} - heavyLogOnly :: (Wai.Request, LByteString) -> Maybe (Wai.Request, LByteString) - heavyLogOnly out@(req, _) = - if Wai.requestMethod req == "POST" && Wai.pathInfo req == ["sso", "finalize-login"] - then Just out - else Nothing - pure (wrappedApp, let sparCtxRequestId = Bilge.RequestId "N/A" in Env {..}) - -lookupRequestIdMiddleware :: Logger -> (RequestId -> Wai.Application) -> Wai.Application -lookupRequestIdMiddleware logger mkapp req cont = do - case lookupRequestId req of - Just rid -> do - mkapp (RequestId rid) req cont - Nothing -> do - localRid <- RequestId . encodeUtf8 . UUID.toText <$> UUID.nextRandom - Log.info logger $ "request-id" .= localRid ~~ "request" .= (show req) ~~ msg (val "generated a new request id for local request") - mkapp localRid req cont + pure (middleware $ app ctx0, ctx0) diff --git a/services/spar/src/Spar/Scim/Auth.hs b/services/spar/src/Spar/Scim/Auth.hs index 4ec989f9d4b..35e2b6a394f 100644 --- a/services/spar/src/Spar/Scim/Auth.hs +++ b/services/spar/src/Spar/Scim/Auth.hs @@ -69,7 +69,7 @@ import Wire.Sem.Random (Random) import qualified Wire.Sem.Random as Random -- | An instance that tells @hscim@ how authentication should be done for SCIM routes. -instance Member ScimTokenStore r => Scim.Class.Auth.AuthDB SparTag (Sem r) where +instance (Member ScimTokenStore r) => Scim.Class.Auth.AuthDB SparTag (Sem r) where -- Validate and resolve a given token authCheck :: Maybe ScimToken -> Scim.ScimHandler (Sem r) ScimTokenInfo authCheck Nothing = diff --git a/services/spar/src/Spar/Scim/User.hs b/services/spar/src/Spar/Scim/User.hs index fb292202198..0ce2a38a2fd 100644 --- a/services/spar/src/Spar/Scim/User.hs +++ b/services/spar/src/Spar/Scim/User.hs @@ -45,7 +45,7 @@ where import qualified Control.Applicative as Applicative (empty) import Control.Lens hiding (op) import Control.Monad.Error.Class (MonadError) -import Control.Monad.Except (throwError, withExceptT) +import Control.Monad.Except (throwError) import Control.Monad.Trans.Except (mapExceptT) import Control.Monad.Trans.Maybe (MaybeT (MaybeT), runMaybeT) import Crypto.Hash (Digest, SHA256, hashlazy) @@ -54,7 +54,7 @@ import qualified Data.Aeson.Text as Aeson import Data.ByteString (toStrict) import Data.ByteString.Conversion (fromByteString, toByteString, toByteString') import qualified Data.ByteString.UTF8 as UTF8 -import Data.Handle (Handle (Handle), parseHandle) +import Data.Handle (Handle, fromHandle, parseHandle) import Data.Id (Id (..), TeamId, UserId, idToText) import Data.Json.Util (UTCTimeMillis, fromUTCTimeMillis, toUTCTimeMillis) import qualified Data.Text as Text @@ -219,12 +219,12 @@ validateScimUser errloc tokinfo user = do Left err -> throwError err Right validatedUser -> pure validatedUser -tokenInfoToIdP :: Member IdPConfigStore r => ScimTokenInfo -> Scim.ScimHandler (Sem r) (Maybe IdP) +tokenInfoToIdP :: (Member IdPConfigStore r) => ScimTokenInfo -> Scim.ScimHandler (Sem r) (Maybe IdP) tokenInfoToIdP ScimTokenInfo {stiIdP} = mapM (lift . IdPConfigStore.getConfig) stiIdP -- | Validate a handle (@userName@). -validateHandle :: Member (Error Scim.ScimError) r => Text -> Sem r Handle +validateHandle :: (Member (Error Scim.ScimError) r) => Text -> Sem r Handle validateHandle txt = case parseHandle txt of Just h -> pure h Nothing -> @@ -279,8 +279,13 @@ validateScimUser' errloc midp richInfoLimit user = do -- be a little less brittle. uname <- do let err msg = - throw . Scim.badRequest Scim.InvalidValue . Just $ - Text.pack msg <> " (" <> errloc <> ")" + throw + . Scim.badRequest Scim.InvalidValue + . Just + $ Text.pack msg + <> " (" + <> errloc + <> ")" either err pure $ Brig.mkUserName (Scim.displayName user) veid richInfo <- validateRichInfo (Scim.extra user ^. ST.sueRichInfo) let active = Scim.active user @@ -320,8 +325,9 @@ validateScimUser' errloc midp richInfoLimit user = do throw $ ( Scim.badRequest Scim.InvalidValue - ( Just . Text.pack $ - show [RI.richInfoMapURN @Text, RI.richInfoAssocListURN @Text] + ( Just + . Text.pack + $ show [RI.richInfoMapURN @Text, RI.richInfoAssocListURN @Text] <> " together exceed the size limit: max " <> show richInfoLimit <> " characters, but got " @@ -489,17 +495,18 @@ createValidScimUser tokeninfo@ScimTokenInfo {stiTeam} vsu@(ST.ValidScimUser veid Just (buid, ScimUserCreated) -> -- If the user has been created, but can't be found in brig anymore, -- the invitation has timed out and the user has been deleted on brig's side. - -- If this is the case we can safely create the user again. + -- If this is the case we can safely create the user again, AFTER THE + -- HALF-CREATED ACCOUNT HAS BEEN GARBAGE-COLLECTED. -- Otherwise we return a conflict error. lift (BrigAccess.getStatusMaybe buid) >>= \case - Just Active -> throwError externalIdTakenError - Just Suspended -> throwError externalIdTakenError - Just Ephemeral -> throwError externalIdTakenError - Just PendingInvitation -> throwError externalIdTakenError - Just Deleted -> pure () - Nothing -> pure () + Just Active -> throwError (externalIdTakenError ("user with status Active exists: " <> Text.pack (show (veid, buid)))) + Just Suspended -> throwError (externalIdTakenError ("user with status Suspended exists" <> Text.pack (show (veid, buid)))) + Just Ephemeral -> throwError (externalIdTakenError ("user with status Ephemeral exists" <> Text.pack (show (veid, buid)))) + Just PendingInvitation -> throwError (externalIdTakenError ("user with status PendingInvitation exists" <> Text.pack (show (veid, buid)))) + Just Deleted -> incompleteUserCreationCleanUp buid + Nothing -> incompleteUserCreationCleanUp buid Just (buid, ScimUserCreating) -> - incompleteUserCreationCleanUp buid externalIdTakenError + incompleteUserCreationCleanUp buid Nothing -> pure () -- ensure uniqueness constraints of all affected identifiers. @@ -562,18 +569,17 @@ createValidScimUser tokeninfo@ScimTokenInfo {stiTeam} vsu@(ST.ValidScimUser veid lift $ ScimExternalIdStore.insertStatus stiTeam veid buid ScimUserCreated pure storedUser where - incompleteUserCreationCleanUp :: UserId -> Scim.ScimError -> Scim.ScimHandler (Sem r) () - incompleteUserCreationCleanUp buid e = do + incompleteUserCreationCleanUp :: UserId -> Scim.ScimHandler (Sem r) () + incompleteUserCreationCleanUp buid = do -- something went wrong while storing the user in brig -- we can try clean up now, but if brig is down, we can't do much - -- maybe retrying the user creation in brig is also an option? - -- after clean up we rethrow the error so the handler returns the correct failure + -- and just fail with a 5xx. lift $ Logger.warn $ Log.msg @Text "An earlier attempt of creating a user with this external ID has failed and left some inconsistent data. Attempting to clean up." - withExceptT (const e) $ deleteScimUser tokeninfo buid - lift $ Logger.info $ Log.msg @Text "Clean up successful." + deleteScimUser tokeninfo buid + lift $ Logger.info $ Log.msg @Text "Clean up complete." - externalIdTakenError :: Scim.ScimError - externalIdTakenError = Scim.conflict {Scim.detail = Just "ExternalId is already taken"} + externalIdTakenError :: Text -> Scim.ScimError + externalIdTakenError msg = Scim.conflict {Scim.detail = Just ("ExternalId is already taken: " <> msg)} -- | Store scim timestamps, saml credentials, scim externalId locally in spar. Table -- `spar.scim_external` gets an entry iff there is no `UserRef`: if there is, we don't do a @@ -702,7 +708,7 @@ updateVsuUref team uid old new = do BrigAccess.setVeid uid new toScimStoredUser' :: - HasCallStack => + (HasCallStack) => UTCTimeMillis -> UTCTimeMillis -> URIBS.URI -> @@ -733,7 +739,7 @@ toScimStoredUser' createdAt lastChangedAt baseuri uid usr = updScimStoredUser :: forall r. - Member Now r => + (Member Now r) => Scim.User ST.SparTag -> Scim.StoredUser ST.SparTag -> Sem r (Scim.StoredUser ST.SparTag) @@ -773,47 +779,36 @@ deleteScimUser tokeninfo@ScimTokenInfo {stiTeam, stiIdP} uid = . logUser uid ) (const id) - $ do + do -- `getBrigUser` does not include deleted users. This is fine: these -- ("tombstones") would not have the needed values (`userIdentity = -- Nothing`) to delete a user in spar. I.e. `SAML.UserRef` and `Email` -- cannot be figured out when a `User` has status `Deleted`. mbBrigUser <- lift $ Brig.getBrigUser WithPendingInvitations uid - deletionStatus <- case mbBrigUser of + case mbBrigUser of Nothing -> -- Ensure there's no left-over of this user in brig. This is safe -- because the user has either been deleted (tombstone) or does not -- exist. Asserting the correct team id here is not needed (and would -- be hard as the check relies on the data of `mbBrigUser`): The worst - -- thing that could happen is that foreign users cleanup particially + -- thing that could happen is that foreign users cleanup partially -- deleted users. - lift $ BrigAccess.deleteUser uid + void . lift $ BrigAccess.deleteUser uid Just brigUser -> do - -- FUTUREWORK: currently it's impossible to delete the last available team owner via SCIM - -- (because that owner won't be managed by SCIM in the first place), but if it ever becomes - -- possible, we should do a check here and prohibit it. - unless (userTeam brigUser == Just stiTeam) $ - -- users from other teams get you a 404. - throwError $ - Scim.notFound "user" (idToText uid) - - -- This deletion needs data from the non-deleted User in brig. So, - -- execute it first, then delete the user in brig. Unfortunately, this - -- dependency prevents us from cleaning up the spar fragments of users - -- that have been deleted in brig. Deleting scim-managed users in brig - -- (via the TM app) is blocked, though, so there is no legal way to enter - -- that situation. - deleteUserInSpar brigUser - lift $ BrigAccess.deleteUser uid - case deletionStatus of - NoUser -> - throwError $ - Scim.notFound "user" (idToText uid) - AccountAlreadyDeleted -> - throwError $ - Scim.notFound "user" (idToText uid) - AccountDeleted -> - pure () + if userTeam brigUser == Just stiTeam + then do + -- This deletion needs data from the non-deleted User in brig. So, + -- execute it first, then delete the user in brig. Unfortunately, this + -- dependency prevents us from cleaning up the spar fragments of users + -- that have been deleted in brig. Deleting scim-managed users in brig + -- (via the TM app) is blocked, though, so there is no legal way to enter + -- that situation. + deleteUserInSpar brigUser + void . lift $ BrigAccess.deleteUser uid + else do + -- if we find the user in another team, we pretend it wasn't even there, to + -- avoid leaking data to attackers (very unlikely, but hey). + pure () where deleteUserInSpar :: ( Member IdPConfigStore r, @@ -918,16 +913,16 @@ assertExternalIdInAllowedValues allowedValues errmsg tid veid = do unless isGood $ throwError Scim.conflict {Scim.detail = Just errmsg} -assertHandleUnused :: Member BrigAccess r => Handle -> Scim.ScimHandler (Sem r) () +assertHandleUnused :: (Member BrigAccess r) => Handle -> Scim.ScimHandler (Sem r) () assertHandleUnused = assertHandleUnused' "userName is already taken" -assertHandleUnused' :: Member BrigAccess r => Text -> Handle -> Scim.ScimHandler (Sem r) () +assertHandleUnused' :: (Member BrigAccess r) => Text -> Handle -> Scim.ScimHandler (Sem r) () assertHandleUnused' msg hndl = lift (BrigAccess.checkHandleAvailable hndl) >>= \case True -> pure () False -> throwError Scim.conflict {Scim.detail = Just msg} -assertHandleNotUsedElsewhere :: Member BrigAccess r => UserId -> Handle -> Scim.ScimHandler (Sem r) () +assertHandleNotUsedElsewhere :: (Member BrigAccess r) => UserId -> Handle -> Scim.ScimHandler (Sem r) () assertHandleNotUsedElsewhere uid hndl = do musr <- lift $ Brig.getBrigUser Brig.WithPendingInvitations uid unless ((userHandle =<< musr) == Just hndl) $ @@ -1018,7 +1013,7 @@ synthesizeStoredUser' :: URIBS.URI -> Locale -> Maybe Role -> - MonadError Scim.ScimError m => m (Scim.StoredUser ST.SparTag) + (MonadError Scim.ScimError m) => m (Scim.StoredUser ST.SparTag) synthesizeStoredUser' uid veid dname handle richInfo accStatus createdAt lastUpdatedAt baseuri locale mbRole = do let scimUser :: Scim.User ST.SparTag scimUser = @@ -1039,8 +1034,8 @@ synthesizeStoredUser' uid veid dname handle richInfo accStatus createdAt lastUpd synthesizeScimUser :: ST.ValidScimUser -> Scim.User ST.SparTag synthesizeScimUser info = - let Handle userName = info ^. ST.vsuHandle - in (Scim.empty ST.userSchemas userName (ST.ScimUserExtra (info ^. ST.vsuRichInfo))) + let userName = info ^. ST.vsuHandle . to fromHandle + in (Scim.empty @ST.SparTag ST.userSchemas userName (ST.ScimUserExtra (info ^. ST.vsuRichInfo))) { Scim.externalId = Brig.renderValidExternalId $ info ^. ST.vsuExternalId, Scim.displayName = Just $ fromName (info ^. ST.vsuName), Scim.active = Just . Scim.ScimBool $ info ^. ST.vsuActive, @@ -1097,10 +1092,8 @@ getUserById midp stiTeam uid = do veidChanged :: User -> ST.ValidExternalId -> Bool veidChanged usr veid = case userIdentity usr of Nothing -> True - Just (FullIdentity _ _) -> True Just (EmailIdentity _) -> True - Just (PhoneIdentity _) -> True - Just (SSOIdentity ssoid _ _) -> Brig.veidToUserSSOId veid /= ssoid + Just (SSOIdentity ssoid _) -> Brig.veidToUserSSOId veid /= ssoid managedByChanged :: User -> Bool managedByChanged usr = userManagedBy usr /= ManagedByScim diff --git a/services/spar/src/Spar/Sem/AReqIDStore/Mem.hs b/services/spar/src/Spar/Sem/AReqIDStore/Mem.hs index 6768f59c308..736bfa5cb76 100644 --- a/services/spar/src/Spar/Sem/AReqIDStore/Mem.hs +++ b/services/spar/src/Spar/Sem/AReqIDStore/Mem.hs @@ -32,7 +32,7 @@ import Wire.API.User.Saml (AReqId) import Wire.Sem.Now aReqIDStoreToMem :: - Member Now r => + (Member Now r) => Sem (AReqIDStore ': r) a -> Sem r (Map AReqId SAML.Time, a) aReqIDStoreToMem = (runState mempty .) $ diff --git a/services/spar/src/Spar/Sem/AssIDStore/Mem.hs b/services/spar/src/Spar/Sem/AssIDStore/Mem.hs index 54dcca2d94d..01a7163083c 100644 --- a/services/spar/src/Spar/Sem/AssIDStore/Mem.hs +++ b/services/spar/src/Spar/Sem/AssIDStore/Mem.hs @@ -32,7 +32,7 @@ import Wire.API.User.Saml (AssId) import Wire.Sem.Now assIdStoreToMem :: - Member Now r => + (Member Now r) => Sem (AssIDStore ': r) a -> Sem r (Map AssId SAML.Time, a) assIdStoreToMem = (runState mempty .) $ diff --git a/services/spar/src/Spar/Sem/BrigAccess.hs b/services/spar/src/Spar/Sem/BrigAccess.hs index 450edf7564e..1936116030f 100644 --- a/services/spar/src/Spar/Sem/BrigAccess.hs +++ b/services/spar/src/Spar/Sem/BrigAccess.hs @@ -53,6 +53,7 @@ import Imports import Polysemy import qualified SAML2.WebSSO as SAML import Web.Cookie +import Wire.API.Locale import Wire.API.Team.Role import Wire.API.User (AccountStatus (..), DeleteUserResult, VerificationAction) import Wire.API.User.Identity diff --git a/services/spar/src/Spar/Sem/DefaultSsoCode/Spec.hs b/services/spar/src/Spar/Sem/DefaultSsoCode/Spec.hs index d4dd4ad848d..3f83e9b3459 100644 --- a/services/spar/src/Spar/Sem/DefaultSsoCode/Spec.hs +++ b/services/spar/src/Spar/Sem/DefaultSsoCode/Spec.hs @@ -30,7 +30,7 @@ import Test.Hspec.QuickCheck import Test.QuickCheck propsForInterpreter :: - PropConstraints r f => + (PropConstraints r f) => String -> (forall a. Sem r a -> IO (f a)) -> Spec @@ -48,15 +48,15 @@ propsForInterpreter interpreter lower = do -- A regular type synonym doesn't work due to dreaded impredicative -- polymorphism. class - (Arbitrary IdPId, CoArbitrary IdPId, Functor f, Member E.DefaultSsoCode r, forall z. Show z => Show (f z), forall z. Eq z => Eq (f z)) => + (Arbitrary IdPId, CoArbitrary IdPId, Functor f, Member E.DefaultSsoCode r, forall z. (Show z) => Show (f z), forall z. (Eq z) => Eq (f z)) => PropConstraints r f instance - (Arbitrary IdPId, CoArbitrary IdPId, Functor f, Member E.DefaultSsoCode r, forall z. Show z => Show (f z), forall z. Eq z => Eq (f z)) => + (Arbitrary IdPId, CoArbitrary IdPId, Functor f, Member E.DefaultSsoCode r, forall z. (Show z) => Show (f z), forall z. (Eq z) => Eq (f z)) => PropConstraints r f prop_storeGet :: - PropConstraints r f => + (PropConstraints r f) => Maybe (f (Maybe IdPId) -> String) -> (forall a. Sem r a -> IO (f a)) -> Property @@ -75,7 +75,7 @@ prop_storeGet = ) prop_getStore :: - PropConstraints r f => + (PropConstraints r f) => Maybe (f () -> String) -> (forall a. Sem r a -> IO (f a)) -> Property @@ -91,7 +91,7 @@ prop_getStore = ) prop_storeDelete :: - PropConstraints r f => + (PropConstraints r f) => Maybe (f () -> String) -> (forall a. Sem r a -> IO (f a)) -> Property @@ -109,7 +109,7 @@ prop_storeDelete = ) prop_deleteStore :: - PropConstraints r f => + (PropConstraints r f) => Maybe (f () -> String) -> (forall a. Sem r a -> IO (f a)) -> Property @@ -127,7 +127,7 @@ prop_deleteStore = ) prop_storeStore :: - PropConstraints r f => + (PropConstraints r f) => Maybe (f () -> String) -> (forall a. Sem r a -> IO (f a)) -> Property @@ -146,7 +146,7 @@ prop_storeStore = ) prop_deleteDelete :: - PropConstraints r f => + (PropConstraints r f) => Maybe (f () -> String) -> (forall a. Sem r a -> IO (f a)) -> Property @@ -163,7 +163,7 @@ prop_deleteDelete = ) prop_deleteGet :: - PropConstraints r f => + (PropConstraints r f) => Maybe (f (Maybe IdPId) -> String) -> (forall a. Sem r a -> IO (f a)) -> Property diff --git a/services/spar/src/Spar/Sem/IdPRawMetadataStore/Spec.hs b/services/spar/src/Spar/Sem/IdPRawMetadataStore/Spec.hs index f55560cf769..1a8805e8afe 100644 --- a/services/spar/src/Spar/Sem/IdPRawMetadataStore/Spec.hs +++ b/services/spar/src/Spar/Sem/IdPRawMetadataStore/Spec.hs @@ -30,15 +30,15 @@ import Test.Hspec.QuickCheck import Test.QuickCheck class - (Arbitrary IdPId, CoArbitrary IdPId, Arbitrary Text, CoArbitrary Text, Functor f, Member E.IdPRawMetadataStore r, forall z. Show z => Show (f z), forall z. Eq z => Eq (f z)) => + (Arbitrary IdPId, CoArbitrary IdPId, Arbitrary Text, CoArbitrary Text, Functor f, Member E.IdPRawMetadataStore r, forall z. (Show z) => Show (f z), forall z. (Eq z) => Eq (f z)) => PropConstraints r f instance - (Arbitrary IdPId, CoArbitrary IdPId, Arbitrary Text, CoArbitrary Text, Functor f, Member E.IdPRawMetadataStore r, forall z. Show z => Show (f z), forall z. Eq z => Eq (f z)) => + (Arbitrary IdPId, CoArbitrary IdPId, Arbitrary Text, CoArbitrary Text, Functor f, Member E.IdPRawMetadataStore r, forall z. (Show z) => Show (f z), forall z. (Eq z) => Eq (f z)) => PropConstraints r f prop_storeGetRaw :: - PropConstraints r f => + (PropConstraints r f) => Maybe (f (Maybe Text) -> String) -> (forall a. Sem r a -> IO (f a)) -> Property @@ -60,7 +60,7 @@ prop_storeGetRaw = ) prop_storeStoreRaw :: - PropConstraints r f => + (PropConstraints r f) => Maybe (f (Maybe Text) -> String) -> (forall a. Sem r a -> IO (f a)) -> Property @@ -84,7 +84,7 @@ prop_storeStoreRaw = ) prop_storeDeleteRaw :: - PropConstraints r f => + (PropConstraints r f) => Maybe (f (Maybe Text) -> String) -> (forall a. Sem r a -> IO (f a)) -> Property @@ -106,7 +106,7 @@ prop_storeDeleteRaw = ) prop_deleteGetRaw :: - PropConstraints r f => + (PropConstraints r f) => Maybe (f (Maybe Text) -> String) -> (forall a. Sem r a -> IO (f a)) -> Property @@ -131,7 +131,7 @@ prop_deleteGetRaw = ) propsForInterpreter :: - PropConstraints r f => + (PropConstraints r f) => (forall x. f x -> x) -> (forall a. Sem r a -> IO (f a)) -> Spec diff --git a/services/spar/src/Spar/Sem/SAML2.hs b/services/spar/src/Spar/Sem/SAML2.hs index 1e7168370b8..f94c87fe020 100644 --- a/services/spar/src/Spar/Sem/SAML2.hs +++ b/services/spar/src/Spar/Sem/SAML2.hs @@ -50,7 +50,7 @@ data SAML2 m a where SAML2 m resp Meta :: Text -> m Issuer -> m URI -> SAML2 m SPMetadata ToggleCookie :: - KnownSymbol name => + (KnownSymbol name) => ByteString -> Maybe (Text, NominalDiffTime) -> SAML2 m (SimpleSetCookie name) diff --git a/services/spar/src/Spar/Sem/SAML2/Library.hs b/services/spar/src/Spar/Sem/SAML2/Library.hs index 67059ce4c85..e728fe6d0be 100644 --- a/services/spar/src/Spar/Sem/SAML2/Library.hs +++ b/services/spar/src/Spar/Sem/SAML2/Library.hs @@ -62,10 +62,10 @@ wrapMonadClientSPImpl action = . show @SomeException ) -instance Member (Final IO) r => Catch.MonadThrow (SPImpl r) where +instance (Member (Final IO) r) => Catch.MonadThrow (SPImpl r) where throwM = SPImpl . embedFinal . Catch.throwM @IO -instance Member (Final IO) r => Catch.MonadCatch (SPImpl r) where +instance (Member (Final IO) r) => Catch.MonadCatch (SPImpl r) where catch (SPImpl m) handler = SPImpl $ withStrategicToFinal @IO $ do m' <- runS m @@ -76,21 +76,21 @@ instance Member (Final IO) r => Catch.MonadCatch (SPImpl r) where newtype SPImpl r a = SPImpl {unSPImpl :: Sem r a} deriving (Functor, Applicative, Monad) -instance Member (Input Opts) r => HasConfig (SPImpl r) where +instance (Member (Input Opts) r) => HasConfig (SPImpl r) where getConfig = SPImpl $ inputs saml instance - Member (Logger String) r => + (Member (Logger String) r) => HasLogger (SPImpl r) where logger lvl = SPImpl . Logger.log (Logger.samlFromLevel lvl) -instance Member (Embed IO) r => MonadIO (SPImpl r) where +instance (Member (Embed IO) r) => MonadIO (SPImpl r) where liftIO = SPImpl . embed @IO -instance Member (Embed IO) r => HasCreateUUID (SPImpl r) +instance (Member (Embed IO) r) => HasCreateUUID (SPImpl r) -instance Member (Embed IO) r => HasNow (SPImpl r) +instance (Member (Embed IO) r) => HasNow (SPImpl r) instance ( Member (Error SparError) r, @@ -130,7 +130,7 @@ instance Nothing -> IdPConfigStore.getIdPByIssuerV1 issuer Just team -> IdPConfigStore.getIdPByIssuerV2 issuer team -instance Member (Error SparError) r => MonadError SparError (SPImpl r) where +instance (Member (Error SparError) r) => MonadError SparError (SPImpl r) where throwError = SPImpl . throw catchError m handler = SPImpl $ catch (unSPImpl m) $ unSPImpl . handler diff --git a/services/spar/src/Spar/Sem/SAMLUserStore/Cassandra.hs b/services/spar/src/Spar/Sem/SAMLUserStore/Cassandra.hs index b7249074273..3436a83acd6 100644 --- a/services/spar/src/Spar/Sem/SAMLUserStore/Cassandra.hs +++ b/services/spar/src/Spar/Sem/SAMLUserStore/Cassandra.hs @@ -27,7 +27,6 @@ where import Cassandra as Cas import Control.Lens -import Control.Monad.Except import Data.Id import Imports import Polysemy @@ -43,13 +42,14 @@ samlUserStoreToCassandra :: Sem r a samlUserStoreToCassandra = interpret $ - embed . \case - Insert ur uid -> insertSAMLUser ur uid - Get ur -> getSAMLUser ur - DeleteByIssuer is -> deleteSAMLUsersByIssuer is - Delete uid ur -> deleteSAMLUser uid ur - GetAllByIssuerPaginated is -> getAllSAMLUsersByIssuerPaginated is - NextPage page -> nextPage' page + embed + . \case + Insert ur uid -> insertSAMLUser ur uid + Get ur -> getSAMLUser ur + DeleteByIssuer is -> deleteSAMLUsersByIssuer is + Delete uid ur -> deleteSAMLUser uid ur + GetAllByIssuerPaginated is -> getAllSAMLUsersByIssuerPaginated is + NextPage page -> nextPage' page nextPage' :: (HasCallStack, MonadClient m) => Cas.Page a -> m (Cas.Page a) nextPage' = Cas.liftClient . Cas.nextPage diff --git a/services/spar/src/Spar/Sem/ScimExternalIdStore/Spec.hs b/services/spar/src/Spar/Sem/ScimExternalIdStore/Spec.hs index 38ad7834c00..eab1ba7d47f 100644 --- a/services/spar/src/Spar/Sem/ScimExternalIdStore/Spec.hs +++ b/services/spar/src/Spar/Sem/ScimExternalIdStore/Spec.hs @@ -31,7 +31,7 @@ import Test.Hspec.QuickCheck import Test.QuickCheck propsForInterpreter :: - PropConstraints r f => + (PropConstraints r f) => String -> (forall a. f a -> a) -> (forall a. Sem r a -> IO (f a)) -> @@ -52,15 +52,15 @@ propsForInterpreter interpreter extract lower = do -- A regular type synonym doesn't work due to dreaded impredicative -- polymorphism. class - (Arbitrary UserId, CoArbitrary UserId, Arbitrary ScimUserCreationStatus, CoArbitrary ScimUserCreationStatus, Functor f, Member E.ScimExternalIdStore r, forall z. Show z => Show (f z), forall z. Eq z => Eq (f z)) => + (Arbitrary UserId, CoArbitrary UserId, Arbitrary ScimUserCreationStatus, CoArbitrary ScimUserCreationStatus, Functor f, Member E.ScimExternalIdStore r, forall z. (Show z) => Show (f z), forall z. (Eq z) => Eq (f z)) => PropConstraints r f instance - (CoArbitrary UserId, CoArbitrary ScimUserCreationStatus, Functor f, Member E.ScimExternalIdStore r, forall z. Show z => Show (f z), forall z. Eq z => Eq (f z)) => + (CoArbitrary UserId, CoArbitrary ScimUserCreationStatus, Functor f, Member E.ScimExternalIdStore r, forall z. (Show z) => Show (f z), forall z. (Eq z) => Eq (f z)) => PropConstraints r f prop_insertLookup :: - PropConstraints r f => + (PropConstraints r f) => Maybe (f (Maybe UserId) -> String) -> (forall a. Sem r a -> IO (f a)) -> Property @@ -81,7 +81,7 @@ prop_insertLookup = ) prop_lookupInsert :: - PropConstraints r f => + (PropConstraints r f) => Maybe (f () -> String) -> (forall a. Sem r a -> IO (f a)) -> Property @@ -99,7 +99,7 @@ prop_lookupInsert = ) prop_insertDelete :: - PropConstraints r f => + (PropConstraints r f) => Maybe (f () -> String) -> (forall a. Sem r a -> IO (f a)) -> Property @@ -119,7 +119,7 @@ prop_insertDelete = ) prop_deleteInsert :: - PropConstraints r f => + (PropConstraints r f) => Maybe (f () -> String) -> (forall a. Sem r a -> IO (f a)) -> Property @@ -139,7 +139,7 @@ prop_deleteInsert = ) prop_insertInsert :: - PropConstraints r f => + (PropConstraints r f) => Maybe (f (Maybe UserId) -> String) -> (forall a. Sem r a -> IO (f a)) -> Property @@ -162,7 +162,7 @@ prop_insertInsert = ) prop_deleteDelete :: - PropConstraints r f => + (PropConstraints r f) => Maybe (f () -> String) -> (forall a. Sem r a -> IO (f a)) -> Property @@ -181,7 +181,7 @@ prop_deleteDelete = ) prop_deleteLookup :: - PropConstraints r f => + (PropConstraints r f) => Maybe (f (Maybe UserId) -> String) -> (forall a. Sem r a -> IO (f a)) -> Property diff --git a/services/spar/src/Spar/Sem/ScimTokenStore/Cassandra.hs b/services/spar/src/Spar/Sem/ScimTokenStore/Cassandra.hs index 1dd8e176921..6f56b34e77c 100644 --- a/services/spar/src/Spar/Sem/ScimTokenStore/Cassandra.hs +++ b/services/spar/src/Spar/Sem/ScimTokenStore/Cassandra.hs @@ -25,7 +25,6 @@ module Spar.Sem.ScimTokenStore.Cassandra (scimTokenStoreToCassandra) where import Cassandra as Cas import Control.Arrow (Arrow ((&&&))) import Control.Lens -import Control.Monad.Except import Data.Id import Data.Time import Imports @@ -44,12 +43,13 @@ scimTokenStoreToCassandra :: Sem r a scimTokenStoreToCassandra = interpret $ - embed @m . \case - Insert st sti -> insertScimToken st sti - Lookup st -> lookupScimToken st - LookupByTeam tid -> getScimTokens tid - Delete tid ur -> deleteScimToken tid ur - DeleteByTeam tid -> deleteTeamScimTokens tid + embed @m + . \case + Insert st sti -> insertScimToken st sti + Lookup st -> lookupScimToken st + LookupByTeam tid -> getScimTokens tid + Delete tid ur -> deleteScimToken tid ur + DeleteByTeam tid -> deleteTeamScimTokens tid ---------------------------------------------------------------------- -- SCIM auth @@ -114,7 +114,7 @@ lookupScimToken token = do FROM team_provisioning_by_token WHERE token_ in (?, ?) |] - convert :: MonadClient m => ScimToken -> ScimTokenRow -> m (Maybe ScimTokenInfo) + convert :: (MonadClient m) => ScimToken -> ScimTokenRow -> m (Maybe ScimTokenInfo) convert plain row = do let tokenInfo = fromScimTokenRow row connvertPlaintextToken plain tokenInfo diff --git a/services/spar/src/Spar/Sem/Utils.hs b/services/spar/src/Spar/Sem/Utils.hs index 277a4a402b6..9ed9a421cd3 100644 --- a/services/spar/src/Spar/Sem/Utils.hs +++ b/services/spar/src/Spar/Sem/Utils.hs @@ -29,7 +29,7 @@ where import Bilge import Cassandra as Cas import qualified Control.Monad.Catch as Catch -import Control.Monad.Except +import Control.Monad.Except (ExceptT (..), MonadError, runExceptT) import qualified Data.Text.Lazy as LText import Imports hiding (log) import Polysemy @@ -67,10 +67,10 @@ interpretClientToIO ctx = interpret $ \case . show @SomeException pure $ action' `Catch.catch` \e -> handler' $ e <$ st -ttlErrorToSparError :: Member (Error SparError) r => Sem (Error TTLError ': r) a -> Sem r a +ttlErrorToSparError :: (Member (Error SparError) r) => Sem (Error TTLError ': r) a -> Sem r a ttlErrorToSparError = mapError (SAML.CustomError . SparCassandraTTLError) -idpDbErrorToSparError :: Member (Error SparError) r => Sem (Error IdpDbError ': r) a -> Sem r a +idpDbErrorToSparError :: (Member (Error SparError) r) => Sem (Error IdpDbError ': r) a -> Sem r a idpDbErrorToSparError = mapError (SAML.CustomError . IdpDbError) data RunHttpEnv r = RunHttpEnv @@ -83,10 +83,10 @@ newtype RunHttp r a = RunHttp } deriving newtype (Functor, Applicative, Monad, MonadError SparError, MonadReader (RunHttpEnv r)) -instance Member (Embed IO) r => MonadIO (RunHttp r) where +instance (Member (Embed IO) r) => MonadIO (RunHttp r) where liftIO = semToRunHttp . embed -instance Member (Embed IO) r => MonadHttp (RunHttp r) where +instance (Member (Embed IO) r) => MonadHttp (RunHttp r) where handleRequestWithCont r fribia = RunHttp $ lift $ @@ -97,7 +97,7 @@ semToRunHttp :: Sem r a -> RunHttp r a semToRunHttp = RunHttp . lift . lift . lift viaRunHttp :: - Member (Error SparError) r => + (Member (Error SparError) r) => RunHttpEnv r -> RunHttp r a -> Sem r a @@ -107,7 +107,7 @@ viaRunHttp env m = do Left err -> throw err Right a -> pure a -instance Member (Logger (TinyLog.Msg -> TinyLog.Msg)) r => TinyLog.MonadLogger (RunHttp r) where +instance (Member (Logger (TinyLog.Msg -> TinyLog.Msg)) r) => TinyLog.MonadLogger (RunHttp r) where log lvl msg = semToRunHttp $ Logger.log (Logger.fromLevel lvl) msg instance diff --git a/services/spar/src/Spar/Sem/VerdictFormatStore/Cassandra.hs b/services/spar/src/Spar/Sem/VerdictFormatStore/Cassandra.hs index c396fb28fbe..2f4dea03beb 100644 --- a/services/spar/src/Spar/Sem/VerdictFormatStore/Cassandra.hs +++ b/services/spar/src/Spar/Sem/VerdictFormatStore/Cassandra.hs @@ -25,7 +25,6 @@ where import Cassandra as Cas import Control.Lens -import Control.Monad.Except import Data.Time import Imports import Polysemy diff --git a/services/spar/src/Spar/Sem/VerdictFormatStore/Mem.hs b/services/spar/src/Spar/Sem/VerdictFormatStore/Mem.hs index 322dfd6b509..12ecf2368ad 100644 --- a/services/spar/src/Spar/Sem/VerdictFormatStore/Mem.hs +++ b/services/spar/src/Spar/Sem/VerdictFormatStore/Mem.hs @@ -34,7 +34,7 @@ import Wire.Sem.Now (Now, boolTTL) import qualified Wire.Sem.Now as Now verdictFormatStoreToMem :: - Member Now r => + (Member Now r) => Sem (VerdictFormatStore ': r) a -> Sem r (Map AReqId (SAML.Time, VerdictFormat), a) verdictFormatStoreToMem = diff --git a/services/spar/test-integration/Test/MetricsSpec.hs b/services/spar/test-integration/Test/MetricsSpec.hs index b4417b01566..1892bc41c23 100644 --- a/services/spar/test-integration/Test/MetricsSpec.hs +++ b/services/spar/test-integration/Test/MetricsSpec.hs @@ -29,7 +29,7 @@ import Data.String.Conversions import Imports import Util -spec :: HasCallStack => SpecWith TestEnv +spec :: (HasCallStack) => SpecWith TestEnv spec = describe "metrics" . it "works" $ do spar <- asks (^. teSpar) let p1 = "/sso/metadata" diff --git a/services/spar/test-integration/Test/Spar/APISpec.hs b/services/spar/test-integration/Test/Spar/APISpec.hs index ea777758532..90895f2164c 100644 --- a/services/spar/test-integration/Test/Spar/APISpec.hs +++ b/services/spar/test-integration/Test/Spar/APISpec.hs @@ -193,7 +193,7 @@ specInitiateLogin = do let uuid = cs $ UUID.toText UUID.nil get ((env ^. teSpar) . path (cs $ "/sso/initiate-login/" -/ uuid)) `shouldRespondWith` ((== 404) . statusCode) - let checkRespBody :: HasCallStack => ResponseLBS -> Bool + let checkRespBody :: (HasCallStack) => ResponseLBS -> Bool checkRespBody (responseBody -> Just (cs -> bdy)) = all (`isInfixOf` bdy) @@ -219,7 +219,7 @@ specFinalizeLogin = do testRejectsSAMLResponseSayingAccessNotGranted context "access granted" $ do - let loginSuccess :: HasCallStack => ResponseLBS -> TestSpar () + let loginSuccess :: (HasCallStack) => ResponseLBS -> TestSpar () loginSuccess sparresp = liftIO $ do statusCode sparresp `shouldBe` 200 let bdy = maybe "" (cs @LByteString @String) (responseBody sparresp) @@ -229,7 +229,7 @@ specFinalizeLogin = do bdy `shouldContain` "window.opener.postMessage({type: 'AUTH_SUCCESS'}, receiverOrigin)" hasPersistentCookieHeader sparresp `shouldBe` Right () - let loginFailure :: HasCallStack => ResponseLBS -> TestSpar () + let loginFailure :: (HasCallStack) => ResponseLBS -> TestSpar () loginFailure sparresp = liftIO $ do statusCode sparresp `shouldBe` 200 let bdy = maybe "" (cs @LByteString @String) (responseBody sparresp) @@ -393,7 +393,7 @@ specFinalizeLogin = do (idp, (_, privcreds)) <- registerTestIdPWithMeta ownerid spmeta <- getTestSPMetadata tid - let loginSuccess :: HasCallStack => ResponseLBS -> TestSpar () + let loginSuccess :: (HasCallStack) => ResponseLBS -> TestSpar () loginSuccess sparresp = liftIO $ do statusCode sparresp `shouldBe` 200 @@ -423,7 +423,7 @@ specFinalizeLogin = do mbId2 `shouldSatisfy` isJust mbId1 `shouldBe` mbId2 -testGetPutDelete :: HasCallStack => (SparReq -> Maybe UserId -> IdPId -> IdPMetadataInfo -> Http ResponseLBS) -> SpecWith TestEnv +testGetPutDelete :: (HasCallStack) => (SparReq -> Maybe UserId -> IdPId -> IdPMetadataInfo -> Http ResponseLBS) -> SpecWith TestEnv testGetPutDelete whichone = do context "unknown IdP" $ do it "responds with 'not found'" $ do @@ -445,7 +445,7 @@ testGetPutDelete whichone = do env <- ask (ownerid, _tid) <- callCreateUserWithTeam ((^. idpId) -> idpid, (idpmeta, _)) <- registerTestIdPWithMeta ownerid - (uid, _) <- call $ createRandomPhoneUser (env ^. teBrig) + uid <- call $ userId <$> randomUser (env ^. teBrig) whichone (env ^. teSpar) (Just uid) idpid idpmeta `shouldRespondWith` checkErrHspec 403 "insufficient-permissions" context "zuser is a team member, but not a team owner" $ do @@ -816,7 +816,7 @@ specCRUDIdentityProvider = do liftIO $ requri `shouldBe` idpmeta' ^. edRequestURI describe "new certs" $ do let -- Create a team, idp, and update idp with 'sampleIdPCert2'. - initidp :: HasCallStack => TestSpar (IdP, SignPrivCreds, SignPrivCreds) + initidp :: (HasCallStack) => TestSpar (IdP, SignPrivCreds, SignPrivCreds) initidp = do env <- ask (owner, _tid) <- callCreateUserWithTeam @@ -828,7 +828,7 @@ specCRUDIdentityProvider = do pure (idp, oldPrivKey, newPrivKey) -- Sign authn response with a given private key (which may be the one matching -- 'sampleIdPCert2' or not), and check the status of spars response. - check :: HasCallStack => Bool -> Int -> String -> Either String () -> TestSpar () + check :: (HasCallStack) => Bool -> Int -> String -> Either String () -> TestSpar () check useNewPrivKey expectedStatus expectedHtmlTitle expectedCookie = do (idp, oldPrivKey, newPrivKey) <- initidp let tid = idp ^. idpExtraInfo . team @@ -877,7 +877,7 @@ specCRUDIdentityProvider = do context "zuser has no team" $ do it "responds with 'no team member'" $ do env <- ask - (uid, _) <- call $ createRandomPhoneUser (env ^. teBrig) + uid <- call $ userId <$> randomUser (env ^. teBrig) (SampleIdP idpmeta _ _ _) <- makeSampleIdPMetadata callIdpCreate' (env ^. teWireIdPAPIVersion) (env ^. teSpar) (Just uid) idpmeta `shouldRespondWith` checkErrHspec 403 "no-team-member" @@ -1043,7 +1043,7 @@ specCRUDIdentityProvider = do scimStoredUser <- createUser tok scimUser let checkScimSearch :: - HasCallStack => + (HasCallStack) => Scim.StoredUser SparTag -> Scim.User SparTag -> ReaderT TestEnv IO () @@ -1223,12 +1223,12 @@ specDeleteCornerCases = describe "delete corner cases" $ do (Just _) <- createViaSaml idp privcreds uref samlUserShouldSatisfy uref isJust where - samlUserShouldSatisfy :: HasCallStack => SAML.UserRef -> (Maybe UserId -> Bool) -> TestSpar () + samlUserShouldSatisfy :: (HasCallStack) => SAML.UserRef -> (Maybe UserId -> Bool) -> TestSpar () samlUserShouldSatisfy uref property = do muid <- getUserIdViaRef' uref liftIO $ muid `shouldSatisfy` property - createViaSamlResp :: HasCallStack => IdP -> SignPrivCreds -> SAML.UserRef -> TestSpar ResponseLBS + createViaSamlResp :: (HasCallStack) => IdP -> SignPrivCreds -> SAML.UserRef -> TestSpar ResponseLBS createViaSamlResp idp privCreds (SAML.UserRef _ subj) = do let tid = idp ^. idpExtraInfo . team authnReq <- negotiateAuthnRequest idp @@ -1238,7 +1238,7 @@ specDeleteCornerCases = describe "delete corner cases" $ do liftIO $ responseStatus createResp `shouldBe` status200 pure createResp - createViaSaml :: HasCallStack => IdP -> SignPrivCreds -> SAML.UserRef -> TestSpar (Maybe UserId) + createViaSaml :: (HasCallStack) => IdP -> SignPrivCreds -> SAML.UserRef -> TestSpar (Maybe UserId) createViaSaml idp privcreds uref = do resp <- createViaSamlResp idp privcreds uref liftIO $ do @@ -1398,7 +1398,7 @@ specAux :: SpecWith TestEnv specAux = do describe "test helper functions" $ do describe "createTeamMember" $ do - let check :: HasCallStack => Bool -> Int -> SpecWith TestEnv + let check :: (HasCallStack) => Bool -> Int -> SpecWith TestEnv check tryowner permsix = it ("works: tryowner == " <> show (tryowner, permsix)) $ do env <- ask @@ -1509,7 +1509,7 @@ specSsoSettings = do -- TODO: what else needs to be tested, beyond the pending tests listed here? -- TODO: what tests can go to saml2-web-sso package? -getSsoidViaAuthResp :: HasCallStack => SignedAuthnResponse -> TestSpar UserSSOId +getSsoidViaAuthResp :: (HasCallStack) => SignedAuthnResponse -> TestSpar UserSSOId getSsoidViaAuthResp aresp = do parsed :: AuthnResponse <- either error pure . parseFromDocument $ fromSignedAuthnResponse aresp diff --git a/services/spar/test-integration/Test/Spar/AppSpec.hs b/services/spar/test-integration/Test/Spar/AppSpec.hs index ccc5d4ac103..af05a544434 100644 --- a/services/spar/test-integration/Test/Spar/AppSpec.hs +++ b/services/spar/test-integration/Test/Spar/AppSpec.hs @@ -141,7 +141,7 @@ mkAuthnReqMobile idpid = do -- fresh, iff the verdict is "granted" the user will be created during the call to -- 'Spar.verdictHandler'. requestAccessVerdict :: - HasCallStack => + (HasCallStack) => IdP -> -- | is the verdict granted? Bool -> diff --git a/services/spar/test-integration/Test/Spar/DataSpec.hs b/services/spar/test-integration/Test/Spar/DataSpec.hs index 886f084f2d6..25f1ee2f468 100644 --- a/services/spar/test-integration/Test/Spar/DataSpec.hs +++ b/services/spar/test-integration/Test/Spar/DataSpec.hs @@ -25,7 +25,6 @@ where import Cassandra import Control.Lens -import Control.Monad.Except import Data.Kind (Type) import Imports import Polysemy diff --git a/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs b/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs index 1ff2bdb2584..c5d6ae7f436 100644 --- a/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs +++ b/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs @@ -45,7 +45,7 @@ import Data.Aeson.Types (fromJSON, toJSON) import Data.ByteString.Conversion import qualified Data.CaseInsensitive as CI import qualified Data.Csv as Csv -import Data.Handle (Handle (Handle), fromHandle, parseHandleEither) +import Data.Handle (Handle, fromHandle, parseHandle, parseHandleEither) import Data.Id (TeamId, UserId, randomId) import Data.Ix (inRange) import Data.LanguageCodes (ISO639_1 (..)) @@ -210,12 +210,12 @@ specImportToScimFromInvitation = check False check True where - createTeam :: HasCallStack => TestSpar (UserId, TeamId) + createTeam :: (HasCallStack) => TestSpar (UserId, TeamId) createTeam = do env <- ask call $ createUserWithTeam (env ^. teBrig) (env ^. teGalley) - invite :: HasCallStack => UserId -> TeamId -> TestSpar (UserId, Email) + invite :: (HasCallStack) => UserId -> TeamId -> TestSpar (UserId, Email) invite owner teamid = do env <- ask email <- randomEmail @@ -224,7 +224,7 @@ specImportToScimFromInvitation = emailInvited = fromMaybe (error "must have email") (userEmail memberInvited) pure (memberIdInvited, emailInvited) - addSamlIdP :: HasCallStack => UserId -> TestSpar (SAML.IdPConfig User.WireIdP, SAML.SignPrivCreds) + addSamlIdP :: (HasCallStack) => UserId -> TestSpar (SAML.IdPConfig User.WireIdP, SAML.SignPrivCreds) addSamlIdP userid = do env <- ask apiVersion <- view teWireIdPAPIVersion @@ -233,7 +233,7 @@ specImportToScimFromInvitation = pure (idp, privkey) reProvisionWithScim :: - HasCallStack => + (HasCallStack) => Bool -> Maybe (SAML.IdPConfig User.WireIdP) -> TeamId -> @@ -267,7 +267,7 @@ specImportToScimFromInvitation = (SAML.IdPConfig User.WireIdP, SAML.SignPrivCreds) -> Email -> UserId -> TestSpar () + signInWithSaml :: (HasCallStack) => (SAML.IdPConfig User.WireIdP, SAML.SignPrivCreds) -> Email -> UserId -> TestSpar () signInWithSaml (idp, privCreds) email userid = do let uref = SAML.UserRef tenant subj subj = emailToSAMLNameID email @@ -276,7 +276,7 @@ specImportToScimFromInvitation = liftIO $ mbUid `shouldBe` Just userid checkCsvDownload :: - HasCallStack => + (HasCallStack) => UserId -> TeamId -> SAML.IdPConfig User.WireIdP -> @@ -333,18 +333,18 @@ findUserByEmail tok email = do [fstUser] -> pure fstUser _ -> error "expected exactly one user" -assertSparCassandraUref :: HasCallStack => (SAML.UserRef, Maybe UserId) -> TestSpar () +assertSparCassandraUref :: (HasCallStack) => (SAML.UserRef, Maybe UserId) -> TestSpar () assertSparCassandraUref (uref, urefAnswer) = do liftIO . (`shouldBe` urefAnswer) =<< runSpar (SAMLUserStore.get uref) -assertSparCassandraScim :: HasCallStack => ((TeamId, Email), Maybe UserId) -> TestSpar () +assertSparCassandraScim :: (HasCallStack) => ((TeamId, Email), Maybe UserId) -> TestSpar () assertSparCassandraScim ((teamid, email), scimAnswer) = do liftIO . (`shouldBe` scimAnswer) =<< runSpar (ScimExternalIdStore.lookup teamid email) assertBrigCassandra :: - HasCallStack => + (HasCallStack) => UserId -> SAML.UserRef -> Scim.User.User SparTag -> @@ -372,7 +372,7 @@ assertBrigCassandra uid uref usr (valemail, emailValidated) managedBy = do userManagedBy (accountUser acc) `shouldBe` managedBy userIdentity (accountUser acc) - `shouldBe` Just (SSOIdentity (UserSSOId uref) email Nothing) + `shouldBe` Just (SSOIdentity (UserSSOId uref) email) specSuspend :: SpecWith TestEnv specSuspend = do @@ -385,11 +385,11 @@ specSuspend = do member <- loginSsoUserFirstTime idp privCreds -- NOTE: once SCIM is enabled, SSO Auto-provisioning is disabled tok <- registerScimToken teamid (Just (idp ^. SAML.idpId)) - handle'@(Handle handle) <- nextHandle - runSpar $ BrigAccess.setHandle member handle' + handle <- nextHandle + runSpar $ BrigAccess.setHandle member handle unless isActive $ do runSpar $ BrigAccess.setStatus member Suspended - [user] <- listUsers tok (Just (filterBy "userName" handle)) + [user] <- listUsers tok (Just (filterBy "userName" (fromHandle handle))) lift $ (fmap Scim.unScimBool . Scim.User.active . Scim.value . Scim.thing $ user) `shouldBe` Just isActive it "pre-existing suspended users are inactive" $ do checkPreExistingUser False @@ -504,7 +504,7 @@ specCreateUser = describe "POST /Users" $ do pendingWith "factor this out of the PUT tests we already wrote." testCsvData :: - HasCallStack => + (HasCallStack) => TeamId -> UserId -> UserId -> @@ -544,7 +544,7 @@ testCsvData tid owner uid mbeid mbsaml hasissuer = do Nothing -> "" ('n', CsvExport.tExportSAMLNamedId export) `shouldBe` ('n', haveSubject) -decodeCSV :: Csv.FromNamedRecord a => LByteString -> [a] +decodeCSV :: (Csv.FromNamedRecord a) => LByteString -> [a] decodeCSV bstr = either (error "could not decode csv") (V.toList . snd) (Csv.decodeByName bstr) @@ -640,7 +640,7 @@ testCreateUserNoIdP = do scimStoredUser <- createUser tok scimUser liftIO $ (fmap Scim.unScimBool . Scim.User.active . Scim.value . Scim.thing $ scimStoredUser) `shouldBe` Just False let userid = scimUserId scimStoredUser - handle = Handle $ Scim.User.userName scimUser + handle = fromJust . parseHandle $ Scim.User.userName scimUser userName = Name . fromJust . Scim.User.displayName $ scimUser -- get account from brig, status should be PendingInvitation @@ -715,7 +715,7 @@ testCreateUserNoIdP = do where -- cloned from brig's integration tests - searchUser :: HasCallStack => BrigReq -> UserId -> Name -> Bool -> TestSpar () + searchUser :: (HasCallStack) => BrigReq -> UserId -> Name -> Bool -> TestSpar () searchUser brig searcherId searchTarget shouldSucceed = do refreshIndex brig aFewTimesAssert @@ -779,7 +779,7 @@ testCreateUserWithSamlIdP = do let uid = userId brigUser eid = Scim.User.externalId user - sml :: HasCallStack => UserSSOId + sml :: (HasCallStack) => UserSSOId sml = fromJust $ ssoIdentity =<< userIdentity brigUser in testCsvData tid owner uid eid (Just sml) True @@ -958,7 +958,7 @@ testRichInfo = do (tok, (owner, _, _)) <- registerIdPAndScimToken let -- validate response checkStoredUser :: - HasCallStack => + (HasCallStack) => Scim.UserC.StoredUser SparTag -> RichInfo -> TestSpar () @@ -967,7 +967,7 @@ testRichInfo = do `shouldBe` ScimUserExtra rinf -- validate server state after the fact probeUser :: - HasCallStack => + (HasCallStack) => UserId -> RichInfo -> TestSpar () @@ -1053,12 +1053,12 @@ testScimCreateVsUserRef = do tenant' = idp ^. SAML.idpMetadata . SAML.edIssuer createViaSamlFails idp privCreds uref' -samlUserShouldSatisfy :: HasCallStack => SAML.UserRef -> (Maybe UserId -> Bool) -> TestSpar () +samlUserShouldSatisfy :: (HasCallStack) => SAML.UserRef -> (Maybe UserId -> Bool) -> TestSpar () samlUserShouldSatisfy uref property = do muid <- getUserIdViaRef' uref liftIO $ muid `shouldSatisfy` property -createViaSamlResp :: HasCallStack => IdP -> SAML.SignPrivCreds -> SAML.UserRef -> TestSpar ResponseLBS +createViaSamlResp :: (HasCallStack) => IdP -> SAML.SignPrivCreds -> SAML.UserRef -> TestSpar ResponseLBS createViaSamlResp idp privCreds (SAML.UserRef _ subj) = do authnReq <- negotiateAuthnRequest idp let tid = idp ^. SAML.idpExtraInfo . User.team @@ -1068,14 +1068,14 @@ createViaSamlResp idp privCreds (SAML.UserRef _ subj) = do SAML.mkAuthnResponseWithSubj subj privCreds idp spmeta authnReq True submitAuthnResponse tid authnResp IdP -> SAML.SignPrivCreds -> SAML.UserRef -> TestSpar () +createViaSamlFails :: (HasCallStack) => IdP -> SAML.SignPrivCreds -> SAML.UserRef -> TestSpar () createViaSamlFails idp privCreds uref = do resp <- createViaSamlResp idp privCreds uref liftIO $ do maybe (error "no body") cs (responseBody resp) `shouldNotContain` "wire:sso:error:success" -createViaSaml :: HasCallStack => IdP -> SAML.SignPrivCreds -> SAML.UserRef -> TestSpar (Maybe UserId) +createViaSaml :: (HasCallStack) => IdP -> SAML.SignPrivCreds -> SAML.UserRef -> TestSpar (Maybe UserId) createViaSaml idp privCreds uref = do resp <- createViaSamlResp idp privCreds uref liftIO $ do @@ -1127,9 +1127,9 @@ testCreateUserTimeout = do Just inviteeCode <- call $ getInvitationCode brig tid (inInvitation inv) pure (scimStoredUser, inv, inviteeCode) - searchUser :: HasCallStack => Spar.Types.ScimToken -> Scim.User.User tag -> Email -> Bool -> TestSpar () + searchUser :: (HasCallStack) => Spar.Types.ScimToken -> Scim.User.User tag -> Email -> Bool -> TestSpar () searchUser tok scimUser email shouldSucceed = do - let handle = Handle . Scim.User.userName $ scimUser + let handle = fromJust . parseHandle . Scim.User.userName $ scimUser tryquery qry = aFewTimesAssert (length <$> listUsers tok (Just qry)) @@ -1214,7 +1214,7 @@ testFindSamlAutoProvisionedUserMigratedWithEmailInTeamWithSSO = do Just brigUser' <- runSpar $ Intra.getBrigUser Intra.NoPendingInvitations memberIdWithSSO liftIO $ userManagedBy brigUser' `shouldBe` ManagedByScim where - veidToText :: MonadError String m => ValidExternalId -> m Text + veidToText :: (MonadError String m) => ValidExternalId -> m Text veidToText veid = runValidExternalIdEither (\(SAML.UserRef _ subj) -> maybe (throwError "bad uref from brig") (pure . CI.original) $ SAML.shortShowNameID subj) @@ -1318,7 +1318,7 @@ testFindNoDeletedUsers = do liftIO $ users'' `shouldSatisfy` all ((/= userid) . scimUserId) -- | Test that users are not listed if not in the team associated with the token. -testUserListFailsWithNotFoundIfOutsideTeam :: HasCallStack => TestSpar () +testUserListFailsWithNotFoundIfOutsideTeam :: (HasCallStack) => TestSpar () testUserListFailsWithNotFoundIfOutsideTeam = do user <- randomScimUser (tokTeamA, _) <- registerIdPAndScimToken @@ -1366,7 +1366,7 @@ testGetUser = do storedUser' <- getUser tok (scimUserId storedUser) liftIO $ storedUser' `shouldBe` storedUser -shouldBeManagedBy :: HasCallStack => UserId -> ManagedBy -> TestSpar () +shouldBeManagedBy :: (HasCallStack) => UserId -> ManagedBy -> TestSpar () shouldBeManagedBy uid flag = do managedBy <- maybe (error "user not found") userManagedBy <$> runSpar (Intra.getBrigUser Intra.WithPendingInvitations uid) liftIO $ managedBy `shouldBe` flag @@ -1678,7 +1678,7 @@ testUpdateExternalId withidp = do (_owner, tid) <- call $ createUserWithTeam (env ^. teBrig) (env ^. teGalley) (,Nothing,tid) <$> registerScimToken tid Nothing - let checkUpdate :: HasCallStack => Bool -> TestSpar () + let checkUpdate :: (HasCallStack) => Bool -> TestSpar () checkUpdate hasChanged {- is externalId updated with a different value, or with itself? -} = do -- Create a user via SCIM email <- randomEmail @@ -2100,7 +2100,7 @@ specDeleteUser = do liftIO $ (brigUser, samlUser, scimUser) `shouldBe` (Nothing, Nothing, Nothing) - it "should respond with 204 on first deletion, then 404" $ do + it "should respond with 204 on deletion (also indempotently)" $ do (tok, _) <- registerIdPAndScimToken user <- randomScimUser storedUser <- createUser tok user @@ -2109,9 +2109,9 @@ specDeleteUser = do -- Expect first call to succeed deleteUser_ (Just tok) (Just uid) spar !!! const 204 === statusCode - -- Subsequent calls will return 404 eventually - aFewTimes (deleteUser_ (Just tok) (Just uid) spar) ((== 404) . statusCode) - !!! const 404 === statusCode + -- Subsequent calls will always return 204 (idempotency of deletion) + deleteUser_ (Just tok) (Just uid) spar + !!! const 204 === statusCode it "should free externalId and everything else in the scim user for re-use" $ do (tok, _) <- registerIdPAndScimToken user <- randomScimUser @@ -2133,7 +2133,7 @@ specDeleteUser = do let uid = scimUserId storedUser deleteUser_ Nothing (Just uid) spar !!! const 401 === statusCode - it "should return 404 if we provide a token for a different team" $ do + it "should always pretend to succeed, even if user exists in other team (does not leak information by diverging behavior)" $ do (tok, _) <- registerIdPAndScimToken user <- randomScimUser storedUser <- createUser tok user @@ -2141,7 +2141,9 @@ specDeleteUser = do (invalidTok, _) <- registerIdPAndScimToken spar <- view teSpar deleteUser_ (Just invalidTok) (Just uid) spar - !!! const 404 === statusCode + !!! const 204 === statusCode + getUser_ (Just tok) uid spar + !!! const 200 === statusCode it "getUser should return 404 after deleteUser" $ do user <- randomScimUser (tok, _) <- registerIdPAndScimToken @@ -2152,6 +2154,8 @@ specDeleteUser = do !!! const 204 === statusCode aFewTimes (getUser_ (Just tok) uid spar) ((== 404) . statusCode) !!! const 404 === statusCode + deleteUser_ (Just tok) (Just uid) spar + !!! const 204 === statusCode it "whether implemented or not, does *NOT EVER* respond with 5xx!" $ do env <- ask user <- randomScimUser @@ -2243,7 +2247,7 @@ specAzureQuirks = do specEmailValidation :: SpecWith TestEnv specEmailValidation = do describe "email validation" $ do - let setup :: HasCallStack => Bool -> TestSpar (UserId, Email) + let setup :: (HasCallStack) => Bool -> TestSpar (UserId, Email) setup enabled = do (tok, (_ownerid, teamid, idp)) <- registerIdPAndScimToken if enabled @@ -2321,7 +2325,7 @@ specSCIMManaged = do let Right nameid = SAML.emailNameID $ fromEmail oldEmail (_, cky) <- loginCreatedSsoUser nameid idp privCreds sessiontok <- do - let decodeToken :: HasCallStack => ResponseLBS -> ZAuth.Token ZAuth.Access + let decodeToken :: (HasCallStack) => ResponseLBS -> ZAuth.Token ZAuth.Access decodeToken r = fromMaybe (error "invalid access_token") $ do x <- responseBody r t <- x ^? key "access_token" . _String @@ -2372,7 +2376,7 @@ specSCIMManaged = do CsvExport.tExportManagedBy member @?= ManagedByScim CsvExport.tExportCreatedOn member `shouldSatisfy` isJust where - randomAlphaNum :: MonadIO m => m Text + randomAlphaNum :: (MonadIO m) => m Text randomAlphaNum = liftIO $ do nrs <- replicateM 21 (randomRIO (97, 122)) -- a-z pure (cs (map chr nrs)) diff --git a/services/spar/test-integration/Util/Activation.hs b/services/spar/test-integration/Util/Activation.hs new file mode 100644 index 00000000000..143e5adbdf5 --- /dev/null +++ b/services/spar/test-integration/Util/Activation.hs @@ -0,0 +1,47 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2024 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 Util.Activation where + +import Bilge +import Control.Lens +import Data.Aeson.Lens as Aeson +import Data.ByteString.Conversion +import qualified Data.Text.Ascii as Ascii +import Imports +import Util.Types +import Wire.API.User.Activation +import Wire.API.User.Identity + +getActivationCode :: + (MonadHttp m, MonadIO m) => + BrigReq -> + Email -> + m (Maybe (ActivationKey, ActivationCode)) +getActivationCode brig e = do + let qry = queryItem "email" . toByteString' $ e + r <- + get + ( brig + . path "/i/users/activation-code" + . qry + . expectStatus (`elem` [200, 404]) + ) + let lbs = fromMaybe "" $ responseBody r + let akey = ActivationKey . Ascii.unsafeFromText <$> (lbs ^? key "key" . _String) + let acode = ActivationCode . Ascii.unsafeFromText <$> (lbs ^? key "code" . _String) + pure $ (,) <$> akey <*> acode diff --git a/services/spar/test-integration/Util/Core.hs b/services/spar/test-integration/Util/Core.hs index b8c935955d3..a9a29c3445f 100644 --- a/services/spar/test-integration/Util/Core.hs +++ b/services/spar/test-integration/Util/Core.hs @@ -76,7 +76,6 @@ module Util.Core nextSAMLID, nextSubject, nextUserRef, - createRandomPhoneUser, zUser, zConn, ping, @@ -138,13 +137,13 @@ module Util.Core eventually, getIdPByIssuer, retryNUntil, + randomUser, ) where import Bilge hiding (getCookie, host, port) -- we use Web.Cookie instead of the http-client type import qualified Bilge import Bilge.Assert (Assertions, (!!!), ( -- would be a good place to look for code to steal. -mkEnv :: HasCallStack => IntegrationConfig -> Opts -> IO TestEnv +mkEnv :: (HasCallStack) => IntegrationConfig -> Opts -> IO TestEnv mkEnv tstOpts opts = do mgr :: Manager <- newManager defaultManagerSettings sparCtxLogger <- Log.mkLogger (samlToLevel $ saml opts ^. SAML.cfgLogLevel) (logNetStrings opts) (logFormat opts) @@ -290,11 +287,11 @@ mkEnv tstOpts opts = do tstOpts wireIdPAPIVersion -destroyEnv :: HasCallStack => TestEnv -> IO () +destroyEnv :: (HasCallStack) => TestEnv -> IO () destroyEnv _ = pure () it :: - HasCallStack => + (HasCallStack) => -- or, more generally: -- MonadIO m, Example (TestEnv -> m ()), Arg (TestEnv -> m ()) ~ TestEnv String -> @@ -303,7 +300,7 @@ it :: it msg bdy = Test.Hspec.it msg $ runReaderT bdy xit :: - HasCallStack => + (HasCallStack) => -- or, more generally: -- MonadIO m, Example (TestEnv -> m ()), Arg (TestEnv -> m ()) ~ TestEnv String -> @@ -337,7 +334,7 @@ retryNUntil n good m = (const (pure . not . good)) (const m) -aFewTimesAssert :: HasCallStack => TestSpar a -> (a -> Bool) -> TestSpar () +aFewTimesAssert :: (HasCallStack) => TestSpar a -> (a -> Bool) -> TestSpar () aFewTimesAssert action good = do result <- aFewTimes action good good result `assert` pure () @@ -351,7 +348,7 @@ aFewTimesRecover action = do (\_ -> action `runReaderT` env) -- | Duplicate of 'Spar.Intra.getBrigUser'. -getUserBrig :: HasCallStack => UserId -> TestSpar (Maybe User) +getUserBrig :: (HasCallStack) => UserId -> TestSpar (Maybe User) getUserBrig uid = do env <- ask let req = @@ -556,20 +553,20 @@ deleteUserNoWait brigreq uid = -- | See also: 'nextSAMLID', 'nextUserRef'. The names are chosed to be consistent with -- 'UUID.nextRandom'. -nextWireId :: MonadIO m => m (Id a) +nextWireId :: (MonadIO m) => m (Id a) nextWireId = Id <$> liftIO UUID.nextRandom -nextWireIdP :: MonadIO m => WireIdPAPIVersion -> m WireIdP +nextWireIdP :: (MonadIO m) => WireIdPAPIVersion -> m WireIdP nextWireIdP version = WireIdP <$> iid <*> pure (Just version) <*> pure [] <*> pure Nothing <*> idpHandle where iid = Id <$> liftIO UUID.nextRandom idpHandle = iid <&> IdPHandle . pack . show -nextSAMLID :: MonadIO m => m (ID a) +nextSAMLID :: (MonadIO m) => m (ID a) nextSAMLID = mkID . UUID.toText <$> liftIO UUID.nextRandom -nextHandle :: MonadIO m => m Handle -nextHandle = liftIO $ Handle . cs . show <$> randomRIO (0 :: Int, 13371137) +nextHandle :: (MonadIO m) => m Handle +nextHandle = liftIO $ fromJust . parseHandle . cs . show <$> randomRIO (0 :: Int, 13371137) -- | Generate a 'SAML.UserRef' subject. nextSubject :: (HasCallStack, MonadIO m) => m NameID @@ -581,33 +578,13 @@ nextSubject = liftIO $ do _ -> error "nextSubject: impossible" either (error . show) pure $ SAML.mkNameID unameId Nothing Nothing Nothing -nextUserRef :: MonadIO m => m SAML.UserRef +nextUserRef :: (MonadIO m) => m SAML.UserRef nextUserRef = liftIO $ do tenant <- UUID.toText <$> UUID.nextRandom SAML.UserRef (SAML.Issuer $ SAML.unsafeParseURI ("http://" <> tenant)) <$> nextSubject -createRandomPhoneUser :: (HasCallStack, MonadCatch m, MonadIO m, MonadHttp m) => BrigReq -> m (UserId, Phone) -createRandomPhoneUser brig_ = do - usr <- randomUser brig_ - let uid = userId usr - phn <- liftIO randomPhone - -- update phone - let phoneUpdate = RequestBodyLBS . Aeson.encode $ PhoneUpdate phn - put (brig_ . path "/self/phone" . contentJson . zUser uid . zConn "c" . body phoneUpdate) - !!! (const 202 === statusCode) - -- activate - act <- getActivationCode brig_ (Right phn) - case act of - Nothing -> liftIO . throwIO $ ErrorCall "missing activation key/code" - Just kc -> activate brig_ kc !!! const 200 === statusCode - -- check new phone - get (brig_ . path "/self" . zUser uid) !!! do - const 200 === statusCode - const (Right (Just phn)) === (fmap userPhone . responseJsonEither) - pure (uid, phn) - getTeams :: (HasCallStack, MonadHttp m, MonadIO m) => UserId -> GalleyReq -> m Galley.TeamList getTeams u gly = do r <- @@ -619,10 +596,10 @@ getTeams u gly = do ) pure $ responseJsonUnsafe r -getTeamMemberIds :: HasCallStack => UserId -> TeamId -> TestSpar [UserId] +getTeamMemberIds :: (HasCallStack) => UserId -> TeamId -> TestSpar [UserId] getTeamMemberIds usr tid = (^. Team.userId) <$$> getTeamMembers usr tid -getTeamMembers :: HasCallStack => UserId -> TeamId -> TestSpar [Member.TeamMember] +getTeamMembers :: (HasCallStack) => UserId -> TeamId -> TestSpar [Member.TeamMember] getTeamMembers usr tid = do gly <- view teGalley resp <- @@ -633,7 +610,7 @@ getTeamMembers usr tid = do Right mems = responseJsonEither resp pure $ mems ^. Team.teamMembers -promoteTeamMember :: HasCallStack => UserId -> TeamId -> UserId -> TestSpar () +promoteTeamMember :: (HasCallStack) => UserId -> TeamId -> UserId -> TestSpar () promoteTeamMember usr tid memid = do gly <- view teGalley let bdy :: NewTeamMember @@ -653,17 +630,11 @@ zAuthAccess u c = header "Z-Type" "access" . zUser u . zConn c newTeam :: Galley.BindingNewTeam newTeam = Galley.BindingNewTeam $ Galley.newNewTeam (unsafeRange "teamName") DefaultIcon -randomEmail :: MonadIO m => m Email +randomEmail :: (MonadIO m) => m Email randomEmail = do uid <- liftIO nextRandom pure $ Email ("success+" <> UUID.toText uid) "simulator.amazonses.com" -randomPhone :: MonadIO m => m Phone -randomPhone = liftIO $ do - nrs <- map show <$> replicateM 14 (randomRIO (0, 9) :: IO Int) - let phone = parsePhone . cs $ "+0" ++ concat nrs - pure $ fromMaybe (error "Invalid random phone#") phone - randomUser :: (HasCallStack, MonadCatch m, MonadIO m, MonadHttp m) => BrigReq -> m User randomUser brig_ = do n <- cs . UUID.toString <$> liftIO UUID.nextRandom @@ -708,31 +679,6 @@ defPassword = plainTextPassword6Unsafe "topsecretdefaultpassword" defCookieLabel :: CookieLabel defCookieLabel = CookieLabel "auth" -getActivationCode :: - (HasCallStack, MonadIO m, MonadHttp m) => - BrigReq -> - Either Email Phone -> - m (Maybe (ActivationKey, ActivationCode)) -getActivationCode brig_ ep = do - let qry = either (queryItem "email" . toByteString') (queryItem "phone" . toByteString') ep - r <- get $ brig_ . path "/i/users/activation-code" . qry - let lbs = fromMaybe "" $ responseBody r - let akey = ActivationKey . Ascii.unsafeFromText <$> (lbs ^? Aeson.key "key" . Aeson._String) - let acode = ActivationCode . Ascii.unsafeFromText <$> (lbs ^? Aeson.key "code" . Aeson._String) - pure $ (,) <$> akey <*> acode - -activate :: - (HasCallStack, MonadHttp m) => - BrigReq -> - ActivationPair -> - m ResponseLBS -activate brig_ (k, c) = - get $ - brig_ - . path "activate" - . queryItem "key" (toByteString' k) - . queryItem "code" (toByteString' c) - zUser :: UserId -> Request -> Request zUser = header "Z-User" . toByteString' @@ -749,7 +695,7 @@ endpointToSettings ep = Warp.settingsPort = fromIntegral $ ep ^. port } -endpointToURL :: MonadIO m => Endpoint -> Text -> m URI +endpointToURL :: (MonadIO m) => Endpoint -> Text -> m URI endpointToURL ep urlpath = either err pure url where url = parseURI' ("http://" <> urlhost <> ":" <> urlport) <&> (=/ urlpath) @@ -835,7 +781,7 @@ registerTestIdPFrom metadata mgr owner spar = do liftIO . runHttpT mgr $ do callIdpCreate apiVer spar (Just owner) metadata -getCookie :: KnownSymbol name => proxy name -> ResponseLBS -> Either String (SAML.SimpleSetCookie name) +getCookie :: (KnownSymbol name) => proxy name -> ResponseLBS -> Either String (SAML.SimpleSetCookie name) getCookie proxy rsp = do web :: Web.SetCookie <- Web.parseSetCookie @@ -856,7 +802,7 @@ hasPersistentCookieHeader rsp = do Left $ "expiration date should NOT empty: " <> show cky -tryLogin :: HasCallStack => SignPrivCreds -> IdP -> NameID -> TestSpar SAML.UserRef +tryLogin :: (HasCallStack) => SignPrivCreds -> IdP -> NameID -> TestSpar SAML.UserRef tryLogin privkey idp userSubject = do env <- ask let tid = idp ^. idpExtraInfo . team @@ -871,7 +817,7 @@ tryLogin privkey idp userSubject = do either (error . show) (pure . view userRefL) $ SAML.parseFromDocument (fromSignedAuthnResponse idpresp) -tryLoginFail :: HasCallStack => SignPrivCreds -> IdP -> NameID -> String -> TestSpar () +tryLoginFail :: (HasCallStack) => SignPrivCreds -> IdP -> NameID -> String -> TestSpar () tryLoginFail privkey idp userSubject bodyShouldContain = do env <- ask let tid = idp ^. idpExtraInfo . team @@ -969,10 +915,10 @@ loginCreatedSsoUser nameid idp privCreds = do let uid :: UserId uid = Id . fromMaybe (error "bad user field in /access response body") . UUID.fromText $ uidRaw - uidRaw :: HasCallStack => Text + uidRaw :: (HasCallStack) => Text uidRaw = accessToken ^?! Aeson.key "user" . _String - accessToken :: HasCallStack => Aeson.Value + accessToken :: (HasCallStack) => Aeson.Value accessToken = tok where tok = @@ -997,7 +943,7 @@ callAuthnReq sparreq_ idpid = assert test_parseAuthnReqResp $ do resp <- callAuthnReq' (sparreq_ . expect2xx) idpid either (err resp) pure $ parseAuthnReqResp (cs <$> responseBody resp) where - err :: forall n a. MonadIO n => ResponseLBS -> String -> n a + err :: forall n a. (MonadIO n) => ResponseLBS -> String -> n a err resp = liftIO . throwIO . ErrorCall . (<> ("; " <> show (responseBody resp))) test_parseAuthnReqResp :: Bool @@ -1009,7 +955,7 @@ test_parseAuthnReqResp = isRight tst1 parseAuthnReqResp :: forall n. - MonadError String n => + (MonadError String n) => Maybe LText -> n (URI, SAML.AuthnRequest) parseAuthnReqResp Nothing = throwError "no response body" @@ -1032,11 +978,11 @@ safeHead :: forall n a. (MonadError String n) => String -> [a] -> n a safeHead _ (a : _) = pure a safeHead msg [] = throwError $ msg <> ": []" -callAuthnReq' :: MonadHttp m => SparReq -> SAML.IdPId -> m ResponseLBS +callAuthnReq' :: (MonadHttp m) => SparReq -> SAML.IdPId -> m ResponseLBS callAuthnReq' sparreq_ idpid = do get $ sparreq_ . path (cs $ "/sso/initiate-login/" -/ SAML.idPIdToST idpid) -callAuthnReqPrecheck' :: MonadHttp m => SparReq -> SAML.IdPId -> m ResponseLBS +callAuthnReqPrecheck' :: (MonadHttp m) => SparReq -> SAML.IdPId -> m ResponseLBS callAuthnReqPrecheck' sparreq_ idpid = do head $ sparreq_ . path (cs $ "/sso/initiate-login/" -/ SAML.idPIdToST idpid) @@ -1046,7 +992,7 @@ callIdpGet sparreq_ muid idpid = do either (liftIO . throwIO . ErrorCall . show) pure $ responseJsonEither @IdP resp -callIdpGet' :: MonadHttp m => SparReq -> Maybe UserId -> SAML.IdPId -> m ResponseLBS +callIdpGet' :: (MonadHttp m) => SparReq -> Maybe UserId -> SAML.IdPId -> m ResponseLBS callIdpGet' sparreq_ muid idpid = do get $ sparreq_ . maybe id zUser muid . path (cs $ "/identity-providers/" -/ SAML.idPIdToST idpid) @@ -1055,7 +1001,7 @@ callIdpGetRaw sparreq_ muid idpid = do resp <- callIdpGetRaw' (sparreq_ . expect2xx) muid idpid maybe (liftIO . throwIO $ ErrorCall "Nothing") (pure . cs) (responseBody resp) -callIdpGetRaw' :: MonadHttp m => SparReq -> Maybe UserId -> SAML.IdPId -> m ResponseLBS +callIdpGetRaw' :: (MonadHttp m) => SparReq -> Maybe UserId -> SAML.IdPId -> m ResponseLBS callIdpGetRaw' sparreq_ muid idpid = do get $ sparreq_ . maybe id zUser muid . path (cs $ "/identity-providers/" -/ SAML.idPIdToST idpid -/ "raw") @@ -1065,7 +1011,7 @@ callIdpGetAll sparreq_ muid = do either (liftIO . throwIO . ErrorCall . show) pure $ responseJsonEither resp -callIdpGetAll' :: MonadHttp m => SparReq -> Maybe UserId -> m ResponseLBS +callIdpGetAll' :: (MonadHttp m) => SparReq -> Maybe UserId -> m ResponseLBS callIdpGetAll' sparreq_ muid = do get $ sparreq_ . maybe id zUser muid . path "/identity-providers" @@ -1098,7 +1044,7 @@ callIdpCreateRaw sparreq_ muid ctyp metadata = do either (liftIO . throwIO . ErrorCall . show) pure $ responseJsonEither @IdP resp -callIdpCreateRaw' :: MonadHttp m => SparReq -> Maybe UserId -> ByteString -> LByteString -> m ResponseLBS +callIdpCreateRaw' :: (MonadHttp m) => SparReq -> Maybe UserId -> ByteString -> LByteString -> m ResponseLBS callIdpCreateRaw' sparreq_ muid ctyp metadata = do post $ sparreq_ @@ -1169,7 +1115,7 @@ callIdpUpdate' sparreq_ muid idpid metainfo = do either (liftIO . throwIO . ErrorCall . show) pure $ responseJsonEither @IdP resp -callIdpUpdate :: MonadHttp m => SparReq -> Maybe UserId -> IdPId -> IdPMetadataInfo -> m ResponseLBS +callIdpUpdate :: (MonadHttp m) => SparReq -> Maybe UserId -> IdPId -> IdPMetadataInfo -> m ResponseLBS callIdpUpdate sparreq_ muid idpid (IdPMetadataValue metadata _) = do put $ sparreq_ @@ -1178,7 +1124,7 @@ callIdpUpdate sparreq_ muid idpid (IdPMetadataValue metadata _) = do . body (RequestBodyLBS $ cs metadata) . header "Content-Type" "application/xml" -callIdpUpdateWithHandle :: MonadHttp m => SparReq -> Maybe UserId -> IdPId -> IdPMetadataInfo -> IdPHandle -> m ResponseLBS +callIdpUpdateWithHandle :: (MonadHttp m) => SparReq -> Maybe UserId -> IdPId -> IdPMetadataInfo -> IdPHandle -> m ResponseLBS callIdpUpdateWithHandle sparreq_ muid idpid (IdPMetadataValue metadata _) idpHandle = do put $ sparreq_ @@ -1191,14 +1137,14 @@ callIdpUpdateWithHandle sparreq_ muid idpid (IdPMetadataValue metadata _) idpHan callIdpDelete :: (Functor m, MonadHttp m) => SparReq -> Maybe UserId -> SAML.IdPId -> m () callIdpDelete sparreq_ muid idpid = void $ callIdpDelete' (sparreq_ . expect2xx) muid idpid -callIdpDelete' :: MonadHttp m => SparReq -> Maybe UserId -> SAML.IdPId -> m ResponseLBS +callIdpDelete' :: (MonadHttp m) => SparReq -> Maybe UserId -> SAML.IdPId -> m ResponseLBS callIdpDelete' sparreq_ muid idpid = do delete $ sparreq_ . maybe id zUser muid . path (cs $ "/identity-providers/" -/ SAML.idPIdToST idpid) -callIdpDeletePurge' :: MonadHttp m => SparReq -> Maybe UserId -> SAML.IdPId -> m ResponseLBS +callIdpDeletePurge' :: (MonadHttp m) => SparReq -> Maybe UserId -> SAML.IdPId -> m ResponseLBS callIdpDeletePurge' sparreq_ muid idpid = do delete $ sparreq_ @@ -1206,13 +1152,13 @@ callIdpDeletePurge' sparreq_ muid idpid = do . path (cs $ "/identity-providers/" -/ SAML.idPIdToST idpid) . queryItem "purge" "true" -callGetDefaultSsoCode :: MonadHttp m => SparReq -> m ResponseLBS +callGetDefaultSsoCode :: (MonadHttp m) => SparReq -> m ResponseLBS callGetDefaultSsoCode sparreq_ = do get $ sparreq_ . path "/sso/settings/" -callSetDefaultSsoCode :: MonadHttp m => SparReq -> SAML.IdPId -> m ResponseLBS +callSetDefaultSsoCode :: (MonadHttp m) => SparReq -> SAML.IdPId -> m ResponseLBS callSetDefaultSsoCode sparreq_ ssoCode = do let settings = RequestBodyLBS . Aeson.encode $ @@ -1225,7 +1171,7 @@ callSetDefaultSsoCode sparreq_ ssoCode = do . body settings . header "Content-Type" "application/json" -callDeleteDefaultSsoCode :: MonadHttp m => SparReq -> m ResponseLBS +callDeleteDefaultSsoCode :: (MonadHttp m) => SparReq -> m ResponseLBS callDeleteDefaultSsoCode sparreq_ = do let settings = RequestBodyLBS . Aeson.encode $ @@ -1274,34 +1220,29 @@ runSparE action = do ctx <- (^. teSparEnv) <$> ask liftIO $ runSparToIO ctx action -getSsoidViaSelf :: HasCallStack => UserId -> TestSpar UserSSOId +getSsoidViaSelf :: (HasCallStack) => UserId -> TestSpar UserSSOId getSsoidViaSelf uid = maybe (error "not found") pure =<< getSsoidViaSelf' uid -getSsoidViaSelf' :: HasCallStack => UserId -> TestSpar (Maybe UserSSOId) +getSsoidViaSelf' :: (HasCallStack) => UserId -> TestSpar (Maybe UserSSOId) getSsoidViaSelf' uid = do musr <- aFewTimes (runSpar $ Intra.getBrigUser Intra.NoPendingInvitations uid) isJust - pure $ case userIdentity =<< musr of - Just (SSOIdentity ssoid _ _) -> Just ssoid - Just (FullIdentity _ _) -> Nothing - Just (EmailIdentity _) -> Nothing - Just (PhoneIdentity _) -> Nothing - Nothing -> Nothing - -getUserIdViaRef :: HasCallStack => UserRef -> TestSpar UserId + pure $ ssoIdentity =<< (userIdentity =<< musr) + +getUserIdViaRef :: (HasCallStack) => UserRef -> TestSpar UserId getUserIdViaRef uref = maybe (error "not found") pure =<< getUserIdViaRef' uref -getUserIdViaRef' :: HasCallStack => UserRef -> TestSpar (Maybe UserId) +getUserIdViaRef' :: (HasCallStack) => UserRef -> TestSpar (Maybe UserId) getUserIdViaRef' uref = do aFewTimes (runSpar $ SAMLUserStore.get uref) isJust -checkErr :: HasCallStack => Int -> Maybe TestErrorLabel -> Assertions () +checkErr :: (HasCallStack) => Int -> Maybe TestErrorLabel -> Assertions () checkErr status mlabel = do const status === statusCode case mlabel of Nothing -> pure () Just label -> const (Right label) === responseJsonEither -checkErrHspec :: HasCallStack => Int -> TestErrorLabel -> ResponseLBS -> Bool +checkErrHspec :: (HasCallStack) => Int -> TestErrorLabel -> ResponseLBS -> Bool checkErrHspec status label resp = status == statusCode resp && responseJsonEither resp == Right label -- | copied from brig integration tests @@ -1313,7 +1254,7 @@ stdInvitationRequest' :: Maybe User.Locale -> Maybe Role -> User.Email -> TeamIn stdInvitationRequest' loc role email = TeamInvitation.InvitationRequest loc role Nothing email Nothing -setRandomHandleBrig :: HasCallStack => UserId -> TestSpar () +setRandomHandleBrig :: (HasCallStack) => UserId -> TestSpar () setRandomHandleBrig uid = do env <- ask call (changeHandleBrig (env ^. teBrig) uid =<< liftIO randomHandle) @@ -1373,10 +1314,10 @@ checkChangeRoleOfTeamMember tid adminId targetId = forM_ [minBound ..] $ \role - [member'] <- filter ((== targetId) . (^. Member.userId)) <$> getTeamMembers adminId tid liftIO $ (member' ^. Member.permissions . to Member.permissionsRole) `shouldBe` Just role -eventually :: HasCallStack => TestSpar a -> TestSpar a +eventually :: (HasCallStack) => TestSpar a -> TestSpar a eventually = recoverAll (limitRetries 3 <> exponentialBackoff 100000) . const -getIdPByIssuer :: HasCallStack => Issuer -> TeamId -> TestSpar (Maybe IdP) +getIdPByIssuer :: (HasCallStack) => Issuer -> TeamId -> TestSpar (Maybe IdP) getIdPByIssuer issuer tid = do idpApiVersion <- view teWireIdPAPIVersion runSpar $ case idpApiVersion of diff --git a/services/spar/test-integration/Util/Email.hs b/services/spar/test-integration/Util/Email.hs index 13c8089284a..74c564ad2bc 100644 --- a/services/spar/test-integration/Util/Email.hs +++ b/services/spar/test-integration/Util/Email.hs @@ -30,11 +30,11 @@ import Data.Aeson.Lens import Data.ByteString.Conversion import Data.Id import qualified Data.Misc as Misc -import qualified Data.Text.Ascii as Ascii import Data.Text.Encoding (encodeUtf8) import qualified Data.ZAuth.Token as ZAuth import Imports import Test.Tasty.HUnit +import Util.Activation import Util.Core import Util.Types import qualified Wire.API.Team.Feature as Feature @@ -63,7 +63,7 @@ changeEmailBrig brig usr newEmail = do Auth.PasswordLogin $ Auth.PasswordLoginData (Auth.LoginByEmail e) pw cl Nothing - login :: Auth.Login -> Auth.CookieType -> MonadHttp m => m ResponseLBS + login :: Auth.Login -> Auth.CookieType -> (MonadHttp m) => m ResponseLBS login l t = post $ brig @@ -71,10 +71,10 @@ changeEmailBrig brig usr newEmail = do . (if t == Auth.PersistentCookie then queryItem "persist" "true" else id) . json l - decodeCookie :: HasCallStack => Response a -> Bilge.Cookie + decodeCookie :: (HasCallStack) => Response a -> Bilge.Cookie decodeCookie = fromMaybe (error "missing zuid cookie") . Bilge.getCookie "zuid" - decodeToken :: HasCallStack => Response (Maybe LByteString) -> ZAuth.Token ZAuth.Access + decodeToken :: (HasCallStack) => Response (Maybe LByteString) -> ZAuth.Token ZAuth.Access decodeToken r = fromMaybe (error "invalid access_token") $ do x <- responseBody r t <- x ^? key "access_token" . _String @@ -106,9 +106,9 @@ activateEmail :: (MonadCatch m, MonadIO m, HasCallStack) => BrigReq -> Email -> - MonadHttp m => m () + (MonadHttp m) => m () activateEmail brig email = do - act <- getActivationCode brig (Left email) + act <- getActivationCode brig email case act of Nothing -> liftIO $ assertFailure "missing activation key/code" Just kc -> @@ -120,13 +120,13 @@ failActivatingEmail :: (MonadCatch m, MonadIO m, HasCallStack) => BrigReq -> Email -> - MonadHttp m => m () + (MonadHttp m) => m () failActivatingEmail brig email = do - act <- getActivationCode brig (Left email) + act <- getActivationCode brig email liftIO $ assertEqual "there should be no pending activation" act Nothing checkEmail :: - HasCallStack => + (HasCallStack) => UserId -> Maybe Email -> TestSpar () @@ -149,20 +149,7 @@ activate brig (k, c) = . queryItem "key" (toByteString' k) . queryItem "code" (toByteString' c) -getActivationCode :: - (MonadCatch m, MonadHttp m, HasCallStack) => - BrigReq -> - Either Email Phone -> - m (Maybe (ActivationKey, ActivationCode)) -getActivationCode brig ep = do - let qry = either (queryItem "email" . toByteString') (queryItem "phone" . toByteString') ep - r <- get $ brig . path "/i/users/activation-code" . qry - let lbs = fromMaybe "" $ responseBody r - let akey = ActivationKey . Ascii.unsafeFromText <$> (lbs ^? key "key" . _String) - let acode = ActivationCode . Ascii.unsafeFromText <$> (lbs ^? key "code" . _String) - pure $ (,) <$> akey <*> acode - -setSamlEmailValidation :: HasCallStack => TeamId -> Feature.FeatureStatus -> TestSpar () +setSamlEmailValidation :: (HasCallStack) => TeamId -> Feature.FeatureStatus -> TestSpar () setSamlEmailValidation tid status = do galley <- view teGalley let req = put $ galley . paths p . json (Feature.WithStatusNoLock @Feature.ValidateSAMLEmailsConfig status Feature.trivialConfig Feature.FeatureTTLUnlimited) diff --git a/services/spar/test-integration/Util/Invitation.hs b/services/spar/test-integration/Util/Invitation.hs index 7bf394177f2..8a9d0fe6490 100644 --- a/services/spar/test-integration/Util/Invitation.hs +++ b/services/spar/test-integration/Util/Invitation.hs @@ -37,12 +37,12 @@ import Util import Wire.API.Team.Invitation (Invitation (..)) import Wire.API.User -headInvitation404 :: HasCallStack => BrigReq -> Email -> Http () +headInvitation404 :: (HasCallStack) => BrigReq -> Email -> Http () headInvitation404 brig email = do Bilge.head (brig . path "/teams/invitations/by-email" . contentJson . queryItem "email" (toByteString' email)) !!! const 404 === statusCode -getInvitation :: HasCallStack => BrigReq -> Email -> Http Invitation +getInvitation :: (HasCallStack) => BrigReq -> Email -> Http Invitation getInvitation brig email = responseJsonUnsafe <$> Bilge.get @@ -70,7 +70,7 @@ getInvitationCode brig t ref = do let lbs = fromMaybe "" $ responseBody r pure $ fromByteString (maybe (error "No code?") encodeUtf8 (lbs ^? key "code" . _String)) -registerInvitation :: HasCallStack => Email -> Name -> InvitationCode -> Bool -> TestSpar () +registerInvitation :: (HasCallStack) => Email -> Name -> InvitationCode -> Bool -> TestSpar () registerInvitation email name inviteeCode shouldSucceed = do env <- ask let brig = env ^. teBrig diff --git a/services/spar/test-integration/Util/Scim.hs b/services/spar/test-integration/Util/Scim.hs index d32608f4397..40ef9884d0a 100644 --- a/services/spar/test-integration/Util/Scim.hs +++ b/services/spar/test-integration/Util/Scim.hs @@ -27,7 +27,7 @@ import Control.Lens import Control.Monad.Random import Data.ByteString.Conversion import qualified Data.ByteString.Lazy as Lazy -import Data.Handle (Handle (Handle)) +import Data.Handle (Handle, parseHandle) import Data.Id import Data.LanguageCodes (ISO639_1 (EN)) import Data.String.Conversions @@ -70,7 +70,7 @@ import Wire.API.User.Scim -- | Call 'registerTestIdP', then 'registerScimToken'. The user returned is the owner of the team; -- the IdP is registered with the team; the SCIM token can be used to manipulate the team. -registerIdPAndScimToken :: HasCallStack => TestSpar (ScimToken, (UserId, TeamId, IdP)) +registerIdPAndScimToken :: (HasCallStack) => TestSpar (ScimToken, (UserId, TeamId, IdP)) registerIdPAndScimToken = do env <- ask (owner, teamid) <- call $ createUserWithTeam (env ^. teBrig) (env ^. teGalley) @@ -81,7 +81,7 @@ registerIdPAndScimToken = do -- | Call 'registerTestIdPWithMeta', then 'registerScimToken'. The user returned is the owner of the team; -- the IdP is registered with the team; the SCIM token can be used to manipulate the team. -registerIdPAndScimTokenWithMeta :: HasCallStack => TestSpar (ScimToken, (UserId, TeamId, IdP, (IdPMetadataInfo, SAML.SignPrivCreds))) +registerIdPAndScimTokenWithMeta :: (HasCallStack) => TestSpar (ScimToken, (UserId, TeamId, IdP, (IdPMetadataInfo, SAML.SignPrivCreds))) registerIdPAndScimTokenWithMeta = do env <- ask (owner, teamid) <- call $ createUserWithTeam (env ^. teBrig) (env ^. teGalley) @@ -93,7 +93,7 @@ registerIdPAndScimTokenWithMeta = do -- -- FUTUREWORK(mangoiv): this is an integration test, it should use the -- API, and not directly manipulate the database -registerScimToken :: HasCallStack => TeamId -> Maybe IdPId -> TestSpar ScimToken +registerScimToken :: (HasCallStack) => TeamId -> Maybe IdPId -> TestSpar ScimToken registerScimToken teamid midpid = do tok <- ScimToken <$> do @@ -152,7 +152,7 @@ randomScimUserWithSubjectAndRichInfo richInfo = do ) _ -> error "randomScimUserWithSubject: impossible" pure - ( (Scim.User.empty userSchemas ("scimuser_" <> suffix) (ScimUserExtra richInfo)) + ( (Scim.User.empty @SparTag userSchemas ("scimuser_" <> suffix) (ScimUserExtra richInfo)) { Scim.User.displayName = Just ("ScimUser" <> suffix), Scim.User.externalId = Just externalId, Scim.User.emails = emails, @@ -171,33 +171,33 @@ randomScimUserWithSubjectAndRichInfo richInfo = do -- support externalIds that are not emails, and storing email addresses in `emails` in the -- scim schema. `randomScimUserWithEmail` is from a time where non-idp-authenticated users -- could only be provisioned with email as externalId. we should probably rework all that. -randomScimUserWithEmail :: MonadRandom m => m (Scim.User.User SparTag, Email) +randomScimUserWithEmail :: (MonadRandom m) => m (Scim.User.User SparTag, Email) randomScimUserWithEmail = do suffix <- cs <$> replicateM 7 (getRandomR ('0', '9')) let email = Email ("email" <> suffix) "example.com" externalId = fromEmail email pure - ( (Scim.User.empty userSchemas ("scimuser_" <> suffix) (ScimUserExtra mempty)) + ( (Scim.User.empty @SparTag userSchemas ("scimuser_" <> suffix) (ScimUserExtra mempty)) { Scim.User.displayName = Just ("ScimUser" <> suffix), Scim.User.externalId = Just externalId }, email ) -randomScimUserWithNick :: MonadRandom m => m (Scim.User.User SparTag, Text) +randomScimUserWithNick :: (MonadRandom m) => m (Scim.User.User SparTag, Text) randomScimUserWithNick = do suffix <- cs <$> replicateM 7 (getRandomR ('0', '9')) let nick = "nick" <> suffix externalId = nick pure - ( (Scim.User.empty userSchemas ("scimuser_" <> suffix) (ScimUserExtra mempty)) + ( (Scim.User.empty @SparTag userSchemas ("scimuser_" <> suffix) (ScimUserExtra mempty)) { Scim.User.displayName = Just ("ScimUser" <> suffix), Scim.User.externalId = Just externalId }, nick ) -randomScimEmail :: MonadRandom m => m Email.Email +randomScimEmail :: (MonadRandom m) => m Email.Email randomScimEmail = do let typ :: Maybe Text = Nothing primary :: Maybe Scim.ScimBool = Nothing -- TODO: where should we catch users with more than one @@ -208,7 +208,7 @@ randomScimEmail = do pure . Email.EmailAddress2 $ Email.unsafeEmailAddress localpart domainpart pure Email.Email {..} -randomScimPhone :: MonadRandom m => m Phone.Phone +randomScimPhone :: (MonadRandom m) => m Phone.Phone randomScimPhone = do let typ :: Maybe Text = Nothing value :: Maybe Text <- do @@ -222,7 +222,7 @@ randomScimPhone = do -- API wrappers createUser' :: - HasCallStack => + (HasCallStack) => ScimToken -> Scim.User.User SparTag -> TestSpar ResponseLBS @@ -235,7 +235,7 @@ createUser' tok user = do -- | Create a user. createUser :: - HasCallStack => + (HasCallStack) => ScimToken -> Scim.User.User SparTag -> TestSpar (Scim.StoredUser SparTag) @@ -244,7 +244,7 @@ createUser tok user = do pure (responseJsonUnsafe r) updateUser' :: - HasCallStack => + (HasCallStack) => ScimToken -> UserId -> Scim.User.User SparTag -> @@ -255,7 +255,7 @@ updateUser' tok userid user = do -- | Update a user. updateUser :: - HasCallStack => + (HasCallStack) => ScimToken -> UserId -> Scim.User.User SparTag -> @@ -266,7 +266,7 @@ updateUser tok userid user = do -- | Patch a user patchUser :: - HasCallStack => + (HasCallStack) => ScimToken -> UserId -> Scim.PatchOp.PatchOp SparTag -> @@ -277,7 +277,7 @@ patchUser tok uid patchOp = do -- | Patch a user patchUser' :: - HasCallStack => + (HasCallStack) => ScimToken -> UserId -> Scim.PatchOp.PatchOp SparTag -> @@ -288,7 +288,7 @@ patchUser' tok uid patchOp = do -- | Delete a user. deleteUser :: - HasCallStack => + (HasCallStack) => ScimToken -> UserId -> TestSpar (Scim.StoredUser SparTag) @@ -304,7 +304,7 @@ deleteUser tok userid = do -- | List all users. listUsers :: - HasCallStack => + (HasCallStack) => ScimToken -> Maybe Scim.Filter -> TestSpar [Scim.StoredUser SparTag] @@ -325,7 +325,7 @@ listUsers tok mbFilter = do -- | Get a user. getUser :: - HasCallStack => + (HasCallStack) => ScimToken -> UserId -> TestSpar (Scim.StoredUser SparTag) @@ -341,7 +341,7 @@ getUser tok userid = do -- | Create a SCIM token. createToken :: - HasCallStack => + (HasCallStack) => UserId -> CreateScimToken -> TestSpar CreateScimTokenResponse @@ -356,7 +356,7 @@ createToken zusr payload = do pure (responseJsonUnsafe r) createTokenFailsWith :: - HasCallStack => + (HasCallStack) => UserId -> CreateScimToken -> Int -> @@ -365,9 +365,10 @@ createTokenFailsWith :: createTokenFailsWith zusr payload expectedStatus expectedLabel = do env <- ask void $ - createToken_ zusr payload (env ^. teSpar) Maybe Lazy.Text @@ -375,7 +376,7 @@ errorLabel = fmap Error.label . responseJsonMaybe -- | Delete a SCIM token. deleteToken :: - HasCallStack => + (HasCallStack) => UserId -> -- | Token to delete ScimTokenId -> @@ -390,7 +391,7 @@ deleteToken zusr tokenid = do -- | List SCIM tokens. listTokens :: - HasCallStack => + (HasCallStack) => UserId -> TestSpar ScimTokenList listTokens zusr = do @@ -422,14 +423,15 @@ createUser_ auth user spar_ = do -- still some confusion here about the distinction between *validated* -- emails and *scim-provided* emails, which are two entirely -- different things. - call . post $ - ( spar_ - . paths ["scim", "v2", "Users"] - . scimAuth auth - . contentScim - . json user - . acceptScim - ) + call + . post + $ ( spar_ + . paths ["scim", "v2", "Users"] + . scimAuth auth + . contentScim + . json user + . acceptScim + ) -- | Update a user. updateUser_ :: @@ -444,26 +446,28 @@ updateUser_ :: SparReq -> TestSpar ResponseLBS updateUser_ auth muid user spar_ = do - call . put $ - ( spar_ - . paths (["scim", "v2", "Users"] <> maybeToList (toByteString' <$> muid)) - . scimAuth auth - . contentScim - . json user - . acceptScim - ) + call + . put + $ ( spar_ + . paths (["scim", "v2", "Users"] <> maybeToList (toByteString' <$> muid)) + . scimAuth auth + . contentScim + . json user + . acceptScim + ) -- | Patch a user patchUser_ :: Maybe ScimToken -> Maybe UserId -> Scim.PatchOp.PatchOp SparTag -> SparReq -> TestSpar ResponseLBS patchUser_ auth muid patchop spar_ = - call . patch $ - ( spar_ - . paths (["scim", "v2", "Users"] <> maybeToList (toByteString' <$> muid)) - . scimAuth auth - . contentScim - . json patchop - . acceptScim - ) + call + . patch + $ ( spar_ + . paths (["scim", "v2", "Users"] <> maybeToList (toByteString' <$> muid)) + . scimAuth auth + . contentScim + . json patchop + . acceptScim + ) -- | Delete a user. deleteUser_ :: @@ -475,13 +479,14 @@ deleteUser_ :: SparReq -> TestSpar ResponseLBS deleteUser_ auth uid spar_ = do - call . delete $ - ( spar_ - . paths (["scim", "v2", "Users"] <> (toByteString' <$> maybeToList uid)) - . scimAuth auth - . contentScim - . acceptScim - ) + call + . delete + $ ( spar_ + . paths (["scim", "v2", "Users"] <> (toByteString' <$> maybeToList uid)) + . scimAuth auth + . contentScim + . acceptScim + ) -- | List all users. listUsers_ :: @@ -493,18 +498,19 @@ listUsers_ :: SparReq -> TestSpar ResponseLBS listUsers_ auth mbFilter spar_ = do - call . get $ - ( spar_ - . paths ["scim", "v2", "Users"] - . queryItem' "filter" (toByteString' . Scim.renderFilter <$> mbFilter) - . scimAuth auth - . acceptScim - ) + call + . get + $ ( spar_ + . paths ["scim", "v2", "Users"] + . queryItem' "filter" (toByteString' . Scim.renderFilter <$> mbFilter) + . scimAuth auth + . acceptScim + ) filterBy :: Text -> Text -> Filter.Filter filterBy name value = Filter.FilterAttrCompare (Filter.topLevelAttrPath name) Filter.OpEq (Filter.ValString value) -filterForStoredUser :: HasCallStack => Scim.StoredUser SparTag -> Filter.Filter +filterForStoredUser :: (HasCallStack) => Scim.StoredUser SparTag -> Filter.Filter filterForStoredUser = filterBy "externalId" . fromJust . Scim.User.externalId . Scim.value . Scim.thing -- | Get one user. @@ -517,12 +523,13 @@ getUser_ :: SparReq -> TestSpar ResponseLBS getUser_ auth userid spar_ = do - call . get $ - ( spar_ - . paths ["scim", "v2", "Users", toByteString' userid] - . scimAuth auth - . acceptScim - ) + call + . get + $ ( spar_ + . paths ["scim", "v2", "Users", toByteString' userid] + . scimAuth auth + . acceptScim + ) -- | Create a SCIM token. createToken_ :: @@ -533,14 +540,15 @@ createToken_ :: SparReq -> TestSpar ResponseLBS createToken_ userid payload spar_ = do - call . post $ - ( spar_ - . paths ["scim", "auth-tokens"] - . zUser userid - . contentJson - . json payload - . acceptJson - ) + call + . post + $ ( spar_ + . paths ["scim", "auth-tokens"] + . zUser userid + . contentJson + . json payload + . acceptJson + ) -- | Delete a SCIM token. deleteToken_ :: @@ -552,12 +560,13 @@ deleteToken_ :: SparReq -> TestSpar ResponseLBS deleteToken_ userid tokenid spar_ = do - call . delete $ - ( spar_ - . paths ["scim", "auth-tokens"] - . queryItem "id" (toByteString' tokenid) - . zUser userid - ) + call + . delete + $ ( spar_ + . paths ["scim", "auth-tokens"] + . queryItem "id" (toByteString' tokenid) + . zUser userid + ) -- | List SCIM tokens. listTokens_ :: @@ -567,11 +576,12 @@ listTokens_ :: SparReq -> TestSpar ResponseLBS listTokens_ userid spar_ = do - call . get $ - ( spar_ - . paths ["scim", "auth-tokens"] - . zUser userid - ) + call + . get + $ ( spar_ + . paths ["scim", "auth-tokens"] + . zUser userid + ) ---------------------------------------------------------------------------- -- Utilities @@ -646,7 +656,7 @@ _wrappedStoredUserToWrappedUser f = f . WrappedScimUser . Scim.value . Scim.thin instance IsUser (WrappedScimUser SparTag) where maybeUserId = Nothing - maybeHandle = Just (Just . Handle . Scim.User.userName . fromWrappedScimUser) + maybeHandle = Just (parseHandle . Scim.User.userName . fromWrappedScimUser) maybeName = Just (fmap Name . Scim.User.displayName . fromWrappedScimUser) maybeTenant = Nothing maybeSubject = Nothing @@ -706,7 +716,7 @@ userShouldMatch u1 u2 = liftIO $ do check :: (Eq a, Show a) => Text -> -- field name - (forall u. IsUser u => Maybe (u -> a)) -> -- accessor (polymorphic) + (forall u. (IsUser u) => Maybe (u -> a)) -> -- accessor (polymorphic) IO () check field getField = case (getField <&> ($ u1), getField <&> ($ u2)) of (Just a1, Just a2) -> (field, a1) `shouldBe` (field, a2) @@ -716,7 +726,7 @@ userShouldMatch u1 u2 = liftIO $ do -- floor. This function calls the spar functions that do that. This allows us to express -- what we expect a user that comes back from spar to look like in terms of what it looked -- like when we sent it there. -whatSparReturnsFor :: HasCallStack => IdP -> Int -> Scim.User.User SparTag -> TestSpar (Either String (Scim.User.User SparTag)) +whatSparReturnsFor :: (HasCallStack) => IdP -> Int -> Scim.User.User SparTag -> TestSpar (Either String (Scim.User.User SparTag)) whatSparReturnsFor idp richInfoSizeLimit user = do eitherValidatedScimUser <- runSpar $ runError @Scim.ScimError $ validateScimUser' "whatSparReturnsFor" (Just idp) richInfoSizeLimit user pure $ case eitherValidatedScimUser of @@ -740,21 +750,23 @@ scimifyBrigUserHack :: User -> Email -> User scimifyBrigUserHack usr email = usr { userManagedBy = ManagedByScim, - userIdentity = Just (SSOIdentity (UserScimExternalId (fromEmail email)) (Just email) Nothing) + userIdentity = Just (SSOIdentity (UserScimExternalId (fromEmail email)) (Just email)) } getDefaultUserLocale :: TestSpar Locale getDefaultUserLocale = do env <- ask LocaleUpdate defLocale <- - fmap responseJsonUnsafe . call . get $ - ( (env ^. teBrig) - . path "/i/users/locale" - . expect2xx - ) + fmap responseJsonUnsafe + . call + . get + $ ( (env ^. teBrig) + . path "/i/users/locale" + . expect2xx + ) pure defLocale -checkTeamMembersRole :: HasCallStack => TeamId -> UserId -> UserId -> Role -> TestSpar () +checkTeamMembersRole :: (HasCallStack) => TeamId -> UserId -> UserId -> Role -> TestSpar () checkTeamMembersRole tid owner uid role = do [member] <- filter ((== uid) . (^. Member.userId)) <$> getTeamMembers owner tid liftIO $ (member ^. Member.permissions . to Member.permissionsRole) `shouldBe` Just role diff --git a/services/spar/test/Arbitrary.hs b/services/spar/test/Arbitrary.hs index bac29a685da..bc7cc42d9c2 100644 --- a/services/spar/test/Arbitrary.hs +++ b/services/spar/test/Arbitrary.hs @@ -110,7 +110,7 @@ instance CoArbitrary Time instance CoArbitrary Issuer where coarbitrary (Issuer ur) = coarbitrary $ show ur -instance CoArbitrary a => CoArbitrary (URIRef a) where +instance (CoArbitrary a) => CoArbitrary (URIRef a) where coarbitrary = coarbitrary . show instance CoArbitrary (IdPConfig WireIdP) diff --git a/services/spar/test/Test/Spar/DataSpec.hs b/services/spar/test/Test/Spar/DataSpec.hs index 61af59b7c9a..bf7c9b03dcf 100644 --- a/services/spar/test/Test/Spar/DataSpec.hs +++ b/services/spar/test/Test/Spar/DataSpec.hs @@ -37,16 +37,16 @@ spec = do addTime (ttlToNominalDiffTime $ TTL 3) (Time $ parsetm "1924-07-14T08:30:00Z") `shouldBe` Time (parsetm "1924-07-14T08:30:03Z") -check :: HasCallStack => Int -> Env -> String -> Either TTLError (TTL "authresp") -> Spec +check :: (HasCallStack) => Int -> Env -> String -> Either TTLError (TTL "authresp") -> Spec check testnumber env (parsetm -> endOfLife) expectttl = it (show testnumber) $ mkTTLAssertions env endOfLife `shouldBe` expectttl -parsetm :: HasCallStack => String -> UTCTime +parsetm :: (HasCallStack) => String -> UTCTime parsetm = fromJust . parseTimeM True defaultTimeLocale "%Y-%m-%dT%H:%M:%S%QZ" {-# HLINT ignore "Eta reduce" #-} -- For clarity -mkDataEnv :: HasCallStack => String -> TTL "authresp" -> Env +mkDataEnv :: (HasCallStack) => String -> TTL "authresp" -> Env mkDataEnv now maxttl = Env (parsetm now) diff --git a/services/spar/test/Test/Spar/Scim/UserSpec.hs b/services/spar/test/Test/Spar/Scim/UserSpec.hs index 16dc0636a12..3cbd3208669 100644 --- a/services/spar/test/Test/Spar/Scim/UserSpec.hs +++ b/services/spar/test/Test/Spar/Scim/UserSpec.hs @@ -37,22 +37,22 @@ spec = describe "deleteScimUser" $ do (mockBrig (withActiveUser acc) AccountDeleted) (deleteUserAndAssertDeletionInSpar acc tokenInfo) r `shouldBe` Right () - it "returns an error when the account was deleted before" $ do + it "is idempotent" $ do tokenInfo <- generate arbitrary acc <- someActiveUser tokenInfo r <- interpretWithBrigAccessMock (mockBrig (withActiveUser acc) AccountAlreadyDeleted) (deleteUserAndAssertDeletionInSpar acc tokenInfo) - r `shouldBe` Left (notFound "user" ((idToText . userId . accountUser) acc)) - it "returns an error when there never was an account" $ do + r `shouldBe` Right () + it "works if there never was an account" $ do uid <- generate arbitrary tokenInfo <- generate arbitrary r <- interpretWithBrigAccessMock (mockBrig (const Nothing) NoUser) (runExceptT $ deleteScimUser tokenInfo uid) - r `shouldBe` Left (notFound "user" (idToText uid)) + r `shouldBe` Right () it "returns no error when there was a partially deleted account" $ do uid <- generate arbitrary tokenInfo <- generate arbitrary @@ -64,16 +64,17 @@ spec = describe "deleteScimUser" $ do deleteUserAndAssertDeletionInSpar :: forall (r :: EffectRow). - Members - '[ Logger (Msg -> Msg), - BrigAccess, - ScimExternalIdStore.ScimExternalIdStore, - ScimUserTimesStore, - SAMLUserStore, - IdPConfigStore, - Embed IO - ] - r => + ( Members + '[ Logger (Msg -> Msg), + BrigAccess, + ScimExternalIdStore.ScimExternalIdStore, + ScimUserTimesStore, + SAMLUserStore, + IdPConfigStore, + Embed IO + ] + r + ) => UserAccount -> ScimTokenInfo -> Sem r (Either ScimError ()) @@ -113,12 +114,12 @@ interpretWithBrigAccessMock mock = . ignoringState idPToMem . mock -ignoringState :: Functor f => (a -> f (c, b)) -> a -> f b +ignoringState :: (Functor f) => (a -> f (c, b)) -> a -> f b ignoringState f = fmap snd . f mockBrig :: forall (r :: EffectRow) a. - Member (Embed IO) r => + (Member (Embed IO) r) => (UserId -> Maybe UserAccount) -> DeleteUserResult -> Sem (BrigAccess ': r) a -> diff --git a/tools/db/assets/src/Assets/Lib.hs b/tools/db/assets/src/Assets/Lib.hs index 036b31ae6b8..9a91599ef11 100644 --- a/tools/db/assets/src/Assets/Lib.hs +++ b/tools/db/assets/src/Assets/Lib.hs @@ -151,7 +151,7 @@ instance Cql AssetText where 0 -> pure $! ImageAssetText k _ -> Left $ "unexpected user asset type: " ++ show t where - required :: Cql r => Text -> Either String r + required :: (Cql r) => Text -> Either String r required f = maybe (Left ("Asset: Missing required field '" ++ show f ++ "'")) diff --git a/tools/db/auto-whitelist/auto-whitelist.cabal b/tools/db/auto-whitelist/auto-whitelist.cabal index 09239aa43c9..487ccc7ff6d 100644 --- a/tools/db/auto-whitelist/auto-whitelist.cabal +++ b/tools/db/auto-whitelist/auto-whitelist.cabal @@ -62,8 +62,8 @@ executable auto-whitelist ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path - -funbox-strict-fields -threaded -with-rtsopts=-N -with-rtsopts=-T - -rtsopts -Wredundant-constraints -Wunused-packages + -funbox-strict-fields -threaded "-with-rtsopts=-N -T" -rtsopts + -Wredundant-constraints -Wunused-packages build-depends: base diff --git a/tools/db/find-undead/find-undead.cabal b/tools/db/find-undead/find-undead.cabal index 4d80aabac45..16a7035e1ed 100644 --- a/tools/db/find-undead/find-undead.cabal +++ b/tools/db/find-undead/find-undead.cabal @@ -62,8 +62,8 @@ executable find-undead ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path - -funbox-strict-fields -threaded -with-rtsopts=-N -with-rtsopts=-T - -rtsopts -Wredundant-constraints -Wunused-packages + -funbox-strict-fields -threaded "-with-rtsopts=-N -T" -rtsopts + -Wredundant-constraints -Wunused-packages build-depends: aeson diff --git a/tools/db/find-undead/src/Work.hs b/tools/db/find-undead/src/Work.hs index 4803e7dfb24..87fceb70e64 100644 --- a/tools/db/find-undead/src/Work.hs +++ b/tools/db/find-undead/src/Work.hs @@ -55,7 +55,7 @@ runCommand l cas es indexStr mappingStr = do ---------------------------------------------------------------------------- -- Queries -logProgress :: MonadIO m => Logger -> [UUID] -> m () +logProgress :: (MonadIO m) => Logger -> [UUID] -> m () logProgress l uuids = Log.info l $ Log.field "Progress" (show $ length uuids) logDifference :: Logger -> ([UUID], [(UUID, Maybe AccountStatus, Maybe (Writetime ()))]) -> ES.BH IO () @@ -67,7 +67,7 @@ logDifference l (uuidsFromES, fromCas) = do mapM_ (logUUID l "Deleted") deletedUuidsFromCas mapM_ (logUUID l "Extra" . (,Nothing,Nothing)) extraUuids -logUUID :: MonadIO m => Logger -> ByteString -> (UUID, Maybe AccountStatus, Maybe (Writetime ())) -> m () +logUUID :: (MonadIO m) => Logger -> ByteString -> (UUID, Maybe AccountStatus, Maybe (Writetime ())) -> m () logUUID l f (uuid, _, time) = Log.info l $ Log.msg f @@ -101,7 +101,7 @@ esSearch = (ES.mkSearch Nothing (Just esFilter)) {ES.size = ES.Size chunkSize} extractHits :: ES.SearchResult User -> [User] extractHits = mapMaybe ES.hitSource . ES.hits . ES.searchHits -extractScrollId :: MonadThrow m => ES.SearchResult a -> m ES.ScrollId +extractScrollId :: (MonadThrow m) => ES.SearchResult a -> m ES.ScrollId extractScrollId res = maybe (throwM NoScrollId) pure (ES.scrollId res) usersInCassandra :: [UUID] -> Client [(UUID, Maybe AccountStatus, Maybe (Writetime ()))] diff --git a/tools/db/inconsistencies/default.nix b/tools/db/inconsistencies/default.nix index 2ad3a98e5eb..9e1586be4a8 100644 --- a/tools/db/inconsistencies/default.nix +++ b/tools/db/inconsistencies/default.nix @@ -5,7 +5,6 @@ { mkDerivation , aeson , base -, brig , bytestring , cassandra-util , conduit @@ -20,6 +19,7 @@ , types-common , unliftio , wire-api +, wire-subsystems }: mkDerivation { pname = "inconsistencies"; @@ -30,7 +30,6 @@ mkDerivation { executableHaskellDepends = [ aeson base - brig bytestring cassandra-util conduit @@ -43,6 +42,7 @@ mkDerivation { types-common unliftio wire-api + wire-subsystems ]; description = "Find handles which belong to deleted users"; license = lib.licenses.agpl3Only; diff --git a/tools/db/inconsistencies/inconsistencies.cabal b/tools/db/inconsistencies/inconsistencies.cabal index 0c0a76d1a4d..4cc38f77c90 100644 --- a/tools/db/inconsistencies/inconsistencies.cabal +++ b/tools/db/inconsistencies/inconsistencies.cabal @@ -65,13 +65,12 @@ executable inconsistencies ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path - -funbox-strict-fields -threaded -with-rtsopts=-N -with-rtsopts=-T - -rtsopts -Wredundant-constraints -Wunused-packages + -funbox-strict-fields -threaded "-with-rtsopts=-N -T" -rtsopts + -Wredundant-constraints -Wunused-packages build-depends: aeson , base - , brig , bytestring , cassandra-util , conduit @@ -84,5 +83,6 @@ executable inconsistencies , types-common , unliftio , wire-api + , wire-subsystems default-language: GHC2021 diff --git a/tools/db/inconsistencies/src/DanglingHandles.hs b/tools/db/inconsistencies/src/DanglingHandles.hs index c6c7571169d..5538274a9b2 100644 --- a/tools/db/inconsistencies/src/DanglingHandles.hs +++ b/tools/db/inconsistencies/src/DanglingHandles.hs @@ -93,7 +93,7 @@ data WithWritetime a = WithWritetime } deriving (Generic) -instance Aeson.ToJSON a => Aeson.ToJSON (WithWritetime a) +instance (Aeson.ToJSON a) => Aeson.ToJSON (WithWritetime a) ---------------------------------------------------------------------------- -- Queries diff --git a/tools/db/inconsistencies/src/DanglingUserKeys.hs b/tools/db/inconsistencies/src/DanglingUserKeys.hs index 59f914fc686..3d27d4c208c 100644 --- a/tools/db/inconsistencies/src/DanglingUserKeys.hs +++ b/tools/db/inconsistencies/src/DanglingUserKeys.hs @@ -22,9 +22,6 @@ module DanglingUserKeys where -import Brig.Data.UserKey -import Brig.Email (EmailKey (..), mkEmailKey) -import Brig.Phone (PhoneKey (..), mkPhoneKey) import Cassandra import Cassandra.Util import Conduit @@ -39,7 +36,8 @@ import Imports import System.Logger import System.Logger qualified as Log import UnliftIO.Async -import Wire.API.User hiding (userEmail, userPhone) +import Wire.API.User hiding (userEmail) +import Wire.UserKeyStore runCommand :: Logger -> ClientState -> FilePath -> IO () runCommand l brig inconsistenciesFile = do @@ -79,7 +77,7 @@ pageSize = 1000 data Inconsistency = Inconsistency { -- | Key in the user_keys table - key :: UserKey, + key :: EmailKey, userId :: UserId, time :: Writetime UserId, status :: Maybe (WithWritetime AccountStatus), @@ -97,27 +95,27 @@ data WithWritetime a = WithWritetime } deriving (Generic) -instance Aeson.ToJSON a => Aeson.ToJSON (WithWritetime a) +instance (Aeson.ToJSON a) => Aeson.ToJSON (WithWritetime a) ---------------------------------------------------------------------------- -- Queries -getKey :: UserKey -> Client (Maybe (UserId, Writetime UserId)) +getKey :: EmailKey -> Client (Maybe (UserId, Writetime UserId)) getKey key = retry x5 $ query1 cql (params LocalQuorum (Identity key)) where - cql :: PrepQuery R (Identity UserKey) (UserId, Writetime UserId) + cql :: PrepQuery R (Identity EmailKey) (UserId, Writetime UserId) cql = "SELECT user, writetime(user) from user_keys where key = ?" -getKeys :: ConduitM () [(UserKey, UserId, Writetime UserId)] Client () +getKeys :: ConduitM () [(EmailKey, UserId, Writetime UserId)] Client () getKeys = paginateC cql (paramsP LocalQuorum () pageSize) x5 where - cql :: PrepQuery R () (UserKey, UserId, Writetime UserId) + cql :: PrepQuery R () (EmailKey, UserId, Writetime UserId) cql = "SELECT key, user, writetime(user) from user_keys" -parseKey :: Text -> Maybe UserKey -parseKey t = (userEmailKey <$> parseEmail t) <|> (userPhoneKey <$> parsePhone t) +parseKey :: Text -> Maybe EmailKey +parseKey t = mkEmailKey <$> parseEmail t -instance Cql UserKey where +instance Cql EmailKey where ctype = Tagged TextColumn fromCql (CqlText t) = @@ -127,10 +125,10 @@ instance Cql UserKey where (parseKey t) fromCql _ = Left "userkey: expected text" - toCql k = toCql $ keyText k + toCql k = toCql $ emailKeyUniq k -instance Aeson.ToJSON UserKey where - toJSON = Aeson.toJSON . keyText +instance Aeson.ToJSON EmailKey where + toJSON = Aeson.toJSON . emailKeyUniq type UserDetailsRow = (Maybe AccountStatus, Maybe (Writetime AccountStatus), Maybe Email, Maybe (Writetime Email), Maybe Phone, Maybe (Writetime Phone)) @@ -140,28 +138,28 @@ getUserDetails uid = retry x5 $ query1 cql (params LocalQuorum (Identity uid)) cql :: PrepQuery R (Identity UserId) UserDetailsRow cql = "SELECT status, writetime(status), email, writetime(email), phone, writetime(phone) from user where id = ?" -checkKey :: Logger -> ClientState -> UserKey -> Bool -> IO (Maybe Inconsistency) +checkKey :: Logger -> ClientState -> EmailKey -> Bool -> IO (Maybe Inconsistency) checkKey l brig key repairData = do mUser <- runClient brig $ getKey key case mUser of Nothing -> do - Log.warn l (Log.msg (Log.val "No user found for key") . Log.field "key" (keyText key)) + Log.warn l (Log.msg (Log.val "No user found for key") . Log.field "key" (emailKeyUniq key)) pure Nothing Just (uid, writeTime) -> checkUser l brig key uid writeTime repairData -- mostly copied from Brig to not need a Brig Env/ReaderT -freeUserKey :: Logger -> UserKey -> Client () -freeUserKey l k = do - Log.info l $ Log.msg (Log.val "Freeing key") . Log.field "key" (keyText k) - retry x5 $ write keyDelete (params LocalQuorum (Identity $ keyText k)) +freeEmailKey :: Logger -> EmailKey -> Client () +freeEmailKey l k = do + Log.info l $ Log.msg (Log.val "Freeing key") . Log.field "key" (emailKeyUniq k) + retry x5 $ write keyDelete (params LocalQuorum (Identity $ emailKeyUniq k)) where keyDelete :: PrepQuery W (Identity Text) () keyDelete = "DELETE FROM user_keys WHERE key = ?" -insertKey :: Logger -> UserId -> UserKey -> Client () +insertKey :: Logger -> UserId -> EmailKey -> Client () insertKey l u k = do - Log.info l $ Log.msg (Log.val "Inserting key") . Log.field "key" (keyText k) . Log.field "userId" (show u) - retry x5 $ write keyInsert (params LocalQuorum (keyText k, u)) + Log.info l $ Log.msg (Log.val "Inserting key") . Log.field "key" (emailKeyUniq k) . Log.field "userId" (show u) + retry x5 $ write keyInsert (params LocalQuorum (emailKeyUniq k, u)) where keyInsert :: PrepQuery W (Text, UserId) () keyInsert = "INSERT INTO user_keys (key, user) VALUES (?, ?)" @@ -174,7 +172,7 @@ insertKey l u k = do -- 3.b. this user's email, when searched for points to another user -> do nothing; log this issue -- 3.c this user's email, when searched for does not exist in user_keys. Do nothing, let this be handled by the other module EmailLessUsers.hs -- 4. user has an email in user_keys but no email inside user table -> do nothing. How to resolve? -checkUser :: Logger -> ClientState -> UserKey -> UserId -> Writetime UserId -> Bool -> IO (Maybe Inconsistency) +checkUser :: Logger -> ClientState -> EmailKey -> UserId -> Writetime UserId -> Bool -> IO (Maybe Inconsistency) checkUser l brig key uid time repairData = do maybeDetails <- runClient brig $ getUserDetails uid case maybeDetails of @@ -185,7 +183,7 @@ checkUser l brig key uid time repairData = do inconsistencyCase = "2." when repairData $ -- case 2. runClient brig $ - freeUserKey l key + freeEmailKey l key pure . Just $ Inconsistency {userId = uid, ..} Just (mStatus, mStatusWriteTime, mEmail, mEmailWriteTime, mPhone, mPhoneWriteTime) -> do let status = WithWritetime <$> mStatus <*> mStatusWriteTime @@ -196,12 +194,11 @@ checkUser l brig key uid time repairData = do Just Deleted -> True _ -> False compareEmail e = (emailKeyUniq . mkEmailKey <$> mEmail) /= Just (fromEmail e) - comparePhone p = (phoneKeyUniq . mkPhoneKey <$> mPhone) /= Just (fromPhone p) - keyError = foldKey compareEmail comparePhone key + keyError = compareEmail (emailKeyOrig key) if statusError then do let inconsistencyCase = "1." - when repairData $ runClient brig (freeUserKey l key) + when repairData $ runClient brig (freeEmailKey l key) pure . Just $ Inconsistency {userId = uid, ..} else if keyError @@ -212,17 +209,17 @@ checkUser l brig key uid time repairData = do let inconsistencyCase = "4." pure . Just $ Inconsistency {userId = uid, ..} Just email -> do - validKeysEntry <- runClient brig $ getKey (userEmailKey email) + validKeysEntry <- runClient brig $ getKey (mkEmailKey email) case validKeysEntry of Just (keyEntryUserId, _) -> if keyEntryUserId == uid then do -- there is a valid matching user_key entry for a user in the user table; just *also* an extra entry that can be cleaned up (case 3.a.) - Log.warn l (Log.msg (Log.val "Subcase 3a: entry can be repaired by removing entry") . Log.field "key" (keyText key)) + Log.warn l (Log.msg (Log.val "Subcase 3a: entry can be repaired by removing entry") . Log.field "key" (emailKeyUniq key)) let inconsistencyCase = "3.a." when repairData $ runClient brig $ - freeUserKey l key + freeEmailKey l key pure . Just $ Inconsistency {userId = uid, ..} else do let inconsistencyCase = "3.b." diff --git a/tools/db/inconsistencies/src/EmailLessUsers.hs b/tools/db/inconsistencies/src/EmailLessUsers.hs index 7aa277d7167..021a5064ae3 100644 --- a/tools/db/inconsistencies/src/EmailLessUsers.hs +++ b/tools/db/inconsistencies/src/EmailLessUsers.hs @@ -21,8 +21,6 @@ module EmailLessUsers where -import Brig.Data.UserKey -import Brig.Email import Cassandra import Cassandra.Util import Conduit @@ -40,6 +38,7 @@ import System.Logger import System.Logger qualified as Log import UnliftIO.Async import Wire.API.User hiding (userEmail) +import Wire.UserKeyStore runCommand :: Logger -> ClientState -> FilePath -> IO () runCommand l brig inconsistenciesFile = do @@ -96,7 +95,7 @@ data WithWritetime a = WithWritetime } deriving (Generic) -instance Aeson.ToJSON a => Aeson.ToJSON (WithWritetime a) +instance (Aeson.ToJSON a) => Aeson.ToJSON (WithWritetime a) ---------------------------------------------------------------------------- -- Queries @@ -117,7 +116,7 @@ type UserDetailsRow = (UserId, Maybe AccountStatus, Maybe (Writetime AccountStat insertMissingEmail :: Logger -> ClientState -> Email -> UserId -> IO () insertMissingEmail l brig email uid = do - runClient brig $ K.insertKey l uid (userEmailKey email) + runClient brig $ K.insertKey l uid (mkEmailKey email) userWithEmailAndStatus :: UserDetailsRow -> Maybe (UserId, AccountStatus, Writetime AccountStatus, Email, Writetime Email) userWithEmailAndStatus (uid, mStatus, mStatusWritetime, mEmail, mEmailWritetime, activated) = do @@ -138,7 +137,7 @@ checkUser :: Logger -> ClientState -> Bool -> (UserId, AccountStatus, Writetime checkUser l brig repairData (uid, statusValue, statusWritetime, userEmailValue, userEmailWriteTime) = do let status = WithWritetime statusValue statusWritetime userEmail = WithWritetime userEmailValue userEmailWriteTime - mKeyDetails <- runClient brig $ K.getKey (userEmailKey userEmailValue) + mKeyDetails <- runClient brig $ K.getKey (mkEmailKey userEmailValue) case mKeyDetails of Nothing -> do let emailKey = Nothing diff --git a/tools/db/inconsistencies/src/HandleLessUsers.hs b/tools/db/inconsistencies/src/HandleLessUsers.hs index cec0d5f6948..994b5d69957 100644 --- a/tools/db/inconsistencies/src/HandleLessUsers.hs +++ b/tools/db/inconsistencies/src/HandleLessUsers.hs @@ -72,7 +72,7 @@ data WithWritetime a = WithWritetime } deriving (Generic) -instance Aeson.ToJSON a => Aeson.ToJSON (WithWritetime a) +instance (Aeson.ToJSON a) => Aeson.ToJSON (WithWritetime a) ---------------------------------------------------------------------------- -- Queries diff --git a/tools/db/migrate-sso-feature-flag/migrate-sso-feature-flag.cabal b/tools/db/migrate-sso-feature-flag/migrate-sso-feature-flag.cabal index aca192a3aa1..b8b23b523b9 100644 --- a/tools/db/migrate-sso-feature-flag/migrate-sso-feature-flag.cabal +++ b/tools/db/migrate-sso-feature-flag/migrate-sso-feature-flag.cabal @@ -64,8 +64,8 @@ executable migrate-sso-feature-flag ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path - -funbox-strict-fields -threaded -with-rtsopts=-N -with-rtsopts=-T - -rtsopts -Wredundant-constraints -Wunused-packages + -funbox-strict-fields -threaded "-with-rtsopts=-N -T" -rtsopts + -Wredundant-constraints -Wunused-packages build-depends: base diff --git a/tools/db/migrate-sso-feature-flag/src/Work.hs b/tools/db/migrate-sso-feature-flag/src/Work.hs index 36f5d5aba9b..8751c90c084 100644 --- a/tools/db/migrate-sso-feature-flag/src/Work.hs +++ b/tools/db/migrate-sso-feature-flag/src/Work.hs @@ -59,7 +59,7 @@ getSsoTeams = paginateC cql (paramsP LocalQuorum () pageSize) x5 writeSsoFlags :: [TeamId] -> Client () writeSsoFlags = mapM_ (`setSSOTeamConfig` FeatureStatusEnabled) where - setSSOTeamConfig :: MonadClient m => TeamId -> FeatureStatus -> m () + setSSOTeamConfig :: (MonadClient m) => TeamId -> FeatureStatus -> m () setSSOTeamConfig tid ssoTeamConfigStatus = do retry x5 $ write updateSSOTeamConfig (params LocalQuorum (ssoTeamConfigStatus, tid)) diff --git a/tools/db/move-team/move-team.cabal b/tools/db/move-team/move-team.cabal index ba3abc5a288..c2a033e20db 100644 --- a/tools/db/move-team/move-team.cabal +++ b/tools/db/move-team/move-team.cabal @@ -65,8 +65,8 @@ library ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path - -funbox-strict-fields -threaded -with-rtsopts=-N -with-rtsopts=-T - -rtsopts -Wredundant-constraints -Wunused-packages + -funbox-strict-fields -threaded "-with-rtsopts=-N -T" -rtsopts + -Wredundant-constraints -Wunused-packages build-depends: aeson @@ -144,8 +144,8 @@ executable move-team ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path - -funbox-strict-fields -threaded -with-rtsopts=-N -with-rtsopts=-T - -rtsopts -Wredundant-constraints -Wunused-packages + -funbox-strict-fields -threaded "-with-rtsopts=-N -T" -rtsopts + -Wredundant-constraints -Wunused-packages build-depends: base @@ -210,8 +210,8 @@ executable move-team-generate ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path - -funbox-strict-fields -threaded -with-rtsopts=-N -with-rtsopts=-T - -rtsopts -Wredundant-constraints -Wunused-packages + -funbox-strict-fields -threaded "-with-rtsopts=-N -T" -rtsopts + -Wredundant-constraints -Wunused-packages build-depends: base diff --git a/tools/db/move-team/src/Common.hs b/tools/db/move-team/src/Common.hs index 0b7f185f4e9..26a65089649 100644 --- a/tools/db/move-team/src/Common.hs +++ b/tools/db/move-team/src/Common.hs @@ -31,11 +31,11 @@ sourceJsonLines handle = .| C.linesUnboundedAscii .| mapC (either error id . eitherDecodeStrict) -sinkJsonLines :: ToJSON a => Handle -> ConduitT [a] Void IO () +sinkJsonLines :: (ToJSON a) => Handle -> ConduitT [a] Void IO () sinkJsonLines hd = C.mapM_ (mapM_ (LBS.hPutStr hd . (<> "\n") . encode)) -- FUTUREWORK: this is very slow. Look for alterantives. Maybe `batch` queries are faster. -sinkTableRows :: Tuple a => PrepQuery W a () -> ConduitM a Void Client () +sinkTableRows :: (Tuple a) => PrepQuery W a () -> ConduitM a Void Client () sinkTableRows insertQuery = go where go = do diff --git a/tools/db/move-team/src/Options.hs b/tools/db/move-team/src/Options.hs index f5d26ed767b..9d13bf9c867 100644 --- a/tools/db/move-team/src/Options.hs +++ b/tools/db/move-team/src/Options.hs @@ -149,5 +149,5 @@ cassandraSettingsParser ks = ) ) -parseUUID :: HasCallStack => String -> UUID +parseUUID :: (HasCallStack) => String -> UUID parseUUID = fromJust . Data.UUID.fromString diff --git a/tools/db/move-team/src/Types.hs b/tools/db/move-team/src/Types.hs index 3c3cfe4d722..3f7ef7ebe36 100644 --- a/tools/db/move-team/src/Types.hs +++ b/tools/db/move-team/src/Types.hs @@ -71,10 +71,10 @@ instance Cql AssetIgnoreData where toCql _ = error "AssetIgnoreData: you should not have any data of this" fromCql _ = pure AssetIgnoreData -instance ToJSON a => ToJSON (Cassandra.Set a) where +instance (ToJSON a) => ToJSON (Cassandra.Set a) where toJSON = toJSON . Cassandra.fromSet -instance FromJSON a => FromJSON (Cassandra.Set a) where +instance (FromJSON a) => FromJSON (Cassandra.Set a) where parseJSON = fmap Cassandra.Set . parseJSON instance ToJSON Blob where diff --git a/tools/db/move-team/src/Work.hs b/tools/db/move-team/src/Work.hs index b8a75722080..e0394c808be 100644 --- a/tools/db/move-team/src/Work.hs +++ b/tools/db/move-team/src/Work.hs @@ -155,7 +155,7 @@ runFullScans env@Env {..} users = do readSparUserAll env .| mapC (filter (haveId . view _3)) -appendJsonLines :: ToJSON a => FilePath -> ConduitM () [a] IO () -> IO () +appendJsonLines :: (ToJSON a) => FilePath -> ConduitM () [a] IO () -> IO () appendJsonLines path conduit = IO.withBinaryFile path IO.AppendMode $ \outH -> runConduit $ conduit .| sinkJsonLines outH diff --git a/tools/db/phone-users/src/PhoneUsers/Lib.hs b/tools/db/phone-users/src/PhoneUsers/Lib.hs index 8c913b7a0bf..8bf816461ea 100644 --- a/tools/db/phone-users/src/PhoneUsers/Lib.hs +++ b/tools/db/phone-users/src/PhoneUsers/Lib.hs @@ -62,16 +62,16 @@ getConferenceCalling client tid = do process :: Log.Logger -> Maybe Int -> ClientState -> ClientState -> IO Result process logger limit brigClient galleyClient = - runConduit $ - readUsers brigClient - -- .| Conduit.mapM (\chunk -> SIO.hPutStr stderr "." $> chunk) - .| Conduit.concat - .| (maybe (Conduit.filter (const True)) Conduit.take limit) - .| Conduit.mapM (getUserInfo logger brigClient galleyClient) - .| forever (CL.isolate 10000 .| (Conduit.foldMap infoToResult >>= yield)) - .| Conduit.takeWhile ((> 0) . usersSearched) - .| CL.scan (<>) mempty - `fuseUpstream` Conduit.mapM_ (\r -> Log.info logger $ "intermediate_result" .= show r) + runConduit + $ readUsers brigClient + -- .| Conduit.mapM (\chunk -> SIO.hPutStr stderr "." $> chunk) + .| Conduit.concat + .| (maybe (Conduit.filter (const True)) Conduit.take limit) + .| Conduit.mapM (getUserInfo logger brigClient galleyClient) + .| forever (CL.isolate 10000 .| (Conduit.foldMap infoToResult >>= yield)) + .| Conduit.takeWhile ((> 0) . usersSearched) + .| CL.scan (<>) mempty + `fuseUpstream` Conduit.mapM_ (\r -> Log.info logger $ "intermediate_result" .= show r) getUserInfo :: Log.Logger -> ClientState -> ClientState -> UserRow -> IO UserInfo getUserInfo logger brigClient galleyClient ur = do @@ -95,15 +95,16 @@ getUserInfo logger brigClient galleyClient ur = do Nothing -> pure ActivePersonalUser Just tid -> do isPaying <- isPayingTeam galleyClient tid - pure $ - if isPaying + pure + $ if isPaying then ActiveTeamUser Free else ActiveTeamUser Paid - Log.info logger $ - "active_phone_user" .= show apu - ~~ "user_record" .= show ur - ~~ "last_active_timestamps" .= show lastActiveTimeStamps - ~~ Log.msg (Log.val "active phone user found") + Log.info logger + $ "active_phone_user" + .= show apu + ~~ "user_record" .= show ur + ~~ "last_active_timestamps" .= show lastActiveTimeStamps + ~~ Log.msg (Log.val "active phone user found") pure apu else pure InactiveLast90Days pure $ PhoneUser userInfo diff --git a/tools/db/phone-users/src/PhoneUsers/Types.hs b/tools/db/phone-users/src/PhoneUsers/Types.hs index fc60a3ee038..9a19a26f001 100644 --- a/tools/db/phone-users/src/PhoneUsers/Types.hs +++ b/tools/db/phone-users/src/PhoneUsers/Types.hs @@ -77,7 +77,8 @@ galleyCassandraParser = <> value 9043 <> showDefault ) - <*> ( C.Keyspace . view packed + <*> ( C.Keyspace + . view packed <$> strOption ( long "galley-cassandra-keyspace" <> metavar "STRING" @@ -105,7 +106,8 @@ brigCassandraParser = <> value 9042 <> showDefault ) - <*> ( C.Keyspace . view packed + <*> ( C.Keyspace + . view packed <$> strOption ( long "brig-cassandra-keyspace" <> metavar "STRING" diff --git a/tools/db/repair-brig-clients-table/repair-brig-clients-table.cabal b/tools/db/repair-brig-clients-table/repair-brig-clients-table.cabal index c8cfd818ad5..56f53e49d1d 100644 --- a/tools/db/repair-brig-clients-table/repair-brig-clients-table.cabal +++ b/tools/db/repair-brig-clients-table/repair-brig-clients-table.cabal @@ -64,8 +64,8 @@ executable repair-brig-clients-table ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path - -funbox-strict-fields -threaded -with-rtsopts=-N -with-rtsopts=-T - -rtsopts -Wredundant-constraints -Wunused-packages + -funbox-strict-fields -threaded "-with-rtsopts=-N -T" -rtsopts + -Wredundant-constraints -Wunused-packages build-depends: base diff --git a/tools/db/repair-brig-clients-table/src/Work.hs b/tools/db/repair-brig-clients-table/src/Work.hs index 41eca357c92..3541c1b62fa 100644 --- a/tools/db/repair-brig-clients-table/src/Work.hs +++ b/tools/db/repair-brig-clients-table/src/Work.hs @@ -75,7 +75,7 @@ filterReportRemove dryRun l row@(user, client, Nothing, Nothing, Nothing, Nothin rm user client Log.info l (Log.msg @Text "removed!") where - rm :: MonadClient m => UserId -> Text -> m () + rm :: (MonadClient m) => UserId -> Text -> m () rm uid cid = retry x5 $ write rmq (params LocalQuorum (uid, cid)) diff --git a/tools/db/repair-handles/src/Options.hs b/tools/db/repair-handles/src/Options.hs index 31d7228e7bf..ece858a6058 100644 --- a/tools/db/repair-handles/src/Options.hs +++ b/tools/db/repair-handles/src/Options.hs @@ -35,7 +35,7 @@ settingsParser = <*> option auto (short 's' <> long "page-size" <> value 1000) <*> (Id . parseUUID <$> strArgument (metavar "TEAM-UUID")) -parseUUID :: HasCallStack => String -> UUID +parseUUID :: (HasCallStack) => String -> UUID parseUUID = fromJust . Data.UUID.fromString cassandraSettingsParser :: String -> Parser CassandraSettings diff --git a/tools/db/repair-handles/src/Work.hs b/tools/db/repair-handles/src/Work.hs index 70647a443d5..065941f385f 100644 --- a/tools/db/repair-handles/src/Work.hs +++ b/tools/db/repair-handles/src/Work.hs @@ -198,7 +198,7 @@ runCommand env@Env {..} = do tally (nErrs, nReset, nSet, nNoOp) (Right NoActionRequired {}) = (nErrs, nReset, nSet, nNoOp + 1) tally (nErrs, nReset, nSet, nNoOp) (Left _) = (nErrs + 1, nReset, nSet, nNoOp) - chunkify :: Monad m => Int -> ConduitT i [i] m () + chunkify :: (Monad m) => Int -> ConduitT i [i] m () chunkify n = void (C.map (: [])) .| C.chunksOfE n main :: IO () diff --git a/tools/db/service-backfill/service-backfill.cabal b/tools/db/service-backfill/service-backfill.cabal index c6806e06a39..83ab197e26c 100644 --- a/tools/db/service-backfill/service-backfill.cabal +++ b/tools/db/service-backfill/service-backfill.cabal @@ -62,8 +62,8 @@ executable service-backfill ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path - -funbox-strict-fields -threaded -with-rtsopts=-N -with-rtsopts=-T - -rtsopts -Wredundant-constraints -Wunused-packages + -funbox-strict-fields -threaded "-with-rtsopts=-N -T" -rtsopts + -Wredundant-constraints -Wunused-packages build-depends: base diff --git a/tools/fedcalls/fedcalls.cabal b/tools/fedcalls/fedcalls.cabal index 56f14407a56..aa2f03e2d4e 100644 --- a/tools/fedcalls/fedcalls.cabal +++ b/tools/fedcalls/fedcalls.cabal @@ -59,8 +59,8 @@ executable fedcalls ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path - -funbox-strict-fields -threaded -with-rtsopts=-N -with-rtsopts=-T - -rtsopts -Wredundant-constraints -Wunused-packages + -funbox-strict-fields -threaded "-with-rtsopts=-N -T" -rtsopts + -Wredundant-constraints -Wunused-packages build-depends: base diff --git a/tools/fedcalls/src/Main.hs b/tools/fedcalls/src/Main.hs index 8c8775fa9a1..ad14e495706 100644 --- a/tools/fedcalls/src/Main.hs +++ b/tools/fedcalls/src/Main.hs @@ -103,7 +103,7 @@ filterCalls fedCall = <*> fmap pure (method fedCall) <*> pure (fedCalls fedCall) -parse :: HasFeds api => Proxy api -> [MakesCallTo] +parse :: (HasFeds api) => Proxy api -> [MakesCallTo] parse p = do fedCallM <- evalState (getFedCalls p) mempty fedCallI <- maybeToList $ filterCalls fedCallM diff --git a/tools/mlsstats/src/MlsStats/Run.hs b/tools/mlsstats/src/MlsStats/Run.hs index 803ea8a7bb5..ec3eb3bc370 100644 --- a/tools/mlsstats/src/MlsStats/Run.hs +++ b/tools/mlsstats/src/MlsStats/Run.hs @@ -101,7 +101,7 @@ runCommand s3 galleyTables brigTables queryPageSize = do upload "domain-user-client-group.csv" (domainUserClientGroup galleyTables queryPageSize) upload "user-conv.csv" (userConv galleyTables queryPageSize) -userClient :: MonadIO m => ClientState -> Int32 -> ConduitT () ByteString m () +userClient :: (MonadIO m) => ClientState -> Int32 -> ConduitT () ByteString m () userClient cassandra queryPageSize = do yield "user,client\r\n" ( transPipe @@ -114,7 +114,7 @@ userClient cassandra queryPageSize = do userClientCql :: PrepQuery R () (UserId, ClientId) userClientCql = "SELECT user, client FROM clients" -convGroupTeamProtocol :: MonadIO m => ClientState -> Int32 -> ConduitT () ByteString m () +convGroupTeamProtocol :: (MonadIO m) => ClientState -> Int32 -> ConduitT () ByteString m () convGroupTeamProtocol cassandra queryPageSize = do yield "conversation,group,team,protocol\r\n" ( transPipe @@ -143,7 +143,7 @@ convGroupTeamProtocol cassandra queryPageSize = do A.String s -> s _ -> "?" -domainUserClientGroup :: MonadIO m => ClientState -> Int32 -> ConduitT () ByteString m () +domainUserClientGroup :: (MonadIO m) => ClientState -> Int32 -> ConduitT () ByteString m () domainUserClientGroup cassandra queryPageSize = do yield "user_domain,user,client,group\r\n" ( transPipe @@ -166,7 +166,7 @@ domainUserClientGroup cassandra queryPageSize = do domainUserClientGroupCql :: PrepQuery R () (Domain, UserId, ClientId, GroupId) domainUserClientGroupCql = "SELECT user_domain, user, client, group_id FROM mls_group_member_client" -userConv :: MonadIO m => ClientState -> Int32 -> ConduitT () ByteString m () +userConv :: (MonadIO m) => ClientState -> Int32 -> ConduitT () ByteString m () userConv cassandra queryPageSize = do yield "user,conversation\r\n" ( transPipe diff --git a/tools/rex/Main.hs b/tools/rex/Main.hs index 12e9ad777c9..34401a8037e 100644 --- a/tools/rex/Main.hs +++ b/tools/rex/Main.hs @@ -356,7 +356,7 @@ getPeerConnectivityStats lgr seed dom = do Log.warn lgr . msg $ "Peer " <> show addr <> ":" <> show port <> " unreachable: " <> show e -serveIO :: MonadIO m => Opts -> IO RegistrySample -> m () +serveIO :: (MonadIO m) => Opts -> IO RegistrySample -> m () serveIO opts runSample = liftIO $ runSettings diff --git a/tools/stern/default.nix b/tools/stern/default.nix index 5c9adf4ce7d..8ccf0f63f20 100644 --- a/tools/stern/default.nix +++ b/tools/stern/default.nix @@ -24,7 +24,6 @@ , lens , lens-aeson , lib -, metrics-wai , mtl , openapi3 , optparse-applicative @@ -74,7 +73,6 @@ mkDerivation { http-types imports lens - metrics-wai mtl openapi3 schema-profunctor diff --git a/tools/stern/src/Stern/API.hs b/tools/stern/src/Stern/API.hs index c604da034ac..8b071b59b45 100644 --- a/tools/stern/src/Stern/API.hs +++ b/tools/stern/src/Stern/API.hs @@ -29,7 +29,7 @@ where import Brig.Types.Intra import Control.Error -import Control.Lens ((^.)) +import Control.Lens ((.~), (^.)) import Control.Monad.Except import Data.Aeson hiding (Error, json) import Data.Aeson.KeyMap qualified as KeyMap @@ -52,6 +52,7 @@ import Imports hiding (head) import Network.HTTP.Types import Network.Wai import Network.Wai.Utilities as Wai +import Network.Wai.Utilities.Server import Network.Wai.Utilities.Server qualified as Server import Servant (NoContent (NoContent), ServerT, (:<|>) (..)) import Servant qualified @@ -80,13 +81,15 @@ start :: Opts -> IO () start o = do e <- newEnv o s <- Server.newSettings (server e) - Server.runSettingsWithShutdown s (servantApp e) Nothing + Server.runSettingsWithShutdown s (requestIdMiddleware (e ^. applog) defaultRequestIdHeaderName $ servantApp e) Nothing where server :: Env -> Server.Server - server e = Server.defaultServer (unpack $ stern o ^. host) (stern o ^. port) (e ^. applog) (e ^. metrics) + server e = Server.defaultServer (unpack $ stern o ^. host) (stern o ^. port) (e ^. applog) servantApp :: Env -> Application - servantApp e = + servantApp e0 req cont = do + let rid = getRequestId defaultRequestIdHeaderName req + let e = requestId .~ rid $ e0 Servant.serve ( Proxy @( SwaggerDocsAPI @@ -100,6 +103,8 @@ start o = do :<|> sitemap e :<|> sitemapRedirectToSwaggerDocs ) + req + cont ------------------------------------------------------------------------------- -- servant API @@ -124,7 +129,6 @@ sitemap' = Named @"suspend-user" suspendUser :<|> Named @"unsuspend-user" unsuspendUser :<|> Named @"get-users-by-email" usersByEmail - :<|> Named @"get-users-by-phone" usersByPhone :<|> Named @"get-users-by-ids" usersByIds :<|> Named @"get-users-by-handles" usersByHandles :<|> Named @"get-user-connections" userConnections @@ -132,7 +136,6 @@ sitemap' = :<|> Named @"search-users" searchOnBehalf :<|> Named @"revoke-identity" revokeIdentity :<|> Named @"put-email" changeEmail - :<|> Named @"put-phone" changePhone :<|> Named @"delete-user" deleteUser :<|> Named @"suspend-team" (setTeamStatusH Team.Suspended) :<|> Named @"unsuspend-team" (setTeamStatusH Team.Active) @@ -205,10 +208,7 @@ unsuspendUser :: UserId -> Handler NoContent unsuspendUser uid = NoContent <$ Intra.putUserStatus Active uid usersByEmail :: Email -> Handler [UserAccount] -usersByEmail = Intra.getUserProfilesByIdentity . Left - -usersByPhone :: Phone -> Handler [UserAccount] -usersByPhone = Intra.getUserProfilesByIdentity . Right +usersByEmail = Intra.getUserProfilesByIdentity usersByIds :: [UserId] -> Handler [UserAccount] usersByIds = Intra.getUserProfiles . Left @@ -232,19 +232,15 @@ searchOnBehalf (fromMaybe (unsafeRange 10) . checked @1 @100 @Int32 . fromMaybe 10 -> s) = Intra.getContacts uid q (fromRange s) -revokeIdentity :: Maybe Email -> Maybe Phone -> Handler NoContent -revokeIdentity mbe mbp = NoContent <$ (Intra.revokeIdentity =<< doubleMaybeToEither "email, phone" mbe mbp) +revokeIdentity :: Email -> Handler NoContent +revokeIdentity e = NoContent <$ Intra.revokeIdentity e changeEmail :: UserId -> EmailUpdate -> Handler NoContent changeEmail uid upd = NoContent <$ Intra.changeEmail uid upd -changePhone :: UserId -> PhoneUpdate -> Handler NoContent -changePhone uid upd = NoContent <$ Intra.changePhone uid upd - -deleteUser :: UserId -> Maybe Email -> Maybe Phone -> Handler NoContent -deleteUser uid mbEmail mbPhone = do - emailOrPhone <- doubleMaybeToEither "email, phone" mbEmail mbPhone - usrs <- Intra.getUserProfilesByIdentity emailOrPhone +deleteUser :: UserId -> Email -> Handler NoContent +deleteUser uid email = do + usrs <- Intra.getUserProfilesByIdentity email case usrs of [accountUser -> u] -> if userId u == uid @@ -252,7 +248,7 @@ deleteUser uid mbEmail mbPhone = do info $ userMsg uid . msg (val "Deleting account") void $ Intra.deleteAccount uid pure NoContent - else throwE $ mkError status400 "match-error" "email or phone did not match UserId" + else throwE $ mkError status400 "match-error" "email did not match UserId" (_ : _ : _) -> error "impossible" _ -> throwE $ mkError status404 "not-found" "not found" @@ -261,7 +257,7 @@ setTeamStatusH status tid = NoContent <$ Intra.setStatusBindingTeam tid status deleteTeam :: TeamId -> Maybe Bool -> Maybe Email -> Handler NoContent deleteTeam givenTid (fromMaybe False -> False) (Just email) = do - acc <- Intra.getUserProfilesByIdentity (Left email) >>= handleNoUser . listToMaybe + acc <- Intra.getUserProfilesByIdentity email >>= handleNoUser . listToMaybe userTid <- (Intra.getUserBindingTeam . userId . accountUser $ acc) >>= handleNoTeam when (givenTid /= userTid) $ throwE bindingTeamMismatch @@ -280,27 +276,24 @@ deleteTeam tid (fromMaybe False -> True) _ = do deleteTeam _ _ _ = throwE $ mkError status400 "Bad Request" "either email or 'force=true' parameter is required" -isUserKeyBlacklisted :: Maybe Email -> Maybe Phone -> Handler NoContent -isUserKeyBlacklisted mbemail mbphone = do - emailOrPhone <- doubleMaybeToEither "email, phone" mbemail mbphone - bl <- Intra.isBlacklisted emailOrPhone +isUserKeyBlacklisted :: Email -> Handler NoContent +isUserKeyBlacklisted email = do + bl <- Intra.isBlacklisted email if bl then throwE $ mkError status200 "blacklisted" "The given user key IS blacklisted" else throwE $ mkError status404 "not-blacklisted" "The given user key is NOT blacklisted" -addBlacklist :: Maybe Email -> Maybe Phone -> Handler NoContent -addBlacklist mbemail mbphone = do - emailOrPhone <- doubleMaybeToEither "email, phone" mbemail mbphone - NoContent <$ Intra.setBlacklistStatus True emailOrPhone +addBlacklist :: Email -> Handler NoContent +addBlacklist email = do + NoContent <$ Intra.setBlacklistStatus True email -deleteFromBlacklist :: Maybe Email -> Maybe Phone -> Handler NoContent -deleteFromBlacklist mbemail mbphone = do - emailOrPhone <- doubleMaybeToEither "email, phone" mbemail mbphone - NoContent <$ Intra.setBlacklistStatus False emailOrPhone +deleteFromBlacklist :: Email -> Handler NoContent +deleteFromBlacklist email = do + NoContent <$ Intra.setBlacklistStatus False email getTeamInfoByMemberEmail :: Email -> Handler TeamInfo getTeamInfoByMemberEmail e = do - acc <- Intra.getUserProfilesByIdentity (Left e) >>= handleUser . listToMaybe + acc <- Intra.getUserProfilesByIdentity e >>= handleUser . listToMaybe tid <- (Intra.getUserBindingTeam . userId . accountUser $ acc) >>= handleTeam Intra.getTeamInfo tid where @@ -411,7 +404,7 @@ setTeamBillingInfo tid billingInfo = do getConsentLog :: Email -> Handler ConsentLogAndMarketo getConsentLog e = do - acc <- listToMaybe <$> Intra.getUserProfilesByIdentity (Left e) + acc <- listToMaybe <$> Intra.getUserProfilesByIdentity e when (isJust acc) $ throwE $ mkError status403 "user-exists" "Trying to access consent log of existing user!" @@ -421,24 +414,30 @@ getConsentLog e = do getUserData :: UserId -> Maybe Int -> Maybe Int -> Handler UserMetaInfo getUserData uid mMaxConvs mMaxNotifs = do + -- brig account <- Intra.getUserProfiles (Left [uid]) >>= noSuchUser . listToMaybe conns <- Intra.getUserConnections uid - convs <- Intra.getUserConversations uid (fromMaybe 1 mMaxConvs) clts <- Intra.getUserClients uid + cookies <- Intra.getUserCookies uid + properties <- Intra.getUserProperties uid + + -- galley + convs <- Intra.getUserConversations uid (fromMaybe 1 mMaxConvs) + + -- gundeck notfs <- - ( Intra.getUserNotifications uid (fromMaybe 10 mMaxNotifs) + ( Intra.getUserNotifications uid (fromMaybe 100 mMaxNotifs) <&> toJSON @[QueuedNotification] ) `catchE` (pure . String . T.pack . show) + + -- galeb consent <- (Intra.getUserConsentValue uid <&> toJSON @ConsentValue) `catchE` (pure . String . T.pack . show) consentLog <- (Intra.getUserConsentLog uid <&> toJSON @ConsentLog) `catchE` (pure . String . T.pack . show) - cookies <- Intra.getUserCookies uid - properties <- Intra.getUserProperties uid - -- Get all info from Marketo too let em = userEmail $ accountUser account marketo <- do let noEmail = MarketoResult $ KeyMap.singleton "results" emptyArray @@ -464,7 +463,7 @@ getUserData uid mMaxConvs mMaxNotifs = do -- Utilities -instance FromByteString a => Servant.FromHttpApiData [a] where +instance (FromByteString a) => Servant.FromHttpApiData [a] where parseUrlPiece = maybe (Left "not a list of a's") (Right . fromList) . fromByteString' diff --git a/tools/stern/src/Stern/API/Routes.hs b/tools/stern/src/Stern/API/Routes.hs index 55113e85177..b52d262f142 100644 --- a/tools/stern/src/Stern/API/Routes.hs +++ b/tools/stern/src/Stern/API/Routes.hs @@ -91,14 +91,6 @@ type SternAPI = :> QueryParam' [Required, Strict, Description "Email address"] "email" Email :> Get '[JSON] [UserAccount] ) - :<|> Named - "get-users-by-phone" - ( Summary "Displays user's info given a phone number" - :> "users" - :> "by-phone" - :> QueryParam' [Required, Strict, Description "Phone number"] "phone" Phone - :> Get '[JSON] [UserAccount] - ) :<|> Named "get-users-by-ids" ( Summary "Displays active users info given a list of ids" @@ -144,7 +136,7 @@ type SternAPI = ) :<|> Named "revoke-identity" - ( Summary "Revoke a verified user identity. Specify exactly one of phone, email." + ( Summary "Revoke a verified user identity. Specify email." :> Description "Forcefully revokes a verified user identity. \ \WARNING: If the given identity is the only verified \ @@ -153,8 +145,7 @@ type SternAPI = \If the given identity is not taken / verified, this is a no-op." :> "users" :> "revoke-identity" - :> QueryParam' [Optional, Strict, Description "A verified email address"] "email" Email - :> QueryParam' [Optional, Strict, Description "A verified phone number (E.164 format)."] "phone" Phone + :> QueryParam' [Required, Strict, Description "A verified email address"] "email" Email :> Post '[JSON] NoContent ) :<|> Named @@ -167,25 +158,14 @@ type SternAPI = :> Servant.ReqBody '[JSON] EmailUpdate :> Put '[JSON] NoContent ) - :<|> Named - "put-phone" - ( Summary "Change a user's phone number." - :> Description "The new phone number must be verified before the change takes effect." - :> "users" - :> Capture "uid" UserId - :> "phone" - :> Servant.ReqBody '[JSON] PhoneUpdate - :> Put '[JSON] NoContent - ) :<|> Named "delete-user" ( Summary "Delete a user (irrevocable!)" :> Description - "Email or Phone must match UserId's (to prevent copy/paste mistakes). Use exactly one of the two query params." + "Email must match UserId's (to prevent copy/paste mistakes)." :> "users" :> Capture "uid" UserId - :> QueryParam' [Optional, Strict, Description "A verified email address"] "email" Email - :> QueryParam' [Optional, Strict, Description "A verified phone number (E.164 format)."] "phone" Phone + :> QueryParam' [Required, Strict, Description "A verified email address"] "email" Email :> Delete '[JSON] NoContent ) :<|> Named @@ -228,29 +208,26 @@ type SternAPI = ) :<|> Named "head-user-blacklist" - ( Summary "Fetch blacklist information on a email/phone (200: blacklisted; 404: not blacklisted)" + ( Summary "Fetch blacklist information on a email (200: blacklisted; 404: not blacklisted)" :> "users" :> "blacklist" - :> QueryParam' [Optional, Strict, Description "A verified email address"] "email" Email - :> QueryParam' [Optional, Strict, Description "A verified phone number (E.164 format)."] "phone" Phone + :> QueryParam' [Required, Strict, Description "A verified email address"] "email" Email :> Verb 'GET 200 '[JSON] NoContent ) :<|> Named "post-user-blacklist" - ( Summary "Add the email/phone to our blacklist" + ( Summary "Add the email to our blacklist" :> "users" :> "blacklist" - :> QueryParam' [Optional, Strict, Description "A verified email address"] "email" Email - :> QueryParam' [Optional, Strict, Description "A verified phone number (E.164 format)."] "phone" Phone + :> QueryParam' [Required, Strict, Description "A verified email address"] "email" Email :> Post '[JSON] NoContent ) :<|> Named "delete-user-blacklist" - ( Summary "Remove the email/phone from our blacklist" + ( Summary "Remove the email from our blacklist" :> "users" :> "blacklist" - :> QueryParam' [Optional, Strict, Description "A verified email address"] "email" Email - :> QueryParam' [Optional, Strict, Description "A verified phone number (E.164 format)."] "phone" Phone + :> QueryParam' [Required, Strict, Description "A verified email address"] "email" Email :> Delete '[JSON] NoContent ) :<|> Named @@ -399,7 +376,7 @@ type SternAPI = :> "meta-info" :> QueryParam' [Required, Strict, Description "A valid UserId"] "id" UserId :> QueryParam' [Optional, Strict, Description "Max number of conversation (default 1)"] "max_conversations" Int - :> QueryParam' [Optional, Strict, Description "Max number of notifications (default 10)"] "max_notifications" Int + :> QueryParam' [Optional, Strict, Description "Max number of notifications (min 100, default 100)"] "max_notifications" Int :> Post '[JSON] UserMetaInfo ) :<|> Named @@ -505,7 +482,7 @@ instance Schema.ToSchema UserConnectionGroups where <*> ucgMissingLegalholdConsent Schema..= Schema.field "ucgMissingLegalholdConsent" Schema.schema <*> ucgTotal Schema..= Schema.field "ucgTotal" Schema.schema -doubleMaybeToEither :: Monad m => LText -> Maybe a -> Maybe b -> ExceptT Error m (Either a b) +doubleMaybeToEither :: (Monad m) => LText -> Maybe a -> Maybe b -> ExceptT Error m (Either a b) doubleMaybeToEither _ (Just a) Nothing = pure $ Left a doubleMaybeToEither _ Nothing (Just b) = pure $ Right b doubleMaybeToEither msg _ _ = throwE $ mkError status400 "either-params" ("Must use exactly one of two query params: " <> msg) diff --git a/tools/stern/src/Stern/App.hs b/tools/stern/src/Stern/App.hs index 0f3b0aa5e4b..3a75f308748 100644 --- a/tools/stern/src/Stern/App.hs +++ b/tools/stern/src/Stern/App.hs @@ -33,7 +33,6 @@ import Control.Monad.Reader.Class import Control.Monad.Trans.Class import Data.ByteString.Conversion (toByteString') import Data.Id -import Data.Metrics.Middleware qualified as Metrics import Data.Text.Encoding (encodeUtf8) import Data.UUID (toString) import Data.UUID.V4 qualified as UUID @@ -43,6 +42,7 @@ import Network.Wai (Request, Response, ResponseReceived) import Network.Wai.Utilities (Error (..), lookupRequestId) import Network.Wai.Utilities.Error qualified as WaiError import Network.Wai.Utilities.Response (json, setStatus) +import Network.Wai.Utilities.Server (defaultRequestIdHeaderName) import Network.Wai.Utilities.Server qualified as Server import Stern.Options as O import System.Logger qualified as Log @@ -58,7 +58,6 @@ data Env = Env _ibis :: !Bilge.Request, _galeb :: !Bilge.Request, _applog :: !Logger, - _metrics :: !Metrics.Metrics, _requestId :: !Bilge.RequestId, _httpManager :: !Bilge.Manager } @@ -67,9 +66,8 @@ makeLenses ''Env newEnv :: Opts -> IO Env newEnv o = do - mt <- Metrics.metrics l <- Log.mkLogger (O.logLevel o) (O.logNetStrings o) (O.logFormat o) - Env (mkRequest $ O.brig o) (mkRequest $ O.galley o) (mkRequest $ O.gundeck o) (mkRequest $ O.ibis o) (mkRequest $ O.galeb o) l mt (RequestId "N/A") + Env (mkRequest $ O.brig o) (mkRequest $ O.galley o) (mkRequest $ O.gundeck o) (mkRequest $ O.ibis o) (mkRequest $ O.galeb o) l (RequestId "N/A") <$> newManager where mkRequest s = Bilge.host (encodeUtf8 (s ^. host)) . Bilge.port (s ^. port) $ Bilge.empty @@ -91,7 +89,7 @@ deriving instance MonadUnliftIO App type App = AppT IO -instance MonadIO m => MonadLogger (AppT m) where +instance (MonadIO m) => MonadLogger (AppT m) where log l m = do g <- view applog r <- view requestId @@ -100,12 +98,12 @@ instance MonadIO m => MonadLogger (AppT m) where instance MonadLogger (ExceptT e App) where log l m = lift (LC.log l m) -instance MonadIO m => Bilge.MonadHttp (AppT m) where +instance (MonadIO m) => Bilge.MonadHttp (AppT m) where handleRequestWithCont req h = do m <- view httpManager liftIO $ Bilge.withResponse req m h -instance Monad m => HasRequestId (AppT m) where +instance (Monad m) => HasRequestId (AppT m) where getRequestId = view requestId instance HasRequestId (ExceptT e App) where @@ -128,7 +126,7 @@ type Continue m = Response -> m ResponseReceived runHandler :: Env -> Request -> Handler ResponseReceived -> Continue IO -> IO ResponseReceived runHandler e r h k = do - i <- reqId (lookupRequestId r) + i <- reqId (lookupRequestId defaultRequestIdHeaderName r) let e' = set requestId (Bilge.RequestId i) e a <- runAppT e' (runExceptT h) either (onError (view applog e) r k) pure a diff --git a/tools/stern/src/Stern/Intra.hs b/tools/stern/src/Stern/Intra.hs index 7db21d1c5f9..59636d7e5ba 100644 --- a/tools/stern/src/Stern/Intra.hs +++ b/tools/stern/src/Stern/Intra.hs @@ -76,7 +76,6 @@ import Bilge.RPC import Brig.Types.Intra import Control.Error import Control.Lens (view, (^.)) -import Control.Monad.Reader import Data.Aeson hiding (Error) import Data.Aeson.KeyMap qualified as KeyMap import Data.Aeson.Types (emptyArray) @@ -249,13 +248,13 @@ getUserProfiles uidsOrHandles = do prepareQS :: Either [UserId] [Handle] -> [Request -> Request] prepareQS (Left uids) = fmap (queryItem "ids") (toQS uids) prepareQS (Right handles) = fmap (queryItem "handles") (toQS handles) - toQS :: ToByteString a => [a] -> [ByteString] + toQS :: (ToByteString a) => [a] -> [ByteString] toQS = fmap (BS.intercalate "," . map toByteString') . chunksOf 50 -getUserProfilesByIdentity :: Either Email Phone -> Handler [UserAccount] -getUserProfilesByIdentity emailOrPhone = do +getUserProfilesByIdentity :: Email -> Handler [UserAccount] +getUserProfilesByIdentity email = do info $ msg "Getting user accounts by identity" b <- view brig r <- @@ -265,7 +264,7 @@ getUserProfilesByIdentity emailOrPhone = do b ( method GET . Bilge.path "i/users" - . userKeyToParam emailOrPhone + . userKeyToParam email . expect2xx ) parseResponse (mkError status502 "bad-upstream") r @@ -277,7 +276,7 @@ getEjpdInfo handles includeContacts = do let bdy :: Value bdy = object - [ "ejpd_request" + [ "EJPDRequest" .= (decodeUtf8With lenientDecode . toByteString' <$> handles) ] r <- @@ -311,17 +310,18 @@ getContacts u q s = do ) parseResponse (mkError status502 "bad-upstream") r -revokeIdentity :: Either Email Phone -> Handler () -revokeIdentity emailOrPhone = do +revokeIdentity :: Email -> Handler () +revokeIdentity email = do info $ msg "Revoking user identity" b <- view brig - void . catchRpcErrors $ - rpc' + void + . catchRpcErrors + $ rpc' "brig" b ( method POST . Bilge.path "i/users/revoke-identity" - . userKeyToParam emailOrPhone + . userKeyToParam email . expect2xx ) @@ -329,8 +329,9 @@ deleteAccount :: UserId -> Handler () deleteAccount uid = do info $ msg "Deleting account" b <- view brig - void . catchRpcErrors $ - rpc' + void + . catchRpcErrors + $ rpc' "brig" b ( method DELETE @@ -346,8 +347,9 @@ setStatusBindingTeam tid status = do <> UTF8.toString (BS.toStrict . encode $ status) ) g <- view galley - void . catchRpcErrors $ - rpc' + void + . catchRpcErrors + $ rpc' "galley" g ( method PUT @@ -360,8 +362,9 @@ deleteBindingTeam :: TeamId -> Handler () deleteBindingTeam tid = do info $ msg "Deleting team" g <- view galley - void . catchRpcErrors $ - rpc' + void + . catchRpcErrors + $ rpc' "galley" g ( method DELETE @@ -374,8 +377,9 @@ deleteBindingTeamForce :: TeamId -> Handler () deleteBindingTeamForce tid = do info $ msg "Deleting team with force flag" g <- view galley - void . catchRpcErrors $ - rpc' + void + . catchRpcErrors + $ rpc' "galley" g ( method DELETE @@ -388,8 +392,9 @@ changeEmail :: UserId -> EmailUpdate -> Handler () changeEmail u upd = do info $ msg "Updating email address" b <- view brig - void . catchRpcErrors $ - rpc' + void + . catchRpcErrors + $ rpc' "brig" b ( method PUT @@ -406,8 +411,9 @@ changePhone :: UserId -> PhoneUpdate -> Handler () changePhone u upd = do info $ msg "Updating phone number" b <- view brig - void . catchRpcErrors $ - rpc' + void + . catchRpcErrors + $ rpc' "brig" b ( method PUT @@ -445,7 +451,8 @@ getUserBindingTeam u = do listToMaybe $ fmap (view teamId) $ filter ((== Binding) . view teamBinding) $ - teams ^. teamListTeams + teams + ^. teamListTeams getInvoiceUrl :: TeamId -> InvoiceId -> Handler ByteString getInvoiceUrl tid iid = do @@ -484,8 +491,9 @@ setTeamBillingInfo :: TeamId -> TeamBillingInfo -> Handler () setTeamBillingInfo tid tbu = do info $ msg "Setting team billing info" i <- view ibis - void . catchRpcErrors $ - rpc' + void + . catchRpcErrors + $ rpc' "ibis" i ( method PUT @@ -495,8 +503,8 @@ setTeamBillingInfo tid tbu = do . expect2xx ) -isBlacklisted :: Either Email Phone -> Handler Bool -isBlacklisted emailOrPhone = do +isBlacklisted :: Email -> Handler Bool +isBlacklisted email = do info $ msg "Checking blacklist" b <- view brig resp <- @@ -506,24 +514,25 @@ isBlacklisted emailOrPhone = do b ( method GET . Bilge.path "i/users/blacklist" - . userKeyToParam emailOrPhone + . userKeyToParam email ) case Bilge.statusCode resp of 200 -> pure True 404 -> pure False _ -> throwE (mkError status502 "bad-upstream" (errorMessage resp)) -setBlacklistStatus :: Bool -> Either Email Phone -> Handler () -setBlacklistStatus status emailOrPhone = do +setBlacklistStatus :: Bool -> Email -> Handler () +setBlacklistStatus status email = do info $ msg "Changing blacklist status" b <- view brig - void . catchRpcErrors $ - rpc' + void + . catchRpcErrors + $ rpc' "brig" b ( method (statusToMethod status) . Bilge.path "i/users/blacklist" - . userKeyToParam emailOrPhone + . userKeyToParam email . expect2xx ) where @@ -604,8 +613,9 @@ setTeamFeatureLockStatus :: setTeamFeatureLockStatus tid lstat = do info $ msg ("Setting lock status: " <> show (symbolVal (Proxy @(Public.FeatureSymbol cfg)), lstat)) gly <- view galley - fromResponseBody <=< catchRpcErrors $ - rpc' + fromResponseBody + <=< catchRpcErrors + $ rpc' "galley" gly ( method PUT @@ -626,8 +636,9 @@ getSearchVisibility :: TeamId -> Handler TeamSearchVisibilityView getSearchVisibility tid = do info $ msg "Getting TeamSearchVisibilityView value" gly <- view galley - fromResponseBody <=< catchRpcErrors $ - rpc' + fromResponseBody + <=< catchRpcErrors + $ rpc' "galley" gly ( method GET @@ -668,9 +679,8 @@ setSearchVisibility tid typ = do stripBS :: ByteString -> ByteString stripBS = encodeUtf8 . strip . decodeUtf8 -userKeyToParam :: Either Email Phone -> Request -> Request -userKeyToParam (Left e) = queryItem "email" (stripBS $ toByteString' e) -userKeyToParam (Right p) = queryItem "phone" (stripBS $ toByteString' p) +userKeyToParam :: Email -> Request -> Request +userKeyToParam e = queryItem "email" (stripBS $ toByteString' e) errorMessage :: Response (Maybe LByteString) -> LText errorMessage = maybe "" TL.decodeUtf8 . responseBody @@ -767,9 +777,17 @@ getMarketoResult email = do ) -- 404 is acceptable when marketo doesn't know about this user, return an empty result case statusCode r of - 200 -> parseResponse (mkError status502 "bad-upstream") r + 200 -> do + let responseOrError = responseJsonEither r + case responseOrError of + Left e -> do + Log.err $ msg ("Error parsing marketo response: " ++ e) + throwE (mkError status502 "bad-upstream" (pack e)) + Right res -> pure res 404 -> pure noEmail - _ -> throwE (mkError status502 "bad-upstream" "") + otherStatus -> do + Log.err $ msg ("Unexpected status code from marketo: " ++ show otherStatus) + throwE (mkError status502 "bad-upstream" "") where noEmail = MarketoResult $ KeyMap.singleton "results" emptyArray @@ -849,7 +867,12 @@ getUserClients uid = do . expect2xx ) info $ msg ("Response" ++ show r) - parseResponse (mkError status502 "bad-upstream") r + let resultOrError :: Either String [Versioned 'V5 Client] = responseJsonEither r + case resultOrError of + Left e -> do + Log.err $ msg ("Error parsing client response: " ++ e) + pure [] + Right res -> pure $ fmap unVersioned res getUserProperties :: UserId -> Handler UserProperties getUserProperties uid = do @@ -892,13 +915,17 @@ getUserNotifications uid maxNotifs = do where fetchAll :: [QueuedNotification] -> Maybe NotificationId -> Int -> ExceptT Error App [QueuedNotification] fetchAll xs start remaining = do - userNotificationList <- fetchBatch start (min 100 remaining) - let batch = view queuedNotifications userNotificationList - remaining' = remaining - length batch - if (not . null) batch && view queuedHasMore userNotificationList && remaining' > 0 - then fetchAll (batch ++ xs) (Just . view queuedNotificationId $ last batch) remaining' - else pure (batch ++ xs) - fetchBatch :: Maybe NotificationId -> Int -> Handler QueuedNotificationList + -- size must be within 100-1000 + mUserNotificationList <- fetchBatch start (max 100 (min 1000 remaining)) + case mUserNotificationList of + Nothing -> pure xs + Just userNotificationList -> do + let batch = view queuedNotifications userNotificationList + remaining' = remaining - length batch + if (not . null) batch && view queuedHasMore userNotificationList && remaining' > 0 + then fetchAll (batch ++ xs) (Just . view queuedNotificationId $ last batch) remaining' + else pure (batch ++ xs) + fetchBatch :: Maybe NotificationId -> Int -> Handler (Maybe QueuedNotificationList) fetchBatch start batchSize = do baseReq <- view gundeck r <- @@ -916,9 +943,23 @@ getUserNotifications uid maxNotifs = do -- 404 is an acceptable response, in case, for some reason, -- "start" is not found we still return a QueuedNotificationList case statusCode r of - 200 -> parseResponse (mkError status502 "bad-upstream") r - 404 -> parseResponse (mkError status502 "bad-upstream") r - _ -> throwE (mkError status502 "bad-upstream" "") + 200 -> do + let responseOrError = responseJsonEither r + case responseOrError of + Left e -> do + Log.err $ msg ("Error parsing notification response: " ++ e) + pure Nothing + Right res -> pure $ Just res + 404 -> do + let resultOrError = responseJsonEither r + case resultOrError of + Left e -> do + Log.err $ msg ("Error parsing notification response: " ++ e) + pure Nothing + Right res -> pure $ Just res + otherStatus -> do + Log.err $ msg ("Unexpected status code from gundeck: " ++ show otherStatus) + pure Nothing getSsoDomainRedirect :: Text -> Handler (Maybe CustomBackend) getSsoDomainRedirect domain = do @@ -948,8 +989,9 @@ putSsoDomainRedirect domain config welcome = do -- }' -- curl -XPUT http://localhost/i/custom-backend/by-domain/${DOMAIN_EXAMPLE} -d "${DOMAIN_ENTRY}" g <- view galley - void . catchRpcErrors $ - rpc' + void + . catchRpcErrors + $ rpc' "galley" g ( method PUT @@ -968,8 +1010,9 @@ deleteSsoDomainRedirect domain = do info $ msg "deleteSsoDomainRedirect" -- curl -XDELETE http://localhost/i/custom-backend/by-domain/${DOMAIN_EXAMPLE} g <- view galley - void . catchRpcErrors $ - rpc' + void + . catchRpcErrors + $ rpc' "galley" g ( method DELETE diff --git a/tools/stern/stern.cabal b/tools/stern/stern.cabal index 9d3634cccc2..e7572f7c330 100644 --- a/tools/stern/stern.cabal +++ b/tools/stern/stern.cabal @@ -87,7 +87,6 @@ library , http-types >=0.8 , imports , lens >=4.4 - , metrics-wai >=0.3 , mtl >=2.1 , openapi3 , schema-profunctor diff --git a/tools/stern/test/integration/API.hs b/tools/stern/test/integration/API.hs index 83c5827773d..69b351cabdb 100644 --- a/tools/stern/test/integration/API.hs +++ b/tools/stern/test/integration/API.hs @@ -65,7 +65,6 @@ tests s = test s "POST /users/:uid/suspend" testSuspendUser, test s "POST /users/:uid/unsuspend" testUnsuspendUser, test s "GET /users/by-email" testGetUsersByEmail, - test s "GET /users/by-phone" testGetUsersByPhone, test s "GET /users/by-ids" testGetUsersByIds, test s "GET /users/by-handles" testGetUsersByHandles, test s "GET /users/:id/connections" testGetConnections, @@ -73,7 +72,6 @@ tests s = test s "GET /users/:uid/search" testSearchUsers, test s "POST /users/revoke-identity?email=..." testRevokeIdentity, test s "PUT /users/:uid/email" testPutEmail, - test s "PUT /users/:uid/phone" testPutPhone, test s "DELETE /users/:uid" testDeleteUser, test s "PUT /teams/:tid/suspend" testSuspendTeam, test s "PUT /teams/:tid/unsuspend" testUnsuspendTeam, @@ -175,13 +173,6 @@ testGetUserMetaInfo = do -- Just make sure this returns a 200 void $ getUserMetaInfo uid -testPutPhone :: TestM () -testPutPhone = do - uid <- randomUser - phone <- randomPhone - -- We simply test that this call returns 200 - putPhone uid (PhoneUpdate phone) - testDeleteUser :: TestM () testDeleteUser = do (uid, email) <- randomEmailUser @@ -234,8 +225,8 @@ testEjpdInfo = do uid <- randomUser h <- randomHandle void $ setHandle uid h - info <- ejpdInfo True [Handle h] - liftIO $ fmap (.ejpdResponseHandle) info.ejpdResponseBody @?= [Just (Handle h)] + info <- ejpdInfo True [fromJust $ parseHandle h] + liftIO $ fmap (.ejpdResponseRootHandle) info.ejpdResponseBody @?= [Just (fromJust (parseHandle h))] testUserBlacklist :: TestM () testUserBlacklist = do @@ -405,12 +396,6 @@ testGetUsersByHandles = do [ua] <- getUsersByHandles h liftIO $ userId ua.accountUser @?= uid -testGetUsersByPhone :: TestM () -testGetUsersByPhone = do - (uid, phone) <- randomPhoneUser - [ua] <- getUsersByPhone phone - liftIO $ userId ua.accountUser @?= uid - testGetUsersByEmail :: TestM () testGetUsersByEmail = do (uid, email) <- randomEmailUser @@ -466,14 +451,13 @@ testSearchUsers = do testRevokeIdentity :: TestM () testRevokeIdentity = do - (_, (email, phone)) <- randomEmailPhoneUser + (_, email) <- randomEmailUser do [ua] <- getUsersByEmail email liftIO $ do ua.accountStatus @?= Active isJust ua.accountUser.userIdentity @?= True void $ revokeIdentity (Left email) - void $ revokeIdentity (Right phone) do [ua] <- getUsersByEmail email liftIO $ do @@ -511,12 +495,6 @@ getUsersByHandles h = do r <- get (stern . paths ["users", "by-handles"] . queryItem "handles" (cs h) . expect2xx) pure $ responseJsonUnsafe r -getUsersByPhone :: Phone -> TestM [UserAccount] -getUsersByPhone phone = do - stern <- view tsStern - r <- get (stern . paths ["users", "by-phone"] . queryItem "phone" (toByteString' phone) . expect2xx) - pure $ responseJsonUnsafe r - getUsersByEmail :: Email -> TestM [UserAccount] getUsersByEmail email = do stern <- view tsStern @@ -571,11 +549,6 @@ putEmail uid emailUpdate = do s <- view tsStern void $ put (s . paths ["users", toByteString' uid, "email"] . json emailUpdate . expect2xx) -putPhone :: UserId -> PhoneUpdate -> TestM () -putPhone uid phoneUpdate = do - s <- view tsStern - void $ put (s . paths ["users", toByteString' uid, "phone"] . json phoneUpdate . expect2xx) - deleteUser :: UserId -> Either Email Phone -> TestM () deleteUser uid emailOrPhone = do s <- view tsStern diff --git a/tools/stern/test/integration/Util.hs b/tools/stern/test/integration/Util.hs index acfa6afa731..2c26c513d13 100644 --- a/tools/stern/test/integration/Util.hs +++ b/tools/stern/test/integration/Util.hs @@ -54,7 +54,7 @@ import Wire.API.User as User eventually :: (MonadIO m, MonadMask m, MonadUnliftIO m) => m a -> m a eventually = recoverAll (limitRetries 7 <> exponentialBackoff 50000) . const -createTeamWithNMembers :: HasCallStack => Int -> TestM (UserId, TeamId, [UserId]) +createTeamWithNMembers :: (HasCallStack) => Int -> TestM (UserId, TeamId, [UserId]) createTeamWithNMembers n = do (owner, tid) <- createBindingTeam mems <- replicateM n $ do @@ -62,64 +62,50 @@ createTeamWithNMembers n = do pure (mem ^. Team.userId) pure (owner, tid, mems) -createBindingTeam :: HasCallStack => TestM (UserId, TeamId) +createBindingTeam :: (HasCallStack) => TestM (UserId, TeamId) createBindingTeam = do first User.userId <$> createBindingTeam' -createBindingTeam' :: HasCallStack => TestM (User, TeamId) +createBindingTeam' :: (HasCallStack) => TestM (User, TeamId) createBindingTeam' = do owner <- randomTeamCreator' refreshIndex pure (owner, fromMaybe (error "createBindingTeam: no team id") (owner.userTeam)) -randomTeamCreator' :: HasCallStack => TestM User +randomTeamCreator' :: (HasCallStack) => TestM User randomTeamCreator' = randomUser'' True True True -randomUser :: HasCallStack => TestM UserId +randomUser :: (HasCallStack) => TestM UserId randomUser = qUnqualified <$> randomUser' False True True -randomUser' :: HasCallStack => Bool -> Bool -> Bool -> TestM (Qualified UserId) +randomUser' :: (HasCallStack) => Bool -> Bool -> Bool -> TestM (Qualified UserId) randomUser' isCreator hasPassword hasEmail = userQualifiedId <$> randomUser'' isCreator hasPassword hasEmail -randomUser'' :: HasCallStack => Bool -> Bool -> Bool -> TestM User +randomUser'' :: (HasCallStack) => Bool -> Bool -> Bool -> TestM User randomUser'' isCreator hasPassword hasEmail = selfUser <$> randomUserProfile' isCreator hasPassword hasEmail -randomUserProfile' :: HasCallStack => Bool -> Bool -> Bool -> TestM SelfProfile +randomUserProfile' :: (HasCallStack) => Bool -> Bool -> Bool -> TestM SelfProfile randomUserProfile' isCreator hasPassword hasEmail = randomUserProfile'' isCreator hasPassword hasEmail <&> fst -randomUserProfile'' :: HasCallStack => Bool -> Bool -> Bool -> TestM (SelfProfile, (Email, Phone)) +randomUserProfile'' :: (HasCallStack) => Bool -> Bool -> Bool -> TestM (SelfProfile, Email) randomUserProfile'' isCreator hasPassword hasEmail = do b <- view tsBrig e <- liftIO randomEmail - p <- liftIO randomPhone let pl = object $ ["name" .= fromEmail e] <> ["password" .= defPassword | hasPassword] <> ["email" .= fromEmail e | hasEmail] - <> ["phone" .= fromPhone p] <> ["team" .= BindingNewTeam (newNewTeam (unsafeRange "teamName") DefaultIcon) | isCreator] - (,(e, p)) . responseJsonUnsafe <$> (post (b . path "/i/users" . Bilge.json pl) (post (b . path "/i/users" . Bilge.json pl) m Phone -randomPhone = liftIO $ do - nrs <- map show <$> replicateM 14 (randomRIO (0, 9) :: IO Int) - let phone = parsePhone . Text.pack $ "+0" ++ concat nrs - pure $ fromMaybe (error "Invalid random phone#") phone - -randomEmailUser :: HasCallStack => TestM (UserId, Email) -randomEmailUser = randomUserProfile'' False False True <&> bimap (User.userId . selfUser) fst - -randomPhoneUser :: HasCallStack => TestM (UserId, Phone) -randomPhoneUser = randomUserProfile'' False False True <&> bimap (User.userId . selfUser) snd - -randomEmailPhoneUser :: HasCallStack => TestM (UserId, (Email, Phone)) -randomEmailPhoneUser = randomUserProfile'' False False True <&> first (User.userId . selfUser) +randomEmailUser :: (HasCallStack) => TestM (UserId, Email) +randomEmailUser = randomUserProfile'' False False True <&> first (User.userId . selfUser) defPassword :: PlainTextPassword8 defPassword = plainTextPassword8Unsafe "topsecretdefaultpassword" -randomEmail :: MonadIO m => m Email +randomEmail :: (MonadIO m) => m Email randomEmail = do uid <- liftIO nextRandom pure $ Email ("success+" <> UUID.toText uid) "simulator.amazonses.com" @@ -135,7 +121,7 @@ setHandle uid h = do !!! do const 200 === statusCode -randomHandle :: MonadIO m => m Text +randomHandle :: (MonadIO m) => m Text randomHandle = liftIO $ do nrs <- replicateM 21 (randomRIO (97, 122)) -- a-z pure (Text.pack (map chr nrs)) @@ -145,10 +131,10 @@ refreshIndex = do brig <- view tsBrig post (brig . path "/i/index/refresh") !!! const 200 === statusCode -addUserToTeam :: HasCallStack => UserId -> TeamId -> TestM TeamMember +addUserToTeam :: (HasCallStack) => UserId -> TeamId -> TestM TeamMember addUserToTeam = addUserToTeamWithRole Nothing -addUserToTeamWithRole :: HasCallStack => Maybe Role -> UserId -> TeamId -> TestM TeamMember +addUserToTeamWithRole :: (HasCallStack) => Maybe Role -> UserId -> TeamId -> TestM TeamMember addUserToTeamWithRole role inviter tid = do (inv, rsp2) <- addUserToTeamWithRole' role inviter tid let invitee :: User = responseJsonUnsafe rsp2 @@ -160,7 +146,7 @@ addUserToTeamWithRole role inviter tid = do liftIO $ assertEqual "Wrong cookie" (Just "zuid") (setCookieName <$> zuid) pure mem -addUserToTeamWithRole' :: HasCallStack => Maybe Role -> UserId -> TeamId -> TestM (Invitation, ResponseLBS) +addUserToTeamWithRole' :: (HasCallStack) => Maybe Role -> UserId -> TeamId -> TestM (Invitation, ResponseLBS) addUserToTeamWithRole' role inviter tid = do brig <- view tsBrig inviteeEmail <- randomEmail @@ -187,7 +173,7 @@ acceptInviteBody email code = "team_code" .= code ] -getInvitationCode :: HasCallStack => TeamId -> InvitationId -> TestM InvitationCode +getInvitationCode :: (HasCallStack) => TeamId -> InvitationId -> TestM InvitationCode getInvitationCode t ref = do brig <- view tsBrig let getm :: TestM (Maybe InvitationCode) @@ -233,7 +219,7 @@ zConn = header "Z-Connection" zType :: ByteString -> Request -> Request zType = header "Z-Type" -getTeamMember :: HasCallStack => UserId -> TeamId -> UserId -> TestM TeamMember +getTeamMember :: (HasCallStack) => UserId -> TeamId -> UserId -> TestM TeamMember getTeamMember getter tid gettee = do g <- view tsGalley getTeamMember' g getter tid gettee diff --git a/tools/test-stats/Main.hs b/tools/test-stats/Main.hs index 7c97134cbbb..c825fca8fbc 100644 --- a/tools/test-stats/Main.hs +++ b/tools/test-stats/Main.hs @@ -166,6 +166,6 @@ pushToPostgresql opts (reports, failedRuns, successfulRuns) = do map (testCaseRunId,) report.failureDesc void $ MonoidalMap.traverseWithKey saveTestCaseRun reports -extractId :: HasCallStack => [Only Int] -> IO Int +extractId :: (HasCallStack) => [Only Int] -> IO Int extractId [] = error $ "No ID returned by query" extractId (Only x : _) = pure x diff --git a/weeder.toml b/weeder.toml new file mode 100644 index 00000000000..5e2042081e4 --- /dev/null +++ b/weeder.toml @@ -0,0 +1,6 @@ +# weeder intro and further reading: https://github.com/ocharles/weeder?tab=readme-ov-file#weeder +roots = ["^Main.main$", "^Paths_.*", "^Testlib.RunServices.main$", "^Testlib.Run.main$", "^Test.Wire.API.Golden.Run.main$"] +type-class-roots = true # `root-instances` is more precise, but requires more config maintenance. + +# FUTUREWORK: unused-types = true +# FUTUREWORK: type-class-roots = false, and see how bad it gets