diff --git a/.dockerignore b/.dockerignore index f23c963a41..2caea16db9 100644 --- a/.dockerignore +++ b/.dockerignore @@ -9,3 +9,6 @@ .stack-root-buildah .local services/nginz/src/objs +dist-newstyle +.env +.direnv diff --git a/.hlint.yaml b/.hlint.yaml new file mode 100644 index 0000000000..ad6303e32d --- /dev/null +++ b/.hlint.yaml @@ -0,0 +1,15 @@ +# We need quasi quotes support. +- arguments: [ -XQuasiQuotes, --color ] +# Used to enforce ormolu styling. Can be revisited if we change formatters. +- ignore: { name: Redundant $ } +- ignore: { name: Redundant do } +- ignore: { name: Use newtype instead of data } +# +# Left for the programmer to decide. See discussion at https://github.com/wireapp/wire-server/pull/2382#discussion_r871194424 +- ignore: { name: Avoid lambda } +- ignore: { name: Avoid lambda using `infix` } + +- ignore: { name: Use section } +# custom rules: +- hint: { lhs: (() <$), rhs: void } +- hint: { lhs: return, rhs: pure } diff --git a/CHANGELOG.md b/CHANGELOG.md index 106b132cdf..75b092df18 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,92 @@ +# [2022-06-07] (Chart Release 4.13.0) + +## Release notes + + +* The `.cannon.drainTimeout` setting on the wire-server helm chart has been + removed and replaced with `.cannon.config.drainOpts`. (#2416) + +* Note for wire.com operators: deploy nginz (#2439) + + +## API changes + + +* Disable rate limiting for /api-version (#2439) + + +## Features + + +* Drain websockets in a controlled fashion when cannon receives a SIGTERM or + SIGINT. Instead of waiting for connections to close on their own, the websockets + are now severed at a controlled pace. This allows for quicker rollouts of new + versions. (#2416) + +* Optionally allow to run cannon with its own nginz inside the same pod; and connect to a load balancer directly. + This allows the cannon-slow-drain behaviour implemented in #2416 to take effect by not having other intermediate network hops which could break websocket connections all at once. + Some (internal) context: https://wearezeta.atlassian.net/wiki/spaces/PS/pages/585564424/How+to+gracefully+drain+cannon+but+not+so+slowly + For details on how to configure this, see docs/src/how-to/install/configuration-options.rst (#2421) + +* Support running brig with GeoIP database when using helm charts (#2406) + +* charts/nginz: Add upstream configuration for galeb (#2444) + +* charts/nginz: Allow upstreams to be in other namespaces (#2444) + +* CSV export in team management now includes the number of devices per user (#2407) + + +## Bug fixes and other updates + + +* When an IdP issuer (aka entity ID) is updated, the old issuer was still marked as "in use". (#2400) + +* On actions that require re-authentication a password is not required if the user has SAML credentials (#2430, #2434, #2437) + + +## Documentation + + +* Feature configs should have different swagger schema names (#2425) + + +## Internal changes + + +* `AllFeatureConfigs` is now typed (#2403) + +* Type class for default team feature status (#2404) + +* charts/{redis-ephemeral,legalhold}: Use old index for bitnami repo as the new index doesn't have old versions of postgresql and redis helm charts (#2448) + +* Bump haskell/zlib version to 0.6.3.0 (#2431) + +* New internal brig endpoints for MLS KeyPackage -> Conversation association query/update (#2375) + +* galley: refactor withSettingsOverrides (#2381) + +* charts/{nginz,cannon}: Increase map_hash_bucket_size for nginx to 128 (#2443) + +* charts/{cannon,nginz}: values listed in + `nginx_conf.randomport_allowlisted_origins` must be full hostnames. Hostnames + listed here will be allowlisted with and without TLS. (#2438) + +* Remove binding of users to saml idps using saml (this has never been picked up by clients; use scim instead) (#2441) + +* Remove golden test case generator + + (#2442) + +* Convert Team CSV endpoint to Servant (#2419) + + +## Federation changes + + +* Send only the raw welcome message in the Galley "mls-welcome" federation endpoint (#2412) + + # [2022-05-18] (Chart Release 4.12.0) ## Release notes diff --git a/Makefile b/Makefile index f32542ca2d..8ccab6b483 100644 --- a/Makefile +++ b/Makefile @@ -79,7 +79,7 @@ ci: c # pass target=package:name to specify which target is watched. .PHONY: ghcid ghcid: - ghcid --command "cabal repl $(target)" + ghcid -l=hlint --command "cabal repl $(target)" # reset db using cabal .PHONY: db-reset-package diff --git a/cabal.project.freeze b/cabal.project.freeze index ad4f6d1504..c3c62797a6 100644 --- a/cabal.project.freeze +++ b/cabal.project.freeze @@ -2754,7 +2754,7 @@ constraints: any.AC-Angle ==1.0, any.zip-stream ==0.2.1.0, any.zipper-extra ==0.1.3.2, any.zippers ==0.3.2, - any.zlib ==0.6.2.3, + any.zlib ==0.6.3.0, any.zlib-bindings ==0.1.1.5, any.zlib-lens ==0.1.2.1, any.zot ==0.0.3, diff --git a/charts/brig/templates/configmap.yaml b/charts/brig/templates/configmap.yaml index 21a67cff69..7b06eb9b55 100644 --- a/charts/brig/templates/configmap.yaml +++ b/charts/brig/templates/configmap.yaml @@ -202,6 +202,11 @@ data: {{- end }} {{- end }} + {{- if .geoip.enabled }} + # Shared emptyDir with geoipupdate container + geoDb: /usr/share/GeoIP/GeoIP2-City.mmdb + {{- end }} + {{- with .optSettings }} optSettings: setActivationTimeout: {{ .setActivationTimeout }} diff --git a/charts/brig/templates/deployment.yaml b/charts/brig/templates/deployment.yaml index 050d2456c4..531f816948 100644 --- a/charts/brig/templates/deployment.yaml +++ b/charts/brig/templates/deployment.yaml @@ -42,6 +42,40 @@ spec: - name: "brig-secrets" secret: secretName: "brig" + {{- if .Values.config.geoip.enabled }} + - name: "geoip" + emptyDir: {} + {{- end }} + {{- if .Values.config.geoip.enabled }} + # Brig needs GeoIP database to be downloaded before it can start. + initContainers: + - name: geoipdownload + image: "{{ .Values.config.geoip.image.repository }}:{{ .Values.config.geoip.image.tag }}" + imagePullPolicy: {{ default "" .Values.config.geoip.imagePullPolicy | quote }} + volumeMounts: + - name: "geoip" + mountPath: "/usr/share/GeoIP" + # The environment variables are documented at: + # https://github.com/maxmind/geoipupdate/blob/62b34e648a842dc03ccf4ad3f61e2d85eaec98fc/doc/docker.md + env: + - name: GEOIPUPDATE_ACCOUNT_ID + valueFrom: + secretKeyRef: + name: brig-geoip + key: accountId + - name: GEOIPUPDATE_LICENSE_KEY + valueFrom: + secretKeyRef: + name: brig-geoip + key: licenseKey + - name: GEOIPUPDATE_EDITION_IDS + valueFrom: + secretKeyRef: + name: brig-geoip + key: editionIds + - name: GEOIPUPDATE_FREQUENCY + value: "0" # Setting this to 0 makes the script only run geoipupdate once. + {{- end }} containers: - name: brig image: "{{ .Values.image.repository }}:{{ .Values.image.tag }}" @@ -55,6 +89,10 @@ spec: - name: "turn-servers" mountPath: "/etc/wire/brig/turn" {{- end }} + {{- if .Values.config.geoip.enabled }} + - name: "geoip" + mountPath: "/usr/share/GeoIP" + {{- end }} env: - name: LOG_LEVEL value: {{ .Values.config.logLevel }} @@ -107,3 +145,31 @@ spec: port: {{ .Values.service.internalPort }} resources: {{ toYaml .Values.resources | indent 12 }} + {{- if .Values.config.geoip.enabled }} + - name: geoipupdate + image: "{{ .Values.config.geoip.image.repository }}:{{ .Values.config.geoip.image.tag }}" + imagePullPolicy: {{ default "" .Values.config.geoip.imagePullPolicy | quote }} + volumeMounts: + - name: "geoip" + mountPath: "/usr/share/GeoIP" + # The environment variables are documented at: + # https://github.com/maxmind/geoipupdate/blob/62b34e648a842dc03ccf4ad3f61e2d85eaec98fc/doc/docker.md + env: + - name: GEOIPUPDATE_ACCOUNT_ID + valueFrom: + secretKeyRef: + name: brig-geoip + key: accountId + - name: GEOIPUPDATE_LICENSE_KEY + valueFrom: + secretKeyRef: + name: brig-geoip + key: licenseKey + - name: GEOIPUPDATE_EDITION_IDS + valueFrom: + secretKeyRef: + name: brig-geoip + key: editionIds + - name: GEOIPUPDATE_FREQUENCY + value: "24" # hours + {{- end }} diff --git a/charts/brig/templates/geoip-secret.yaml b/charts/brig/templates/geoip-secret.yaml new file mode 100644 index 0000000000..db6df8a1ee --- /dev/null +++ b/charts/brig/templates/geoip-secret.yaml @@ -0,0 +1,18 @@ +{{- if .Values.config.geoip.enabled }} +apiVersion: v1 +kind: Secret +metadata: + name: brig-geoip + labels: + wireService: brig + chart: {{ .Chart.Name }}-{{ .Chart.Version | replace "+" "_" }} + release: "{{ .Release.Name }}" + heritage: "{{ .Release.Service }}" +type: Opaque +data: + {{- with .Values.secrets.geoip }} + accountId: {{ required ".secrets.geoip.accountId must be provided when .Values.config.geoip.enabled is True" .accountId | b64enc | quote }} + licenseKey: {{ required ".secrets.geoip.licenseKey must be provided when .Values.config.geoip.enabled is True" .licenseKey | b64enc | quote }} + editionIds: {{ required ".secrets.geoip.editionIds must be provided when .Values.config.geoip.enabled is True" .editionIds | b64enc | quote }} + {{- end }} +{{- end }} diff --git a/charts/brig/values.yaml b/charts/brig/values.yaml index 0ffd06f651..0106d38620 100644 --- a/charts/brig/values.yaml +++ b/charts/brig/values.yaml @@ -84,6 +84,14 @@ config: smtp: passwordFile: /etc/wire/brig/secrets/smtp-password.txt proxy: {} + + geoip: + # When enabling this, .secrets.geoip.accountId, .secrets.geoip.licenseKey and + # .secret.geoip.editionIds must be provided. + enabled: false + image: + repository: docker.io/maxmindinc/geoipupdate + tag: v4.9 turnStatic: v1: - turn:localhost:3478 diff --git a/charts/cannon/conf/static/zauth.acl b/charts/cannon/conf/static/zauth.acl new file mode 100644 index 0000000000..9498b8cc43 --- /dev/null +++ b/charts/cannon/conf/static/zauth.acl @@ -0,0 +1,17 @@ +a (blacklist (path "/provider") + (path "/provider/**") + (path "/bot") + (path "/bot/**") + (path "/i/**")) + +b (whitelist (path "/bot") + (path "/bot/**")) + +p (whitelist (path "/provider") + (path "/provider/**")) + +# LegalHold Access Tokens +la (whitelist (path "/notifications") + (path "/assets/v3/**") + (path "/users") + (path "/users/**")) diff --git a/charts/cannon/templates/conf/_nginx.conf.tpl b/charts/cannon/templates/conf/_nginx.conf.tpl new file mode 100644 index 0000000000..2b20ba84be --- /dev/null +++ b/charts/cannon/templates/conf/_nginx.conf.tpl @@ -0,0 +1,352 @@ +{{- define "cannon_nginz_nginx.conf" }} +user {{ .Values.nginx_conf.user }} {{ .Values.nginx_conf.group }}; +worker_processes {{ .Values.nginx_conf.worker_processes }}; +worker_rlimit_nofile {{ .Values.nginx_conf.worker_rlimit_nofile | default 1024 }}; +pid /var/run/nginz.pid; + +# nb. start up errors (eg. misconfiguration) may still end up in +# /var/log/nginz/error.log +error_log stderr warn; + +events { + worker_connections {{ .Values.nginx_conf.worker_connections | default 1024 }}; + multi_accept off; + use epoll; +} + +http { + # + # Sockets + # + + sendfile on; + tcp_nopush on; + tcp_nodelay on; + + # + # Timeouts + # + + client_body_timeout 60; + client_header_timeout 60; + keepalive_timeout 75; + send_timeout 60; + + ignore_invalid_headers off; + + types_hash_max_size 2048; + map_hash_bucket_size 128; + + server_names_hash_bucket_size 64; + server_name_in_redirect off; + + large_client_header_buffers 4 8k; + + + # + # Security + # + + server_tokens off; + + # + # Logging + # + # Note sanitized_request: + # We allow passing access_token as query parameter for e.g. websockets + # However we do not want to log access tokens. + # + + log_format custom_zeta '$remote_addr $remote_user "$time_local" "$sanitized_request" $status $body_bytes_sent "$http_referer" "$http_user_agent" $http_x_forwarded_for $connection $request_time $upstream_response_time $upstream_cache_status $zauth_user $zauth_connection $request_id $proxy_protocol_addr "$http_tracestate"'; + access_log /dev/stdout custom_zeta; + + # + # Monitoring + # + vhost_traffic_status_zone; + + # + # Gzip + # + + gzip on; + gzip_disable msie6; + gzip_vary on; + gzip_proxied any; + gzip_comp_level 6; + gzip_buffers 16 8k; + gzip_http_version 1.1; + gzip_min_length 1024; + gzip_types text/plain text/css application/json application/x-javascript text/xml application/xml application/xml+rss text/javascript; + + # + # This directive ensures that X-Forwarded-For is used + # as the client's real IP address (since nginz is always + # behind an ELB, remote_addr now becomes the client's real + # IP address) + # + + real_ip_header X-Forwarded-For; + set_real_ip_from 0.0.0.0/0; + + # + # Rate Limiting Exemptions + # + + geo $rate_limit { + default 1; + + # IPs to exempt can be added in the .Values.nginx_conf.rate_limit and .Values.nginx_conf.simulators helm values + {{ if (hasKey .Values.nginx_conf "rate_limit_exemptions") }} + {{ range $ip := .Values.nginx_conf.rate_limit_exemptions }} + {{ $ip }} 0; + {{ end }} + {{ end }} + + {{ if (hasKey .Values.nginx_conf "simulators") }} + {{ range $ip := .Values.nginx_conf.simulators }} + {{ $ip }} 0; + {{ end }} + {{ end }} + } + + # + # Rate Limiting Mapping + # + + map $rate_limit $rate_limited_by_addr { + 1 "$binary_remote_addr$uri"; + 0 ""; + } + + map $rate_limit $rate_limited_by_zuser { + 1 $zauth_user; + 0 ""; + } + + map $http_origin $cors_header { + default ""; + {{ range $origin := .Values.nginx_conf.allowlisted_origins }} + "https://{{ $origin }}.{{ $.Values.nginx_conf.external_env_domain}}" "$http_origin"; + {{ end }} + + # Allow additional origins at random ports. This is useful for testing with an HTTP proxy. + # It should not be used in production. + {{ range $origin := .Values.nginx_conf.randomport_allowlisted_origins }} + "~^https?://{{ $origin }}(:[0-9]{2,5})?$" "$http_origin"; + {{ end }} + } + + + # + # Rate Limiting + # + + limit_req_zone $rate_limited_by_zuser zone=reqs_per_user:12m rate=10r/s; + limit_req_zone $rate_limited_by_addr zone=reqs_per_addr:12m rate=5r/m; + +{{- range $limit := .Values.nginx_conf.user_rate_limit_request_zones }} + {{ $limit }} +{{- end }} + + limit_conn_zone $rate_limited_by_zuser zone=conns_per_user:10m; + limit_conn_zone $rate_limited_by_addr zone=conns_per_addr:10m; + + # Too Many Requests (420) is returned on throttling + # TODO: Change to 429 once all clients support this + limit_req_status 420; + limit_conn_status 420; + + limit_req_log_level warn; + limit_conn_log_level warn; + + # Limit by $zauth_user if present and not part of rate limit exemptions + limit_req zone=reqs_per_user burst=20; + limit_conn conns_per_user 25; + + # + # Proxied Upstream Services + # + + upstream cannon { + least_conn; + keepalive 32; + server localhost:{{ .Values.service.internalPort }}; + } + + # + # Mapping for websocket connections + # + + map $http_upgrade $connection_upgrade { + websocket upgrade; + default ''; + } + + + + # + # Locations + # + + server { + listen {{ .Values.service.nginz.internalPort }} ssl; + + ssl_certificate /etc/wire/nginz/tls/tls.crt; + ssl_certificate_key /etc/wire/nginz/tls/tls.key; + + ssl_protocols {{ .Values.nginx_conf.tls.protocols }}; + ssl_ciphers {{ .Values.nginx_conf.tls.ciphers }}; + + # Disable session resumption. See comments in SQPIT-226 for more context and + # discussion. + ssl_session_tickets off; + ssl_session_cache off; + + zauth_keystore {{ .Values.nginx_conf.zauth_keystore }}; + zauth_acl {{ .Values.nginx_conf.zauth_acl }}; + + location /status { + zauth off; + access_log off; + + return 200; + } + + location /vts { + zauth off; + access_log off; + allow 10.0.0.0/8; + allow 127.0.0.1; + deny all; + + # Requests with an X-Forwarded-For header will have the real client + # source IP address set correctly, due to the real_ip_header directive + # in the top-level configuration. However, this will not set the client + # IP correctly for clients which are connected via a load balancer which + # uses the PROXY protocol. + # + # Hence, for safety, we deny access to the vts metrics endpoints to + # clients which are connected via PROXY protocol. + if ($proxy_protocol_addr != "") { + return 403; + } + + vhost_traffic_status_display; + vhost_traffic_status_display_format html; + } + + # Block "Franz" -- http://meetfranz.com + if ($http_user_agent ~* Franz) { + return 403; + } + + {{ range $path := .Values.nginx_conf.disabled_paths }} + location ~* ^(/v[0-9]+)?{{ $path }} { + + return 404; + } + {{ end }} + + # + # Service Routing + # + + {{ range $name, $locations := .Values.nginx_conf.upstreams -}} + {{- range $location := $locations -}} + {{- if hasKey $location "envs" -}} + {{- range $env := $location.envs -}} + {{- if or (eq $env $.Values.nginx_conf.env) (eq $env "all") -}} + + {{- if $location.strip_version }} + + rewrite ^/v[0-9]+({{ $location.path }}) $1; + {{- end }} + + {{- $versioned := ternary $location.versioned true (hasKey $location "versioned") -}} + {{- $path := printf "%s%s" (ternary "(/v[0-9]+)?" "" $versioned) $location.path }} + + location ~* ^{{ $path }} { + + # remove access_token from logs, see 'Note sanitized_request' above. + set $sanitized_request $request; + if ($sanitized_request ~ (.*)access_token=[^&\s]*(.*)) { + set $sanitized_request $1access_token=****$2; + } + + {{- if ($location.disable_zauth) }} + zauth off; + + # If zauth is off, limit by remote address if not part of limit exemptions + {{- if ($location.unlimited_requests_endpoint) }} + # Note that this endpoint has no rate limit + {{- else -}} + limit_req zone=reqs_per_addr burst=5 nodelay; + limit_conn conns_per_addr 20; + {{- end -}} + {{- else }} + + {{- if hasKey $location "specific_user_rate_limit" }} + limit_req zone={{ $location.specific_user_rate_limit }} nodelay; + {{- end }} + {{- end }} + + if ($request_method = 'OPTIONS') { + add_header 'Access-Control-Allow-Methods' "GET, POST, PUT, DELETE, OPTIONS"; + add_header 'Access-Control-Allow-Headers' "$http_access_control_request_headers, DNT,X-Mx-ReqToken,Keep-Alive,User-Agent,X-Requested-With,If-Modified-Since,Cache-Control,Content-Type"; + add_header 'Content-Type' 'text/plain; charset=UTF-8'; + add_header 'Content-Length' 0; + return 204; + } + + proxy_pass http://{{ $name }}{{ if hasKey $.Values.nginx_conf.upstream_namespace $name }}.{{ get $.Values.nginx_conf.upstream_namespace $name }}{{end}}; + proxy_http_version 1.1; + + {{- if ($location.disable_request_buffering) }} + proxy_request_buffering off; + {{ end -}} + {{- if (hasKey $location "body_buffer_size") }} + client_body_buffer_size {{ $location.body_buffer_size -}}; + {{- end }} + client_max_body_size {{ $location.max_body_size | default "64k" }}; + + {{ if ($location.use_websockets) }} + proxy_set_header Upgrade $http_upgrade; + proxy_set_header Connection $connection_upgrade; + proxy_read_timeout 1h; + {{- else }} + proxy_set_header Connection ""; + {{ end -}} + + {{- if not ($location.disable_zauth) }} + proxy_set_header Authorization ""; + {{- end }} + + proxy_set_header Z-Type $zauth_type; + proxy_set_header Z-User $zauth_user; + proxy_set_header Z-Connection $zauth_connection; + proxy_set_header Z-Provider $zauth_provider; + proxy_set_header Z-Bot $zauth_bot; + proxy_set_header Z-Conversation $zauth_conversation; + proxy_set_header Request-Id $request_id; + + {{- if ($location.allow_credentials) }} + more_set_headers 'Access-Control-Allow-Credentials: true'; + {{ end -}} + + more_set_headers 'Access-Control-Allow-Origin: $cors_header'; + + more_set_headers 'Access-Control-Expose-Headers: Request-Id, Location'; + more_set_headers 'Request-Id: $request_id'; + more_set_headers 'Strict-Transport-Security: max-age=31536000; preload'; + } + + {{- end -}} + {{- end -}} + + {{- end -}} + {{- end -}} + {{- end }} + } +} +{{- end }} diff --git a/charts/cannon/templates/configmap.yaml b/charts/cannon/templates/configmap.yaml index a7057e26b7..17a00a5c7e 100644 --- a/charts/cannon/templates/configmap.yaml +++ b/charts/cannon/templates/configmap.yaml @@ -1,8 +1,7 @@ apiVersion: v1 data: cannon.yaml: | - logNetStrings: True # log using netstrings encoding: - # http://cr.yp.to/proto/netstrings.txt + logFormat: StructuredJSON logLevel: {{ .Values.config.logLevel }} cannon: @@ -13,6 +12,12 @@ data: gundeck: host: gundeck port: 8080 + + drainOpts: + gracePeriodSeconds: {{ .Values.config.drainOpts.gracePeriodSeconds }} + millisecondsBetweenBatches: {{ .Values.config.drainOpts.millisecondsBetweenBatches }} + minBatchSize: {{ .Values.config.drainOpts.minBatchSize }} + kind: ConfigMap metadata: name: cannon diff --git a/charts/cannon/templates/nginz-certificate-secret.yaml b/charts/cannon/templates/nginz-certificate-secret.yaml new file mode 100644 index 0000000000..4531ad19e3 --- /dev/null +++ b/charts/cannon/templates/nginz-certificate-secret.yaml @@ -0,0 +1,16 @@ +{{- if and .Values.service.nginz.enabled (not .Values.service.nginz.certManager.enabled ) }} +apiVersion: v1 +kind: Secret +metadata: + name: {{ .Values.service.nginz.tls.secretName }} + labels: + wireService: cannon-nginz + app: cannon-nginz + chart: "{{ .Chart.Name }}-{{ .Chart.Version }}" + release: "{{ .Release.Name }}" + heritage: "{{ .Release.Service }}" +type: kubernetes.io/tls +data: + tls.crt: {{ .Values.secrets.nginz.tls.crt }} + tls.key: {{ .Values.secrets.nginz.tls.key }} +{{- end }} diff --git a/charts/cannon/templates/nginz-certificate.yaml b/charts/cannon/templates/nginz-certificate.yaml new file mode 100644 index 0000000000..4245befdfb --- /dev/null +++ b/charts/cannon/templates/nginz-certificate.yaml @@ -0,0 +1,30 @@ +{{- if and .Values.service.nginz.enabled .Values.service.nginz.certManager.enabled -}} +apiVersion: cert-manager.io/v1 +kind: Certificate +metadata: + name: {{ .Values.service.nginz.certManager.certificate.name }} + namespace: {{ .Release.Namespace }} + labels: + chart: "{{ .Chart.Name }}-{{ .Chart.Version }}" + release: "{{ .Release.Name }}" + heritage: "{{ .Release.Service }}" +spec: + issuerRef: + name: {{ .Values.service.nginz.certManager.issuer.name }} + kind: {{ .Values.service.nginz.certManager.issuer.kind }} + usages: + - server auth + duration: 2160h # 90d, Letsencrypt default; NOTE: changes are ignored by Letsencrypt + renewBefore: 360h # 15d + isCA: false + secretName: {{ .Values.service.nginz.tls.secretName }} + + privateKey: + algorithm: ECDSA + size: 384 # 521 is not supported by Letsencrypt + encoding: PKCS1 + rotationPolicy: Always + + dnsNames: + - {{ required "Please provide .service.nginz.hostname when .service.nginz.enabled and .service.nginz.certManager.enabled are True" .Values.service.nginz.hostname | quote }} +{{- end -}} diff --git a/charts/cannon/templates/nginz-configmap.yaml b/charts/cannon/templates/nginz-configmap.yaml new file mode 100644 index 0000000000..9c946455c9 --- /dev/null +++ b/charts/cannon/templates/nginz-configmap.yaml @@ -0,0 +1,10 @@ +{{- if .Values.service.nginz.enabled }} +apiVersion: v1 +kind: ConfigMap +metadata: + name: cannon-nginz +data: + nginx.conf: |2 +{{- include "cannon_nginz_nginx.conf" . | indent 4 }} +{{ (.Files.Glob "conf/static/*").AsConfig | indent 2 }} +{{- end }} diff --git a/charts/cannon/templates/nginz-secret.yaml b/charts/cannon/templates/nginz-secret.yaml new file mode 100644 index 0000000000..23dd7c7d0c --- /dev/null +++ b/charts/cannon/templates/nginz-secret.yaml @@ -0,0 +1,20 @@ +{{- if .Values.service.nginz.enabled }} +apiVersion: v1 +kind: Secret +metadata: + name: cannon-nginz + labels: + wireService: cannon-nginz + app: cannon-nginz + chart: "{{ .Chart.Name }}-{{ .Chart.Version }}" + release: "{{ .Release.Name }}" + heritage: "{{ .Release.Service }}" +type: Opaque +data: + {{/* for_helm_linting is necessary only since the 'with' block below does not throw an error upon an empty .Values.secrets */}} + for_helm_linting: {{ required "No .secrets found in configuration. Did you forget to helm -f path/to/secrets.yaml ?" .Values.secrets | quote | b64enc | quote }} + + {{- with .Values.secrets.nginz }} + zauth.conf: {{ .zAuth.publicKeys | b64enc | quote }} + {{- end }} +{{- end }} diff --git a/charts/cannon/templates/nginz-service.yaml b/charts/cannon/templates/nginz-service.yaml new file mode 100644 index 0000000000..fd820c2b75 --- /dev/null +++ b/charts/cannon/templates/nginz-service.yaml @@ -0,0 +1,40 @@ +{{- if .Values.service.nginz.enabled }} +# This service has to be exposed using type `LoadBalancer` to ensure that there +# is no other pod between the load balancer and this service. This ensures that +# only thing which disrupts the websocket connection is when a cannon pod gets +# stopped. If, like other services we have a separate nginz and an +# ingress-controller between the load balancer and the service, stopping any of +# these pods would cause websockets to be disrupted. +# +# In the future, if desired, type=LoadBalancer could also become type=NodePort +# if this is needed on some environments without loadbalancer support. +apiVersion: v1 +kind: Service +metadata: + name: {{ .Values.service.nginz.name }} + labels: + wireService: cannon + chart: {{ .Chart.Name }}-{{ .Chart.Version | replace "+" "_" }} + release: {{ .Release.Name }} + heritage: {{ .Release.Service }} + annotations: + {{- if .Values.service.nginz.externalDNS.enabled }} + external-dns.alpha.kubernetes.io/ttl: {{ .Values.service.nginz.externalDNS.ttl | quote }} + external-dns.alpha.kubernetes.io/hostname: {{ required "Please provide .service.nginz.hostname when .service.nginz.enabled and .service.nginz.externalDNS.enabled are True" .Values.service.nginz.hostname | quote }} + {{- end }} +{{ toYaml .Values.service.nginz.annotations | indent 4 }} +spec: + type: LoadBalancer + # This ensures websocket traffic does not go from one kubernetes node to + # another, if that happened, restarting the originating kubernetes node would + # cause all websocket connections to be severed at once. + externalTrafficPolicy: "Local" + ports: + - name: http + port: {{ .Values.service.nginz.externalPort }} + targetPort: {{ .Values.service.nginz.internalPort }} + protocol: TCP + selector: + wireService: cannon + release: {{ .Release.Name }} +{{- end }} diff --git a/charts/cannon/templates/statefulset.yaml b/charts/cannon/templates/statefulset.yaml index d0397c07a1..c9adaae62b 100644 --- a/charts/cannon/templates/statefulset.yaml +++ b/charts/cannon/templates/statefulset.yaml @@ -29,18 +29,59 @@ spec: release: {{ .Release.Name }} annotations: checksum/configmap: {{ include (print .Template.BasePath "/configmap.yaml") . | sha256sum }} + {{- if .Values.service.nginz.enabled }} + checksum/nginz-configmap: {{ include (print .Template.BasePath "/nginz-configmap.yaml") . | sha256sum }} + {{- end }} spec: - terminationGracePeriodSeconds: {{ .Values.drainTimeout }} # should be higher than the sleep duration of preStop + terminationGracePeriodSeconds: {{ add .Values.config.drainOpts.gracePeriodSeconds 5 }} containers: - - name: cannon - image: "{{ .Values.image.repository }}:{{ .Values.image.tag }}" + {{- if .Values.service.nginz.enabled }} + - name: nginz + image: "{{ .Values.nginzImage.repository }}:{{ .Values.nginzImage.tag }}" + imagePullPolicy: "{{ .Values.nginzImage.pullPolicy }}" + env: + # Any file changes to this path causes nginx to reload configs without + # restarting or breaking any connections. + - name: WATCH_PATHS + value: "/etc/wire/nginz/tls" + volumeMounts: + - name: nginz-config + mountPath: /etc/wire/nginz/conf + readOnly: true + - name: nginz-secrets + mountPath: /etc/wire/nginz/secrets + readOnly: true + - name: certificate + mountPath: /etc/wire/nginz/tls + readOnly: true + ports: + - name: https + containerPort: {{ .Values.service.nginz.internalPort }} + readinessProbe: + httpGet: + path: /status + port: {{ .Values.service.nginz.internalPort }} + scheme: HTTPS + livenessProbe: + initialDelaySeconds: 30 + timeoutSeconds: 1 + httpGet: + path: /status + port: {{ .Values.service.nginz.internalPort }} + scheme: HTTPS lifecycle: preStop: - # kubernetes by default immediately sends a SIGTERM to the container, - # which would cause cannon to exit, breaking existing websocket connections. - # Instead we sleep for a day. (SIGTERM is still sent, but after the preStop completes) exec: - command: ["sleep", {{ .Values.drainTimeout | quote }} ] + # kubernetes by default sends a SIGTERM to the container, + # which would cause nginz to exit, breaking existing websocket connections. + # Instead we terminate gracefully and sleep given grace period + 5 seconds. + # (SIGTERM is still sent, but afterwards) + command: ["sh", "-c", "nginx -c /etc/wire/nginz/conf/nginx.conf -s quit && sleep {{ add .Values.config.drainOpts.gracePeriodSeconds 5 }}"] + resources: +{{ toYaml .Values.resources | indent 12 }} + {{- end }} + - name: cannon + image: "{{ .Values.image.repository }}:{{ .Values.image.tag }}" volumeMounts: - name: empty mountPath: /etc/wire/cannon/externalHost @@ -65,7 +106,7 @@ spec: {{ toYaml .Values.resources | indent 12 }} initContainers: - name: cannon-configurator - image: alpine:3.13.1 + image: alpine:3.15.4 command: - /bin/sh args: @@ -83,3 +124,14 @@ spec: name: cannon - name: empty emptyDir: {} + {{- if .Values.service.nginz.enabled }} + - name: nginz-config + configMap: + name: cannon-nginz + - name: nginz-secrets + secret: + secretName: cannon-nginz + - name: certificate + secret: + secretName: {{ .Values.service.nginz.tls.secretName }} + {{- end }} diff --git a/charts/cannon/values.yaml b/charts/cannon/values.yaml index 66f87bd931..f5f4970df2 100644 --- a/charts/cannon/values.yaml +++ b/charts/cannon/values.yaml @@ -3,8 +3,73 @@ image: repository: quay.io/wire/cannon tag: do-not-use pullPolicy: IfNotPresent +nginzImage: + repository: quay.io/wire/nginz + tag: do-not-use + pullPolicy: IfNotPresent config: logLevel: Info + + # See also the section 'Controlling the speed of websocket draining during + # cannon pod replacement' in docs/how-to/install/configuration-options.rst + drainOpts: + # The following drains a minimum of 400 connections/second + # for a total of 10000 over 25 seconds + # (if cannon holds more connections, draining will happen at a faster pace) + gracePeriodSeconds: 25 + millisecondsBetweenBatches: 50 + minBatchSize: 20 + +nginx_conf: + user: nginx + group: nginx + zauth_keystore: /etc/wire/nginz/secrets/zauth.conf + zauth_acl: /etc/wire/nginz/conf/zauth.acl + worker_processes: auto + worker_rlimit_nofile: 131072 + worker_connections: 65536 + disabled_paths: [] + user_rate_limit_request_zones: [] + + tls: + protocols: TLSv1.2 TLSv1.3 + # NOTE: These are some sane defaults (compliant to TR-02102-2), you may want to overrride them on your own installation + # For TR-02102-2 see https://www.bsi.bund.de/SharedDocs/Downloads/EN/BSI/Publications/TechGuidelines/TG02102/BSI-TR-02102-2.html + # As a Wire employee, for Wire-internal discussions and context see + # * https://wearezeta.atlassian.net/browse/FS-33 + # * https://wearezeta.atlassian.net/browse/FS-444 + ciphers: "TLS_AES_128_GCM_SHA256:TLS_AES_256_GCM_SHA384:ECDHE-ECDSA-AES256-GCM-SHA384:ECDHE-RSA-AES256-GCM-SHA384:ECDHE-ECDSA-AES128-GCM-SHA256:ECDHE-RSA-AES128-GCM-SHA256" + + # The origins from which we allow CORS requests. These are combined with + # 'external_env_domain' to form a full url + allowlisted_origins: + - webapp + - teams + - account + # 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. + # The list entries must be full hostnames (they are **not** combined with + # 'external_env_domain'). http and https URLs are allow listed. + randomport_allowlisted_origins: [] # default is empty by intention + + # Setting this value does nothing as the only upstream recongnized here is + # 'cannon' and is forwarded to localhost. This is here only to make sure that + # nginx.conf templating doesn't differ too much with the one in nginz helm + # chart. + upstream_namespace: {} + + # Only upstream recognized by the generated nginx config is 'cannon', the + # server for this will be cannon running on localhost. This setting is like + # this so that templating for nginx.conf doesn't differ too much from the one + # in the nginz helm chart. + upstreams: + cannon: + - path: /await + envs: + - all + use_websockets: true + +# FUTUREWORK: allow resources for cannon and nginz to be different resources: requests: memory: "256Mi" @@ -16,4 +81,26 @@ service: name: cannon internalPort: 8080 externalPort: 8080 -drainTimeout: 0 + nginz: + # Enable this only if service of `type: LoadBalancer` can work in your K8s + # cluster. + enabled: false + # hostname: # Needed when using either externalDNS or certManager + name: cannon-nginz + internalPort: 8443 + externalPort: 443 + annotations: {} + tls: + secretName: cannon-nginz-cert + externalDNS: + enabled: false + ttl: "10m" + certManager: + # When certManager is not enabled, certificates must be provided at + # .secrets.nginz.tls.crt and .secrets.nginz.tls.key. + enabled: false + certificate: + name: cannon-nginz + issuer: + name: letsencrypt + kind: ClusterIssuer diff --git a/charts/legalhold/requirements.yaml b/charts/legalhold/requirements.yaml index 3ed34d472e..9c52a54436 100644 --- a/charts/legalhold/requirements.yaml +++ b/charts/legalhold/requirements.yaml @@ -1,4 +1,8 @@ dependencies: - name: postgresql version: 9.8.12 - repository: https://charts.bitnami.com/bitnami + # Use helm repo from the git repo because bitnami removed charts from the + # official index to keep the index small. On next upgrade, this should be + # changed to use the official repo. Context: + # https://github.com/bitnami/charts/issues/10539 + repository: https://raw.githubusercontent.com/bitnami/charts/defb094c658024e4aa8245622dab202874880cbc/bitnami/ diff --git a/charts/nginx-ingress-services/templates/certificate.yaml b/charts/nginx-ingress-services/templates/certificate.yaml index 9b223f1132..58da22ac4d 100644 --- a/charts/nginx-ingress-services/templates/certificate.yaml +++ b/charts/nginx-ingress-services/templates/certificate.yaml @@ -27,7 +27,9 @@ spec: dnsNames: - {{ .Values.config.dns.https }} + {{- if .Values.websockets.enabled }} - {{ .Values.config.dns.ssl }} + {{- end }} {{- if .Values.webapp.enabled }} - {{ .Values.config.dns.webapp }} {{- end }} diff --git a/charts/nginx-ingress-services/templates/ingress.yaml b/charts/nginx-ingress-services/templates/ingress.yaml index 4ce2619ef9..39fe2e3318 100644 --- a/charts/nginx-ingress-services/templates/ingress.yaml +++ b/charts/nginx-ingress-services/templates/ingress.yaml @@ -10,7 +10,9 @@ spec: tls: - hosts: - {{ .Values.config.dns.https }} +{{- if .Values.websockets.enabled }} - {{ .Values.config.dns.ssl }} +{{- end }} {{- if .Values.webapp.enabled }} - {{ .Values.config.dns.webapp }} {{- end }} @@ -32,6 +34,7 @@ spec: backend: serviceName: nginz-http servicePort: {{ .Values.service.nginz.externalHttpPort }} +{{- if .Values.websockets.enabled }} - host: {{ .Values.config.dns.ssl }} http: paths: @@ -39,6 +42,7 @@ spec: backend: serviceName: nginz-tcp servicePort: {{ .Values.service.nginz.externalTcpPort }} +{{- end }} {{- if .Values.webapp.enabled }} - host: {{ .Values.config.dns.webapp }} http: diff --git a/charts/nginx-ingress-services/templates/service.yaml b/charts/nginx-ingress-services/templates/service.yaml index e969219700..236789b856 100644 --- a/charts/nginx-ingress-services/templates/service.yaml +++ b/charts/nginx-ingress-services/templates/service.yaml @@ -10,6 +10,7 @@ spec: targetPort: 8080 selector: wireService: nginz +{{- if .Values.websockets.enabled }} --- apiVersion: v1 kind: Service @@ -22,6 +23,7 @@ spec: targetPort: 8081 selector: wireService: nginz +{{- end }} {{- if .Values.webapp.enabled }} --- apiVersion: v1 diff --git a/charts/nginx-ingress-services/values.yaml b/charts/nginx-ingress-services/values.yaml index fba9394c0e..44f49f0847 100644 --- a/charts/nginx-ingress-services/values.yaml +++ b/charts/nginx-ingress-services/values.yaml @@ -6,6 +6,8 @@ teamSettings: # Account pages may be useful to enable password reset or email validation done after the initial registration accountPages: enabled: false +websockets: + enabled: true webapp: enabled: true fakeS3: @@ -96,7 +98,8 @@ service: # config: # dns: # https: nginz-https. -# ssl: nginz-ssl. +# ssl: nginz-ssl. # For websockets +# ^ ssl is ignored if websockets.enabled == false # webapp: webapp. # ^ webapp is ignored if webapp.enabled == false # fakeS3: assets. diff --git a/charts/nginz/templates/conf/_nginx.conf.tpl b/charts/nginz/templates/conf/_nginx.conf.tpl index cacac26849..02c422b727 100644 --- a/charts/nginz/templates/conf/_nginx.conf.tpl +++ b/charts/nginz/templates/conf/_nginx.conf.tpl @@ -35,6 +35,7 @@ http { ignore_invalid_headers off; types_hash_max_size 2048; + map_hash_bucket_size 128; server_names_hash_bucket_size 64; server_name_in_redirect off; @@ -132,7 +133,7 @@ http { # Allow additional origins at random ports. This is useful for testing with an HTTP proxy. # It should not be used in production. {{ range $origin := .Values.nginx_conf.randomport_allowlisted_origins }} - "~^https://{{ $origin }}.{{ $.Values.nginx_conf.external_env_domain}}(:[0-9]{2,5})?$" "$http_origin"; + "~^https?://{{ $origin }}(:[0-9]{2,5})?$" "$http_origin"; {{ end }} } @@ -144,6 +145,10 @@ http { limit_req_zone $rate_limited_by_zuser zone=reqs_per_user:12m rate=10r/s; limit_req_zone $rate_limited_by_addr zone=reqs_per_addr:12m rate=5r/m; +{{- range $limit := .Values.nginx_conf.user_rate_limit_request_zones }} + {{ $limit }} +{{- end }} + limit_conn_zone $rate_limited_by_zuser zone=conns_per_user:10m; limit_conn_zone $rate_limited_by_addr zone=conns_per_addr:10m; @@ -190,8 +195,6 @@ http { location /status { zauth off; access_log off; - allow 10.0.0.0/8; - deny all; return 200; } @@ -236,6 +239,7 @@ http { # {{ range $name, $locations := .Values.nginx_conf.upstreams -}} + {{- if not (has $name $.Values.nginx_conf.ignored_upstreams) -}} {{- range $location := $locations -}} {{- if hasKey $location "envs" -}} {{- range $env := $location.envs -}} @@ -277,6 +281,11 @@ http { limit_req zone=reqs_per_addr burst=5 nodelay; limit_conn conns_per_addr 20; {{- end -}} + {{- else }} + + {{- if hasKey $location "specific_user_rate_limit" }} + limit_req zone={{ $location.specific_user_rate_limit }} nodelay; + {{- end }} {{- end }} if ($request_method = 'OPTIONS') { @@ -287,7 +296,7 @@ http { return 204; } - proxy_pass http://{{ $name }}; + proxy_pass http://{{ $name }}{{ if hasKey $.Values.nginx_conf.upstream_namespace $name }}.{{ get $.Values.nginx_conf.upstream_namespace $name }}{{end}}; proxy_http_version 1.1; {{- if ($location.disable_request_buffering) }} @@ -334,6 +343,7 @@ http { {{- end -}} {{- end -}} + {{- end -}} {{- end }} {{ if not (eq $.Values.nginx_conf.env "prod") }} diff --git a/charts/nginz/templates/conf/_upstreams.txt.tpl b/charts/nginz/templates/conf/_upstreams.txt.tpl index 62994068d0..fe03dafa0f 100644 --- a/charts/nginz/templates/conf/_upstreams.txt.tpl +++ b/charts/nginz/templates/conf/_upstreams.txt.tpl @@ -1,3 +1,3 @@ {{ define "nginz_upstreams.txt" }} -{{ range $key, $value := .Values.nginx_conf.upstreams }}{{ $key }} {{ end -}} -{{ end }} +{{ range $key, $value := .Values.nginx_conf.upstreams }}{{ if not (has $key $.Values.nginx_conf.ignored_upstreams) }} {{ $key }}{{ if hasKey $.Values.nginx_conf.upstream_namespace $key }}.{{ get $.Values.nginx_conf.upstream_namespace $key }}{{end}} {{ end }}{{ end -}} +{{ end }} \ No newline at end of file diff --git a/charts/nginz/templates/deployment.yaml b/charts/nginz/templates/deployment.yaml index 0472c82c01..d790e22913 100644 --- a/charts/nginz/templates/deployment.yaml +++ b/charts/nginz/templates/deployment.yaml @@ -30,7 +30,7 @@ spec: checksum/secret: {{ include (print .Template.BasePath "/secret.yaml") . | sha256sum }} fluentbit.io/parser-nginz: nginz spec: - terminationGracePeriodSeconds: {{ .Values.terminationGracePeriodSeconds }} # should be higher than the drainTimeout (sleep duration of preStop) + terminationGracePeriodSeconds: {{ .Values.terminationGracePeriodSeconds }} containers: - name: nginz-disco image: "{{ .Values.images.nginzDisco.repository }}:{{ .Values.images.nginzDisco.tag }}" @@ -43,14 +43,6 @@ spec: readOnly: false - name: nginz image: "{{ .Values.images.nginz.repository }}:{{ .Values.images.nginz.tag }}" - lifecycle: - preStop: - exec: - # kubernetes by default sends a SIGTERM to the container, - # which would cause nginz to exit, breaking existing websocket connections. - # Instead we sleep for a day, then terminate gracefully. - # (SIGTERM is still sent, but afterwards) - command: ["sh", "-c", "sleep {{ .Values.drainTimeout }} && nginx -c /etc/wire/nginz/conf/nginx.conf -s quit"] volumeMounts: - name: secrets mountPath: /etc/wire/nginz/secrets diff --git a/charts/nginz/values.yaml b/charts/nginz/values.yaml index c0f35c83e6..972d4968d8 100644 --- a/charts/nginz/values.yaml +++ b/charts/nginz/values.yaml @@ -19,7 +19,6 @@ config: ws: wsPort: 8081 useProxyProtocol: true -drainTimeout: 0 terminationGracePeriodSeconds: 30 nginx_conf: user: nginx @@ -52,16 +51,40 @@ nginx_conf: - /conversations/([^/]*)/call/state - /search/top - /search/common - # -- The origins from which we allow CORS requests. These are combined with 'external_env_domain' to form a full url + + # This value must be a list of strings. Each string is copied verbatim into + # the nginx.conf after the default 'limit_req_zone' directives. This should be + # used to create request zones which can then be specified in + # 'upstreams...specific_user_rate_limit'. + user_rate_limit_request_zones: + - limit_req_zone $rate_limited_by_zuser zone=reqs_per_user_signatures:12m rate=10r/m; + + # The origins from which we allow CORS requests. These are combined with + # 'external_env_domain' to form a full url allowlisted_origins: - webapp - teams - account - # -- The origins from which we allow CORS requests at random ports. This is + + # 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. - # The list entries are combined with 'external_env_domain' to form a full url - # regex that matches for all ports. + # The list entries must be full hostnames (they are **not** combined with + # 'external_env_domain'). http and https URLs are allow listed. randomport_allowlisted_origins: [] # default is empty by intention + + # Add 'cannon' to 'ignored_upstreams' if you wish to make use of separate + # network traffic to cannon-with-its-own-nginz See also "Separate incoming + # websocket network traffic from the rest of the https traffic" section in the + # docs. + ignored_upstreams: [] + + # If an upstream runs in a different namespace than nginz, its namespace must + # be specified here otherwise nginz_disco will fail to find the upstream and + # nginx will think that the upstream is down. + upstream_namespace: { + # galeb: integrations + } + upstreams: cargohold: - path: /conversations/([^/]*)/assets @@ -96,6 +119,7 @@ nginx_conf: envs: - all disable_zauth: true + unlimited_requests_endpoint: true - path: /users envs: - all @@ -430,9 +454,6 @@ nginx_conf: envs: - staging versioned: false - - path: /sso-initiate-bind - envs: - - all - path: /sso/initiate-login envs: - all @@ -478,6 +499,27 @@ nginx_conf: - all versioned: false strip_version: true + galeb: + - path: /consent + envs: + - all + disable_zauth: true + versioned: false + strip_version: true + - path: /self/consent + versioned: false + strip_version: true + - path: /signature + versioned: false + specific_user_rate_limit: reqs_per_user_signatures + strip_version: true + - path: /i/marketo/emails/([^/]*)$ + disable_zauth: true + versioned: false + basic_auth: true + envs: + - staging + calling-test: - path: /calling-test envs: diff --git a/charts/redis-ephemeral/requirements.yaml b/charts/redis-ephemeral/requirements.yaml index b32bec9424..a39623d533 100644 --- a/charts/redis-ephemeral/requirements.yaml +++ b/charts/redis-ephemeral/requirements.yaml @@ -1,5 +1,9 @@ dependencies: - name: redis version: 11.3.4 - repository: https://charts.bitnami.com/bitnami + # Use helm repo from the git repo because bitnami removed charts from the + # official index to keep the index small. On next upgrade, this should be + # changed to use the official repo. Context: + # https://github.com/bitnami/charts/issues/10539 + repository: https://raw.githubusercontent.com/bitnami/charts/defb094c658024e4aa8245622dab202874880cbc/bitnami/ alias: redis-ephemeral diff --git a/deploy/services-demo/conf/cannon.demo-docker.yaml b/deploy/services-demo/conf/cannon.demo-docker.yaml index bdaa2be9e7..2d63eec9cf 100644 --- a/deploy/services-demo/conf/cannon.demo-docker.yaml +++ b/deploy/services-demo/conf/cannon.demo-docker.yaml @@ -7,5 +7,10 @@ gundeck: host: gundeck port: 8086 +drainOpts: + gracePeriodSeconds: 1 + millisecondsBetweenBatches: 5 + minBatchSize: 100 + logLevel: Info logNetStrings: false diff --git a/deploy/services-demo/conf/cannon.demo.yaml b/deploy/services-demo/conf/cannon.demo.yaml index 56f6430e58..999988bafb 100644 --- a/deploy/services-demo/conf/cannon.demo.yaml +++ b/deploy/services-demo/conf/cannon.demo.yaml @@ -7,5 +7,10 @@ gundeck: host: 127.0.0.1 port: 8086 +drainOpts: + gracePeriodSeconds: 1 + millisecondsBetweenBatches: 5 + minBatchSize: 100 + logLevel: Info logNetStrings: false diff --git a/deploy/services-demo/conf/nginz/nginx.conf b/deploy/services-demo/conf/nginz/nginx.conf index 70aaeb02fe..1195f45095 100644 --- a/deploy/services-demo/conf/nginz/nginx.conf +++ b/deploy/services-demo/conf/nginz/nginx.conf @@ -479,11 +479,6 @@ http { proxy_pass http://spar; } - location /sso-initiate-bind { - include common_response_with_zauth.conf; - proxy_pass http://spar; - } - location /identity-providers { include common_response_with_zauth.conf; proxy_pass http://spar; diff --git a/docs/legacy/reference/spar-braindump.md b/docs/legacy/reference/spar-braindump.md index f92775beca..ecb6ccda3e 100644 --- a/docs/legacy/reference/spar-braindump.md +++ b/docs/legacy/reference/spar-braindump.md @@ -274,12 +274,6 @@ not lead to a good user experience. so instead we require users to adopt the more robust and contemporary scim standard. -#### we don't support binding password/phone-auth'ed users to saml yet - -to keep track of whether we have, see https://github.com/zinfra/backend-issues/issues/731 - - - ## application logic ### deleting users that exist on spar diff --git a/docs/reference/provisioning/scim-token.md b/docs/reference/provisioning/scim-token.md index 0128216c9d..b0cf7e2ecb 100644 --- a/docs/reference/provisioning/scim-token.md +++ b/docs/reference/provisioning/scim-token.md @@ -1 +1 @@ -file has moved [here](../legacy/reference/provisioning/scim-token.md) +file has moved [here](../../legacy/reference/provisioning/scim-token.md) diff --git a/docs/reference/provisioning/scim-via-curl.md b/docs/reference/provisioning/scim-via-curl.md index d34fd5ade0..6eeebaa543 100644 --- a/docs/reference/provisioning/scim-via-curl.md +++ b/docs/reference/provisioning/scim-via-curl.md @@ -1 +1 @@ -file has moved [here](../legacy/reference/provisioning/scim-via-curl.md) +file has moved [here](../../legacy/reference/provisioning/scim-via-curl.md) diff --git a/docs/src/_static/css/wire.css b/docs/src/_static/css/wire.css new file mode 100644 index 0000000000..a28bd8b810 --- /dev/null +++ b/docs/src/_static/css/wire.css @@ -0,0 +1,243 @@ +*{ + -webkit-box-sizing:border-box; + -moz-box-sizing:border-box; + box-sizing:border-box +} +html,body{ + margin:0; + padding:0; + min-height:100% +} +html{ + font-family:-apple-system,BlinkMacSystemFont,sans-serif; + font-size:16px; + line-height:1.5; + position:relative; +} +body{ + color:#34383b; + background-color:#fff; +} +a{ + color:#0772de; + text-decoration:none; + transition:color 0.08s +} +a:hover,a:focus{ + color:#05498f +} +html,body{ + -webkit-font-smoothing:antialiased; + -moz-osx-font-smoothing:grayscale; + -webkit-text-size-adjust:100%; + -ms-text-size-adjust:100%; + font-weight:300 +} +h1,h2,h3,h4,h5,h6{ + margin-bottom:0; + line-height:1.5; + text-rendering:optimizeLegibility +} +h1{ + font-size:2rem; + font-weight:300; + text-align:center; + padding:32px 16px +} +h2{ + margin-top:2rem; + font-size:1.5rem; + font-weight:600 +} +h2:first-child{ + margin-top:0 +} +h3{ + margin-top:2rem; + font-size:1.5rem; + font-weight:300 +} +h4{ + margin-top:2rem; + font-size:1rem; + font-weight:600 +} +strong,b{ + font-weight:600 +} +p,dd{ + margin-top:0; + margin-bottom:1rem +} +p.lead,dd.lead{ + font-size:2rem; + font-weight:300; + color:#696c6e +} +p.dark,dd.dark{ + color:#34383b +} +p.error,dd.error{ + margin:160px 0 80px; + text-align:center +} +p a { + word-break: break-all; +} +ul,ol,dl{ + margin:0 0 1rem; + padding:0 +} +li{ + list-style-image:url('data:image/svg+xml;utf8,'); +} + +hr{ + margin:2rem 0; + border:0; + border-top:1px solid #696c6e; + border-bottom:0 +} +blockquote{ + padding:0 0 0 12px; + margin:1rem 0 1rem -14px; + border-left:2px solid #696c6e; + color:#34383b +} +dt{ + font-weight:600 +} +del{ + color:#34383b +} +main{ + max-width:840px; + display:flex; + align-items:stretch; + margin:0 auto +} +@media screen and (max-width: 550px){ + main{ + display:inherit + } +} +article{ + max-width:560px; + margin:0 auto +} +main article{ + margin:0 +} +header{ + max-width:840px; + height:96px; + border-bottom:1px solid #bec0c1; + display:flex; + align-items:center; + justify-content:center; + margin:0 auto 32px +} +header a{ + font-size:12px; + font-weight:600; + color:#34383b +} +header a:hover{ + color:#17181a +} +header a:first-child{ + margin-right:auto +} +header a:last-child{ + margin-left:auto +} +a h1{ + color:#34383b +} +input[type='checkbox']{ + display:none +} +input[type='checkbox']:checked ~ #menu{ + display:block +} +footer{ + text-align:center; + color: #696C6E; +} +footer div{ + max-width:840px; + line-height:160px; + margin:0 auto; + font-size:12px; + font-weight:600 +} + +.wy-menu-vertical a { + color: #0772de; +} + +.wy-menu-vertical a:hover { + color: #05498f; + background-color: #fff; +} + +.wy-side-scroll { + background-color: #fafafa; +} + +.wy-nav-side { + background-color: #fafafa; +} + +.wy-side-nav-search { + background-color: #fafafa; +} + +.wy-body-for-nav { + background-color: #fff; +} + +.wy-nav-content { + background-color: #fff !important; +} + +.wy-nav-content-wrap { + background-color: #fff !important; +} + +.wy-menu-vertical li.current { + background-color: #eaeaea; +} + +.wy-menu-vertical li.current a { + border: none; +} + +.wy-menu-vertical li.toctree-l2.current li.toctree-l3>a, .wy-menu-vertical li.toctree-l3.current li.toctree-l4>a { + background: unset; +} + +.wy-menu-vertical li.toctree-l2.current li.toctree-l3>a:hover, .wy-menu-vertical li.toctree-l3.current li.toctree-l4>a:hover { + background-color: #c9c9c9; +} + +.wy-nav-content { + max-width: unset; +} + +.wy-nav-top { + background-color: #fafafa; + color: #34383b; +} + +.wy-nav-top a { + color: #34383b; +} +/* +.wy-side-nav-search a { + color: #0772de; +} + +.wy-side-nav-search a:hover { + color: #05498f; +} */ \ No newline at end of file diff --git a/docs/src/_static/favicon/favicon.ico b/docs/src/_static/favicon/favicon.ico new file mode 100644 index 0000000000..c528ac2b00 Binary files /dev/null and b/docs/src/_static/favicon/favicon.ico differ diff --git a/docs/src/_static/image/Wire_logo.svg b/docs/src/_static/image/Wire_logo.svg new file mode 100644 index 0000000000..c6392ab636 --- /dev/null +++ b/docs/src/_static/image/Wire_logo.svg @@ -0,0 +1,3 @@ + + + diff --git a/docs/src/_static/image/wire_symbol.png b/docs/src/_static/image/wire_symbol.png new file mode 100644 index 0000000000..4ee3434121 Binary files /dev/null and b/docs/src/_static/image/wire_symbol.png differ diff --git a/docs/src/_templates/README.md b/docs/src/_templates/README.md new file mode 100644 index 0000000000..09f2cdd156 --- /dev/null +++ b/docs/src/_templates/README.md @@ -0,0 +1,4 @@ +# Writing HTML templates + +If you want more control over HTML generation over ReadTheDocs theme. See https://github.com/readthedocs/sphinx_rtd_theme/tree/master/sphinx_rtd_theme for specific templates you may wish to override. It can be fully overriden or partially (just extend the default template and only use the block you wish to change). + diff --git a/docs/src/_templates/layout.html b/docs/src/_templates/layout.html new file mode 100644 index 0000000000..cdf6b5c4a8 --- /dev/null +++ b/docs/src/_templates/layout.html @@ -0,0 +1,21 @@ +{%- extends "sphinx_rtd_theme/layout.html" %} + +{% block sidebartitle %} + + + + + + + {%- include "searchbox.html" %} +{% endblock %} \ No newline at end of file diff --git a/docs/src/conf.py b/docs/src/conf.py index 5ad267b9ae..6b2ee1500c 100644 --- a/docs/src/conf.py +++ b/docs/src/conf.py @@ -22,7 +22,7 @@ today_date = datetime.date.today() copyright = f'{today_date.year}, Wire' author = 'Wire Swiss GmbH' -version = '0.0.3' +version = '0.0.4' # the 'release' variable is used in latex-based PDF generation release = version @@ -97,6 +97,16 @@ # so a file named "default.css" will overwrite the builtin "default.css". html_static_path = ['_static'] +# NOTE: if you want to fully override default theme css, use this property (presumes it is in _static folder) +#html_style = 'css/wire.css' + +# additional css files (presumes they are in _static folder) +html_css_files = [ + 'css/wire.css', +] + +html_favicon = '_static/favicon/favicon.ico' +html_logo = '_static/image/wire_logo.svg' smv_tag_whitelist = '' smv_branch_whitelist = r'^(install-with-poetry)$' diff --git a/docs/src/how-to/install/configuration-options.rst b/docs/src/how-to/install/configuration-options.rst index 791bd403a0..bd4ec0b627 100644 --- a/docs/src/how-to/install/configuration-options.rst +++ b/docs/src/how-to/install/configuration-options.rst @@ -119,6 +119,107 @@ Keys below ``gundeck.secrets`` belong into ``values/wire-server/secrets.yaml``: After making this change and applying it to gundeck (ensure gundeck pods have restarted to make use of the updated configuration - that should happen automatically), make sure to reset the push token on any mobile devices that you may have in use. +Controlling the speed of websocket draining during cannon pod replacement +------------------------------------------------------------------------- + +The 'cannon' component is responsible for persistent websocket connections. +Normally the default options would slowly and gracefully drain active websocket +connections over a maximum of ``(amount of cannon replicas * 30 seconds)`` during +the deployment of a new wire-server version. This will lead to a very brief +interruption for Wire clients when their client has to re-connect on the +websocket. + +You're not expected to need to change these settings. + +The following options are only relevant during the restart of cannon itself. +During a restart of nginz or ingress-controller, all websockets will get +severed. If this is to be avoided, see section :ref:`separate-websocket-traffic` + +``drainOpts``: Drain websockets in a controlled fashion when cannon receives a +SIGTERM or SIGINT (this happens when a pod is terminated e.g. during rollout +of a new version). Instead of waiting for connections to close on their own, +the websockets are now severed at a controlled pace. This allows for quicker +rollouts of new versions. + +There is no way to entirely disable this behaviour, two extreme examples below + +* the quickest way to kill cannon is to set ``gracePeriodSeconds: 1`` and + ``minBatchSize: 100000`` which would sever all connections immediately; but it's + not recommended as you could DDoS yourself by forcing all active clients to + reconnect at the same time. With this, cannon pod replacement takes only 1 + second per pod. +* the slowest way to roll out a new version of cannon without severing websocket + connections for a long time is to set ``minBatchSize: 1``, + ``millisecondsBetweenBatches: 86400000`` and ``gracePeriodSeconds: 86400`` + which would lead to one single websocket connection being closed immediately, + and all others only after 1 day. With this, cannon pod replacement takes a + full day per pod. + +.. code:: yaml + + # overrides for wire-server/values.yaml + cannon: + drainOpts: + # The following defaults drain a minimum of 400 connections/second + # for a total of 10000 over 25 seconds + # (if cannon holds more connections, draining will happen at a faster pace) + gracePeriodSeconds: 25 + millisecondsBetweenBatches: 50 + minBatchSize: 20 + +.. _separate-websocket-traffic: + +Separate incoming websocket network traffic from the rest of the https traffic +------------------------------------------------------------------------------- + +By default, incoming network traffic for websockets comes through these network +hops: + +Internet -> LoadBalancer -> kube-proxy -> nginx-ingress-controller -> nginz -> cannon + +In order to have graceful draining of websockets when something gets restarted, as it is not easily +possible to implement the graceful draining on nginx-ingress-controller or nginz by itself, there is +a configuration option to get the following network hops: + +Internet -> separate LoadBalancer for cannon only -> kube-proxy -> [nginz->cannon (2 containers in the same pod)] + +.. code:: yaml + + # example on AWS when using cert-manager for TLS certificates and external-dns for DNS records + # (see wire-server/charts/cannon/values.yaml for more possible options) + + # in your wire-server/values.yaml overrides: + cannon: + service: + nginz: + enabled: true + hostname: "nginz-ssl.example.com" + externalDNS: + enabled: true + certManager: + enabled: true + annotations: + service.beta.kubernetes.io/aws-load-balancer-type: "nlb" + service.beta.kubernetes.io/aws-load-balancer-scheme: "internet-facing" + nginz: + nginx_conf: + ignored_upstreams: ["cannon"] + +.. code:: yaml + + # in your wire-server/secrets.yaml overrides: + cannon: + secrets: + nginz: + zAuth: + publicKeys: ... # same values as in nginz.secrets.zAuth.publicKeys + +.. code:: yaml + + # in your nginx-ingress-services/values.yaml overrides: + websockets: + enabled: false + Blocking creation of personal users, new teams -------------------------------------------------------------------------- @@ -413,3 +514,19 @@ You need Giphy/Google/Spotify/Soundcloud API keys (if you want to support previews by proxying these services) See the ``proxy`` chart for configuration. + +Routing traffic to other namespaces via nginz +--------------------------------------------- + +If you have some components running in namespaces different from nginz. For +instance, the billing service (``ibis``) could be deployed to a separate +namespace, say ``integrations``. But it still needs to get traffic via +``nginz``. When this is needed, the helm config can be adjusted like this: + +.. code:: yaml + + # in your wire-server/values.yaml overrides: + nginz: + nginx_conf: + upstream_namespace: + ibis: integrations diff --git a/docs/src/security-responses/2022-05_website_outage.md b/docs/src/security-responses/2022-05_website_outage.md new file mode 100644 index 0000000000..7f253d0f7c --- /dev/null +++ b/docs/src/security-responses/2022-05_website_outage.md @@ -0,0 +1,23 @@ +# 2022-05-23 - wire.com website outage + +Last updated: 2022-05-25 + + +On Monday, 2022-05-23 the Wire website wire.com was affected by an outage of our hosting provider. + +This outage concerns **only wire.com** website and none of the services provided by Wire. + +## Timeline + + +*06:00*: wire.com being down was detected by the Security Team\ +*06:46*: Our Hosting Provider was informed about wire.com being down\ +*07:03*: Our Hosting Provider initiated a server restart to mitigate\ +*07:08*: Restart of wire.com server failed due to problems on hypervisor (no additional details provided by upstream provider)\ +*07:23*: We changed the DNS record for wire.com to an old backup to restore basic functionality\ +*10:30*: Our Hosting Provider restored wire.com server\ +*11:20*: Our Hosting Provider informed us that the recent version of wire.com is reliably available again\ +*12:02*: We reverted the DNS changes, to point back to the recent version of wire.com + +## Are Wire installations affected? +**Wire/wire-server was not affected by wire.com website outage.** diff --git a/hack/bin/cabal-run-all-tests.sh b/hack/bin/cabal-run-all-tests.sh index 7d84637417..2101f2477b 100755 --- a/hack/bin/cabal-run-all-tests.sh +++ b/hack/bin/cabal-run-all-tests.sh @@ -2,11 +2,15 @@ set -euo pipefail -DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )" +DIR="$(cd "$(dirname "${BASH_SOURCE[0]}")" && pwd)" TOP_LEVEL="$(cd "$DIR/../.." && pwd)" -find "$TOP_LEVEL" -name '*.cabal' | +mapfile -t packages < <(find "$TOP_LEVEL" -name '*.cabal' | grep -v dist-newstyle | xargs -n 1 dirname | - xargs -n 1 basename | - xargs -n 1 "$DIR/cabal-run-tests.sh" + xargs -n 1 basename) + +for p in "${packages[@]}"; do + echo "==== Testing $p..." + "$DIR/cabal-run-tests.sh" "$p" +done diff --git a/hack/bin/integration-spring-cleaning.sh b/hack/bin/integration-spring-cleaning.sh index cf4451c134..ff6810dfe1 100755 --- a/hack/bin/integration-spring-cleaning.sh +++ b/hack/bin/integration-spring-cleaning.sh @@ -1,13 +1,13 @@ #!/usr/bin/env bash -DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )/.." +DIR="$(cd "$(dirname "${BASH_SOURCE[0]}")" && pwd)/.." set -x IFS=$'\n' for NAMESPACE in $(kubectl get namespaces | grep "^test-" | awk '{print $1}'); do - echo "$NAMESPACE" - kubectl delete namespace "$NAMESPACE" + echo "$NAMESPACE" + kubectl delete namespace "$NAMESPACE" & done diff --git a/hack/bin/integration-teardown-federation.sh b/hack/bin/integration-teardown-federation.sh index 76633f3c6a..91897a6059 100755 --- a/hack/bin/integration-teardown-federation.sh +++ b/hack/bin/integration-teardown-federation.sh @@ -14,3 +14,6 @@ export FEDERATION_DOMAIN_2="." . "$DIR/helm_overrides.sh" helmfile --file "${TOP_LEVEL}/hack/helmfile.yaml" destroy + +kubectl delete namespace "$NAMESPACE_1" +kubectl delete namespace "$NAMESPACE_2" diff --git a/hack/bin/set-chart-image-version.sh b/hack/bin/set-chart-image-version.sh index 966a96c7c9..d133007e4a 100755 --- a/hack/bin/set-chart-image-version.sh +++ b/hack/bin/set-chart-image-version.sh @@ -11,8 +11,8 @@ for chart in $charts do if [[ "$chart" == "nginz" ]]; then # nginz has a different docker tag indentation - sed -i "s/ tag: .*/ tag: $docker_tag/g" "$CHARTS_DIR/$chart/values.yaml" + sed -i "s/^ tag: .*/ tag: $docker_tag/g" "$CHARTS_DIR/$chart/values.yaml" else - sed -i "s/ tag: .*/ tag: $docker_tag/g" "$CHARTS_DIR/$chart/values.yaml" + sed -i "s/^ tag: .*/ tag: $docker_tag/g" "$CHARTS_DIR/$chart/values.yaml" fi done diff --git a/hack/bin/set-wire-server-image-version.sh b/hack/bin/set-wire-server-image-version.sh index 3c92e5fd3e..d3438814e9 100755 --- a/hack/bin/set-wire-server-image-version.sh +++ b/hack/bin/set-wire-server-image-version.sh @@ -9,8 +9,8 @@ CHARTS_DIR="$TOP_LEVEL/.local/charts" charts=(brig cannon galley gundeck spar cargohold proxy cassandra-migrations elasticsearch-index federator) for chart in "${charts[@]}"; do - sed -i "s/ tag: .*/ tag: $target_version/g" "$CHARTS_DIR/$chart/values.yaml" + sed -i "s/^ tag: .*/ tag: $target_version/g" "$CHARTS_DIR/$chart/values.yaml" done #special case nginz -sed -i "s/ tag: .*/ tag: $target_version/g" "$CHARTS_DIR/nginz/values.yaml" +sed -i "s/^ tag: .*/ tag: $target_version/g" "$CHARTS_DIR/nginz/values.yaml" diff --git a/libs/galley-types/src/Galley/Types/Teams.hs b/libs/galley-types/src/Galley/Types/Teams.hs index 3afce5078d..c8e1273575 100644 --- a/libs/galley-types/src/Galley/Types/Teams.hs +++ b/libs/galley-types/src/Galley/Types/Teams.hs @@ -270,15 +270,15 @@ instance FromJSON FeatureFlags where <$> obj .: "sso" <*> obj .: "legalhold" <*> obj .: "teamSearchVisibility" - <*> (fromMaybe (Defaults defaultAppLockStatus) <$> (obj .:? "appLock")) - <*> (fromMaybe defaultClassifiedDomains <$> (obj .:? "classifiedDomains")) - <*> (fromMaybe (Defaults defaultTeamFeatureFileSharing) <$> (obj .:? "fileSharing")) - <*> (fromMaybe (Defaults (TeamFeatureStatusNoConfig TeamFeatureEnabled)) <$> (obj .:? "conferenceCalling")) - <*> (fromMaybe (Defaults defaultSelfDeletingMessagesStatus) <$> (obj .:? "selfDeletingMessages")) - <*> (fromMaybe (Defaults defaultGuestLinksStatus) <$> (obj .:? "conversationGuestLinks")) - <*> (fromMaybe (Defaults defaultTeamFeatureValidateSAMLEmailsStatus) <$> (obj .:? "validateSAMLEmails")) - <*> (fromMaybe (Defaults defaultTeamFeatureSndFactorPasswordChallengeStatus) <$> (obj .:? "sndFactorPasswordChallenge")) - <*> (fromMaybe (Defaults defaultTeamFeatureSearchVisibilityInbound) <$> (obj .:? "searchVisibilityInbound")) + <*> (fromMaybe (Defaults (defTeamFeatureStatus @'TeamFeatureAppLock)) <$> (obj .:? "appLock")) + <*> (fromMaybe (defTeamFeatureStatus @'TeamFeatureClassifiedDomains) <$> (obj .:? "classifiedDomains")) + <*> (fromMaybe (Defaults (defTeamFeatureStatus @'TeamFeatureFileSharing)) <$> (obj .:? "fileSharing")) + <*> (fromMaybe (Defaults (defTeamFeatureStatus @'TeamFeatureConferenceCalling)) <$> (obj .:? "conferenceCalling")) + <*> (fromMaybe (Defaults (defTeamFeatureStatus @'TeamFeatureSelfDeletingMessages)) <$> (obj .:? "selfDeletingMessages")) + <*> (fromMaybe (Defaults (defTeamFeatureStatus @'TeamFeatureGuestLinks)) <$> (obj .:? "conversationGuestLinks")) + <*> (fromMaybe (Defaults (defTeamFeatureStatus @'TeamFeatureValidateSAMLEmails)) <$> (obj .:? "validateSAMLEmails")) + <*> (fromMaybe (Defaults (defTeamFeatureStatus @'TeamFeatureSndFactorPasswordChallenge)) <$> (obj .:? "sndFactorPasswordChallenge")) + <*> (fromMaybe (Defaults (defTeamFeatureStatus @'TeamFeatureSearchVisibilityInbound)) <$> (obj .:? "searchVisibilityInbound")) instance ToJSON FeatureFlags where toJSON diff --git a/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs b/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs index 8ec0177ced..ed679c8780 100644 --- a/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs +++ b/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs @@ -352,17 +352,16 @@ logError :: (MonadIO m, HasRequest r) => Logger -> Maybe r -> Wai.Error -> m () logError g mr = logError' g (lookupRequestId =<< mr) logError' :: (MonadIO m) => Logger -> Maybe ByteString -> Wai.Error -> m () -logError' g mr e = liftIO $ doLog g (logErrorMsg mr e) +logError' g mr e = liftIO $ doLog g (logErrorMsgWithRequest mr e) where doLog | statusCode (Error.code e) >= 500 = Log.err | otherwise = Log.debug -logErrorMsg :: Maybe ByteString -> Wai.Error -> Msg -> Msg -logErrorMsg mr (Wai.Error c l m md) = +logErrorMsg :: Wai.Error -> Msg -> Msg +logErrorMsg (Wai.Error c l m md) = field "code" (statusCode c) . field "label" l - . field "request" (fromMaybe "N/A" mr) . fromMaybe id (fmap logErrorData md) . msg (val "\"" +++ m +++ val "\"") where @@ -370,6 +369,10 @@ logErrorMsg mr (Wai.Error c l m md) = field "domain" (domainText d) . field "path" p +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 diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs b/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs index 6b4ed3fd56..b26d82695c 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs @@ -14,7 +14,6 @@ -- -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Wire.API.Federation.API.Galley where @@ -60,7 +59,7 @@ type GalleyApi = :<|> FedEndpoint "send-message" MessageSendRequest MessageSendResponse :<|> FedEndpoint "on-user-deleted-conversations" UserDeletedConversationsNotification EmptyResponse :<|> FedEndpoint "update-conversation" ConversationUpdateRequest ConversationUpdateResponse - :<|> FedEndpoint "mls-welcome" MLSWelcomeRequest () + :<|> FedEndpoint "mls-welcome" MLSWelcomeRequest EmptyResponse data GetConversationsRequest = GetConversationsRequest { gcrUserId :: UserId, @@ -256,17 +255,10 @@ data ConversationUpdateResponse (ToJSON, FromJSON) via (CustomEncoded ConversationUpdateResponse) -newtype MLSWelcomeRecipient = MLSWelcomeRecipient {unMLSWelRecipient :: (UserId, ClientId)} - deriving stock (Generic) - deriving (Arbitrary) via (GenericUniform MLSWelcomeRecipient) - deriving (FromJSON, ToJSON) via CustomEncoded MLSWelcomeRecipient - deriving newtype (Show, Eq) - -data MLSWelcomeRequest = MLSWelcomeRequest - { mwrRawWelcome :: Base64ByteString, - -- | These are qualified implicitly by the target domain - mwrRecipients :: [MLSWelcomeRecipient] +-- | A wrapper around a raw welcome message +newtype MLSWelcomeRequest = MLSWelcomeRequest + { unMLSWelcomeRequest :: Base64ByteString } - deriving stock (Generic) + deriving stock (Eq, Generic, Show) deriving (Arbitrary) via (GenericUniform MLSWelcomeRequest) deriving (FromJSON, ToJSON) via (CustomEncoded MLSWelcomeRequest) diff --git a/libs/wire-api/src/Wire/API/Conversation.hs b/libs/wire-api/src/Wire/API/Conversation.hs index 152deb5337..a2d2edc027 100644 --- a/libs/wire-api/src/Wire/API/Conversation.hs +++ b/libs/wire-api/src/Wire/API/Conversation.hs @@ -174,8 +174,10 @@ accessRolesSchemaOpt = toOutput .= accessRolesSchemaTuple `withParser` validate accessRolesSchemaTuple :: ObjectSchema SwaggerDoc (Maybe AccessRoleLegacy, Maybe (Set AccessRoleV2)) accessRolesSchemaTuple = - (,) <$> fst .= optField "access_role" (maybeWithDefault A.Null schema) - <*> snd .= optField "access_role_v2" (maybeWithDefault A.Null $ set schema) + (,) <$> fst .= optFieldWithDocModifier "access_role" (description ?~ "Deprecated, please use access_role_v2") (maybeWithDefault A.Null schema) + <*> snd .= optFieldWithDocModifier "access_role_v2" (description ?~ desc) (maybeWithDefault A.Null $ set schema) + where + desc = "This field is optional. If it is not present, the default will be `[team_member, non_team_member, service]`. Please note that an empty list is not allowed when creating a new conversation." conversationMetadataObjectSchema :: ObjectSchema SwaggerDoc ConversationMetadata conversationMetadataObjectSchema = diff --git a/libs/wire-api/src/Wire/API/Cookie.hs b/libs/wire-api/src/Wire/API/Cookie.hs deleted file mode 100644 index d92f65c5f9..0000000000 --- a/libs/wire-api/src/Wire/API/Cookie.hs +++ /dev/null @@ -1,52 +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 . - -module Wire.API.Cookie where - -import Control.Monad.Except -import Data.Proxy (Proxy (Proxy)) -import Data.String.Conversions -import Data.Swagger -import Imports -import SAML2.WebSSO (SimpleSetCookie) -import qualified SAML2.WebSSO as SAML -import Servant.API (FromHttpApiData (..), ToHttpApiData (..)) -import Web.Cookie - -newtype SetBindCookie = SetBindCookie {getSimpleSetCookie :: SimpleSetCookie "zbind"} - deriving (Eq, Show, FromHttpApiData, ToHttpApiData) - -instance ToParamSchema SetBindCookie where - toParamSchema _ = toParamSchema (Proxy @String) - -newtype BindCookie = BindCookie {fromBindCookie :: ST} - deriving (Eq, Ord) - -instance ToParamSchema BindCookie where - toParamSchema _ = toParamSchema (Proxy @String) - --- | Extract @zbind@ cookie from HTTP header contents if it exists. -bindCookieFromHeader :: ST -> Maybe BindCookie -bindCookieFromHeader = fmap BindCookie . lookup "zbind" . parseCookiesText . cs - --- (we could rewrite this as @SAML.cookieName SetBindCookie@ if 'cookieName' --- accepted any @proxy :: Symbol -> *@ rather than just 'Proxy'.) - -setBindCookieValue :: HasCallStack => SetBindCookie -> BindCookie -setBindCookieValue = BindCookie . cs . setCookieValue . SAML.fromSimpleSetCookie . getSimpleSetCookie diff --git a/services/spar/src/Spar/Sem/BindCookieStore.hs b/libs/wire-api/src/Wire/API/Routes/CSV.hs similarity index 64% rename from services/spar/src/Spar/Sem/BindCookieStore.hs rename to libs/wire-api/src/Wire/API/Routes/CSV.hs index 67616a7fff..0d09941545 100644 --- a/services/spar/src/Spar/Sem/BindCookieStore.hs +++ b/libs/wire-api/src/Wire/API/Routes/CSV.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE TemplateHaskell #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2022 Wire Swiss GmbH @@ -17,21 +15,12 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Spar.Sem.BindCookieStore - ( BindCookieStore (..), - insert, - lookup, - ) -where +module Wire.API.Routes.CSV where -import Data.Id (UserId) -import Data.Time (NominalDiffTime) -import Imports (Maybe) -import Polysemy -import Wire.API.Cookie +import Network.HTTP.Media.MediaType +import Servant.API -data BindCookieStore m a where - Insert :: SetBindCookie -> UserId -> NominalDiffTime -> BindCookieStore m () - Lookup :: BindCookie -> BindCookieStore m (Maybe UserId) +data CSV -makeSem ''BindCookieStore +instance Accept CSV where + contentType _ = "text" // "csv" 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 2e7187f647..017d5b51cd 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs @@ -34,6 +34,7 @@ where import Control.Lens ((.~)) import qualified Data.Code as Code import Data.Id as Id +import Data.Qualified (Qualified) import Data.Swagger (HasInfo (info), HasTitle (title), Swagger) import Imports hiding (head) import Servant hiding (Handler, JSON, addHeader, respond) @@ -144,24 +145,61 @@ type AccountAPI = :> MultiVerb 'POST '[Servant.JSON] RegisterInternalResponses (Either RegisterError SelfProfile) ) -type MLSAPI = GetClientByKeyPackageRef :<|> GetMLSClients :<|> MapKeyPackageRefs +type MLSAPI = + "mls" + :> ( ( "key-packages" :> Capture "ref" KeyPackageRef + :> ( Named + "get-client-by-key-package-ref" + ( Summary "Resolve an MLS key package ref to a qualified client ID" + :> MultiVerb + 'GET + '[Servant.JSON] + '[ RespondEmpty 404 "Key package ref not found", + Respond 200 "Key package ref found" ClientIdentity + ] + (Maybe ClientIdentity) + ) + :<|> ( "conversation" + :> ( PutConversationByKeyPackageRef + :<|> GetConversationByKeyPackageRef + ) + ) + ) + ) + :<|> GetMLSClients + :<|> MapKeyPackageRefs + ) + +type PutConversationByKeyPackageRef = + Named + "put-conversation-by-key-package-ref" + ( Summary "Associate a conversation with a key package" + :> ReqBody '[Servant.JSON] (Qualified ConvId) + :> MultiVerb + 'PUT + '[Servant.JSON] + [ RespondEmpty 404 "No key package found by reference", + RespondEmpty 204 "Converstaion associated" + ] + Bool + ) -type GetClientByKeyPackageRef = - Summary "Resolve an MLS key package ref to a qualified client ID" - :> "mls" - :> "key-packages" - :> Capture "ref" KeyPackageRef - :> MultiVerb - 'GET - '[Servant.JSON] - '[ RespondEmpty 404 "Key package ref not found", - Respond 200 "Key package ref found" ClientIdentity - ] - (Maybe ClientIdentity) +type GetConversationByKeyPackageRef = + Named + "get-conversation-by-key-package-ref" + ( Summary + "Retrieve the conversation associated with a key package" + :> MultiVerb + 'GET + '[Servant.JSON] + [ RespondEmpty 404 "No associated conversation or bad key package", + Respond 200 "Conversation found" (Qualified ConvId) + ] + (Maybe (Qualified ConvId)) + ) type GetMLSClients = Summary "Return all MLS-enabled clients of a user" - :> "mls" :> "clients" :> CanThrow 'UserNotFound :> QualifiedCapture "user" UserId @@ -173,7 +211,6 @@ type GetMLSClients = type MapKeyPackageRefs = Summary "Insert bundle into the KeyPackage ref mapping. Only for tests." - :> "mls" :> "key-package-refs" :> ReqBody '[Servant.JSON] KeyPackageBundle :> MultiVerb 'PUT '[Servant.JSON] '[RespondEmpty 204 "Mapping was updated"] () diff --git a/libs/wire-api/src/Wire/API/Routes/LowLevelStream.hs b/libs/wire-api/src/Wire/API/Routes/LowLevelStream.hs new file mode 100644 index 0000000000..ef2ec8bbe7 --- /dev/null +++ b/libs/wire-api/src/Wire/API/Routes/LowLevelStream.hs @@ -0,0 +1,110 @@ +-- 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.Routes.LowLevelStream where + +import Control.Lens (at, (.~), (?~)) +import Data.ByteString.Char8 as B8 +import qualified Data.CaseInsensitive as CI +import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap +import Data.Metrics.Servant +import Data.Proxy +import qualified Data.Swagger as S +import qualified Data.Text as Text +import GHC.TypeLits +import Imports +import qualified Network.HTTP.Media as HTTP +import Network.HTTP.Types +import Network.Wai +import Servant.API +import Servant.API.ContentTypes +import Servant.API.Status +import Servant.Server hiding (respond) +import Servant.Server.Internal +import Servant.Swagger as S +import Servant.Swagger.Internal as S + +-- FUTUREWORK: make it possible to generate headers at runtime +data LowLevelStream method status (headers :: [(Symbol, Symbol)]) desc ctype + +class RenderHeaders (headers :: [(Symbol, Symbol)]) where + renderHeaders :: [(HeaderName, ByteString)] + +instance RenderHeaders '[] where + renderHeaders = [] + +instance + (KnownSymbol name, KnownSymbol value, RenderHeaders headers) => + RenderHeaders ('(name, value) ': headers) + where + renderHeaders = (name, value) : renderHeaders @headers + where + name :: HeaderName + name = CI.mk (B8.pack (symbolVal (Proxy @name))) + value :: ByteString + value = B8.pack (symbolVal (Proxy @value)) + +instance + (ReflectMethod method, KnownNat status, RenderHeaders headers, Accept ctype) => + HasServer (LowLevelStream method status headers desc ctype) context + where + type ServerT (LowLevelStream method status headers desc ctype) m = m StreamingBody + hoistServerWithContext _ _ nt s = nt s + + route Proxy _ action = leafRouter $ \env request respond -> + let AcceptHeader accH = getAcceptHeader request + cmediatype = HTTP.matchAccept [contentType (Proxy @ctype)] accH + accCheck = when (isNothing cmediatype) $ delayedFail err406 + contentHeader = (hContentType, HTTP.renderHeader . maybeToList $ cmediatype) + in runAction + ( action `addMethodCheck` methodCheck method request + `addAcceptCheck` accCheck + ) + env + request + respond + $ Route . responseStream status (contentHeader : extraHeaders) + where + method = reflectMethod (Proxy :: Proxy method) + status = statusFromNat (Proxy :: Proxy status) + extraHeaders = renderHeaders @headers + +instance + (Accept ctype, KnownNat status, KnownSymbol desc, SwaggerMethod method) => + HasSwagger (LowLevelStream method status headers desc ctype) + where + toSwagger _ = + mempty + & S.paths + . at "/" + ?~ ( mempty + & method + ?~ ( mempty + & S.produces ?~ S.MimeList [contentType (Proxy @ctype)] + & S.responses . S.responses .~ fmap S.Inline responses + ) + ) + where + method = S.swaggerMethod (Proxy @method) + responses = + InsOrdHashMap.singleton + (fromIntegral (natVal (Proxy @status))) + $ mempty + & S.description .~ Text.pack (symbolVal (Proxy @desc)) + +instance RoutesToPaths (LowLevelStream method status headers desc ctype) where + getRoutes = [] diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs b/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs index 2dcd3df2da..1a19df810f 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs @@ -46,6 +46,8 @@ import Wire.API.MLS.Serialisation import Wire.API.MLS.Servant import Wire.API.MLS.Welcome import Wire.API.Message +import Wire.API.Routes.CSV +import Wire.API.Routes.LowLevelStream import Wire.API.Routes.MultiVerb import Wire.API.Routes.Named import Wire.API.Routes.Public @@ -1653,6 +1655,29 @@ type TeamMemberAPI = '[JSON] (RespondEmpty 200 "") ) + :<|> Named + "get-team-members-csv" + ( Summary "Get all members of the team as a CSV file" + :> CanThrow 'AccessDenied + :> Description + "The endpoint returns data in chunked transfer encoding.\ + \ Internal server errors might result in a failed transfer\ + \ instead of a 500 response." + :> ZLocalUser + :> "teams" + :> Capture "tid" TeamId + :> "members" + :> "csv" + :> LowLevelStream + 'GET + 200 + '[ '( "Content-Disposition", + "attachment; filename=\"wire_team_members.csv\"" + ) + ] + "CSV of team members" + CSV + ) type TeamMemberDeleteResultResponseType = '[ RespondEmpty 202 "Team member scheduled for deletion", 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 31b4149888..d5b53bbac1 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Spar.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Spar.hs @@ -19,7 +19,6 @@ module Wire.API.Routes.Public.Spar where import Data.Id import Data.Proxy -import Data.String.Conversions (ST) import Data.Swagger (Swagger) import Imports import qualified SAML2.WebSSO as SAML @@ -32,7 +31,6 @@ import qualified URI.ByteString as URI import Web.Scim.Capabilities.MetaSchema as Scim.Meta import Web.Scim.Class.Auth as Scim.Auth import Web.Scim.Class.User as Scim.User -import Wire.API.Cookie import Wire.API.Error import Wire.API.Error.Brig import Wire.API.Routes.Public @@ -47,8 +45,6 @@ import Wire.API.User.Scim type API = "sso" :> APISSO - :<|> "sso-initiate-bind" :> APIAuthReqPrecheck -- (see comment on 'APIAuthReq') - :<|> "sso-initiate-bind" :> APIAuthReq -- (see comment on 'APIAuthReq') :<|> "identity-providers" :> APIIDP :<|> "scim" :> APIScim :<|> OmitDocs :> "i" :> APIINTERNAL @@ -70,74 +66,15 @@ type APIAuthReqPrecheck = :> Capture "idp" SAML.IdPId :> CheckOK '[PlainText] NoContent --- | Dual-use route for initiating either login or bind. --- --- We could distinguish the two cases by the presence or absence of a `Z-User` header. However, we --- also need to use this route under two different prefices because nginz only supports mandatory --- auth and no auth, but not optional auth for any given end-point. See also: 'DoInitiate'. --- --- __Binding existing users to SSO__ --- --- A user has an existing account with email address and password, and gets idp credentails. She --- now wants to upgrade her password-based login to sso login, or *bind* the existing user to the --- sso credentials. --- --- __The Solution__ --- --- 0. user logs in with password --- 1. inside the session, she requests `/sso-initiate-bind/` for an idp of her choice (idp --- must be registered with her team) --- 2. spar checks the `Z-User` header and sends a short-lived bind cookie with the response that --- otherwise is the same as for `/sso/initiate-login/` --- 3. everybody goes through the well-known SAML web sso moves, until: --- 4. the authentication response is sent to `/sso/finalize-login/` together with the bind --- cookie --- 5. spar identifies the user both via the bind cookie and via the SAML authentication response, --- and performs the binding. --- --- Why a special cookie, and not the cookie already available, or the session token? The wire cookie --- gets only sent to `/access`, and we would need to change that; session tokens are hard to handle --- while switching between app context and browser context. Having a separate cookie makes both the --- context switching simple and allows us to set a different cookie recipient end-point and short --- cookie lifetime. --- --- This solution is very flexible. UX variants: --- --- * team admin posts the initiate-bind link in a group in the wire team. no new UI components --- are needed in the frontend. --- * we add buttons in the settings page somewhere. --- * we send a link containing a token to the user by email. when the user clicks on the link, --- she gets authenticated and redirected to the initiate-bind end-point in step 1 above. --- * ...? --- --- __Corner Case: Accidental Creation of new SSO User__ --- --- What happens if the user authenticates via SSO first, creates a new user, and then receives the --- bind invite? --- --- Possible solutions: --- --- * The IdP could create all users via SCIM and we block implicit user creation. --- * After the fact, the duplicated user deletes the SSO user, loses a little bit of user data, --- and goes through the bind process. --- * Block implicit creation for a short time window, and ask all existing users to use that time --- window to bind. type APIAuthReq = - ZOptUser - :> QueryParam "success_redirect" URI.URI + QueryParam "success_redirect" URI.URI :> QueryParam "error_redirect" URI.URI -- (SAML.APIAuthReq from here on, except for the cookies) :> Capture "idp" SAML.IdPId - :> Get '[SAML.HTML] (WithSetBindCookie (SAML.FormRedirect SAML.AuthnRequest)) - -data DoInitiate = DoInitiateLogin | DoInitiateBind - deriving (Eq, Show, Bounded, Enum) - -type WithSetBindCookie = Headers '[Servant.Header "Set-Cookie" SetBindCookie] + :> Get '[SAML.HTML] (SAML.FormRedirect SAML.AuthnRequest) type APIAuthRespLegacy = "finalize-login" - :> Header "Cookie" ST -- (SAML.APIAuthResp from here on, except for response) :> MultipartForm Mem SAML.AuthnResponseBody :> Post '[PlainText] Void @@ -145,7 +82,6 @@ type APIAuthRespLegacy = type APIAuthResp = "finalize-login" :> Capture "team" TeamId - :> Header "Cookie" ST -- (SAML.APIAuthResp from here on, except for response) :> MultipartForm Mem SAML.AuthnResponseBody :> Post '[PlainText] Void diff --git a/libs/wire-api/src/Wire/API/Team/Export.hs b/libs/wire-api/src/Wire/API/Team/Export.hs index 4cffed4cf2..ac9cd8a824 100644 --- a/libs/wire-api/src/Wire/API/Team/Export.hs +++ b/libs/wire-api/src/Wire/API/Team/Export.hs @@ -49,7 +49,8 @@ data TeamExportUser = TeamExportUser tExportSAMLNamedId :: Text, -- If SAML IdP and SCIM peer are set up correctly, 'tExportSAMLNamedId' and 'tExportSCIMExternalId' always align. tExportSCIMExternalId :: Text, tExportSCIMRichInfo :: Maybe RichInfo, - tExportUserId :: UserId + tExportUserId :: UserId, + tExportNumDevices :: Int } deriving (Show, Eq, Generic) deriving (Arbitrary) via (GenericUniform TeamExportUser) @@ -68,7 +69,8 @@ instance ToNamedRecord TeamExportUser where ("saml_name_id", secureCsvFieldToByteString (tExportSAMLNamedId row)), ("scim_external_id", secureCsvFieldToByteString (tExportSCIMExternalId row)), ("scim_rich_info", maybe "" (cs . Aeson.encode) (tExportSCIMRichInfo row)), - ("user_id", secureCsvFieldToByteString (tExportUserId row)) + ("user_id", secureCsvFieldToByteString (tExportUserId row)), + ("num_devices", secureCsvFieldToByteString (tExportNumDevices row)) ] secureCsvFieldToByteString :: forall a. ToByteString a => a -> ByteString @@ -89,7 +91,8 @@ instance DefaultOrdered TeamExportUser where "saml_name_id", "scim_external_id", "scim_rich_info", - "user_id" + "user_id", + "num_devices" ] allowEmpty :: (ByteString -> Parser a) -> ByteString -> Parser (Maybe a) @@ -117,6 +120,7 @@ instance FromNamedRecord TeamExportUser where <*> (nrec .: "scim_external_id" >>= parseByteString) <*> (nrec .: "scim_rich_info" >>= allowEmpty (maybe (fail "failed to decode RichInfo") pure . Aeson.decode . cs)) <*> (nrec .: "user_id" >>= parseByteString) + <*> (nrec .: "num_devices" >>= parseByteString) quoted :: ByteString -> ByteString quoted bs = case C.uncons bs of diff --git a/libs/wire-api/src/Wire/API/Team/Feature.hs b/libs/wire-api/src/Wire/API/Team/Feature.hs index f4b103099b..092f11e823 100644 --- a/libs/wire-api/src/Wire/API/Team/Feature.hs +++ b/libs/wire-api/src/Wire/API/Team/Feature.hs @@ -37,14 +37,7 @@ module Wire.API.Team.Feature LockStatus (..), LockStatusValue (..), IncludeLockStatus (..), - defaultAppLockStatus, - defaultClassifiedDomains, - defaultSelfDeletingMessagesStatus, - defaultGuestLinksStatus, - defaultTeamFeatureFileSharing, - defaultTeamFeatureValidateSAMLEmailsStatus, - defaultTeamFeatureSndFactorPasswordChallengeStatus, - defaultTeamFeatureSearchVisibilityInbound, + DefTeamFeatureStatus (..), -- * Swagger typeTeamFeatureName, @@ -62,8 +55,6 @@ module Wire.API.Team.Feature where import qualified Cassandra.CQL as Cass -import Control.Lens.Combinators (dimap) -import qualified Data.Aeson as Aeson import qualified Data.Attoparsec.ByteString as Parser import Data.ByteString.Conversion (FromByteString (..), ToByteString (..), fromByteString, toByteString') import Data.Domain (Domain) @@ -85,7 +76,7 @@ import Wire.API.Arbitrary (Arbitrary, GenericUniform (..)) ---------------------------------------------------------------------- -- TeamFeatureName --- | If you add a constructor here, you need extend multiple defintions, which +-- | If you add a constructor here, you need extend multiple definitions, which -- aren't checked by GHC. -- -- Follow this Checklist: @@ -102,9 +93,8 @@ import Wire.API.Arbitrary (Arbitrary, GenericUniform (..)) -- * Update the Arbitrary instance of FeatureFlags -- in libs/galley-types/test/unit/Test/Galley/Types.hs -- * roleHiddenPermissions ChangeTeamFeature and ViewTeamFeature --- * services/galley/src/Galley/API/Teams/Features.hs --- * maybe extend getAllFeatureConfigs (if feature status is user-visibile) --- * maybe extend getAllFeatures (if feature status is user-visibile) +-- * add the feature status to `AllFeatureConfigs` (see below) +-- * follow the type errors and fix them (e.g. in services/galley/src/Galley/API/Teams/Features.hs) -- * services/galley/schema/src/ -- * add a migration like the one in "V43_TeamFeatureDigitalSignatures.hs" -- * services/galley/test/integration/API/Teams/Feature.hs @@ -362,6 +352,59 @@ modelForTeamFeature TeamFeatureGuestLinks = modelTeamFeatureStatusNoConfig modelForTeamFeature TeamFeatureSndFactorPasswordChallenge = modelTeamFeatureStatusNoConfig modelForTeamFeature TeamFeatureSearchVisibilityInbound = modelTeamFeatureStatusNoConfig +data AllFeatureConfigs = AllFeatureConfigs + { afcLegalholdStatusInternal :: TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureLegalHold, + afcSSOStatusInternal :: TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureSSO, + afcTeamSearchVisibilityAvailableInternal :: TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureSearchVisibility, + afcValidateSAMLEmailsInternal :: TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureValidateSAMLEmails, + afcDigitalSignaturesInternal :: TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureDigitalSignatures, + afcAppLockInternal :: TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureAppLock, + afcFileSharingInternal :: TeamFeatureStatus 'WithLockStatus 'TeamFeatureFileSharing, + afcClassifiedDomainsInternal :: TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureClassifiedDomains, + afcConferenceCallingInternal :: TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureConferenceCalling, + afcSelfDeletingMessagesInternal :: TeamFeatureStatus 'WithLockStatus 'TeamFeatureSelfDeletingMessages, + afcGuestLinkInternal :: TeamFeatureStatus 'WithLockStatus 'TeamFeatureGuestLinks, + afcSndFactorPasswordChallengeInternal :: TeamFeatureStatus 'WithLockStatus 'TeamFeatureSndFactorPasswordChallenge + } + deriving stock (Eq, Show) + deriving (FromJSON, ToJSON, S.ToSchema) via (Schema AllFeatureConfigs) + +instance ToSchema AllFeatureConfigs where + schema = + object "AllFeatureConfigs" $ + AllFeatureConfigs + <$> afcLegalholdStatusInternal .= field (name @'TeamFeatureLegalHold) schema + <*> afcSSOStatusInternal .= field (name @'TeamFeatureSSO) schema + <*> afcTeamSearchVisibilityAvailableInternal .= field (name @'TeamFeatureSearchVisibility) schema + <*> afcValidateSAMLEmailsInternal .= field (name @'TeamFeatureValidateSAMLEmails) schema + <*> afcDigitalSignaturesInternal .= field (name @'TeamFeatureDigitalSignatures) schema + <*> afcAppLockInternal .= field (name @'TeamFeatureAppLock) schema + <*> afcFileSharingInternal .= field (name @'TeamFeatureFileSharing) schema + <*> afcClassifiedDomainsInternal .= field (name @'TeamFeatureClassifiedDomains) schema + <*> afcConferenceCallingInternal .= field (name @'TeamFeatureConferenceCalling) schema + <*> afcSelfDeletingMessagesInternal .= field (name @'TeamFeatureSelfDeletingMessages) schema + <*> afcGuestLinkInternal .= field (name @'TeamFeatureGuestLinks) schema + <*> afcSndFactorPasswordChallengeInternal .= field (name @'TeamFeatureSndFactorPasswordChallenge) schema + where + name :: forall a. KnownTeamFeatureName a => Text + name = cs (toByteString' (knownTeamFeatureName @a)) + +instance Arbitrary AllFeatureConfigs where + arbitrary = + AllFeatureConfigs + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + ---------------------------------------------------------------------- -- TeamFeatureStatusNoConfig @@ -430,10 +473,13 @@ modelTeamFeatureStatusWithConfig name cfgModel = Doc.defineModel (cs $ show name instance ToSchema cfg => ToSchema (TeamFeatureStatusWithConfig cfg) where schema = - object "TeamFeatureStatusWithConfig" $ + object name $ TeamFeatureStatusWithConfig <$> tfwcStatus .= field "status" schema - <*> tfwcConfig .= field "config" schema + <*> tfwcConfig .= field "config" inner + where + inner = schema @cfg + name = "TeamFeatureStatusWithConfig." <> fromMaybe "" (getName (schemaDoc inner)) data TeamFeatureStatusWithConfigAndLockStatus (cfg :: *) = TeamFeatureStatusWithConfigAndLockStatus { tfwcapsStatus :: TeamFeatureStatusValue, @@ -455,18 +501,14 @@ modelTeamFeatureStatusWithConfigAndLockStatus name cfgModel = Doc.defineModel (c instance ToSchema cfg => ToSchema (TeamFeatureStatusWithConfigAndLockStatus cfg) where schema = - object "TeamFeatureStatusWithConfigAndLockStatus" $ + object name $ TeamFeatureStatusWithConfigAndLockStatus <$> tfwcapsStatus .= field "status" schema - <*> tfwcapsConfig .= field "config" schema + <*> tfwcapsConfig .= field "config" inner <*> tfwcapsLockStatus .= field "lockStatus" schema - ----------------------------------------------------------------------- --- TeamFeatureFileSharing - -defaultTeamFeatureFileSharing :: TeamFeatureStatusNoConfigAndLockStatus -defaultTeamFeatureFileSharing = - TeamFeatureStatusNoConfigAndLockStatus TeamFeatureEnabled Unlocked + where + inner = schema @cfg + name = "TeamFeatureStatusWithConfigAndLockStatus." <> fromMaybe "" (getName (schemaDoc inner)) ---------------------------------------------------------------------- -- TeamFeatureClassifiedDomainsConfig @@ -490,12 +532,6 @@ modelTeamFeatureClassifiedDomainsConfig = Doc.defineModel "TeamFeatureClassifiedDomainsConfig" $ do Doc.property "domains" (Doc.array Doc.string') $ Doc.description "domains" -defaultClassifiedDomains :: TeamFeatureStatusWithConfig TeamFeatureClassifiedDomainsConfig -defaultClassifiedDomains = - TeamFeatureStatusWithConfig - TeamFeatureDisabled - (TeamFeatureClassifiedDomainsConfig []) - ---------------------------------------------------------------------- -- TeamFeatureAppLockConfig @@ -529,12 +565,6 @@ modelTeamFeatureAppLockConfig = Doc.property "enforceAppLock" Doc.bool' $ Doc.description "enforceAppLock" Doc.property "inactivityTimeoutSecs" Doc.int32' $ Doc.description "" -defaultAppLockStatus :: TeamFeatureStatusWithConfig TeamFeatureAppLockConfig -defaultAppLockStatus = - TeamFeatureStatusWithConfig - TeamFeatureEnabled - (TeamFeatureAppLockConfig (EnforceAppLock False) 60) - ---------------------------------------------------------------------- -- TeamFeatureSelfDeletingMessagesConfig @@ -556,13 +586,6 @@ modelTeamFeatureSelfDeletingMessagesConfig = Doc.defineModel "TeamFeatureSelfDeletingMessagesConfig" $ do Doc.property "enforcedTimeoutSeconds" Doc.int32' $ Doc.description "optional; default: `0` (no enforcement)" -defaultSelfDeletingMessagesStatus :: TeamFeatureStatusWithConfigAndLockStatus TeamFeatureSelfDeletingMessagesConfig -defaultSelfDeletingMessagesStatus = - TeamFeatureStatusWithConfigAndLockStatus - TeamFeatureEnabled - (TeamFeatureSelfDeletingMessagesConfig 0) - Unlocked - ---------------------------------------------------------------------- -- LockStatus @@ -634,28 +657,47 @@ instance Cass.Cql LockStatusValue where toCql Unlocked = Cass.CqlInt 1 ---------------------------------------------------------------------- --- guest links +-- defaults -defaultGuestLinksStatus :: TeamFeatureStatusNoConfigAndLockStatus -defaultGuestLinksStatus = TeamFeatureStatusNoConfigAndLockStatus TeamFeatureEnabled Unlocked +class DefTeamFeatureStatus (a :: TeamFeatureName) where + defTeamFeatureStatus :: TeamFeatureStatus 'WithLockStatus a ----------------------------------------------------------------------- --- TeamFeatureValidateSAMLEmails +instance DefTeamFeatureStatus 'TeamFeatureGuestLinks where + defTeamFeatureStatus = TeamFeatureStatusNoConfigAndLockStatus TeamFeatureEnabled Unlocked -defaultTeamFeatureValidateSAMLEmailsStatus :: TeamFeatureStatusNoConfig -defaultTeamFeatureValidateSAMLEmailsStatus = TeamFeatureStatusNoConfig TeamFeatureEnabled +instance DefTeamFeatureStatus 'TeamFeatureValidateSAMLEmails where + defTeamFeatureStatus = TeamFeatureStatusNoConfig TeamFeatureEnabled ----------------------------------------------------------------------- --- TeamFeatureSndFactorPasswordChallenge +instance DefTeamFeatureStatus 'TeamFeatureSndFactorPasswordChallenge where + defTeamFeatureStatus = TeamFeatureStatusNoConfigAndLockStatus TeamFeatureDisabled Locked -defaultTeamFeatureSndFactorPasswordChallengeStatus :: TeamFeatureStatusNoConfigAndLockStatus -defaultTeamFeatureSndFactorPasswordChallengeStatus = TeamFeatureStatusNoConfigAndLockStatus TeamFeatureDisabled Locked +instance DefTeamFeatureStatus 'TeamFeatureSearchVisibilityInbound where + defTeamFeatureStatus = TeamFeatureStatusNoConfig TeamFeatureDisabled ----------------------------------------------------------------------- --- TeamFeatureSearchVisibilityInbound +instance DefTeamFeatureStatus 'TeamFeatureFileSharing where + defTeamFeatureStatus = TeamFeatureStatusNoConfigAndLockStatus TeamFeatureEnabled Unlocked + +instance DefTeamFeatureStatus 'TeamFeatureSelfDeletingMessages where + defTeamFeatureStatus = + TeamFeatureStatusWithConfigAndLockStatus + TeamFeatureEnabled + (TeamFeatureSelfDeletingMessagesConfig 0) + Unlocked + +instance DefTeamFeatureStatus 'TeamFeatureClassifiedDomains where + defTeamFeatureStatus = + TeamFeatureStatusWithConfig + TeamFeatureDisabled + (TeamFeatureClassifiedDomainsConfig []) + +instance DefTeamFeatureStatus 'TeamFeatureAppLock where + defTeamFeatureStatus = + TeamFeatureStatusWithConfig + TeamFeatureEnabled + (TeamFeatureAppLockConfig (EnforceAppLock False) 60) -defaultTeamFeatureSearchVisibilityInbound :: TeamFeatureStatusNoConfig -defaultTeamFeatureSearchVisibilityInbound = TeamFeatureStatusNoConfig TeamFeatureDisabled +instance DefTeamFeatureStatus 'TeamFeatureConferenceCalling where + defTeamFeatureStatus = TeamFeatureStatusNoConfig TeamFeatureEnabled ---------------------------------------------------------------------- -- internal @@ -665,12 +707,3 @@ data LowerCaseFirst instance StringModifier LowerCaseFirst where getStringModifier (x : xs) = toLower x : xs getStringModifier [] = [] - -newtype AllFeatureConfigs = AllFeatureConfigs {_allFeatureConfigs :: Aeson.Object} - deriving stock (Eq, Show) - deriving (FromJSON, ToJSON, S.ToSchema) via (Schema AllFeatureConfigs) - -instance ToSchema AllFeatureConfigs where - schema = - named "AllFeatureConfigs" $ - dimap _allFeatureConfigs AllFeatureConfigs jsonObject diff --git a/libs/wire-api/src/Wire/API/User/Saml.hs b/libs/wire-api/src/Wire/API/User/Saml.hs index 38ac763829..4d3939a3f4 100644 --- a/libs/wire-api/src/Wire/API/User/Saml.hs +++ b/libs/wire-api/src/Wire/API/User/Saml.hs @@ -114,8 +114,7 @@ data Opts' a = Opts instance FromJSON (Opts' (Maybe ())) data DerivedOpts = DerivedOpts - { derivedOptsBindCookiePath :: !SBS, - derivedOptsScimBaseURI :: !URI + { derivedOptsScimBaseURI :: !URI } deriving (Show, Generic) diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generator.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generator.hs deleted file mode 100644 index e785940cff..0000000000 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generator.hs +++ /dev/null @@ -1,362 +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.Wire.API.Golden.Generator where - -import Data.Id -import Imports -import System.IO (Handle, hPutStr, hPutStrLn) -import Test.Tasty.QuickCheck (Arbitrary (..), generate) -import Type.Reflection (typeRep) -import qualified Wire.API.Asset as Asset -import qualified Wire.API.Call.Config as Call.Config -import qualified Wire.API.Connection as Connection -import qualified Wire.API.Conversation as Conversation -import qualified Wire.API.Conversation.Bot as Conversation.Bot -import qualified Wire.API.Conversation.Code as Conversation.Code -import qualified Wire.API.Conversation.Member as Conversation.Member -import qualified Wire.API.Conversation.Role as Conversation.Role -import qualified Wire.API.Conversation.Typing as Conversation.Typing -import qualified Wire.API.CustomBackend as CustomBackend -import qualified Wire.API.Event.Conversation as Event.Conversation -import qualified Wire.API.Event.Team as Event.Team -import qualified Wire.API.Message as Message -import qualified Wire.API.Notification as Notification -import qualified Wire.API.Properties as Properties -import qualified Wire.API.Provider as Provider -import qualified Wire.API.Provider.Bot as Provider.Bot -import qualified Wire.API.Provider.External as Provider.External -import qualified Wire.API.Provider.Service as Provider.Service -import qualified Wire.API.Provider.Service.Tag as Provider.Service.Tag -import qualified Wire.API.Push.Token as Push.Token -import qualified Wire.API.Team as Team -import qualified Wire.API.Team.Conversation as Team.Conversation -import qualified Wire.API.Team.Feature as Team.Feature -import qualified Wire.API.Team.Invitation as Team.Invitation -import qualified Wire.API.Team.LegalHold as Team.LegalHold -import qualified Wire.API.Team.LegalHold.External as Team.LegalHold.External -import qualified Wire.API.Team.Member as Team.Member -import qualified Wire.API.Team.Permission as Team.Permission -import qualified Wire.API.Team.Role as Team.Role -import qualified Wire.API.Team.SearchVisibility as Team.SearchVisibility -import qualified Wire.API.User as User -import qualified Wire.API.User.Activation as User.Activation -import qualified Wire.API.User.Auth as User.Auth -import qualified Wire.API.User.Client as User.Client -import qualified Wire.API.User.Client.Prekey as User.Client.Prekey -import qualified Wire.API.User.Handle as User.Handle -import qualified Wire.API.User.Identity as User.Identity -import qualified Wire.API.User.Password as User.Password -import qualified Wire.API.User.Profile as User.Profile -import qualified Wire.API.User.RichInfo as User.RichInfo -import qualified Wire.API.User.Search as User.Search -import qualified Wire.API.Wrapped as Wrapped - -type Ref = IORef [(FilePath, [(String, FilePath)])] - --- NOTE: this will generate broken haskell code --- --- To make the generated code compile, this needs to be run with --- patched Show instances for certain types. Furthermore, a --- substitution must be run on the generated code. This is done --- automatically by the gentests.sh script. -generateBindingModule' :: - forall a. - (Arbitrary a, Show a) => - String -> - String -> - Ref -> - IO () -generateBindingModule' typeName section ref = do - tmpdir <- getEnv "GOLDEN_TMPDIR" - objects <- replicateM 20 (generate (arbitrary @a)) - let escape c - | isAlphaNum c = [c] - | ord c < 256 = - [ '_', - intToDigit (ord c `div` 16), - intToDigit (ord c `mod` 16) - ] - | otherwise = "" - moduleName = (typeName >>= escape) <> "_" <> section - varName n = "testObject_" <> moduleName <> "_" <> show n - fileName n = varName n <> ".json" - numberedObjs = zip [1 :: Int ..] objects - generateBinding h n o = do - hPutStrLn h $ varName n <> " :: " <> typeName - hPutStrLn h $ varName n <> " = " <> show o - varNames = map (\(n, _) -> (varName n, fileName n)) numberedObjs - h <- openFile (tmpdir <> "/" <> moduleName <> ".hs") WriteMode - traverse_ (uncurry (generateBinding h)) numberedObjs - modifyIORef ref (<> [(moduleName, varNames)]) - hClose h - putStrLn (moduleName <> " " <> section) - -generateBindingModule :: - forall a. - (Arbitrary a, Show a, Typeable a) => - String -> - Ref -> - IO () -generateBindingModule = generateBindingModule' @a (show (typeRep @a)) - -generateImports :: Handle -> (FilePath, [(String, FilePath)]) -> IO () -generateImports h (module_, _) = hPutStrLn h $ "import qualified Test.Wire.API.Golden.Generated." <> module_ - -generateTestCase :: Handle -> Int -> (FilePath, [(String, FilePath)]) -> IO () -generateTestCase h index (module_, objs) = do - hPutStr h " " - when (index > 0) $ hPutStr h "," - hPutStrLn h $ " testCase (\"Golden: " <> module_ <> "\") $ " - hPutStrLn h $ " testObjects [" <> intercalate ", " (map objTuple objs) <> "]" - where - objTuple (var, path) = "(" <> "Test.Wire.API.Golden.Generated." <> module_ <> "." <> var <> ", " <> show path <> ")" - -generateTestModule :: IO () -generateTestModule = do - ref <- newIORef mempty - - generateBindingModule @Asset.AssetToken "user" ref - generateBindingModule @Asset.NewAssetToken "user" ref - generateBindingModule @Asset.AssetRetention "user" ref - generateBindingModule @Asset.AssetSettings "user" ref - generateBindingModule @Asset.AssetKey "user" ref - generateBindingModule @Call.Config.TurnHost "user" ref - generateBindingModule @Call.Config.Scheme "user" ref - generateBindingModule @Call.Config.Transport "user" ref - generateBindingModule @Call.Config.TurnURI "user" ref - generateBindingModule @Call.Config.TurnUsername "user" ref - generateBindingModule @Call.Config.RTCIceServer "user" ref - generateBindingModule @Call.Config.RTCConfiguration "user" ref - generateBindingModule @Call.Config.SFTServer "user" ref - generateBindingModule @Connection.ConnectionRequest "user" ref - generateBindingModule @Connection.Relation "user" ref - generateBindingModule @Connection.UserConnection "user" ref - generateBindingModule @Connection.UserConnectionList "user" ref - generateBindingModule @Connection.ConnectionUpdate "user" ref - generateBindingModule @Conversation.Conversation "user" ref - generateBindingModule @(Conversation.ConversationList ConvId) "user" ref - generateBindingModule @(Conversation.ConversationList Conversation.Conversation) "user" ref - generateBindingModule @Conversation.Access "user" ref - generateBindingModule @Conversation.ConvType "user" ref - generateBindingModule @Conversation.ReceiptMode "user" ref - generateBindingModule @Conversation.ConvTeamInfo "user" ref - generateBindingModule @Conversation.Invite "user" ref - generateBindingModule @Conversation.ConversationRename "user" ref - generateBindingModule @Conversation.ConversationAccessData "user" ref - generateBindingModule @Conversation.ConversationReceiptModeUpdate "user" ref - generateBindingModule @Conversation.ConversationMessageTimerUpdate "user" ref - generateBindingModule @Conversation.Bot.AddBot "user" ref - generateBindingModule @Conversation.Bot.AddBotResponse "user" ref - generateBindingModule @Conversation.Bot.RemoveBotResponse "user" ref - generateBindingModule @Conversation.Bot.UpdateBotPrekeys "user" ref - generateBindingModule @Conversation.Code.ConversationCode "user" ref - generateBindingModule @Conversation.Member.MemberUpdate "user" ref - generateBindingModule @Conversation.Member.MutedStatus "user" ref - generateBindingModule @Conversation.Member.Member "user" ref - generateBindingModule @Conversation.Member.OtherMember "user" ref - generateBindingModule @Conversation.Member.ConvMembers "user" ref - generateBindingModule @Conversation.Member.OtherMemberUpdate "user" ref - generateBindingModule @Conversation.Role.RoleName "user" ref - generateBindingModule @Conversation.Role.Action "user" ref - generateBindingModule @Conversation.Role.ConversationRole "user" ref - generateBindingModule @Conversation.Role.ConversationRolesList "user" ref - generateBindingModule @Conversation.Typing.TypingStatus "user" ref - generateBindingModule @Conversation.Typing.TypingData "user" ref - generateBindingModule @CustomBackend.CustomBackend "user" ref - generateBindingModule @Event.Conversation.Event "user" ref - generateBindingModule @Event.Conversation.EventType "user" ref - generateBindingModule @Event.Conversation.SimpleMember "user" ref - generateBindingModule @Event.Conversation.SimpleMembers "user" ref - generateBindingModule @Event.Conversation.Connect "user" ref - generateBindingModule @Event.Conversation.MemberUpdateData "user" ref - generateBindingModule @Event.Conversation.OtrMessage "user" ref - generateBindingModule @Message.Priority "user" ref - generateBindingModule @Message.OtrRecipients "user" ref - generateBindingModule @Message.NewOtrMessage "user" ref - generateBindingModule @Message.ClientMismatch "user" ref - generateBindingModule @Notification.QueuedNotification "user" ref - generateBindingModule @Notification.QueuedNotificationList "user" ref - generateBindingModule @Properties.PropertyKey "user" ref - generateBindingModule' @Push.Token.Transport "Push.Token.Transport" "user" ref - generateBindingModule @Push.Token.Token "user" ref - generateBindingModule @Push.Token.AppName "user" ref - generateBindingModule @Push.Token.PushToken "user" ref - generateBindingModule @Push.Token.PushTokenList "user" ref - generateBindingModule @User.NameUpdate "user" ref - generateBindingModule @User.NewUser "user" ref - generateBindingModule @User.NewUserPublic "user" ref - generateBindingModule @User.UserIdList "user" ref - generateBindingModule @(User.LimitedQualifiedUserIdList 20) "user" ref - generateBindingModule @User.UserProfile "user" ref - generateBindingModule @User.User "user" ref - generateBindingModule @User.SelfProfile "user" ref - generateBindingModule @User.InvitationCode "user" ref - generateBindingModule @User.BindingNewTeamUser "user" ref - generateBindingModule @User.UserUpdate "user" ref - generateBindingModule @User.PasswordChange "user" ref - generateBindingModule @User.LocaleUpdate "user" ref - generateBindingModule @User.EmailUpdate "user" ref - generateBindingModule @User.PhoneUpdate "user" ref - generateBindingModule @User.HandleUpdate "user" ref - generateBindingModule @User.DeleteUser "user" ref - generateBindingModule @User.VerifyDeleteUser "user" ref - generateBindingModule @User.DeletionCodeTimeout "user" ref - generateBindingModule @User.Activation.ActivationKey "user" ref - generateBindingModule @User.Activation.ActivationCode "user" ref - generateBindingModule @User.Activation.Activate "user" ref - generateBindingModule @User.Activation.ActivationResponse "user" ref - generateBindingModule @User.Activation.SendActivationCode "user" ref - generateBindingModule @User.Auth.LoginId "user" ref - generateBindingModule @User.Auth.LoginCode "user" ref - generateBindingModule @User.Auth.PendingLoginCode "user" ref - generateBindingModule @User.Auth.SendLoginCode "user" ref - generateBindingModule @User.Auth.LoginCodeTimeout "user" ref - generateBindingModule @User.Auth.CookieLabel "user" ref - generateBindingModule @User.Auth.Login "user" ref - generateBindingModule @User.Auth.CookieId "user" ref - generateBindingModule @User.Auth.CookieType "user" ref - generateBindingModule @(User.Auth.Cookie ()) "user" ref - generateBindingModule @User.Auth.CookieList "user" ref - generateBindingModule @User.Auth.RemoveCookies "user" ref - generateBindingModule @User.Auth.TokenType "user" ref - generateBindingModule @User.Auth.AccessToken "user" ref - generateBindingModule @(User.Client.UserClientMap Int) "user" ref - generateBindingModule @User.Client.UserClients "user" ref - generateBindingModule @User.Client.ClientType "user" ref - generateBindingModule @User.Client.ClientClass "user" ref - generateBindingModule @User.Client.PubClient "user" ref - generateBindingModule @User.Client.Client "user" ref - generateBindingModule @User.Client.NewClient "user" ref - generateBindingModule @User.Client.UpdateClient "user" ref - generateBindingModule @User.Client.RmClient "user" ref - generateBindingModule @User.Client.Prekey.LastPrekey "user" ref - generateBindingModule @User.Client.Prekey.PrekeyId "user" ref - generateBindingModule @User.Client.Prekey.Prekey "user" ref - generateBindingModule @User.Client.Prekey.ClientPrekey "user" ref - generateBindingModule @User.Client.Prekey.PrekeyBundle "user" ref - generateBindingModule @User.Handle.UserHandleInfo "user" ref - generateBindingModule @User.Handle.CheckHandles "user" ref - generateBindingModule @User.Identity.Email "user" ref - generateBindingModule @User.Identity.Phone "user" ref - generateBindingModule @User.Identity.UserSSOId "user" ref - generateBindingModule @User.Identity.UserIdentity "user" ref - generateBindingModule @User.Password.NewPasswordReset "user" ref - generateBindingModule @User.Password.PasswordResetKey "user" ref - generateBindingModule @User.Password.PasswordResetCode "user" ref - generateBindingModule @User.Password.CompletePasswordReset "user" ref - generateBindingModule @User.Profile.Pict "user" ref - generateBindingModule @User.Profile.Name "user" ref - generateBindingModule @User.Profile.ColourId "user" ref - generateBindingModule @User.Profile.AssetSize "user" ref - generateBindingModule' @User.Profile.Asset "User.Profile.Asset" "user" ref - generateBindingModule @User.Profile.Locale "user" ref - generateBindingModule @User.Profile.ManagedBy "user" ref - generateBindingModule @User.RichInfo.RichField "user" ref - generateBindingModule @User.RichInfo.RichInfoAssocList "user" ref - generateBindingModule @User.RichInfo.RichInfoMapAndList "user" ref - generateBindingModule @User.RichInfo.RichInfo "user" ref - generateBindingModule @(User.Search.SearchResult User.Search.Contact) "user" ref - generateBindingModule @User.Search.Contact "user" ref - generateBindingModule @(User.Search.SearchResult User.Search.TeamContact) "user" ref - generateBindingModule @User.Search.TeamContact "user" ref - generateBindingModule @(Wrapped.Wrapped "some_int" Int) "user" ref - generateBindingModule @Asset.Asset "asset" ref - generateBindingModule @Event.Team.Event "team" ref - generateBindingModule @Event.Team.EventType "team" ref - generateBindingModule @Provider.Provider "provider" ref - generateBindingModule @Provider.ProviderProfile "provider" ref - generateBindingModule @Provider.NewProvider "provider" ref - generateBindingModule @Provider.NewProviderResponse "provider" ref - generateBindingModule @Provider.UpdateProvider "provider" ref - generateBindingModule @Provider.ProviderActivationResponse "provider" ref - generateBindingModule @Provider.ProviderLogin "provider" ref - generateBindingModule @Provider.DeleteProvider "provider" ref - generateBindingModule @Provider.PasswordReset "provider" ref - generateBindingModule @Provider.CompletePasswordReset "provider" ref - generateBindingModule @Provider.PasswordChange "provider" ref - generateBindingModule @Provider.EmailUpdate "provider" ref - generateBindingModule @Provider.Bot.BotConvView "provider" ref - generateBindingModule @Provider.Bot.BotUserView "provider" ref - generateBindingModule @Provider.External.NewBotRequest "provider" ref - generateBindingModule @Provider.External.NewBotResponse "provider" ref - generateBindingModule @Provider.Service.ServiceRef "provider" ref - generateBindingModule @Provider.Service.ServiceKeyPEM "provider" ref - generateBindingModule @Provider.Service.ServiceKeyType "provider" ref - generateBindingModule @Provider.Service.ServiceKey "provider" ref - generateBindingModule @Provider.Service.ServiceToken "provider" ref - generateBindingModule @Provider.Service.Service "provider" ref - generateBindingModule @Provider.Service.ServiceProfile "provider" ref - generateBindingModule @Provider.Service.ServiceProfilePage "provider" ref - generateBindingModule @Provider.Service.NewService "provider" ref - generateBindingModule @Provider.Service.NewServiceResponse "provider" ref - generateBindingModule @Provider.Service.UpdateService "provider" ref - generateBindingModule @Provider.Service.UpdateServiceConn "provider" ref - generateBindingModule @Provider.Service.DeleteService "provider" ref - generateBindingModule @Provider.Service.UpdateServiceWhitelist "provider" ref - generateBindingModule @Provider.Service.Tag.ServiceTag "provider" ref - generateBindingModule @Provider.Service.Tag.ServiceTagList "provider" ref - generateBindingModule @Team.BindingNewTeam "team" ref - generateBindingModule @Team.TeamBinding "team" ref - generateBindingModule @Team.Team "team" ref - generateBindingModule @Team.TeamList "team" ref - generateBindingModule @Team.TeamUpdateData "team" ref - generateBindingModule @Team.TeamDeleteData "team" ref - generateBindingModule @Team.Conversation.TeamConversation "team" ref - generateBindingModule @Team.Conversation.TeamConversationList "team" ref - generateBindingModule @(Team.Feature.TeamFeatureStatus 'Team.Feature.WithoutLockStatus 'Team.Feature.TeamFeatureLegalHold) "team" ref - generateBindingModule @(Team.Feature.TeamFeatureStatus 'Team.Feature.WithoutLockStatus 'Team.Feature.TeamFeatureAppLock) "team" ref - generateBindingModule @Team.Feature.TeamFeatureStatusValue "team" ref - generateBindingModule @Team.Invitation.InvitationRequest "team" ref - generateBindingModule @Team.Invitation.Invitation "team" ref - generateBindingModule @Team.Invitation.InvitationList "team" ref - generateBindingModule @Team.LegalHold.NewLegalHoldService "team" ref - generateBindingModule @Team.LegalHold.ViewLegalHoldServiceInfo "team" ref - generateBindingModule @Team.LegalHold.ViewLegalHoldService "team" ref - generateBindingModule @Team.LegalHold.UserLegalHoldStatusResponse "team" ref - generateBindingModule @Team.LegalHold.RemoveLegalHoldSettingsRequest "team" ref - generateBindingModule @Team.LegalHold.DisableLegalHoldForUserRequest "team" ref - generateBindingModule @Team.LegalHold.ApproveLegalHoldForUserRequest "team" ref - generateBindingModule @Team.LegalHold.External.RequestNewLegalHoldClient "team" ref - generateBindingModule @Team.LegalHold.External.NewLegalHoldClient "team" ref - generateBindingModule @Team.LegalHold.External.LegalHoldServiceConfirm "team" ref - generateBindingModule @Team.LegalHold.External.LegalHoldServiceRemove "team" ref - generateBindingModule @Team.Member.TeamMember "team" ref - generateBindingModule @Team.Member.ListType "team" ref - generateBindingModule @Team.Member.TeamMemberList "team" ref - generateBindingModule @Team.Member.NewTeamMember "team" ref - generateBindingModule @Team.Member.TeamMemberDeleteData "team" ref - generateBindingModule @Team.Permission.Permissions "team" ref - generateBindingModule @Team.Role.Role "team" ref - generateBindingModule @Team.SearchVisibility.TeamSearchVisibility "team" ref - generateBindingModule @Team.SearchVisibility.TeamSearchVisibilityView "team" ref - - bindings <- readIORef ref - - testmain <- getEnv "GOLDEN_TESTDIR" - h <- openFile (testmain <> ".hs") WriteMode - hPutStrLn h "module Test.Wire.API.Golden.Generated where\n" - hPutStrLn h "import Imports" - hPutStrLn h "import Test.Wire.API.Golden.Runner" - hPutStrLn h "import Test.Tasty" - hPutStrLn h "import Test.Tasty.HUnit" - traverse_ (generateImports h) bindings - hPutStrLn h "tests :: TestTree" - hPutStrLn h "tests = testGroup \"Golden tests\" [" - traverse_ (uncurry (generateTestCase h)) (zip [0 :: Int ..] bindings) - hPutStrLn h " ]" - hClose h 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 6c125124df..051555807f 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 @@ -201,6 +201,7 @@ tests = testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.WithLockStatus 'Team.Feature.TeamFeatureSelfDeletingMessages), testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.WithoutLockStatus 'Team.Feature.TeamFeatureSelfDeletingMessages), testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.WithoutLockStatus 'Team.Feature.TeamFeatureSearchVisibilityInbound), + testRoundTrip @Team.Feature.AllFeatureConfigs, testRoundTrip @Team.Feature.TeamFeatureStatusValue, testRoundTrip @Team.Feature.LockStatusValue, testRoundTrip @Team.Feature.LockStatus, diff --git a/libs/wire-api/wire-api.cabal b/libs/wire-api/wire-api.cabal index b1c15d5eb0..797d736bf0 100644 --- a/libs/wire-api/wire-api.cabal +++ b/libs/wire-api/wire-api.cabal @@ -30,7 +30,6 @@ library Wire.API.Conversation.Protocol Wire.API.Conversation.Role Wire.API.Conversation.Typing - Wire.API.Cookie Wire.API.CustomBackend Wire.API.Error Wire.API.Error.Brig @@ -69,6 +68,7 @@ library Wire.API.Routes.API Wire.API.Routes.AssetBody Wire.API.Routes.ClientAlgebra + Wire.API.Routes.CSV Wire.API.Routes.Internal.Brig Wire.API.Routes.Internal.Brig.Connection Wire.API.Routes.Internal.Brig.EJPD @@ -76,6 +76,7 @@ library Wire.API.Routes.Internal.Cargohold Wire.API.Routes.Internal.Galley.TeamFeatureNoConfigMulti Wire.API.Routes.Internal.LegalHold + Wire.API.Routes.LowLevelStream Wire.API.Routes.MultiTablePaging Wire.API.Routes.MultiTablePaging.State Wire.API.Routes.MultiVerb @@ -477,7 +478,6 @@ test-suite wire-api-golden-tests Test.Wire.API.Golden.Generated.ViewLegalHoldService_team Test.Wire.API.Golden.Generated.ViewLegalHoldServiceInfo_team Test.Wire.API.Golden.Generated.Wrapped_20_22some_5fint_22_20Int_user - Test.Wire.API.Golden.Generator Test.Wire.API.Golden.Manual Test.Wire.API.Golden.Manual.ClientCapability Test.Wire.API.Golden.Manual.ClientCapabilityList diff --git a/nix/default.nix b/nix/default.nix index 28c3925e49..7b30e313f5 100644 --- a/nix/default.nix +++ b/nix/default.nix @@ -54,6 +54,7 @@ let # for cabal, as setting it in direnv can interfere with programs in the host # system, especially for non-NixOS users. cabal-wrapper = pkgs.writeShellScriptBin "cabal" '' + export NIX_BUILD_SHELL="${pkgs.bash}/bin/bash" export CPATH="${compile-deps}/include" export LD_LIBRARY_PATH="${compile-deps}/lib" export LIBRARY_PATH="${compile-deps}/lib" @@ -80,6 +81,7 @@ let pkgs.gnused pkgs.helm pkgs.helmfile + pkgs.hlint pkgs.jq pkgs.kind pkgs.kubectl diff --git a/services/brig/docs/swagger-v0.json b/services/brig/docs/swagger-v0.json index 40299683ed..c6eaca520c 100644 --- a/services/brig/docs/swagger-v0.json +++ b/services/brig/docs/swagger-v0.json @@ -11512,90 +11512,6 @@ "summary": "Change your phone number." } }, - "/sso-initiate-bind/{idp}": { - "get": { - "parameters": [ - { - "in": "query", - "name": "success_redirect", - "required": false, - "type": "string" - }, - { - "in": "query", - "name": "error_redirect", - "required": false, - "type": "string" - }, - { - "format": "uuid", - "in": "path", - "name": "idp", - "required": true, - "type": "string" - } - ], - "produces": [ - "text/html" - ], - "responses": { - "200": { - "description": "", - "headers": { - "Set-Cookie": { - "type": "string" - } - }, - "schema": { - "$ref": "#/definitions/FormRedirect" - } - }, - "400": { - "description": "Invalid `error_redirect` or `success_redirect`" - }, - "404": { - "description": "`idp` not found" - } - } - }, - "head": { - "parameters": [ - { - "in": "query", - "name": "success_redirect", - "required": false, - "type": "string" - }, - { - "in": "query", - "name": "error_redirect", - "required": false, - "type": "string" - }, - { - "format": "uuid", - "in": "path", - "name": "idp", - "required": true, - "type": "string" - } - ], - "produces": [ - "text/plain;charset=utf-8" - ], - "responses": { - "200": { - "description": "" - }, - "400": { - "description": "Invalid `error_redirect` or `success_redirect`" - }, - "404": { - "description": "`idp` not found" - } - } - } - }, "/sso/finalize-login": { "post": { "parameters": [ diff --git a/services/brig/docs/swagger-v1.json b/services/brig/docs/swagger-v1.json index 32d000f24d..82a9e56584 100644 --- a/services/brig/docs/swagger-v1.json +++ b/services/brig/docs/swagger-v1.json @@ -11512,90 +11512,6 @@ "summary": "Change your phone number." } }, - "/sso-initiate-bind/{idp}": { - "get": { - "parameters": [ - { - "in": "query", - "name": "success_redirect", - "required": false, - "type": "string" - }, - { - "in": "query", - "name": "error_redirect", - "required": false, - "type": "string" - }, - { - "format": "uuid", - "in": "path", - "name": "idp", - "required": true, - "type": "string" - } - ], - "produces": [ - "text/html" - ], - "responses": { - "200": { - "description": "", - "headers": { - "Set-Cookie": { - "type": "string" - } - }, - "schema": { - "$ref": "#/definitions/FormRedirect" - } - }, - "400": { - "description": "Invalid `error_redirect` or `success_redirect`" - }, - "404": { - "description": "`idp` not found" - } - } - }, - "head": { - "parameters": [ - { - "in": "query", - "name": "success_redirect", - "required": false, - "type": "string" - }, - { - "in": "query", - "name": "error_redirect", - "required": false, - "type": "string" - }, - { - "format": "uuid", - "in": "path", - "name": "idp", - "required": true, - "type": "string" - } - ], - "produces": [ - "text/plain;charset=utf-8" - ], - "responses": { - "200": { - "description": "" - }, - "400": { - "description": "Invalid `error_redirect` or `success_redirect`" - }, - "404": { - "description": "`idp` not found" - } - } - } - }, "/sso/finalize-login": { "post": { "parameters": [ diff --git a/services/brig/src/Brig/API/Client.hs b/services/brig/src/Brig/API/Client.hs index 46371c9329..5744bb9b95 100644 --- a/services/brig/src/Brig/API/Client.hs +++ b/services/brig/src/Brig/API/Client.hs @@ -145,9 +145,9 @@ addClientWithReAuthPolicy :: NewClient -> ExceptT ClientError (AppT r) Client addClientWithReAuthPolicy policy u con ip new = do - acc <- lift (wrapClient $ Data.lookupAccount u) >>= maybe (throwE (ClientUserNotFound u)) return + acc <- lift (wrapClient $ Data.lookupAccount u) >>= maybe (throwE (ClientUserNotFound u)) pure wrapHttpClientE $ verifyCode (newClientVerificationCode new) (userId . accountUser $ acc) - loc <- maybe (return Nothing) locationOf ip + loc <- maybe (pure Nothing) locationOf ip maxPermClients <- fromMaybe Opt.defUserMaxPermClients . Opt.setUserMaxPermClients <$> view settings let caps :: Maybe (Set ClientCapability) caps = updlhdev $ newClientCapabilities new @@ -172,7 +172,7 @@ addClientWithReAuthPolicy policy u con ip new = do for_ (userEmail usr) $ \email -> sendNewClientEmail (userDisplayName usr) email clt (userLocale usr) - return clt + pure clt where clientId' = clientIdFromPrekey (unpackLastPrekey $ newClientLastKey new) @@ -374,7 +374,7 @@ claimLocalMultiPrekeyBundles protectee userClients = do getClientKeys u c = do key <- fmap prekeyData <$> Data.claimPrekey u c when (isNothing key) $ noPrekeys u c - return key + pure key -- Utilities diff --git a/services/brig/src/Brig/API/Connection.hs b/services/brig/src/Brig/API/Connection.hs index 21c1efcc35..da4a3dd5fc 100644 --- a/services/brig/src/Brig/API/Connection.hs +++ b/services/brig/src/Brig/API/Connection.hs @@ -122,15 +122,15 @@ createConnectionToLocalUser self conn target = do <$> wrapClient (Data.lookupName (tUnqualified self)) let e2s = ConnectionUpdated s2o' (ucStatus <$> s2o) Nothing mapM_ (Intra.onConnectionEvent (tUnqualified self) (Just conn)) [e2o, e2s] - return s2o' + pure s2o' update :: UserConnection -> UserConnection -> ExceptT ConnectionError (AppT r) (ResponseForExistedCreated UserConnection) update s2o o2s = case (ucStatus s2o, ucStatus o2s) of (MissingLegalholdConsent, _) -> throwE $ InvalidTransition (tUnqualified self) (_, MissingLegalholdConsent) -> throwE $ InvalidTransition (tUnqualified self) - (Accepted, Accepted) -> return $ Existed s2o - (Accepted, Blocked) -> return $ Existed s2o - (Sent, Blocked) -> return $ Existed s2o + (Accepted, Accepted) -> pure $ Existed s2o + (Accepted, Blocked) -> pure $ Existed s2o + (Sent, Blocked) -> pure $ Existed s2o (Blocked, _) -> throwE $ InvalidTransition (tUnqualified self) (_, Blocked) -> change s2o SentWithHistory (_, Sent) -> accept s2o o2s @@ -159,7 +159,7 @@ createConnectionToLocalUser self conn target = do <$> Data.lookupName (tUnqualified self) let e2s = ConnectionUpdated s2o' (Just $ ucStatus s2o) Nothing lift $ mapM_ (Intra.onConnectionEvent (tUnqualified self) (Just conn)) [e2o, e2s] - return $ Existed s2o' + pure $ Existed s2o' resend :: UserConnection -> UserConnection -> ExceptT ConnectionError (AppT r) (ResponseForExistedCreated UserConnection) resend s2o o2s = do @@ -169,7 +169,7 @@ createConnectionToLocalUser self conn target = do logLocalConnection (tUnqualified self) (qUnqualified (ucTo s2o)) . msg (val "Resending connection request") s2o' <- insert (Just s2o) (Just o2s) - return $ Existed s2o' + pure $ Existed s2o' change :: UserConnection -> RelationWithHistory -> ExceptT ConnectionError (AppT r) (ResponseForExistedCreated UserConnection) change c s = Existed <$> lift (wrapClient $ Data.updateConnection c s) @@ -183,7 +183,7 @@ checkLegalholdPolicyConflict uid1 uid2 = do let catchProfileNotFound = -- Does not fit into 'ExceptT', so throw in '(AppT r)'. Anyway at the time of writing -- this, users are guaranteed to exist when called from 'createConnectionToLocalUser'. - maybe (throwM (errorToWai @'E.UserNotFound)) return + maybe (throwM (errorToWai @'E.UserNotFound)) pure status1 <- lift (wrapHttpClient $ getLegalHoldStatus uid1) >>= catchProfileNotFound status2 <- lift (wrapHttpClient $ getLegalHoldStatus uid2) >>= catchProfileNotFound @@ -270,14 +270,14 @@ updateConnectionToLocalUser self other newStatus conn = do -- Cancelled -> {Blocked} (Cancelled, _, Blocked) -> block s2o -- no change - (old, _, new) | old == new -> return Nothing + (old, _, new) | old == new -> pure Nothing -- invalid _ -> throwE $ InvalidTransition (tUnqualified self) let s2oUserConn = s2o' lift . for_ s2oUserConn $ \c -> let e2s = ConnectionUpdated c (Just $ ucStatus s2o) Nothing in Intra.onConnectionEvent (tUnqualified self) conn e2s - return s2oUserConn + pure s2oUserConn where accept :: UserConnection -> UserConnection -> ExceptT ConnectionError (AppT r) (Maybe UserConnection) accept s2o o2s = do @@ -496,4 +496,4 @@ lookupConnections :: UserId -> Maybe UserId -> Range 1 500 Int32 -> (AppT r) Use lookupConnections from start size = do lusr <- qualifyLocal from rs <- wrapClient $ Data.lookupLocalConnections lusr start size - return $! UserConnectionList (Data.resultList rs) (Data.resultHasMore rs) + pure $! UserConnectionList (Data.resultList rs) (Data.resultHasMore rs) diff --git a/services/brig/src/Brig/API/Handler.hs b/services/brig/src/Brig/API/Handler.hs index 4d5e42b5d1..f845156e22 100644 --- a/services/brig/src/Brig/API/Handler.hs +++ b/services/brig/src/Brig/API/Handler.hs @@ -83,7 +83,7 @@ runHandler e r h k = do a <- runAppT e' (runExceptT h) `catches` brigErrorHandlers (view applog e) (unRequestId (view requestId e)) - either (onError (view applog e') r k) return a + either (onError (view applog e') r k) pure a toServantHandler :: Env -> (Handler BrigCanonicalEffects) a -> Servant.Handler a toServantHandler env action = do diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index 94c150661b..2b0c659aba 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -108,7 +108,14 @@ ejpdAPI = :<|> getConnectionsStatus mlsAPI :: ServerT BrigIRoutes.MLSAPI (Handler r) -mlsAPI = getClientByKeyPackageRef :<|> getMLSClients :<|> mapKeyPackageRefsInternal +mlsAPI = + ( \ref -> + Named @"get-client-by-key-package-ref" (getClientByKeyPackageRef ref) + :<|> Named @"put-conversation-by-key-package-ref" (putConvIdByKeyPackageRef ref) + :<|> Named @"get-conversation-by-key-package-ref" (getConvIdByKeyPackageRef ref) + ) + :<|> getMLSClients + :<|> mapKeyPackageRefsInternal accountAPI :: ServerT BrigIRoutes.AccountAPI (Handler r) accountAPI = Named @"createUserNoVerify" createUserNoVerify @@ -133,6 +140,14 @@ deleteAccountFeatureConfig uid = getClientByKeyPackageRef :: KeyPackageRef -> Handler r (Maybe ClientIdentity) getClientByKeyPackageRef = runMaybeT . mapMaybeT wrapClientE . Data.derefKeyPackage +-- Used by galley to update conversation id in mls_key_package_ref +putConvIdByKeyPackageRef :: KeyPackageRef -> Qualified ConvId -> Handler r Bool +putConvIdByKeyPackageRef ref = lift . wrapClient . Data.keyPackageRefSetConvId ref + +-- Used by galley to retrieve conversation id from mls_key_package_ref +getConvIdByKeyPackageRef :: KeyPackageRef -> Handler r (Maybe (Qualified ConvId)) +getConvIdByKeyPackageRef = runMaybeT . mapMaybeT wrapClientE . Data.keyPackageRefConvId + getMLSClients :: Qualified UserId -> SignatureSchemeTag -> Handler r (Set ClientId) getMLSClients qusr ss = do usr <- lift $ tUnqualified <$> ensureLocal qusr @@ -175,8 +190,8 @@ sitemap :: Members '[CodeStore, PasswordResetStore] r => Routes a (Handler r) () sitemap = do - get "/i/status" (continue $ const $ return empty) true - head "/i/status" (continue $ const $ return empty) true + get "/i/status" (continue $ const $ pure empty) true + head "/i/status" (continue $ const $ pure empty) true -- internal email activation (used in tests and in spar for validating emails obtained as -- SAML user identifiers). if the validate query parameter is false or missing, only set @@ -352,12 +367,12 @@ legalHoldClientRequestedH :: UserId ::: JsonRequest LegalHoldClientRequest ::: J legalHoldClientRequestedH (targetUser ::: req ::: _) = do clientRequest <- parseJsonBody req lift $ API.legalHoldClientRequested targetUser clientRequest - return $ setStatus status200 empty + pure $ setStatus status200 empty removeLegalHoldClientH :: UserId ::: JSON -> (Handler r) Response removeLegalHoldClientH (uid ::: _) = do lift $ API.removeLegalHoldClient uid - return $ setStatus status200 empty + pure $ setStatus status200 empty internalListClientsH :: JSON ::: JsonRequest UserSet -> (Handler r) Response internalListClientsH (_ ::: req) = do @@ -466,7 +481,7 @@ getActivationCodeH (_ ::: emailOrPhone) = do getActivationCode :: Either Email Phone -> (Handler r) GetActivationCodeResp getActivationCode emailOrPhone = do apair <- lift . wrapClient $ API.lookupActivationCode emailOrPhone - maybe (throwStd activationKeyNotFound) (return . GetActivationCodeResp) apair + maybe (throwStd activationKeyNotFound) (pure . GetActivationCodeResp) apair newtype GetActivationCodeResp = GetActivationCodeResp (ActivationKey, ActivationCode) @@ -496,19 +511,19 @@ changeAccountStatusH :: UserId ::: JsonRequest AccountStatusUpdate -> (Handler r changeAccountStatusH (usr ::: req) = do status <- suStatus <$> parseJsonBody req wrapHttpClientE (API.changeSingleAccountStatus usr status) !>> accountStatusError - return empty + pure empty getAccountStatusH :: JSON ::: UserId -> (Handler r) Response getAccountStatusH (_ ::: usr) = do status <- lift $ wrapClient $ API.lookupStatus usr - return $ case status of + pure $ case status of Just s -> json $ AccountStatusResp s Nothing -> setStatus status404 empty getConnectionsStatusUnqualified :: ConnectionsStatusRequest -> Maybe Relation -> (Handler r) [ConnectionStatus] getConnectionsStatusUnqualified ConnectionsStatusRequest {csrFrom, csrTo} flt = lift $ do r <- wrapClient $ maybe (API.lookupConnectionStatus' csrFrom) (API.lookupConnectionStatus csrFrom) csrTo - return $ maybe r (filterByRelation r) flt + pure $ maybe r (filterByRelation r) flt where filterByRelation l rel = filter ((== rel) . csStatus) l @@ -532,35 +547,35 @@ getConnectionsStatus (ConnectionsStatusRequestV2 froms mtos mrel) = do revokeIdentityH :: Either Email Phone -> (Handler r) Response revokeIdentityH emailOrPhone = do lift $ API.revokeIdentity emailOrPhone - return $ setStatus status200 empty + pure $ setStatus status200 empty updateConnectionInternalH :: JSON ::: JsonRequest UpdateConnectionsInternal -> (Handler r) Response updateConnectionInternalH (_ ::: req) = do updateConn <- parseJsonBody req API.updateConnectionInternal updateConn !>> connError - return $ setStatus status200 empty + pure $ setStatus status200 empty checkBlacklistH :: Either Email Phone -> (Handler r) Response checkBlacklistH emailOrPhone = do bl <- lift $ API.isBlacklisted emailOrPhone - return $ setStatus (bool status404 status200 bl) empty + pure $ setStatus (bool status404 status200 bl) empty deleteFromBlacklistH :: Either Email Phone -> (Handler r) Response deleteFromBlacklistH emailOrPhone = do void . lift $ API.blacklistDelete emailOrPhone - return empty + pure empty addBlacklistH :: Either Email Phone -> (Handler r) Response addBlacklistH emailOrPhone = do void . lift $ API.blacklistInsert emailOrPhone - return empty + pure empty -- | Get any matching prefixes. Also try for shorter prefix matches, -- i.e. checking for +123456 also checks for +12345, +1234, ... getPhonePrefixesH :: PhonePrefix -> (Handler r) Response getPhonePrefixesH prefix = do results <- lift $ API.phonePrefixGet prefix - return $ case results of + pure $ case results of [] -> setStatus status404 empty _ -> json results @@ -568,13 +583,13 @@ getPhonePrefixesH prefix = do deleteFromPhonePrefixH :: PhonePrefix -> (Handler r) Response deleteFromPhonePrefixH prefix = do void . lift $ API.phonePrefixDelete prefix - return empty + pure empty addPhonePrefixH :: JSON ::: JsonRequest ExcludedPrefix -> (Handler r) Response addPhonePrefixH (_ ::: req) = do prefix :: ExcludedPrefix <- parseJsonBody req void . lift $ API.phonePrefixInsert prefix - return empty + pure empty updateSSOIdH :: UserId ::: JSON ::: JsonRequest UserSSOId -> (Handler r) Response updateSSOIdH (uid ::: _ ::: req) = do @@ -583,8 +598,8 @@ updateSSOIdH (uid ::: _ ::: req) = do if success then do lift $ wrapHttpClient $ Intra.onUserEvent uid Nothing (UserUpdated ((emptyUserUpdatedData uid) {eupSSOId = Just ssoid})) - return empty - else return . setStatus status404 $ plain "User does not exist or has no team." + pure empty + else pure . setStatus status404 $ plain "User does not exist or has no team." deleteSSOIdH :: UserId ::: JSON -> (Handler r) Response deleteSSOIdH (uid ::: _) = do @@ -592,14 +607,14 @@ deleteSSOIdH (uid ::: _) = do if success then do lift $ wrapHttpClient $ Intra.onUserEvent uid Nothing (UserUpdated ((emptyUserUpdatedData uid) {eupSSOIdRemoved = True})) - return empty - else return . setStatus status404 $ plain "User does not exist or has no team." + pure empty + else pure . setStatus status404 $ plain "User does not exist or has no team." updateManagedByH :: UserId ::: JSON ::: JsonRequest ManagedByUpdate -> (Handler r) Response updateManagedByH (uid ::: _ ::: req) = do ManagedByUpdate managedBy <- parseJsonBody req lift $ wrapClient $ Data.updateManagedBy uid managedBy - return empty + pure empty updateRichInfoH :: UserId ::: JSON ::: JsonRequest RichInfoUpdate -> (Handler r) Response updateRichInfoH (uid ::: _ ::: req) = do @@ -662,9 +677,9 @@ checkHandleInternalH = getContactListH :: JSON ::: UserId -> (Handler r) Response getContactListH (_ ::: uid) = do contacts <- lift . wrapClient $ API.lookupContactList uid - return $ json $ UserIds contacts + pure $ json $ UserIds contacts -- Utilities ifNothing :: Utilities.Error -> Maybe a -> (Handler r) a -ifNothing e = maybe (throwStd e) return +ifNothing e = maybe (throwStd e) pure diff --git a/services/brig/src/Brig/API/MLS/KeyPackages/Validation.hs b/services/brig/src/Brig/API/MLS/KeyPackages/Validation.hs index 7cdce75572..c76bb89190 100644 --- a/services/brig/src/Brig/API/MLS/KeyPackages/Validation.hs +++ b/services/brig/src/Brig/API/MLS/KeyPackages/Validation.hs @@ -111,7 +111,7 @@ checkRequiredExtensions re = <*> maybe (Left "Missing capability extension") (pure . Identity) (reCapabilities re) findExtensions :: [Extension] -> Either Text (RequiredExtensions Identity) -findExtensions = (checkRequiredExtensions =<<) . getAp . foldMap findExtension +findExtensions = checkRequiredExtensions <=< (getAp . foldMap findExtension) findExtension :: Extension -> Ap (Either Text) (RequiredExtensions Maybe) findExtension ext = (Ap (decodeExtension ext) >>=) . foldMap $ \case diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index 88efa357e9..05342c39d4 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -196,7 +196,7 @@ servantSitemap = userAPI :<|> selfAPI :<|> accountAPI :<|> clientAPI :<|> prekey selfAPI :: ServerT SelfAPI (Handler r) selfAPI = Named @"get-self" getSelf - :<|> Named @"delete-self" deleteUser + :<|> Named @"delete-self" deleteSelfUser :<|> Named @"put-self" updateUser :<|> Named @"change-phone" changePhone :<|> Named @"remove-phone" removePhone @@ -507,7 +507,7 @@ listPropertyKeys u = lift $ wrapClient (API.lookupPropertyKeys u) listPropertyKeysAndValues :: UserId -> Handler r Public.PropertyKeysAndValues listPropertyKeysAndValues u = do keysAndVals <- fmap Map.fromList . lift $ wrapClient (API.lookupPropertyKeysAndValues u) - fmap Public.PropertyKeysAndValues $ traverse parseStoredPropertyValue keysAndVals + Public.PropertyKeysAndValues <$> traverse parseStoredPropertyValue keysAndVals getPrekeyUnqualifiedH :: UserId -> UserId -> ClientId -> (Handler r) Public.ClientPrekey getPrekeyUnqualifiedH zusr user client = do @@ -689,7 +689,7 @@ createUser (Public.NewUserPublic new) = lift . runExceptT $ do -- 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 _ -> - return () + pure () Public.NewTeamMember _ -> Team.sendMemberWelcomeMail e t n l Public.NewTeamMemberSSO _ -> @@ -798,7 +798,7 @@ checkHandlesH (_ ::: _ ::: req) = do Public.CheckHandles hs num <- parseJsonBody req let handles = mapMaybe parseHandle (fromRange hs) free <- lift . wrapClient $ API.checkHandles handles (fromRange num) - return $ json (free :: [Handle]) + pure $ json (free :: [Handle]) -- | This endpoint returns UserHandleInfo instead of UserProfile for backwards -- compatibility, whereas the corresponding qualified endpoint (implemented by @@ -841,7 +841,7 @@ completePasswordResetH :: completePasswordResetH (_ ::: req) = do Public.CompletePasswordReset {..} <- parseJsonBody req API.completePasswordReset cpwrIdent cpwrCode cpwrPassword !>> pwResetError - return empty + pure empty sendActivationCodeH :: JsonRequest Public.SendActivationCode -> (Handler r) Response sendActivationCodeH req = @@ -891,7 +891,7 @@ updateConnection self conn other update = do let newStatus = Public.cuStatus update lself <- qualifyLocal self mc <- API.updateConnection lself other newStatus (Just conn) !>> connError - return $ maybe Public.Unchanged Public.Updated mc + pure $ maybe Public.Unchanged Public.Updated mc listLocalConnections :: UserId -> Maybe UserId -> Maybe (Range 1 500 Int32) -> (Handler r) Public.UserConnectionList listLocalConnections uid start msize = do @@ -951,18 +951,18 @@ getConnection self other = do lself <- qualifyLocal self lift . wrapClient $ Data.lookupConnection lself other -deleteUser :: +deleteSelfUser :: UserId -> Public.DeleteUser -> (Handler r) (Maybe Code.Timeout) -deleteUser u body = - API.deleteUser u (Public.deleteUserPassword body) !>> deleteUserError +deleteSelfUser u body = + API.deleteSelfUser u (Public.deleteUserPassword body) !>> deleteUserError verifyDeleteUserH :: JsonRequest Public.VerifyDeleteUser ::: JSON -> (Handler r) Response verifyDeleteUserH (r ::: _) = do body <- parseJsonBody r API.verifyDeleteUser body !>> deleteUserError - return (setStatus status200 empty) + pure (setStatus status200 empty) updateUserEmail :: UserId -> UserId -> Public.EmailUpdate -> (Handler r) () updateUserEmail zuserId emailOwnerId (Public.EmailUpdate email) = do @@ -1015,10 +1015,10 @@ activate :: Public.Activate -> (Handler r) ActivationRespWithStatus activate (Public.Activate tgt code dryrun) | dryrun = do wrapClientE (API.preverify tgt code) !>> actError - return ActivationRespDryRun + pure ActivationRespDryRun | otherwise = do result <- API.activate tgt code Nothing !>> actError - return $ case result of + pure $ case result of ActivationSuccess ident x -> respond ident x ActivationPass -> ActivationRespPass where @@ -1088,9 +1088,9 @@ deprecatedCompletePasswordResetH (_ ::: k ::: req) = do (Public.pwrCode pwr) (Public.pwrPassword pwr) !>> pwResetError - return empty + pure empty -- Utilities ifNothing :: Utilities.Error -> Maybe a -> (Handler r) a -ifNothing e = maybe (throwStd e) return +ifNothing e = maybe (throwStd e) pure diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index d68d696d92..4272fb3cb8 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -51,7 +51,7 @@ module Brig.API.User revokeIdentity, deleteUserNoVerify, deleteUsersNoVerify, - Brig.API.User.deleteUser, + deleteSelfUser, verifyDeleteUser, deleteAccount, checkHandles, @@ -299,7 +299,7 @@ createUser new = do lift $ initAccountFeatureConfig uid - return $! CreateUserResult account edata pdata createUserTeam + pure $! CreateUserResult account edata pdata createUserTeam where -- NOTE: all functions in the where block don't use any arguments of createUser @@ -309,14 +309,14 @@ createUser new = do email <- for (newUserEmail newUser) $ \e -> either (const $ throwE RegisterErrorInvalidEmail) - return + pure (validateEmail e) -- Validate phone phone <- for (newUserPhone newUser) $ \p -> maybe (throwE RegisterErrorInvalidPhone) - return + pure =<< lift (wrapClient $ validatePhone p) for_ (catMaybes [userEmailKey <$> email, userPhoneKey <$> phone]) $ \k -> @@ -334,7 +334,7 @@ createUser new = do (Just invite, Just em) | e == userEmailKey em -> do _ <- ensureMemberCanJoin (Team.iiTeam ii) - return $ Just (invite, ii, Team.iiTeam ii) + pure $ Just (invite, ii, Team.iiTeam ii) _ -> throwE RegisterErrorInvalidInvitationCode Nothing -> throwE RegisterErrorInvalidInvitationCode @@ -406,13 +406,13 @@ createUser new = do field "user" (toByteString uid) . field "activation.key" (toByteString $ activationKey edata) . msg (val "Created email activation key/code pair") - return $ Just edata + pure $ Just edata Just c -> do ak <- liftIO $ Data.mkActivationKey ek void $ activateWithCurrency (ActivateKey ak) c (Just uid) (bnuCurrency =<< newTeam) !>> activationErrorToRegisterError - return Nothing + pure Nothing -- Handle phone activation (deprecated, see #RefRegistrationNoPreverification in /docs/reference/user/registration.md) handlePhoneActivation :: Maybe Phone -> UserId -> ExceptT RegisterError (AppT r) (Maybe Activation) @@ -425,11 +425,11 @@ createUser new = do field "user" (toByteString uid) . field "activation.key" (toByteString $ activationKey pdata) . msg (val "Created phone activation key/code pair") - return $ Just pdata + pure $ Just pdata Just c -> do ak <- liftIO $ Data.mkActivationKey pk void $ activate (ActivateKey ak) c (Just uid) !>> activationErrorToRegisterError - return Nothing + pure Nothing initAccountFeatureConfig :: UserId -> (AppT r) () initAccountFeatureConfig uid = do @@ -462,7 +462,7 @@ createUserInviteViaScim uid (NewUserScimInvitation tid loc name rawEmail) = do True lift . wrapClient $ Data.insertAccount account Nothing Nothing activated - return account + pure account -- | docs/reference/user/registration.md {#RefRestrictRegistration}. checkRestrictedUserCreation :: NewUser -> ExceptT RegisterError (AppT r) () @@ -551,17 +551,17 @@ checkHandle uhandle = do if | isJust owner -> -- Handle is taken (=> getHandleInfo will return 200) - return CheckHandleFound + 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'? - return CheckHandleInvalid + pure CheckHandleInvalid | otherwise -> -- Handle is free and can be taken - return CheckHandleNotFound + pure CheckHandleNotFound -------------------------------------------------------------------------------- -- Check Handles @@ -569,8 +569,8 @@ checkHandle uhandle = do checkHandles :: MonadClient m => [Handle] -> Word -> m [Handle] checkHandles check num = reverse <$> collectFree [] check num where - collectFree free _ 0 = return free - collectFree free [] _ = return free + collectFree free _ 0 = pure free + collectFree free [] _ = pure free collectFree free (h : hs) n = if isBlacklistedHandle h then collectFree free hs n @@ -610,7 +610,7 @@ changeEmail u email allowScim = do em <- either (throwE . InvalidNewEmail email) - return + pure (validateEmail email) let ek = userEmailKey em blacklisted <- lift . wrapClient $ Blacklist.exists ek @@ -620,10 +620,10 @@ changeEmail u email allowScim = do unless available $ throwE $ EmailExists email - usr <- maybe (throwM $ UserProfileNotFound u) return =<< lift (wrapClient $ Data.lookupUser WithPendingInvitations u) + usr <- maybe (throwM $ UserProfileNotFound u) pure =<< lift (wrapClient $ Data.lookupUser WithPendingInvitations u) case emailIdentity =<< userIdentity usr of -- The user already has an email address and the new one is exactly the same - Just current | current == em -> return ChangeEmailIdempotent + Just current | current == em -> pure ChangeEmailIdempotent _ -> do unless ( userManagedBy usr /= ManagedByScim @@ -632,7 +632,7 @@ changeEmail u email allowScim = do $ throwE EmailManagedByScim timeout <- setActivationTimeout <$> view settings act <- lift . wrapClient $ Data.newActivation ek timeout (Just u) - return $ ChangeEmailNeedsActivation (usr, act, em) + pure $ ChangeEmailNeedsActivation (usr, act, em) ------------------------------------------------------------------------------- -- Change Phone @@ -642,7 +642,7 @@ changePhone u phone = do canonical <- maybe (throwE InvalidNewPhone) - return + pure =<< lift (wrapClient $ validatePhone phone) let pk = userPhoneKey canonical available <- lift . wrapClient $ Data.keyAvailable pk (Just u) @@ -657,7 +657,7 @@ changePhone u phone = do when prefixExcluded $ throwE BlacklistedNewPhone act <- lift . wrapClient $ Data.newActivation pk timeout (Just u) - return (act, canonical) + pure (act, canonical) ------------------------------------------------------------------------------- -- Remove Email @@ -699,7 +699,7 @@ revokeIdentity key = do let uk = either userEmailKey userPhoneKey key mu <- wrapClient $ Data.lookupKey uk case mu of - Nothing -> return () + Nothing -> pure () Just u -> fetchUserIdentity u >>= \case Just (FullIdentity _ _) -> revokeKey u uk @@ -709,7 +709,7 @@ revokeIdentity key = do Just (PhoneIdentity p) | Right p == key -> do revokeKey u uk wrapClient $ Data.deactivateUser u - _ -> return () + _ -> pure () where revokeKey :: UserId -> UserKey -> AppT r () revokeKey u uk = do @@ -779,8 +779,8 @@ changeSingleAccountStatus uid status = do mkUserEvent :: (MonadUnliftIO m, Traversable t, MonadClient m) => t UserId -> AccountStatus -> ExceptT AccountStatusError m (UserId -> UserEvent) mkUserEvent usrs status = case status of - Active -> return UserResumed - Suspended -> lift $ mapConcurrently revokeAllCookies usrs >> return UserSuspended + Active -> pure UserResumed + Suspended -> lift $ mapConcurrently revokeAllCookies usrs >> pure UserSuspended Deleted -> throwE InvalidAccountStatus Ephemeral -> throwE InvalidAccountStatus PendingInvitation -> throwE InvalidAccountStatus @@ -813,13 +813,13 @@ activateWithCurrency tgt code usr cur = do . msg (val "Activating") event <- wrapClientE $ Data.activateKey key code usr case event of - Nothing -> return ActivationPass + Nothing -> pure ActivationPass Just e -> do (uid, ident, first) <- lift $ onActivated e when first $ lift $ activateTeam uid - return $ ActivationSuccess ident first + pure $ ActivationSuccess ident first where activateTeam uid = do tid <- wrapHttp $ Intra.getTeamId uid @@ -842,14 +842,14 @@ onActivated (AccountActivated account) = do Log.debug $ field "user" (toByteString uid) . field "action" (Log.val "User.onActivated") Log.info $ field "user" (toByteString uid) . msg (val "User activated") wrapHttpClient $ Intra.onUserEvent uid Nothing $ UserActivated (accountUser account) - return (uid, userIdentity (accountUser account), True) + pure (uid, userIdentity (accountUser account), True) onActivated (EmailActivated uid email) = do wrapHttpClient $ Intra.onUserEvent uid Nothing (emailUpdated uid email) wrapHttpClient $ Data.deleteEmailUnvalidated uid - return (uid, Just (EmailIdentity email), False) + pure (uid, Just (EmailIdentity email), False) onActivated (PhoneActivated uid phone) = do wrapHttpClient $ Intra.onUserEvent uid Nothing (phoneUpdated uid phone) - return (uid, Just (PhoneIdentity phone), False) + pure (uid, Just (PhoneIdentity phone), False) -- docs/reference/user/activation.md {#RefActivationRequest} sendActivationCode :: Either Email Phone -> Maybe Locale -> Bool -> ExceptT SendActivationCodeError (AppT r) () @@ -858,7 +858,7 @@ sendActivationCode emailOrPhone loc call = case emailOrPhone of ek <- either (const . throwE . InvalidRecipient $ userEmailKey email) - (return . userEmailKey) + (pure . userEmailKey) (validateEmail email) exists <- lift $ isJust <$> wrapClient (Data.lookupKey ek) when exists $ @@ -877,7 +877,7 @@ sendActivationCode emailOrPhone loc call = case emailOrPhone of canonical <- maybe (throwE $ InvalidRecipient (userPhoneKey phone)) - return + pure =<< lift (wrapClient $ validatePhone phone) let pk = userPhoneKey canonical exists <- lift $ isJust <$> wrapClient (Data.lookupKey pk) @@ -906,7 +906,7 @@ sendActivationCode emailOrPhone loc call = case emailOrPhone of Just c' -> liftIO $ (,c') <$> Data.mkActivationKey k Nothing -> lift $ do dat <- Data.newActivation k timeout u - return (activationKey dat, activationCode dat) + pure (activationKey dat, activationCode dat) sendVerificationEmail ek uc = do p <- wrapClientE $ mkPair ek uc Nothing void . forEmailKey ek $ \em -> @@ -915,7 +915,7 @@ sendActivationCode emailOrPhone loc call = case emailOrPhone of 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) return =<< lift (wrapClient $ Data.lookupUser WithPendingInvitations uid) + u <- maybe (notFound uid) pure =<< lift (wrapClient $ Data.lookupUser WithPendingInvitations uid) p <- wrapClientE $ mkPair ek (Just uc) (Just uid) let ident = userIdentity u name = userDisplayName u @@ -935,19 +935,19 @@ sendActivationCode emailOrPhone loc call = case emailOrPhone of sendActivationMail em name p loc' ident mkActivationKey :: (MonadClient m, MonadReader Env m) => ActivationTarget -> ExceptT ActivationError m ActivationKey -mkActivationKey (ActivateKey k) = return k +mkActivationKey (ActivateKey k) = pure k mkActivationKey (ActivateEmail e) = do ek <- either (throwE . InvalidActivationEmail e) - (return . userEmailKey) + (pure . userEmailKey) (validateEmail e) liftIO $ Data.mkActivationKey ek mkActivationKey (ActivatePhone p) = do pk <- maybe (throwE $ InvalidActivationPhone p) - (return . userPhoneKey) + (pure . userPhoneKey) =<< lift (validatePhone p) liftIO $ Data.mkActivationKey pk @@ -977,7 +977,7 @@ beginPasswordReset :: ExceptT PasswordResetError (AppT r) (UserId, PasswordResetPair) beginPasswordReset target = do let key = either userEmailKey userPhoneKey target - user <- lift (wrapClient $ Data.lookupKey key) >>= maybe (throwE InvalidPasswordResetKey) return + user <- lift (wrapClient $ Data.lookupKey key) >>= maybe (throwE InvalidPasswordResetKey) pure lift . Log.debug $ field "user" (toByteString user) . field "action" (Log.val "User.beginPasswordReset") status <- lift . wrapClient $ Data.lookupStatus user unless (status == Just Active) $ @@ -1020,7 +1020,7 @@ mkPasswordResetKey :: PasswordResetIdentity -> ExceptT PasswordResetError (AppT r) PasswordResetKey mkPasswordResetKey ident = case ident of - PasswordResetIdentityKey k -> return k + PasswordResetIdentityKey k -> pure k PasswordResetEmailIdentity e -> wrapClientE (user (userEmailKey e)) >>= lift . liftSem . E.mkPasswordResetKey @@ -1028,7 +1028,7 @@ mkPasswordResetKey ident = case ident of wrapClientE (user (userPhoneKey p)) >>= lift . liftSem . E.mkPasswordResetKey where - user uk = lift (Data.lookupKey uk) >>= maybe (throwE InvalidPasswordResetKey) return + user uk = lift (Data.lookupKey uk) >>= maybe (throwE InvalidPasswordResetKey) pure ------------------------------------------------------------------------------- -- User Deletion @@ -1041,13 +1041,13 @@ 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. -deleteUser :: UserId -> Maybe PlainTextPassword -> ExceptT DeleteUserError (AppT r) (Maybe Timeout) -deleteUser uid pwd = do +deleteSelfUser :: UserId -> Maybe PlainTextPassword -> ExceptT DeleteUserError (AppT r) (Maybe Timeout) +deleteSelfUser uid pwd = do account <- lift . wrapClient $ Data.lookupAccount uid case account of Nothing -> throwE DeleteUserInvalid Just a -> case accountStatus a of - Deleted -> return Nothing + Deleted -> pure Nothing Suspended -> ensureNotOwner a >> go a Active -> ensureNotOwner a >> go a Ephemeral -> go a @@ -1072,7 +1072,7 @@ deleteUser uid pwd = do Just emailOrPhone -> sendCode a emailOrPhone Nothing -> case pwd of Just _ -> throwE DeleteUserMissingPassword - Nothing -> lift $ wrapHttpClient $ deleteAccount a >> return Nothing + Nothing -> lift $ wrapHttpClient $ deleteAccount a >> pure Nothing byPassword a pw = do lift . Log.info $ field "user" (toByteString uid) @@ -1083,7 +1083,7 @@ deleteUser uid pwd = do Just p -> do unless (verifyPassword pw p) $ throwE DeleteUserInvalidPassword - lift $ wrapHttpClient $ deleteAccount a >> return Nothing + lift $ wrapHttpClient $ 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 @@ -1110,7 +1110,7 @@ deleteUser uid pwd = do (\p -> lift $ wrapClient $ sendDeletionSms p k v l) target `onException` wrapClientE (Code.delete k Code.AccountDeletion) - return $! Just $! Code.codeTTL c + pure $! Just $! Code.codeTTL c -- | Conclude validation and scheduling of user's deletion request that was initiated in -- 'deleteUser'. Called via @post /delete@. @@ -1119,7 +1119,7 @@ verifyDeleteUser d = do let key = verifyDeleteUserKey d let code = verifyDeleteUserCode d c <- lift . wrapClient $ Code.verify key Code.AccountDeletion code - a <- maybe (throwE DeleteUserInvalidCode) return (Code.codeAccount =<< c) + a <- maybe (throwE DeleteUserInvalidCode) pure (Code.codeAccount =<< c) account <- lift . wrapClient $ Data.lookupAccount (Id a) for_ account $ lift . wrapHttpClient . deleteAccount lift . wrapClient $ Code.delete key Code.AccountDeletion @@ -1165,7 +1165,7 @@ deleteAccount account@(accountUser -> user) = do where mkTombstone = do defLoc <- setDefaultUserLocale <$> view settings - return $ + pure $ account { accountStatus = Deleted, accountUser = @@ -1191,7 +1191,7 @@ lookupActivationCode emailOrPhone = do let uk = either userEmailKey userPhoneKey emailOrPhone k <- liftIO $ Data.mkActivationKey uk c <- fmap snd <$> Data.lookupActivationCode uk - return $ (k,) <$> c + pure $ (k,) <$> c lookupPasswordResetCode :: Members '[CodeStore, PasswordResetStore] r => @@ -1201,11 +1201,11 @@ lookupPasswordResetCode emailOrPhone = do let uk = either userEmailKey userPhoneKey emailOrPhone usr <- wrapClient $ Data.lookupKey uk liftSem $ case usr of - Nothing -> return Nothing + Nothing -> pure Nothing Just u -> do k <- E.mkPasswordResetKey u c <- E.lookupPasswordResetCode u - return $ (k,) <$> c + pure $ (k,) <$> c deleteUserNoVerify :: ( MonadReader Env m, @@ -1237,13 +1237,13 @@ userGC :: User -> m User userGC u = case userExpire u of - Nothing -> return u + Nothing -> pure u (Just (fromUTCTimeMillis -> e)) -> do now <- liftIO =<< view currentTime -- ephemeral users past their expiry date are deleted when (diffUTCTime e now < 0) $ deleteUserNoVerify (userId u) - return u + pure u lookupProfile :: ( MonadClient m, @@ -1344,7 +1344,7 @@ lookupLocalProfiles requestingUser others = do Nothing -> pure EmailVisibleToSelf' EmailVisibleToSelf -> pure EmailVisibleToSelf' usersAndStatus <- for users $ \u -> (u,) <$> getLegalHoldStatus' u - return $ map (toProfile emailVisibility'' css) usersAndStatus + pure $ map (toProfile emailVisibility'' css) usersAndStatus where toMap :: [ConnectionStatus] -> Map UserId Relation toMap = Map.fromList . map (csFrom &&& csStatus) diff --git a/services/brig/src/Brig/API/Util.hs b/services/brig/src/Brig/API/Util.hs index 92c3c4bffb..f7e068a29b 100644 --- a/services/brig/src/Brig/API/Util.hs +++ b/services/brig/src/Brig/API/Util.hs @@ -62,7 +62,7 @@ import Wire.API.User.Search (FederatedUserSearchPolicy (NoSearch)) lookupProfilesMaybeFilterSameTeamOnly :: UserId -> [UserProfile] -> (Handler r) [UserProfile] lookupProfilesMaybeFilterSameTeamOnly self us = do selfTeam <- lift $ wrapClient $ Data.lookupUserTeam self - return $ case selfTeam of + pure $ case selfTeam of Just team -> filter (\x -> profileTeam x == Just team) us Nothing -> us @@ -71,7 +71,7 @@ fetchUserIdentity uid = lookupSelfProfile uid >>= maybe (throwM $ UserProfileNotFound uid) - (return . userIdentity . selfUser) + (pure . userIdentity . selfUser) -- | Obtain a profile for a user as he can see himself. lookupSelfProfile :: UserId -> (AppT r) (Maybe SelfProfile) @@ -80,7 +80,7 @@ lookupSelfProfile = fmap (fmap mk) . wrapClient . Data.lookupAccount mk a = SelfProfile (accountUser a) validateHandle :: Text -> (Handler r) Handle -validateHandle = maybe (throwStd (errorToWai @'InvalidHandle)) return . parseHandle +validateHandle = maybe (throwStd (errorToWai @'InvalidHandle)) pure . parseHandle logEmail :: Email -> (Msg -> Msg) logEmail email = diff --git a/services/brig/src/Brig/AWS.hs b/services/brig/src/Brig/AWS.hs index 294de9b578..85c081a514 100644 --- a/services/brig/src/Brig/AWS.hs +++ b/services/brig/src/Brig/AWS.hs @@ -114,9 +114,9 @@ mkEnv lgr opts emailOpts mgr = do sesEndpoint dynamoEndpoint (mkEndpoint SQS.defaultService (Opt.sqsEndpoint opts)) - sq <- maybe (return Nothing) (fmap Just . getQueueUrl e . Opt.sesQueue) emailOpts - jq <- maybe (return Nothing) (fmap Just . getQueueUrl e) (Opt.userJournalQueue opts) - return (Env g sq jq pk e) + sq <- maybe (pure Nothing) (fmap Just . getQueueUrl e . Opt.sesQueue) emailOpts + jq <- maybe (pure Nothing) (fmap Just . getQueueUrl e) (Opt.userJournalQueue opts) + pure (Env g sq jq pk e) where mkEndpoint svc e = AWS.setEndpoint (e ^. awsSecure) (e ^. awsHost) (e ^. awsPort) svc mkAwsEnv g ses dyn sqs = do @@ -180,7 +180,7 @@ listen throttleMillis url callback = forever . handleAny unexpectedError $ do & set SQS.receiveMessage_waitTimeSeconds (Just 20) . set SQS.receiveMessage_maxNumberOfMessages (Just 10) onMessage m = - case decodeStrict =<< Text.encodeUtf8 <$> m ^. SQS.message_body of + case decodeStrict . Text.encodeUtf8 =<< (m ^. SQS.message_body) of Nothing -> err $ msg ("Failed to parse SQS event: " ++ show m) Just n -> do debug $ msg ("Received SQS event: " ++ show n) @@ -214,7 +214,7 @@ sendMail m = do & SES.sendRawEmail_destinations ?~ fmap addressEmail (mailTo m) & SES.sendRawEmail_source ?~ addressEmail (mailFrom m) resp <- retrying retry5x (const canRetry) $ const (sendCatch raw) - void $ either check return resp + void $ either check pure resp where check x = case x of -- To map rejected domain names by SES to 400 responses, in order @@ -242,7 +242,7 @@ send :: AWSRequest r => r -> Amazon (AWSResponse r) send r = throwA =<< sendCatch r throwA :: Either AWS.Error a -> Amazon a -throwA = either (throwM . GeneralError) return +throwA = either (throwM . GeneralError) pure execCatch :: (AWSRequest a, MonadUnliftIO m, MonadCatch m, MonadThrow m, MonadIO m) => @@ -259,7 +259,7 @@ exec :: AWS.Env -> a -> m (AWSResponse a) -exec e cmd = liftIO (execCatch e cmd) >>= either (throwM . GeneralError) return +exec e cmd = liftIO (execCatch e cmd) >>= either (throwM . GeneralError) pure canRetry :: MonadIO m => Either AWS.Error a -> m Bool canRetry (Right _) = pure False diff --git a/services/brig/src/Brig/AWS/Types.hs b/services/brig/src/Brig/AWS/Types.hs index e30b38d61d..8847d66513 100644 --- a/services/brig/src/Brig/AWS/Types.hs +++ b/services/brig/src/Brig/AWS/Types.hs @@ -41,9 +41,9 @@ data SESBounceType deriving (Eq, Show) instance FromJSON SESBounceType where - parseJSON "Undetermined" = return BounceUndetermined - parseJSON "Permanent" = return BouncePermanent - parseJSON "Transient" = return BounceTransient + parseJSON "Undetermined" = pure BounceUndetermined + parseJSON "Permanent" = pure BouncePermanent + parseJSON "Transient" = pure BounceTransient parseJSON x = fail $ "Unknown type: " <> show x instance FromJSON SESNotification where @@ -55,10 +55,10 @@ instance FromJSON SESNotification where bt <- b .: "bounceType" br <- b .: "bouncedRecipients" em <- mapM (\r -> r .: "emailAddress") br - return $! MailBounce bt em + pure $! MailBounce bt em "Complaint" -> do c <- o .: "complaint" cr <- c .: "complainedRecipients" em <- mapM (\r -> r .: "emailAddress") cr - return $! MailComplaint em + pure $! MailComplaint em x -> fail ("Brig.AWS: Unexpected notification type" ++ show x) diff --git a/services/brig/src/Brig/App.hs b/services/brig/src/Brig/App.hs index c7279183b4..80ba594971 100644 --- a/services/brig/src/Brig/App.hs +++ b/services/brig/src/Brig/App.hs @@ -242,7 +242,7 @@ newEnv o = do Just True -> Just <$> newMVar () _ -> pure Nothing kpLock <- newMVar () - return + pure $! Env { _cargohold = mkEndpoint $ Opt.cargohold o, _galley = mkEndpoint $ Opt.galley o, @@ -279,17 +279,17 @@ newEnv o = do _keyPackageLocalLock = kpLock } where - emailConn _ (Opt.EmailAWS aws) = return (Just aws, Nothing) + emailConn _ (Opt.EmailAWS aws) = pure (Just aws, Nothing) emailConn lgr (Opt.EmailSMTP s) = do let host = Opt.smtpEndpoint s ^. epHost port = Just $ fromInteger $ toInteger $ Opt.smtpEndpoint s ^. epPort smtpCredentials <- case Opt.smtpCredentials s of Just (Opt.EmailSMTPCredentials u p) -> do pass <- initCredentials p - return $ Just (SMTP.Username u, SMTP.Password pass) - _ -> return Nothing + pure $ Just (SMTP.Username u, SMTP.Password pass) + _ -> pure Nothing smtp <- SMTP.initSMTP lgr host port smtpCredentials (Opt.smtpConnType s) - return (Nothing, Just smtp) + pure (Nothing, Just smtp) mkEndpoint service = RPC.host (encodeUtf8 (service ^. epHost)) . RPC.port (service ^. epPort) $ RPC.empty mkIndexEnv :: Opts -> Logger -> Manager -> Metrics -> Endpoint -> IndexEnv @@ -302,12 +302,12 @@ mkIndexEnv o lgr mgr mtr galleyEndpoint = in IndexEnv mtr lgr' bhe Nothing mainIndex additionalIndex additionalBhe galleyEndpoint mgr geoSetup :: Logger -> FS.WatchManager -> Maybe FilePath -> IO (Maybe (IORef GeoIp.GeoDB)) -geoSetup _ _ Nothing = return Nothing +geoSetup _ _ Nothing = pure Nothing geoSetup lgr w (Just db) = do path <- canonicalizePath db geodb <- newIORef =<< GeoIp.openGeoDB path startWatching w path (replaceGeoDb lgr geodb) - return $ Just geodb + pure $ Just geodb startWatching :: FS.WatchManager -> FilePath -> FS.Action -> IO () startWatching w p = void . FS.watchDir w (Path.dropFileName p) predicate @@ -384,7 +384,7 @@ initExtGetManager = do managerResponseTimeout = responseTimeoutMicro 10000000 } Just sha <- getDigestByName "SHA256" - return (mgr, mkVerify sha) + pure (mgr, mkVerify sha) where mkVerify sha fprs = let pinset = map toByteString' fprs @@ -411,12 +411,12 @@ initCassandra o g = do . Cas.setPolicy (Cas.dcFilterPolicyIfConfigured g (Opt.cassandra o ^. casFilterNodesByDatacentre)) $ Cas.defSettings runClient p $ versionCheck schemaVersion - return p + pure p initCredentials :: (FromJSON a) => FilePathSecrets -> IO a initCredentials secretFile = do dat <- loadSecret secretFile - return $ either (\e -> error $ "Could not load secrets from " ++ show secretFile ++ ": " ++ e) id dat + pure $ either (\e -> error $ "Could not load secrets from " ++ show secretFile ++ ": " ++ e) id dat userTemplates :: MonadReader Env m => Maybe Locale -> m (Locale, UserTemplates) userTemplates l = forLocale l <$> view usrTemplates @@ -612,10 +612,10 @@ locationOf ip = view geoDb >>= \case Just g -> do database <- liftIO $ readIORef g - return $! do + pure $! do loc <- GeoIp.geoLocation =<< hush (GeoIp.findGeoData database "en" ip) - return $ location (Latitude $ GeoIp.locationLatitude loc) (Longitude $ GeoIp.locationLongitude loc) - Nothing -> return Nothing + pure $ location (Latitude $ GeoIp.locationLatitude loc) (Longitude $ GeoIp.locationLongitude loc) + Nothing -> pure Nothing -------------------------------------------------------------------------------- -- Federation diff --git a/services/brig/src/Brig/Budget.hs b/services/brig/src/Brig/Budget.hs index b7ac60fc88..cf952a3ed7 100644 --- a/services/brig/src/Brig/Budget.hs +++ b/services/brig/src/Brig/Budget.hs @@ -63,18 +63,18 @@ withBudget k b ma = do Budget ttl val <- fromMaybe b <$> lookupBudget k let remaining = val - 1 if remaining < 0 - then return (BudgetExhausted ttl) + then pure (BudgetExhausted ttl) else do a <- ma insertBudget k (Budget ttl remaining) - return (BudgetedValue a remaining) + pure (BudgetedValue a remaining) -- | Like 'withBudget', but does not decrease budget, only takes a look. checkBudget :: MonadClient m => BudgetKey -> Budget -> m (Budgeted ()) checkBudget k b = do Budget ttl val <- fromMaybe b <$> lookupBudget k let remaining = val - 1 - return $ + pure $ if remaining < 0 then BudgetExhausted ttl else BudgetedValue () remaining diff --git a/services/brig/src/Brig/Calling.hs b/services/brig/src/Brig/Calling.hs index 0b140baf91..48f892c64e 100644 --- a/services/brig/src/Brig/Calling.hs +++ b/services/brig/src/Brig/Calling.hs @@ -374,7 +374,7 @@ startWatching w p = void . FS.watchDir w (Path.dropFileName p) predicate predicate FS.Unknown {} = False readTurnList :: FilePath -> IO (Maybe (NonEmpty TurnURI)) -readTurnList = Text.readFile >=> return . fn . mapMaybe (fromByteString . Text.encodeUtf8) . Text.lines +readTurnList = Text.readFile >=> pure . fn . mapMaybe (fromByteString . Text.encodeUtf8) . Text.lines where fn [] = Nothing fn (x : xs) = Just (x :| xs) diff --git a/services/brig/src/Brig/Code.hs b/services/brig/src/Brig/Code.hs index 05fbb72f12..ec7383151e 100644 --- a/services/brig/src/Brig/Code.hs +++ b/services/brig/src/Brig/Code.hs @@ -136,13 +136,13 @@ instance Cql Scope where toCql CreateScimToken = CqlInt 6 toCql DeleteTeam = CqlInt 7 - fromCql (CqlInt 1) = return AccountDeletion - fromCql (CqlInt 2) = return IdentityVerification - fromCql (CqlInt 3) = return PasswordReset - fromCql (CqlInt 4) = return AccountLogin - fromCql (CqlInt 5) = return AccountApproval - fromCql (CqlInt 6) = return CreateScimToken - fromCql (CqlInt 7) = return DeleteTeam + 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} @@ -151,7 +151,7 @@ newtype Retries = Retries {numRetries :: Word8} instance Cql Retries where ctype = Tagged IntColumn toCql = CqlInt . fromIntegral . numRetries - fromCql (CqlInt n) = return (Retries (fromIntegral n)) + fromCql (CqlInt n) = pure (Retries (fromIntegral n)) fromCql _ = Left "fromCql: Retries: int expected" -------------------------------------------------------------------------------- @@ -178,7 +178,7 @@ mkKey cfor = liftIO $ do mkGen :: MonadIO m => CodeFor -> m Gen mkGen cfor = liftIO $ do Just sha256 <- getDigestByName "SHA256" - return (initGen sha256 cfor) + pure (initGen sha256 cfor) where initGen d (ForEmail e) = mkEmailLinkGen e d initGen d _ = mk6DigitGen' cfor d @@ -187,7 +187,7 @@ mkGen cfor = liftIO $ do mk6DigitGen :: MonadIO m => CodeFor -> m Gen mk6DigitGen cfor = liftIO $ do Just sha256 <- getDigestByName "SHA256" - return $ mk6DigitGen' cfor sha256 + pure $ mk6DigitGen' cfor sha256 mk6DigitGen' :: CodeFor -> Digest -> Gen mk6DigitGen' cfor d = @@ -224,7 +224,7 @@ generate :: generate gen scope retries ttl account = do let key = genKey gen val <- liftIO $ genValue gen - return $ mkCode key val + pure $ mkCode key val where mkCode key val = Code @@ -297,14 +297,14 @@ lookup k s = fmap (toCode k s) <$> retry x1 (query1 cql (params LocalQuorum (k, -- | 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 (return Nothing) continue +verify k s v = lookup k s >>= maybe (pure Nothing) continue where continue c - | codeValue c == v = return (Just c) + | codeValue c == v = pure (Just c) | codeRetries c > 0 = do insert (c {codeRetries = codeRetries c - 1}) - return Nothing - | otherwise = return Nothing + pure Nothing + | otherwise = pure Nothing -- | Delete a code associated with the given key and scope. delete :: MonadClient m => Key -> Scope -> m () diff --git a/services/brig/src/Brig/Data/Activation.hs b/services/brig/src/Brig/Data/Activation.hs index 7fff629efc..7f20e71948 100644 --- a/services/brig/src/Brig/Data/Activation.hs +++ b/services/brig/src/Brig/Data/Activation.hs @@ -96,9 +96,9 @@ activateKey :: ExceptT ActivationError m (Maybe ActivationEvent) activateKey k c u = verifyCode k c >>= pickUser >>= activate where - pickUser (uk, u') = maybe (throwE invalidUser) (return . (uk,)) (u <|> u') + pickUser (uk, u') = maybe (throwE invalidUser) (pure . (uk,)) (u <|> u') activate (key, uid) = do - a <- lift (lookupAccount uid) >>= maybe (throwE invalidUser) return + 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 @@ -107,7 +107,7 @@ activateKey k c u = verifyCode k c >>= pickUser >>= activate let ident = foldKey EmailIdentity PhoneIdentity key lift $ activateUser uid ident let a' = a {accountUser = (accountUser a) {userIdentity = Just ident}} - return . Just $ AccountActivated a' + pure . Just $ AccountActivated a' Just _ -> do let usr = accountUser a (profileNeedsUpdate, oldKey) = @@ -118,19 +118,19 @@ activateKey k c u = verifyCode k c >>= pickUser >>= activate usr in handleExistingIdentity uid profileNeedsUpdate oldKey key handleExistingIdentity uid profileNeedsUpdate oldKey key - | oldKey == Just key && not profileNeedsUpdate = return Nothing + | 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 - return . Just $ foldKey (EmailActivated uid) (PhoneActivated uid) key + pure . Just $ foldKey (EmailActivated uid) (PhoneActivated uid) 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))) claim key uid lift $ foldKey (updateEmailAndDeleteEmailUnvalidated uid) (updatePhone uid) key for_ oldKey $ lift . deleteKey - return . Just $ foldKey (EmailActivated uid) (PhoneActivated uid) key + pure . Just $ foldKey (EmailActivated uid) (PhoneActivated uid) key where updateEmailAndDeleteEmailUnvalidated :: MonadClient m => UserId -> Email -> m () updateEmailAndDeleteEmailUnvalidated u' email = @@ -162,7 +162,7 @@ newActivation uk timeout u = do insert t k c = do key <- liftIO $ mkActivationKey uk retry x5 . write keyInsert $ params LocalQuorum (key, t, k, c, u, maxAttempts, round timeout) - return $ Activation key c + pure $ Activation key c genCode = ActivationCode . Ascii.unsafeFromText . pack . printf "%06d" <$> randIntegerZeroToNMinusOne 1000000 @@ -190,10 +190,10 @@ verifyCode key code = do Nothing -> throwE invalidCode where mkScope "email" k u = case parseEmail k of - Just e -> return (userEmailKey e, u) + Just e -> pure (userEmailKey e, u) Nothing -> throwE invalidCode mkScope "phone" k u = case parsePhone k of - Just p -> return (userPhoneKey p, u) + Just p -> pure (userPhoneKey p, u) Nothing -> throwE invalidCode mkScope _ _ _ = throwE invalidCode countdown = lift . retry x5 . write keyInsert . params LocalQuorum @@ -202,9 +202,9 @@ verifyCode key code = do mkActivationKey :: UserKey -> IO ActivationKey mkActivationKey k = do d <- liftIO $ getDigestByName "SHA256" - d' <- maybe (fail "SHA256 not found") return d + d' <- maybe (fail "SHA256 not found") pure d let bs = digestBS d' (T.encodeUtf8 $ keyText k) - return . ActivationKey $ Ascii.encodeBase64Url bs + pure . ActivationKey $ Ascii.encodeBase64Url bs deleteActivationPair :: MonadClient m => ActivationKey -> m () deleteActivationPair = write keyDelete . params LocalQuorum . Identity diff --git a/services/brig/src/Brig/Data/Blacklist.hs b/services/brig/src/Brig/Data/Blacklist.hs index 4ebe61fd7e..9b0c3a45c0 100644 --- a/services/brig/src/Brig/Data/Blacklist.hs +++ b/services/brig/src/Brig/Data/Blacklist.hs @@ -42,7 +42,7 @@ insert uk = retry x5 $ write keyInsert (params LocalQuorum (Identity $ keyText u exists :: MonadClient m => UserKey -> m Bool exists uk = - (return . isJust) . fmap runIdentity + (pure . isJust) . fmap runIdentity =<< retry x1 (query1 keySelect (params LocalQuorum (Identity $ keyText uk))) delete :: MonadClient m => UserKey -> m () @@ -80,12 +80,12 @@ getAllPrefixes prefix = do existsAnyPrefix :: MonadClient m => Phone -> m Bool existsAnyPrefix phone = do let prefixes = fromPhonePrefix <$> allPrefixes (fromPhone phone) - (not . null) <$> selectPrefixes prefixes + not . null <$> selectPrefixes prefixes selectPrefixes :: MonadClient m => [Text] -> m [ExcludedPrefix] selectPrefixes prefixes = do results <- retry x1 (query sel (params LocalQuorum (Identity $ prefixes))) - return $ (\(p, c) -> ExcludedPrefix p c) <$> results + 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/Data/Client.hs b/services/brig/src/Brig/Data/Client.hs index 03ea230140..51b42529a3 100644 --- a/services/brig/src/Brig/Data/Client.hs +++ b/services/brig/src/Brig/Data/Client.hs @@ -147,7 +147,7 @@ addClientWithReAuthPolicy reAuthPolicy u newId c maxPermClients loc cps = do new <- insert let !total = fromIntegral (length clients + if upsert then 0 else 1) let old = maybe (filter (not . exists) typed) (const []) limit - return (new, old, total) + pure (new, old, total) where limit :: Maybe Int limit = case newClientType c of @@ -170,7 +170,7 @@ addClientWithReAuthPolicy reAuthPolicy u newId c maxPermClients loc cps = do prm = (u, newId, now, newClientType c, newClientLabel c, newClientClass c, newClientCookie c, lat, lon, mdl, C.Set . Set.toList <$> cps) retry x5 $ write insertClient (params LocalQuorum prm) addMLSPublicKeys u newId (Map.assocs (newClientMLSPublicKeys c)) - return + pure $! Client { clientId = newId, clientType = newClientType c, @@ -265,8 +265,8 @@ updatePrekeys u c pks = do check a b = do i <- CryptoBox.isPrekey b case i of - Success n -> return (CryptoBox.prekeyId n == keyId (prekeyId a)) - _ -> return False + Success n -> pure (CryptoBox.prekeyId n == keyId (prekeyId a)) + _ -> pure False claimPrekey :: ( Log.MonadLogger m, @@ -298,8 +298,8 @@ claimPrekey u c = field "user" (toByteString u) . field "client" (toByteString c) . msg (val "last resort prekey used") - return $ Just (ClientPrekey c (Prekey i k)) - removeAndReturnPreKey Nothing = return Nothing + pure $ Just (ClientPrekey c (Prekey i k)) + removeAndReturnPreKey Nothing = pure Nothing pickRandomPrekey :: MonadIO f => [(PrekeyId, Text)] -> f (Maybe (PrekeyId, Text)) pickRandomPrekey [] = pure Nothing @@ -309,7 +309,7 @@ claimPrekey u c = pickRandomPrekey pks = do let pks' = filter (\k -> fst k /= lastPrekeyId) pks ind <- liftIO $ randomRIO (0, length pks' - 1) - return $ atMay pks' ind + pure $ atMay pks' ind lookupMLSPublicKey :: MonadClient m => @@ -488,13 +488,13 @@ withOptLock :: withOptLock u c ma = go (10 :: Int) where go !n = do - v <- (version =<<) <$> execDyn return get + v <- (version =<<) <$> execDyn pure get a <- ma - r <- execDyn return (put v) + r <- execDyn pure (put v) case r of Nothing | n > 0 -> reportAttemptFailure >> go (n - 1) - Nothing -> reportFailureAndLogError >> return a - Just _ -> return a + Nothing -> reportFailureAndLogError >> pure a + Just _ -> pure a version :: AWS.GetItemResponse -> Maybe Word32 version v = conv =<< HashMap.lookup ddbVersion (view AWS.getItemResponse_item v) where @@ -549,13 +549,13 @@ withOptLock u c ma = go (10 :: Int) IO (Maybe y) execDyn' e m conv cmd = recovering policy handlers (const run) where - run = execCatch e cmd >>= either handleErr (return . conv) + 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.serviceCode == AWS.ErrorCode "ProvisionedThroughputExceeded" = do Metrics.counterIncr (Metrics.path "client.opt_lock.provisioned_throughput_exceeded") m - return Nothing - handleErr _ = return Nothing + pure Nothing + handleErr _ = pure Nothing withLocalLock :: (MonadMask m, MonadIO m) => MVar () -> m a -> m a withLocalLock l ma = do diff --git a/services/brig/src/Brig/Data/Connection.hs b/services/brig/src/Brig/Data/Connection.hs index 428df573f8..906a94d811 100644 --- a/services/brig/src/Brig/Data/Connection.hs +++ b/services/brig/src/Brig/Data/Connection.hs @@ -290,7 +290,7 @@ countConnections u r = do rels <- retry x1 . query selectStatus $ params One (Identity (tUnqualified u)) relsRemote <- retry x1 . query selectStatusRemote $ params One (Identity (tUnqualified u)) - return $ foldl' count 0 rels + foldl' count 0 relsRemote + pure $ foldl' count 0 rels + foldl' count 0 relsRemote where selectStatus :: QueryString R (Identity UserId) (Identity RelationWithHistory) selectStatus = "SELECT status FROM connection WHERE left = ?" diff --git a/services/brig/src/Brig/Data/Instances.hs b/services/brig/src/Brig/Data/Instances.hs index 7b61939285..feeb356b8e 100644 --- a/services/brig/src/Brig/Data/Instances.hs +++ b/services/brig/src/Brig/Data/Instances.hs @@ -74,7 +74,7 @@ instance Cql Email where ctype = Tagged TextColumn fromCql (CqlText t) = case parseEmail t of - Just e -> return e + Just e -> pure e Nothing -> Left "fromCql: Invalid email" fromCql _ = Left "fromCql: email: CqlText expected" @@ -84,7 +84,7 @@ instance Cql UserSSOId where ctype = Tagged TextColumn fromCql (CqlText t) = case eitherDecode $ cs t of - Right i -> return i + Right i -> pure i Left msg -> Left $ "fromCql: Invalid UserSSOId: " ++ msg fromCql _ = Left "fromCql: UserSSOId: CqlText expected" @@ -129,8 +129,8 @@ instance Cql Pict where fromCql (CqlList l) = do vs <- map (\(Blob lbs) -> lbs) <$> mapM fromCql l as <- mapM (note "Failed to read asset" . JSON.decode) vs - return $ Pict as - fromCql _ = return noPict + pure $ Pict as + fromCql _ = pure noPict toCql = toCql . map (Blob . JSON.encode) . fromPict @@ -145,8 +145,8 @@ instance Cql AssetKey where instance Cql AssetSize where ctype = Tagged IntColumn - fromCql (CqlInt 0) = return AssetPreview - fromCql (CqlInt 1) = return AssetComplete + fromCql (CqlInt 0) = pure AssetPreview + fromCql (CqlInt 1) = pure AssetComplete fromCql n = Left $ "Unexpected asset size: " ++ show n toCql AssetPreview = CqlInt 0 @@ -171,7 +171,7 @@ instance Cql Asset where k <- required "key" s <- optional "size" case (t :: Int32) of - 0 -> return $! ImageAsset k s + 0 -> pure $! ImageAsset k s _ -> Left $ "unexpected user asset type: " ++ show t where required :: Cql r => Text -> Either String r @@ -201,11 +201,11 @@ instance Cql AccountStatus where toCql PendingInvitation = CqlInt 4 fromCql (CqlInt i) = case i of - 0 -> return Active - 1 -> return Suspended - 2 -> return Deleted - 3 -> return Ephemeral - 4 -> return PendingInvitation + 0 -> pure Active + 1 -> pure Suspended + 2 -> pure Deleted + 3 -> pure Ephemeral + 4 -> pure PendingInvitation n -> Left $ "unexpected account status: " ++ show n fromCql _ = Left "account status: int expected" @@ -215,9 +215,9 @@ instance Cql ClientType where toCql PermanentClientType = CqlInt 1 toCql LegalHoldClientType = CqlInt 2 - fromCql (CqlInt 0) = return TemporaryClientType - fromCql (CqlInt 1) = return PermanentClientType - fromCql (CqlInt 2) = return LegalHoldClientType + fromCql (CqlInt 0) = pure TemporaryClientType + fromCql (CqlInt 1) = pure PermanentClientType + fromCql (CqlInt 2) = pure LegalHoldClientType fromCql _ = Left "ClientType: Int [0, 2] expected" instance Cql ClientClass where @@ -227,10 +227,10 @@ instance Cql ClientClass where toCql DesktopClient = CqlInt 2 toCql LegalHoldClient = CqlInt 3 - fromCql (CqlInt 0) = return PhoneClient - fromCql (CqlInt 1) = return TabletClient - fromCql (CqlInt 2) = return DesktopClient - fromCql (CqlInt 3) = return LegalHoldClient + fromCql (CqlInt 0) = pure PhoneClient + fromCql (CqlInt 1) = pure TabletClient + fromCql (CqlInt 2) = pure DesktopClient + fromCql (CqlInt 3) = pure LegalHoldClient fromCql _ = Left "ClientClass: Int [0, 3] expected" instance Cql RawPropertyValue where @@ -244,7 +244,7 @@ instance Cql Country where toCql = toCql . con2Text fromCql (CqlAscii c) = case parseCountry c of - Just c' -> return c' + Just c' -> pure c' Nothing -> Left "Country: ISO 3166-1-alpha2 expected." fromCql _ = Left "Country: ASCII expected" @@ -253,15 +253,15 @@ instance Cql Language where toCql = toCql . lan2Text fromCql (CqlAscii l) = case parseLanguage l of - Just l' -> return l' + Just l' -> pure l' Nothing -> Left "Language: ISO 639-1 expected." fromCql _ = Left "Language: ASCII expected" instance Cql ManagedBy where ctype = Tagged IntColumn - fromCql (CqlInt 0) = return ManagedByWire - fromCql (CqlInt 1) = return ManagedByScim + fromCql (CqlInt 0) = pure ManagedByWire + fromCql (CqlInt 1) = pure ManagedByScim fromCql n = Left $ "Unexpected ManagedBy: " ++ show n toCql ManagedByWire = CqlInt 0 diff --git a/services/brig/src/Brig/Data/LoginCode.hs b/services/brig/src/Brig/Data/LoginCode.hs index 4ac76a2c42..8a93ebcf48 100644 --- a/services/brig/src/Brig/Data/LoginCode.hs +++ b/services/brig/src/Brig/Data/LoginCode.hs @@ -53,7 +53,7 @@ createLoginCode u = do now <- liftIO =<< view currentTime code <- liftIO genCode insertLoginCode u code maxAttempts (ttl `addUTCTime` now) - return $! PendingLoginCode code (Timeout ttl) + pure $! PendingLoginCode code (Timeout ttl) where genCode = LoginCode . T.pack . printf "%06d" <$> randIntegerZeroToNMinusOne 1000000 @@ -62,18 +62,18 @@ verifyLoginCode u c = do code <- retry x1 (query1 codeSelect (params LocalQuorum (Identity u))) now <- liftIO =<< view currentTime case code of - Just (c', _, t) | c == c' && t >= now -> deleteLoginCode u >> return True - Just (c', n, t) | n > 1 && t > now -> insertLoginCode u c' (n - 1) t >> return False - Just (_, _, _) -> deleteLoginCode u >> return False - Nothing -> return False + Just (c', _, t) | c == c' && t >= now -> deleteLoginCode u >> pure True + Just (c', n, t) | n > 1 && t > now -> insertLoginCode u c' (n - 1) t >> pure False + Just (_, _, _) -> deleteLoginCode u >> pure False + Nothing -> pure False lookupLoginCode :: (MonadReader Env m, MonadClient m) => UserId -> m (Maybe PendingLoginCode) lookupLoginCode u = do now <- liftIO =<< view currentTime validate now =<< retry x1 (query1 codeSelect (params LocalQuorum (Identity u))) where - validate now (Just (c, _, t)) | now < t = return (Just (pending c now t)) - validate _ _ = return Nothing + validate now (Just (c, _, t)) | now < t = pure (Just (pending c now t)) + validate _ _ = pure Nothing pending c now t = PendingLoginCode c (timeout now t) timeout now t = Timeout (t `diffUTCTime` now) diff --git a/services/brig/src/Brig/Data/MLS/KeyPackage.hs b/services/brig/src/Brig/Data/MLS/KeyPackage.hs index 96aca4c865..a2d6b78459 100644 --- a/services/brig/src/Brig/Data/MLS/KeyPackage.hs +++ b/services/brig/src/Brig/Data/MLS/KeyPackage.hs @@ -21,13 +21,18 @@ module Brig.Data.MLS.KeyPackage mapKeyPackageRef, countKeyPackages, derefKeyPackage, + keyPackageRefConvId, + keyPackageRefSetConvId, ) where import Brig.App import Cassandra +import Cassandra.Settings import Control.Error +import Control.Exception import Control.Lens +import Control.Monad.Catch import Control.Monad.Random (randomRIO) import Data.Domain import Data.Functor @@ -97,6 +102,34 @@ derefKeyPackage ref = do q :: PrepQuery R (Identity KeyPackageRef) (Domain, UserId, ClientId) q = "SELECT domain, user, client from mls_key_package_refs WHERE ref = ?" +keyPackageRefConvId :: MonadClient m => KeyPackageRef -> MaybeT m (Qualified ConvId) +keyPackageRefConvId ref = MaybeT $ do + qr <- retry x1 $ query1 q (params LocalSerial (Identity ref)) + pure $ do + (domain, cid) <- qr + Qualified <$> cid <*> domain + where + q :: PrepQuery R (Identity KeyPackageRef) (Maybe Domain, Maybe ConvId) + q = "SELECT conv_domain, conv FROM mls_key_package_refs WHERE ref = ?" + +-- We want to proper update, not an upsert, to avoid "ghost" refs without user+client +keyPackageRefSetConvId :: MonadClient m => KeyPackageRef -> Qualified ConvId -> m Bool +keyPackageRefSetConvId ref convId = do + updated <- + retry x5 $ + trans + q + (params LocalQuorum (qDomain convId, qUnqualified convId, ref)) + { serialConsistency = Just LocalSerialConsistency + } + case updated of + [] -> pure False + [_] -> pure True + _ -> throwM $ ErrorCall "Primary key violation detected mls_key_package_refs.ref" + where + q :: PrepQuery W (Domain, ConvId, KeyPackageRef) x + q = "UPDATE mls_key_package_refs SET conv_domain = ?, conv = ? WHERE ref = ? IF EXISTS" + -------------------------------------------------------------------------------- -- Utilities diff --git a/services/brig/src/Brig/Data/User.hs b/services/brig/src/Brig/Data/User.hs index d60bca1680..14b06bb8f1 100644 --- a/services/brig/src/Brig/Data/User.hs +++ b/services/brig/src/Brig/Data/User.hs @@ -31,6 +31,7 @@ module Brig.Data.User reauthenticate, filterActive, isActivated, + isSamlUser, -- * Lookups lookupAccount, @@ -132,7 +133,7 @@ newAccount u inv tid mbHandle = do (Just (toUUID -> uuid), _) -> pure uuid (_, Just uuid) -> pure uuid (Nothing, Nothing) -> liftIO nextRandom - passwd <- maybe (return Nothing) (fmap Just . liftIO . mkSafePassword) pass + passwd <- maybe (pure Nothing) (fmap Just . liftIO . mkSafePassword) pass expiry <- case status of Ephemeral -> do -- Ephemeral users' expiry time is in expires_in (default sessionTokenTimeout) seconds @@ -140,9 +141,9 @@ newAccount u inv tid mbHandle = do let ZAuth.SessionTokenTimeout defTTL = e ^. ZAuth.settings . ZAuth.sessionTokenTimeout ttl = maybe defTTL fromRange (newUserExpiresIn u) now <- liftIO =<< view currentTime - return . Just . toUTCTimeMillis $ addUTCTime (fromIntegral ttl) now - _ -> return Nothing - return (UserAccount (user uid domain (locale defLoc) expiry) status, passwd) + pure . Just . toUTCTimeMillis $ addUTCTime (fromIntegral ttl) now + _ -> pure Nothing + pure (UserAccount (user uid domain (locale defLoc) expiry) status, passwd) where ident = newUserIdentity u pass = newUserPassword u @@ -162,7 +163,7 @@ newAccountInviteViaScim :: (MonadClient m, MonadReader Env m) => UserId -> TeamI newAccountInviteViaScim uid tid locale name email = do defLoc <- setDefaultUserLocale <$> view settings domain <- viewFederationDomain - return (UserAccount (user domain (fromMaybe defLoc locale)) PendingInvitation) + pure (UserAccount (user domain (fromMaybe defLoc locale)) PendingInvitation) where user domain loc = User @@ -196,9 +197,9 @@ authenticate u pw = throwE AuthInvalidCredentials -- | Password reauthentication. If the account has a password, reauthentication --- is mandatory. If the account has no password and no password is given, +-- is mandatory. If the account has no password, or is an SSO user, and no password is given, -- reauthentication is a no-op. -reauthenticate :: MonadClient m => UserId -> Maybe PlainTextPassword -> ExceptT ReAuthError m () +reauthenticate :: (MonadClient m, MonadReader Env m) => UserId -> Maybe PlainTextPassword -> ExceptT ReAuthError m () reauthenticate u pw = lift (lookupAuth u) >>= \case Nothing -> throwE (ReAuthError AuthInvalidUser) @@ -210,11 +211,18 @@ reauthenticate u pw = Just (Just pw', Ephemeral) -> maybeReAuth pw' where maybeReAuth pw' = case pw of - Nothing -> throwE ReAuthMissingPassword + Nothing -> unlessM (isSamlUser u) $ throwE ReAuthMissingPassword Just p -> unless (verifyPassword p pw') $ throwE (ReAuthError AuthInvalidCredentials) +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 + _ -> pure False + insertAccount :: MonadClient m => UserAccount -> @@ -703,7 +711,7 @@ toUserAccount managed_by ) = let ident = toIdentity activated email phone ssoid - deleted = maybe False (== Deleted) status + deleted = Just Deleted == status expiration = if status == Just Ephemeral then expires else Nothing loc = toLocale defaultLocale (lan, con) svc = newServiceRef <$> sid <*> pid @@ -777,7 +785,7 @@ toUsers domain defaultLocale havePendingInvitations = fmap mk . filter fp managed_by ) = let ident = toIdentity activated email phone ssoid - deleted = maybe False (== Deleted) status + deleted = Just Deleted == status expiration = if status == Just Ephemeral then expires else Nothing loc = toLocale defaultLocale (lan, con) svc = newServiceRef <$> sid <*> pid diff --git a/services/brig/src/Brig/Data/UserKey.hs b/services/brig/src/Brig/Data/UserKey.hs index d9afe3af53..027fbac7d1 100644 --- a/services/brig/src/Brig/Data/UserKey.hs +++ b/services/brig/src/Brig/Data/UserKey.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2022 Wire Swiss GmbH @@ -70,8 +68,8 @@ instance Cql UKHashType where ctype = Tagged IntColumn fromCql (CqlInt i) = case i of - 0 -> return UKHashPhone - 1 -> return UKHashEmail + 0 -> pure UKHashPhone + 1 -> pure UKHashEmail n -> Left $ "unexpected hashtype: " ++ show n fromCql _ = Left "userkeyhashtype: int expected" @@ -85,7 +83,7 @@ instance Cql UserKeyHash where fromCql (CqlBlob lbs) = case MH.decode (toStrict lbs) of Left e -> Left ("userkeyhash: " ++ e) - Right h -> return $ UserKeyHash h + Right h -> pure $ UserKeyHash h fromCql _ = Left "userkeyhash: expected blob" toCql (UserKeyHash d) = CqlBlob $ MH.encode (MH.algorithm d) (MH.digest d) @@ -129,7 +127,7 @@ claimKey :: claimKey k u = do free <- keyAvailable k (Just u) when free (insertKey u k) - return free + pure free -- | Check whether a 'UserKey' is available. -- A key is available if it is not already actived for another user or @@ -144,8 +142,8 @@ keyAvailable :: keyAvailable k u = do o <- lookupKey k case (o, u) of - (Nothing, _) -> return True - (Just x, Just y) | x == y -> return True + (Nothing, _) -> pure True + (Just x, Just y) | x == y -> pure True (Just x, _) -> not <$> User.isActivated x lookupKey :: MonadClient m => UserKey -> m (Maybe UserId) @@ -170,7 +168,7 @@ hashKey :: MonadReader Env m => UserKey -> m UserKeyHash hashKey uk = do d <- view digestSHA256 let d' = digestBS d $ T.encodeUtf8 (keyText uk) - return . UserKeyHash $ + pure . UserKeyHash $ MH.MultihashDigest MH.SHA256 (B.length d') d' lookupPhoneHashes :: MonadClient m => [ByteString] -> m [(ByteString, UserId)] diff --git a/services/brig/src/Brig/Data/UserPendingActivation.hs b/services/brig/src/Brig/Data/UserPendingActivation.hs index 2388479446..23a5668428 100644 --- a/services/brig/src/Brig/Data/UserPendingActivation.hs +++ b/services/brig/src/Brig/Data/UserPendingActivation.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2022 Wire Swiss GmbH diff --git a/services/brig/src/Brig/IO/Intra.hs b/services/brig/src/Brig/IO/Intra.hs index afbdec1a85..1a17770abb 100644 --- a/services/brig/src/Brig/IO/Intra.hs +++ b/services/brig/src/Brig/IO/Intra.hs @@ -173,7 +173,7 @@ onConnectionEvent orig conn evt = do orig Push.RouteAny conn - (return $ list1 from []) + (pure $ list1 from []) onPropertyEvent :: -- | Originator of the event. @@ -189,7 +189,7 @@ onPropertyEvent orig conn e = orig Push.RouteDirect (Just conn) - (return $ list1 orig []) + (pure $ list1 orig []) onClientEvent :: -- | Originator of the event. @@ -221,13 +221,13 @@ updateSearchIndex :: m () updateSearchIndex orig e = case e of -- no-ops - UserCreated {} -> return () + UserCreated {} -> pure () UserIdentityUpdated UserIdentityUpdatedData {..} -> do when (isJust eiuEmail) $ Search.reindex orig - UserIdentityRemoved {} -> return () - UserLegalHoldDisabled {} -> return () - UserLegalHoldEnabled {} -> return () - LegalHoldClientRequested {} -> return () + UserIdentityRemoved {} -> pure () + UserLegalHoldDisabled {} -> pure () + UserLegalHoldEnabled {} -> pure () + LegalHoldClientRequested {} -> pure () UserSuspended {} -> Search.reindex orig UserResumed {} -> Search.reindex orig UserActivated {} -> Search.reindex orig @@ -258,7 +258,7 @@ journalEvent orig e = case e of UserDeleted {} -> Journal.userDelete orig _ -> - return () + pure () ------------------------------------------------------------------------------- -- Low-Level Event Notification @@ -282,9 +282,9 @@ dispatchNotifications :: UserEvent -> m () dispatchNotifications orig conn e = case e of - UserCreated {} -> return () - UserSuspended {} -> return () - UserResumed {} -> return () + UserCreated {} -> pure () + UserSuspended {} -> pure () + UserResumed {} -> pure () LegalHoldClientRequested {} -> notifyContacts event orig Push.RouteAny conn UserLegalHoldDisabled {} -> notifyContacts event orig Push.RouteAny conn UserLegalHoldEnabled {} -> notifyContacts event orig Push.RouteAny conn @@ -334,7 +334,7 @@ notifyUserDeletionRemotes :: notifyUserDeletionRemotes deleted = do runConduit $ Data.lookupRemoteConnectedUsersC deleted (fromInteger (natVal (Proxy @UserDeletedNotificationMaxConnections))) - .| C.mapM_ (fanoutNotifications) + .| C.mapM_ fanoutNotifications where fanoutNotifications :: [Remote UserId] -> m () fanoutNotifications = mapM_ notifyBackend . bucketRemote @@ -482,7 +482,7 @@ fork u ma = do let logErr e = ExLog.err g $ request r ~~ user u ~~ msg (show e) withRunInIO $ \lower -> void . liftIO . forkIO $ - either logErr (const $ return ()) + either logErr (const $ pure ()) =<< runExceptT (syncIO $ lower ma) where request = field "request" . unRequestId @@ -542,8 +542,8 @@ notifyContacts events orig route conn = do screenMemberList :: Maybe Team.TeamMemberList -> m [UserId] screenMemberList (Just mems) | mems ^. Team.teamMemberListType == Team.ListComplete = - return $ fmap (view Team.userId) (mems ^. Team.teamMembers) - screenMemberList _ = return [] + pure $ fmap (view Team.userId) (mems ^. Team.teamMembers) + screenMemberList _ = pure [] -- Event Serialisation: @@ -754,7 +754,7 @@ createLocalConnectConv from to cname conn = do . lbytes (encode $ Connect (qUntagged to) Nothing cname Nothing) . expect2xx r <- galleyRequest POST req - maybe (error "invalid conv id") return $ + maybe (error "invalid conv id") pure $ fromByteString $ getHeader' "Location" r @@ -911,7 +911,7 @@ getConv usr cnv = do rs <- galleyRequest GET req case Bilge.statusCode rs of 200 -> Just <$> decodeBody "galley" rs - _ -> return Nothing + _ -> pure Nothing where req = paths ["conversations", toByteString' cnv] @@ -960,7 +960,7 @@ getTeamConv usr tid cnv = do rs <- galleyRequest GET req case Bilge.statusCode rs of 200 -> Just <$> decodeBody "galley" rs - _ -> return Nothing + _ -> pure Nothing where req = paths ["teams", toByteString' tid, "conversations", toByteString' cnv] @@ -1110,10 +1110,10 @@ checkUserCanJoinTeam tid = do remote "galley" . msg (val "Check if can add member to team") rs <- galleyRequest GET req - return $ case Bilge.statusCode rs of + pure $ case Bilge.statusCode rs of 200 -> Nothing _ -> case decodeBody "galley" rs of - Just (e :: Wai.Error) -> return e + Just (e :: Wai.Error) -> pure e Nothing -> error ("Invalid response from galley: " <> show rs) where req = @@ -1138,7 +1138,7 @@ addTeamMember u tid (minvmeta, role) = do remote "galley" . msg (val "Adding member to team") rs <- galleyRequest POST req - return $ case Bilge.statusCode rs of + pure $ case Bilge.statusCode rs of 200 -> True _ -> False where @@ -1170,10 +1170,10 @@ createTeam u t@(Team.BindingNewTeam bt) teamid = do . msg (val "Creating Team") r <- galleyRequest PUT $ req teamid tid <- - maybe (error "invalid team id") return $ + maybe (error "invalid team id") pure $ fromByteString $ getHeader' "Location" r - return (CreateUserTeam tid $ fromRange (bt ^. Team.newTeamName)) + pure (CreateUserTeam tid $ fromRange (bt ^. Team.newTeamName)) where req tid = paths ["i", "teams", toByteString' tid] @@ -1201,7 +1201,7 @@ getTeamMember u tid = do rs <- galleyRequest GET req case Bilge.statusCode rs of 200 -> Just <$> decodeBody "galley" rs - _ -> return Nothing + _ -> pure Nothing where req = paths ["i", "teams", toByteString' tid, "members", toByteString' u] @@ -1265,7 +1265,7 @@ getTeamContacts u = do rs <- galleyRequest GET req case Bilge.statusCode rs of 200 -> Just <$> decodeBody "galley" rs - _ -> return Nothing + _ -> pure Nothing where req = paths ["i", "users", toByteString' u, "team", "members"] @@ -1287,7 +1287,7 @@ getTeamId u = do rs <- galleyRequest GET req case Bilge.statusCode rs of 200 -> Just <$> decodeBody "galley" rs - _ -> return Nothing + _ -> pure Nothing where req = paths ["i", "users", toByteString' u, "team"] diff --git a/services/brig/src/Brig/IO/Journal.hs b/services/brig/src/Brig/IO/Journal.hs index c612c4fc7a..2ebe6b102a 100644 --- a/services/brig/src/Brig/IO/Journal.hs +++ b/services/brig/src/Brig/IO/Journal.hs @@ -51,7 +51,7 @@ userActivate :: (MonadReader Env m, MonadIO m) => User -> m () userActivate u@User {..} = journalEvent UserEvent'USER_ACTIVATE userId (userEmail u) (Just userLocale) userTeam (Just userDisplayName) userUpdate :: (MonadReader Env m, MonadIO m) => UserId -> Maybe Email -> Maybe Locale -> Maybe Name -> m () -userUpdate uid em loc nm = journalEvent UserEvent'USER_UPDATE uid em loc Nothing nm +userUpdate uid em loc = journalEvent UserEvent'USER_UPDATE uid em loc Nothing userEmailRemove :: (MonadReader Env m, MonadIO m) => UserId -> Email -> m () userEmailRemove uid em = journalEvent UserEvent'USER_EMAIL_REMOVE uid (Just em) Nothing Nothing Nothing @@ -67,7 +67,7 @@ journalEvent typ uid em loc tid nm = let userEvent :: UserEvent = defMessage & U.eventType .~ typ - & U.userId .~ (toBytes uid) + & U.userId .~ toBytes uid & U.utcTime .~ ts & U.maybe'email .~ (toByteString' <$> em) & U.maybe'locale .~ (pack . show <$> loc) diff --git a/services/brig/src/Brig/Index/Options.hs b/services/brig/src/Brig/Index/Options.hs index 5935684a41..c614172794 100644 --- a/services/brig/src/Brig/Index/Options.hs +++ b/services/brig/src/Brig/Index/Options.hs @@ -200,27 +200,25 @@ elasticSettingsParser = ) templateParser :: Parser (Maybe ES.TemplateName) = ES.TemplateName - <$$> ( optional - ( option - str - ( long "delete-template" - <> metavar "TEMPLATE_NAME" - <> help "Delete this ES template before creating a new index" - ) - ) - ) + <$$> optional + ( option + str + ( long "delete-template" + <> metavar "TEMPLATE_NAME" + <> help "Delete this ES template before creating a new index" + ) + ) cassandraSettingsParser :: Parser CassandraSettings cassandraSettingsParser = CassandraSettings - <$> ( strOption - ( long "cassandra-host" - <> metavar "HOST" - <> help "Cassandra Host." - <> value (_cHost localCassandraSettings) - <> showDefault - ) - ) + <$> strOption + ( long "cassandra-host" + <> metavar "HOST" + <> help "Cassandra Host." + <> value (_cHost localCassandraSettings) + <> showDefault + ) <*> option auto ( long "cassandra-port" @@ -257,36 +255,33 @@ reindexToAnotherIndexSettingsParser = <> help "Elasticsearch index name to reindex to" ) ) - <*> ( option - auto - ( long "timeout" - <> metavar "SECONDS" - <> help "Number of seconds to wait for reindexing to complete. The reindexing will not be cancelled when this timeout expires." - <> value 600 - <> showDefault - ) - ) + <*> option + auto + ( long "timeout" + <> metavar "SECONDS" + <> help "Number of seconds to wait for reindexing to complete. The reindexing will not be cancelled when this timeout expires." + <> value 600 + <> showDefault + ) galleyEndpointParser :: Parser Endpoint galleyEndpointParser = Endpoint - <$> ( strOption - ( long "galley-host" - <> help "Hostname or IP address of galley" - <> metavar "HOSTNAME" - <> value "localhost" - <> showDefault - ) - ) - <*> ( option - auto - ( long "galley-port" - <> help "Port number of galley" - <> metavar "PORT" - <> value 8085 - <> showDefault - ) - ) + <$> strOption + ( long "galley-host" + <> help "Hostname or IP address of galley" + <> metavar "HOSTNAME" + <> value "localhost" + <> showDefault + ) + <*> option + auto + ( long "galley-port" + <> help "Port number of galley" + <> metavar "PORT" + <> value 8085 + <> showDefault + ) commandParser :: Parser Command commandParser = @@ -295,7 +290,7 @@ commandParser = "create" ( info (Create <$> elasticSettingsParser <*> galleyEndpointParser) - (progDesc ("Create the ES user index, if it doesn't already exist. ")) + (progDesc "Create the ES user index, if it doesn't already exist. ") ) <> command "update-mapping" @@ -307,7 +302,7 @@ commandParser = "reset" ( info (Reset <$> restrictedElasticSettingsParser <*> galleyEndpointParser) - (progDesc ("Delete and re-create the ES user index. Only works on a test index (directory_test).")) + (progDesc "Delete and re-create the ES user index. Only works on a test index (directory_test).") ) <> command "reindex" diff --git a/services/brig/src/Brig/InternalEvent/Types.hs b/services/brig/src/Brig/InternalEvent/Types.hs index b5cf86800d..c9ac85e3ac 100644 --- a/services/brig/src/Brig/InternalEvent/Types.hs +++ b/services/brig/src/Brig/InternalEvent/Types.hs @@ -36,8 +36,8 @@ data InternalNotificationType instance FromJSON InternalNotificationType where parseJSON = \case - "user.delete" -> return UserDeletion - "service.delete" -> return ServiceDeletion + "user.delete" -> pure UserDeletion + "service.delete" -> pure ServiceDeletion x -> fail $ "InternalNotificationType: Unknown type " <> show x instance ToJSON InternalNotificationType where diff --git a/services/brig/src/Brig/Password.hs b/services/brig/src/Brig/Password.hs index d5889d1be7..9c52d9268e 100644 --- a/services/brig/src/Brig/Password.hs +++ b/services/brig/src/Brig/Password.hs @@ -42,7 +42,7 @@ instance Show Password where instance Cql Password where ctype = Tagged BlobColumn - fromCql (CqlBlob lbs) = return . Password . EncryptedPass $ toStrict lbs + fromCql (CqlBlob lbs) = pure . Password . EncryptedPass $ toStrict lbs fromCql _ = Left "password: expected blob" toCql = CqlBlob . fromStrict . getEncryptedPass . fromPassword diff --git a/services/brig/src/Brig/Phone.hs b/services/brig/src/Brig/Phone.hs index c8c54f048a..44eb72f796 100644 --- a/services/brig/src/Brig/Phone.hs +++ b/services/brig/src/Brig/Phone.hs @@ -93,12 +93,12 @@ sendCall call = unless (isTestPhone $ Nexmo.callTo call) $ do Nexmo.CallUnroutable -> unreachable ex Nexmo.CallDestinationBarred -> barred ex _ -> throwM ex - Right _ -> return () + Right _ -> pure () where nexmoHandlers = httpHandlers ++ [ const . Handler $ \(ex :: Nexmo.CallErrorResponse) -> - return $ case Nexmo.caStatus ex of + pure $ case Nexmo.caStatus ex of Nexmo.CallThrottled -> True Nexmo.CallInternal -> True _ -> False @@ -140,7 +140,7 @@ sendSms loc SMSMessage {..} = unless (isTestPhone smsTo) $ do 21610 -> barred ex' -- A real problem _ -> throwM ex' - Right () -> return () + Right () -> pure () where sendNexmoSms :: (MonadIO f, MonadReader Env f) => Manager -> f () sendNexmoSms mgr = do @@ -167,14 +167,14 @@ sendSms loc SMSMessage {..} = unless (isTestPhone smsTo) $ do Twilio.sendMessage crd mgr (Twilio.Message smsFrom smsTo smsText) nexmoFailed = [ Handler $ \(ex :: HttpException) -> - return (Just (SomeException ex)), + pure (Just (SomeException ex)), Handler $ \(ex :: Nexmo.MessageErrorResponse) -> - return (Just (SomeException ex)) + pure (Just (SomeException ex)) ] nexmoHandlers = httpHandlers ++ [ const . Handler $ \(ex :: Nexmo.MessageErrorResponse) -> - return $ case Nexmo.erStatus ex of + pure $ case Nexmo.erStatus ex of Nexmo.MessageThrottled -> True Nexmo.MessageInternal -> True Nexmo.MessageCommunicationFailed -> True @@ -183,7 +183,7 @@ sendSms loc SMSMessage {..} = unless (isTestPhone smsTo) $ do twilioHandlers = httpHandlers ++ [ const . Handler $ \(ex :: Twilio.ErrorResponse) -> - return $ case Twilio.errStatus ex of + pure $ case Twilio.errStatus ex of 20429 -> True -- Too Many Requests 20500 -> True -- Internal Server Error 20503 -> True -- Temporarily Unavailable @@ -204,7 +204,7 @@ sendSms loc SMSMessage {..} = unless (isTestPhone smsTo) $ do -- 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 = return (Just (Phone p)) + | isTestPhone p = pure (Just (Phone p)) | otherwise = do c <- view twilioCreds m <- view httpManager @@ -214,8 +214,8 @@ validatePhone (Phone p) const $ Twilio.lookupPhone c m p LookupNoDetail Nothing case r of - Right x -> return (Just (Phone (Twilio.lookupE164 x))) - Left e | Twilio.errStatus e == 404 -> return Nothing + Right x -> pure (Just (Phone (Twilio.lookupE164 x))) + Left e | Twilio.errStatus e == 404 -> pure Nothing Left e -> throwM e isTestPhone :: Text -> Bool @@ -254,7 +254,7 @@ withSmsBudget phone go = do msg (val "SMS budget deducted.") ~~ field "budget" b ~~ field "phone" phone - return a + pure a -------------------------------------------------------------------------------- -- Voice Call Budgeting @@ -289,7 +289,7 @@ withCallBudget phone go = do msg (val "Voice call budget deducted.") ~~ field "budget" b ~~ field "phone" phone - return a + pure a -------------------------------------------------------------------------------- -- Unique Keys diff --git a/services/brig/src/Brig/Provider/API.hs b/services/brig/src/Brig/Provider/API.hs index eb273b4402..8a8f96c561 100644 --- a/services/brig/src/Brig/Provider/API.hs +++ b/services/brig/src/Brig/Provider/API.hs @@ -332,7 +332,7 @@ newAccountH req = do newAccount :: Public.NewProvider -> (Handler r) Public.NewProviderResponse newAccount new = do email <- case validateEmail (Public.newProviderEmail new) of - Right em -> return em + Right em -> pure em Left _ -> throwStd (errorToWai @'InvalidEmail) let name = Public.newProviderName new let pass = Public.newProviderPassword new @@ -345,7 +345,7 @@ newAccount new = do Nothing -> do newPass <- genPassword safePass <- mkSafePassword newPass - return (safePass, Just newPass) + pure (safePass, Just newPass) pid <- wrapClientE $ DB.insertAccount name safePass url descr gen <- Code.mkGen (Code.ForEmail email) code <- @@ -359,7 +359,7 @@ newAccount new = do let key = Code.codeKey code let val = Code.codeValue code lift $ sendActivationMail name email key val False - return $ Public.NewProviderResponse pid newPass + pure $ Public.NewProviderResponse pid newPass activateAccountKeyH :: Code.Key ::: Code.Value -> (Handler r) Response activateAccountKeyH (key ::: val) = do @@ -370,23 +370,23 @@ activateAccountKey :: Code.Key -> Code.Value -> (Handler r) (Maybe Public.Provid activateAccountKey key val = do c <- wrapClientE (Code.verify key Code.IdentityVerification val) >>= maybeInvalidCode (pid, email) <- case (Code.codeAccount c, Code.codeForEmail c) of - (Just p, Just e) -> return (Id p, e) + (Just p, Just e) -> pure (Id p, e) _ -> throwStd (errorToWai @'InvalidCode) (name, memail, _url, _descr) <- wrapClientE (DB.lookupAccountData pid) >>= maybeInvalidCode case memail of - Just email' | email == email' -> return Nothing + 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 -- Activate the new and remove the old key activate pid (Just email') email - return . Just $ Public.ProviderActivationResponse email + pure . Just $ Public.ProviderActivationResponse email -- Immediate approval for everybody (for now). Nothing -> do activate pid Nothing email lift $ sendApprovalConfirmMail name email - return . Just $ Public.ProviderActivationResponse email + pure . Just $ Public.ProviderActivationResponse email getActivationCodeH :: Public.Email -> (Handler r) Response getActivationCodeH e = do @@ -396,11 +396,11 @@ getActivationCodeH e = do getActivationCode :: Public.Email -> (Handler r) FoundActivationCode getActivationCode e = do email <- case validateEmail e of - Right em -> return em + Right em -> pure em Left _ -> throwStd (errorToWai @'InvalidEmail) gen <- Code.mkGen (Code.ForEmail email) code <- wrapClientE $ Code.lookup (Code.genKey gen) Code.IdentityVerification - maybe (throwStd activationKeyNotFound) (return . FoundActivationCode) code + maybe (throwStd activationKeyNotFound) (pure . FoundActivationCode) code newtype FoundActivationCode = FoundActivationCode Code.Code @@ -514,7 +514,7 @@ updateAccountEmailH (pid ::: req) = do updateAccountEmail :: ProviderId -> Public.EmailUpdate -> (Handler r) () updateAccountEmail pid (Public.EmailUpdate new) = do email <- case validateEmail new of - Right em -> return em + Right em -> pure em Left _ -> throwStd (errorToWai @'InvalidEmail) let emailKey = mkEmailKey email wrapClientE (DB.lookupKey emailKey) >>= mapM_ (const $ throwStd emailExists) @@ -559,10 +559,10 @@ addService pid new = do let assets = newServiceAssets new let tags = fromRange (newServiceTags new) (pk, fp) <- validateServiceKey pubkey >>= maybeInvalidServiceKey - token <- maybe randServiceToken return (newServiceToken new) + token <- maybe randServiceToken pure (newServiceToken new) sid <- wrapClientE $ DB.insertService pid name summary descr baseUrl token pk fp assets tags let rstoken = maybe (Just token) (const Nothing) (newServiceToken new) - return $ Public.NewServiceResponse sid rstoken + pure $ Public.NewServiceResponse sid rstoken listServicesH :: ProviderId -> (Handler r) Response listServicesH pid = do @@ -736,8 +736,8 @@ deleteAccount :: Public.DeleteProvider -> ExceptT Error m () deleteAccount pid del = do - prov <- (DB.lookupAccount pid) >>= maybeInvalidProvider - pass <- (DB.lookupPassword pid) >>= maybeBadCredentials + prov <- DB.lookupAccount pid >>= maybeInvalidProvider + pass <- DB.lookupPassword pid >>= maybeBadCredentials unless (verifyPassword (deleteProviderPassword del) pass) $ throwStd (errorToWai @'BadCredentials) svcs <- DB.listServices pid @@ -828,7 +828,7 @@ getServiceTagListH () = do json <$> getServiceTagList () getServiceTagList :: () -> Monad m => m Public.ServiceTagList -getServiceTagList () = return (Public.ServiceTagList allTags) +getServiceTagList () = pure (Public.ServiceTagList allTags) where allTags = [(minBound :: Public.ServiceTag) ..] @@ -856,11 +856,11 @@ updateServiceWhitelist uid con tid upd = do -- Add to various tables whitelisted <- wrapClientE $ DB.getServiceWhitelistStatus tid pid sid case (whitelisted, newWhitelisted) of - (False, False) -> return UpdateServiceWhitelistRespUnchanged - (True, True) -> return UpdateServiceWhitelistRespUnchanged + (False, False) -> pure UpdateServiceWhitelistRespUnchanged + (True, True) -> pure UpdateServiceWhitelistRespUnchanged (False, True) -> do wrapClientE $ DB.insertServiceWhitelist tid pid sid - return UpdateServiceWhitelistRespChanged + pure UpdateServiceWhitelistRespChanged (True, False) -> do -- When the service is de-whitelisted, remove its bots from team -- conversations @@ -876,7 +876,7 @@ updateServiceWhitelist uid con tid upd = do ) ) wrapClientE $ DB.deleteServiceWhitelist (Just tid) pid sid - return UpdateServiceWhitelistRespChanged + pure UpdateServiceWhitelistRespChanged addBotH :: UserId ::: ConnId ::: ConvId ::: JsonRequest Public.AddBot -> (Handler r) Response addBotH (zuid ::: zcon ::: cid ::: req) = do @@ -947,7 +947,7 @@ addBot zuid zcon cid add = do -- Add the bot to the conversation ev <- lift $ RPC.addBotMember zuid zcon cid bid (clientId clt) pid sid - return $ + pure $ Public.AddBotResponse { Public.rsAddBotId = bid, Public.rsAddBotClient = bcl, @@ -973,9 +973,9 @@ removeBot zusr zcon cid bid = do let busr = botUserId bid let bot = List.find ((== busr) . qUnqualified . omQualifiedId) (cmOthers mems) case bot >>= omService of - Nothing -> return Nothing + Nothing -> pure Nothing Just _ -> do - lift $ Public.RemoveBotResponse <$$> (wrapHttpClient $ deleteBot zusr (Just zcon) bid cid) + lift $ Public.RemoveBotResponse <$$> wrapHttpClient (deleteBot zusr (Just zcon) bid cid) -------------------------------------------------------------------------------- -- Bot API @@ -988,7 +988,7 @@ botGetSelfH bot = do botGetSelf :: BotId -> (Handler r) Public.UserProfile botGetSelf bot = do p <- lift $ wrapClient $ User.lookupUser NoPendingInvitations (botUserId bot) - maybe (throwStd (errorToWai @'UserNotFound)) (return . (`Public.publicProfile` UserLegalHoldNoConsent)) p + maybe (throwStd (errorToWai @'UserNotFound)) (pure . (`Public.publicProfile` UserLegalHoldNoConsent)) p botGetClientH :: BotId -> (Handler r) Response botGetClientH bot = do @@ -1008,7 +1008,7 @@ botListPrekeys :: BotId -> (Handler r) [Public.PrekeyId] botListPrekeys bot = do clt <- lift $ listToMaybe <$> wrapClient (User.lookupClients (botUserId bot)) case clientId <$> clt of - Nothing -> return [] + Nothing -> pure [] Just ci -> lift (wrapClient $ User.lookupPrekeyIds (botUserId bot) ci) botUpdatePrekeysH :: BotId ::: JsonRequest Public.UpdateBotPrekeys -> (Handler r) Response @@ -1045,7 +1045,7 @@ botListUserProfilesH uids = do botListUserProfiles :: List UserId -> (Handler r) [Public.BotUserView] botListUserProfiles uids = do us <- lift . wrapClient $ User.lookupUsers NoPendingInvitations (fromList uids) - return (map mkBotUserView us) + pure (map mkBotUserView us) botGetUserClientsH :: UserId -> (Handler r) Response botGetUserClientsH uid = do @@ -1069,7 +1069,7 @@ botDeleteSelf bid cid = do bot <- lift . wrapClient $ User.lookupUser NoPendingInvitations (botUserId bid) _ <- maybeInvalidBot (userService =<< bot) _ <- lift $ wrapHttpClient $ deleteBot (botUserId bid) Nothing bid cid - return () + pure () -------------------------------------------------------------------------------- -- Utilities @@ -1129,28 +1129,28 @@ deleteBot zusr zcon bid cid = do -- TODO: Consider if we can actually delete the bot user entirely, -- i.e. not just marking the account as deleted. void $ runExceptT $ User.updateStatus buid Deleted - return ev + pure ev validateServiceKey :: MonadIO m => Public.ServiceKeyPEM -> m (Maybe (Public.ServiceKey, Fingerprint Rsa)) validateServiceKey pem = liftIO $ readPublicKey >>= \pk -> case SSL.toPublicKey =<< pk of - Nothing -> return Nothing + Nothing -> pure Nothing Just pk' -> do Just sha <- SSL.getDigestByName "SHA256" let size = SSL.rsaSize (pk' :: SSL.RSAPubKey) if size < minRsaKeySize - then return Nothing + then pure Nothing else do fpr <- Fingerprint <$> SSL.rsaFingerprint sha pk' let bits = fromIntegral size * 8 let key = Public.ServiceKey Public.RsaServiceKey bits pem - return $ Just (key, fpr) + pure $ Just (key, fpr) where readPublicKey = handleAny - (const $ return Nothing) + (const $ pure Nothing) (SSL.readPublicKey (LC8.unpack (toByteString pem)) <&> Just) mkBotUserView :: User -> Public.BotUserView @@ -1167,7 +1167,7 @@ setProviderCookie :: ZAuth.ProviderToken -> Response -> (Handler r) Response setProviderCookie t r = do s <- view settings let hdr = toByteString' (Cookie.renderSetCookie (cookie s)) - return (addHeader "Set-Cookie" hdr r) + pure (addHeader "Set-Cookie" hdr r) where cookie s = Cookie.def @@ -1180,34 +1180,34 @@ setProviderCookie t r = do } maybeInvalidProvider :: Monad m => Maybe a -> (ExceptT Error m) a -maybeInvalidProvider = maybe (throwStd invalidProvider) return +maybeInvalidProvider = maybe (throwStd invalidProvider) pure maybeInvalidCode :: Monad m => Maybe a -> (ExceptT Error m) a -maybeInvalidCode = maybe (throwStd (errorToWai @'InvalidCode)) return +maybeInvalidCode = maybe (throwStd (errorToWai @'InvalidCode)) pure maybeServiceNotFound :: Monad m => Maybe a -> (ExceptT Error m) a -maybeServiceNotFound = maybe (throwStd (notFound "Service not found")) return +maybeServiceNotFound = maybe (throwStd (notFound "Service not found")) pure maybeProviderNotFound :: Monad m => Maybe a -> (ExceptT Error m) a -maybeProviderNotFound = maybe (throwStd (notFound "Provider not found")) return +maybeProviderNotFound = maybe (throwStd (notFound "Provider not found")) pure maybeConvNotFound :: Monad m => Maybe a -> (ExceptT Error m) a -maybeConvNotFound = maybe (throwStd (notFound "Conversation not found")) return +maybeConvNotFound = maybe (throwStd (notFound "Conversation not found")) pure maybeBadCredentials :: Monad m => Maybe a -> (ExceptT Error m) a -maybeBadCredentials = maybe (throwStd (errorToWai @'BadCredentials)) return +maybeBadCredentials = maybe (throwStd (errorToWai @'BadCredentials)) pure maybeInvalidServiceKey :: Monad m => Maybe a -> (ExceptT Error m) a -maybeInvalidServiceKey = maybe (throwStd invalidServiceKey) return +maybeInvalidServiceKey = maybe (throwStd invalidServiceKey) pure maybeInvalidBot :: Monad m => Maybe a -> (ExceptT Error m) a -maybeInvalidBot = maybe (throwStd invalidBot) return +maybeInvalidBot = maybe (throwStd invalidBot) pure maybeInvalidUser :: Monad m => Maybe a -> (ExceptT Error m) a -maybeInvalidUser = maybe (throwStd (errorToWai @'InvalidUser)) return +maybeInvalidUser = maybe (throwStd (errorToWai @'InvalidUser)) pure rangeChecked :: (Within a n m, Monad monad) => a -> (ExceptT Error monad) (Range n m a) -rangeChecked = either (throwStd . invalidRange . fromString) return . checkedEither +rangeChecked = either (throwStd . invalidRange . fromString) pure . checkedEither invalidServiceKey :: Wai.Error invalidServiceKey = Wai.mkError status400 "invalid-service-key" "Invalid service key." diff --git a/services/brig/src/Brig/Provider/DB.hs b/services/brig/src/Brig/Provider/DB.hs index d2dc915989..bf14143ddf 100644 --- a/services/brig/src/Brig/Provider/DB.hs +++ b/services/brig/src/Brig/Provider/DB.hs @@ -52,7 +52,7 @@ insertAccount :: insertAccount name pass url descr = do pid <- randomId retry x5 $ write cql $ params LocalQuorum (pid, name, pass, url, descr) - return pid + pure pid where cql :: PrepQuery W (ProviderId, Name, Password, HttpsUrl, Text) () cql = "INSERT INTO provider (id, name, password, url, descr) VALUES (?, ?, ?, ?, ?)" @@ -204,7 +204,7 @@ insertService pid name summary descr url token key fprint assets tags = do params LocalQuorum (pid, sid, name, summary, descr, url, [token], [key], [fprint], assets, tagSet, False) - return sid + pure sid where cql :: PrepQuery @@ -516,7 +516,7 @@ updateServiceTags :: (Name, RangedServiceTags) -> BatchM () updateServiceTags pid sid (oldName, oldTags) (newName, newTags) - | eqTags && eqNames = return () + | eqTags && eqNames = pure () | eqNames = do let name = oldNameLower let added = diffTags newTags oldTags @@ -582,21 +582,21 @@ paginateServiceTags tags start size providerFilter = liftClient $ do p <- filterResults providerFilter start' <$> queryAll start' size' tags' r <- mapConcurrently resolveRow (result p) -- See Note [buggy pagination] - return $! ServiceProfilePage (hasMore p) (catMaybes r) + pure $! ServiceProfilePage (hasMore p) (catMaybes r) where start' = maybe "" Text.toLower start unpackTags :: QueryAnyTags 1 3 -> [QueryAllTags 1 3] unpackTags = Set.toList . fromRange . queryAnyTagsRange queryAll :: Text -> Int32 -> [QueryAllTags 1 3] -> Client (Page IndexRow) - queryAll _ _ [] = return emptyPage + queryAll _ _ [] = pure emptyPage queryAll s l [t] = do p <- queryTags s l t - return $! p {result = trim size (result p)} + pure $! p {result = trim size (result p)} queryAll s l ts = do ps <- mapConcurrently (queryTags s l) ts let rows = trim l (unfoldr nextRow (map result ps)) let more = any hasMore ps || length rows > fromIntegral size - return $! emptyPage {hasMore = more, result = trim size rows} + pure $! emptyPage {hasMore = more, result = trim size rows} nextRow :: [[IndexRow]] -> Maybe (IndexRow, [[IndexRow]]) nextRow rs = case mapMaybe uncons rs of [] -> Nothing @@ -670,7 +670,7 @@ paginateServiceNames mbPrefix size providerFilter = liftClient $ do in filterResults providerFilter prefix' <$> queryPrefixes prefix' size' r <- mapConcurrently resolveRow (result p) -- See Note [buggy pagination] - return $! ServiceProfilePage (hasMore p) (catMaybes r) + pure $! ServiceProfilePage (hasMore p) (catMaybes r) where queryAll len = do let cql :: PrepQuery R () IndexRow @@ -678,7 +678,7 @@ paginateServiceNames mbPrefix size providerFilter = liftClient $ do "SELECT name, provider, service \ \FROM service_prefix" p <- retry x1 $ paginate cql $ paramsP One () len - return $! p {result = trim size (result p)} + pure $! p {result = trim size (result p)} queryPrefixes prefix len = do let cql :: PrepQuery R (Text, Text) IndexRow cql = @@ -689,7 +689,7 @@ paginateServiceNames mbPrefix size providerFilter = liftClient $ do retry x1 $ paginate cql $ paramsP One (mkPrefixIndex (Name prefix), prefix) len - return $! p {result = trim size (result p)} + pure $! p {result = trim size (result p)} -- Pagination utilities filterResults :: Maybe ProviderId -> Text -> Page IndexRow -> Page IndexRow @@ -705,7 +705,7 @@ filterbyProvider pid p = do filterPrefix :: Text -> Page IndexRow -> Page IndexRow filterPrefix prefix p = do - let prefixed = filter (\(Name n, _, _) -> prefix `Text.isPrefixOf` (Text.toLower n)) (result p) + let prefixed = filter (\(Name n, _, _) -> prefix `Text.isPrefixOf` Text.toLower n) (result p) -- if they were all valid prefixes, there may be more in Cassandra allValid = length prefixed == length (result p) more = allValid && hasMore p @@ -795,7 +795,7 @@ paginateServiceWhitelist tid mbPrefix filterDisabled size = liftClient $ do . maybeFilterDisabled . catMaybes <$> mapConcurrently (uncurry lookupServiceProfile) p - return + pure $! ServiceProfilePage (length r > fromIntegral size) (trim size r) diff --git a/services/brig/src/Brig/Provider/RPC.hs b/services/brig/src/Brig/Provider/RPC.hs index 4c5ef88120..2a26239f39 100644 --- a/services/brig/src/Brig/Provider/RPC.hs +++ b/services/brig/src/Brig/Provider/RPC.hs @@ -88,7 +88,7 @@ createBot scon new = do -- here, not a @Response (Maybe ByteString)@. decodeBytes ctx bs = case eitherDecode' bs of Left e -> throwM $ ParseException ctx e - Right a -> return a + Right a -> pure a reqBuilder = extReq scon ["bots"] . method POST @@ -235,7 +235,7 @@ removeBotMember zusr zcon conv bot = do rs <- galleyRequest DELETE req if isJust (responseBody rs) && Bilge.statusCode rs == 200 then Just <$> decodeBody "galley" rs - else return Nothing + else pure Nothing where req = path "/i/bots" diff --git a/services/brig/src/Brig/Queue/Stomp.hs b/services/brig/src/Brig/Queue/Stomp.hs index 6ee788475e..63741dbba0 100644 --- a/services/brig/src/Brig/Queue/Stomp.hs +++ b/services/brig/src/Brig/Queue/Stomp.hs @@ -167,7 +167,7 @@ listen b q callback = msg (val "Exception when listening to a STOMP queue") ~~ field "queue" (show q) ~~ field "error" (show e) - return True + pure True -- Note [exception handling] -- ~~~ diff --git a/services/brig/src/Brig/Run.hs b/services/brig/src/Brig/Run.hs index 069af57954..a2b87e71a1 100644 --- a/services/brig/src/Brig/Run.hs +++ b/services/brig/src/Brig/Run.hs @@ -110,7 +110,7 @@ run o = do mkApp :: Opts -> IO (Wai.Application, Env) mkApp o = do e <- newEnv o - return (middleware e $ \reqId -> servantApp (e & requestId .~ reqId), e) + pure (middleware e $ \reqId -> servantApp (e & requestId .~ reqId), e) where rtree :: Tree (App (Handler BrigCanonicalEffects)) rtree = compile sitemap diff --git a/services/brig/src/Brig/SMTP.hs b/services/brig/src/Brig/SMTP.hs index f0b9eccad0..920752199b 100644 --- a/services/brig/src/Brig/SMTP.hs +++ b/services/brig/src/Brig/SMTP.hs @@ -73,14 +73,14 @@ initSMTP lg host port credentials connType = do SMTP.defaultSettingsSMTPSSL {SMTP.sslPort = p} ok <- case credentials of (Just (Username u, Password p)) -> SMTP.authenticate SMTP.LOGIN (unpack u) (unpack p) conn - _ -> return True - return (ok, conn) + _ -> pure True + pure (ok, conn) create = do (ok, conn) <- connect if ok then Logger.log lg Logger.Debug (msg $ val "Established connection to: " +++ host) else Logger.log lg Logger.Warn (msg $ val "Failed to established connection, check your credentials to connect to: " +++ host) - return conn + pure conn destroy c = do SMTP.closeSMTP c Logger.log lg Logger.Debug (msg $ val "Closing connection to: " +++ host) diff --git a/services/brig/src/Brig/Sem/CodeStore/Cassandra.hs b/services/brig/src/Brig/Sem/CodeStore/Cassandra.hs index 0aff544c97..7ebc58d057 100644 --- a/services/brig/src/Brig/Sem/CodeStore/Cassandra.hs +++ b/services/brig/src/Brig/Sem/CodeStore/Cassandra.hs @@ -85,8 +85,8 @@ genPhoneCode = mkPwdResetKey :: MonadIO m => UserId -> m PasswordResetKey mkPwdResetKey u = do - d <- liftIO $ getDigestByName "SHA256" >>= maybe (error "SHA256 not found") return - return . PasswordResetKey . encodeBase64Url . digestBS d $ toByteString' u + d <- liftIO $ getDigestByName "SHA256" >>= maybe (error "SHA256 not found") pure + pure . PasswordResetKey . encodeBase64Url . digestBS d $ toByteString' u interpretClientToIO :: Member (Final IO) r => diff --git a/services/brig/src/Brig/Sem/PasswordResetStore/CodeStore.hs b/services/brig/src/Brig/Sem/PasswordResetStore/CodeStore.hs index b16e51b619..c509f3c3a5 100644 --- a/services/brig/src/Brig/Sem/PasswordResetStore/CodeStore.hs +++ b/services/brig/src/Brig/Sem/PasswordResetStore/CodeStore.hs @@ -59,7 +59,7 @@ create u target = do key (PRQueryData code u (Identity maxAttempts) (Identity (ttl `addUTCTime` now))) (round ttl) - return (key, code) + pure (key, code) lookup :: Members '[CodeStore, Now] r => @@ -70,8 +70,8 @@ lookup u = do now <- Now.get validate now =<< codeSelect key where - validate now (Just (PRQueryData c _ _ (Just t))) | t > now = return $ Just c - validate _ _ = return Nothing + validate now (Just (PRQueryData c _ _ (Just t))) | t > now = pure $ Just c + validate _ _ = pure Nothing verify :: Members '[CodeStore, Now] r => @@ -81,9 +81,9 @@ verify (k, c) = do now <- Now.get code <- codeSelect k case code of - Just (PRQueryData c' u _ (Just t)) | c == c' && t >= now -> return (Just u) + 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) - return Nothing + pure Nothing Just PRQueryData {} -> codeDelete k $> Nothing - Nothing -> return Nothing + Nothing -> pure Nothing diff --git a/services/brig/src/Brig/Team/API.hs b/services/brig/src/Brig/Team/API.hs index 025a926f04..25b63a9e4f 100644 --- a/services/brig/src/Brig/Team/API.hs +++ b/services/brig/src/Brig/Team/API.hs @@ -229,7 +229,7 @@ getInvitationCodeH (_ ::: t ::: r) = do getInvitationCode :: TeamId -> InvitationId -> (Handler r) FoundInvitationCode getInvitationCode t r = do code <- lift . wrapClient $ DB.lookupInvitationCode t r - maybe (throwStd $ errorToWai @'E.InvalidInvitationCode) (return . FoundInvitationCode) code + maybe (throwStd $ errorToWai @'E.InvalidInvitationCode) (pure . FoundInvitationCode) code newtype FoundInvitationCode = FoundInvitationCode InvitationCode deriving (Eq, Show, Generic) @@ -258,8 +258,8 @@ createInvitationPublic uid tid body = do let inviteeRole = fromMaybe Team.defaultRole . irRole $ body inviter <- do let inviteePerms = Team.rolePermissions inviteeRole - idt <- maybe (throwStd (errorToWai @'E.NoIdentity)) return =<< lift (fetchUserIdentity uid) - from <- maybe (throwStd noEmail) return (emailIdentity idt) + idt <- maybe (throwStd (errorToWai @'E.NoIdentity)) pure =<< lift (fetchUserIdentity uid) + from <- maybe (throwStd noEmail) pure (emailIdentity idt) ensurePermissionToAddUser uid tid inviteePerms pure $ CreateInvitationInviter uid from @@ -322,7 +322,7 @@ createInvitation' tid inviteeRole mbInviterUid fromEmail body = do -- sendActivationCode. Refactor this to a single place -- Validate e-mail - inviteeEmail <- either (const $ throwStd (errorToWai @'E.InvalidEmail)) return (Email.validateEmail (irInviteeEmail body)) + inviteeEmail <- either (const $ throwStd (errorToWai @'E.InvalidEmail)) pure (Email.validateEmail (irInviteeEmail body)) let uke = userEmailKey inviteeEmail blacklistedEm <- lift $ wrapClient $ Blacklist.exists uke when blacklistedEm $ @@ -333,7 +333,7 @@ createInvitation' tid inviteeRole mbInviterUid fromEmail body = do -- Validate phone inviteePhone <- for (irInviteePhone body) $ \p -> do - validatedPhone <- maybe (throwStd (errorToWai @'E.InvalidPhone)) return =<< lift (wrapClient $ Phone.validatePhone p) + validatedPhone <- maybe (throwStd (errorToWai @'E.InvalidPhone)) pure =<< lift (wrapClient $ Phone.validatePhone p) let ukp = userPhoneKey validatedPhone blacklistedPh <- lift $ wrapClient $ Blacklist.exists ukp when blacklistedPh $ @@ -341,7 +341,7 @@ createInvitation' tid inviteeRole mbInviterUid fromEmail body = do phoneTaken <- lift $ isJust <$> wrapClient (Data.lookupKey ukp) when phoneTaken $ throwStd phoneExists - return validatedPhone + pure validatedPhone maxSize <- setMaxTeamSize <$> view settings pending <- lift $ wrapClient $ DB.countInvitations tid when (fromIntegral pending >= maxSize) $ @@ -385,12 +385,12 @@ listInvitations :: UserId -> TeamId -> Maybe InvitationId -> Range 1 500 Int32 - listInvitations uid tid start size = do ensurePermissions uid tid [Team.AddTeamMember] rs <- lift $ wrapClient $ DB.lookupInvitations tid start size - return $! Public.InvitationList (DB.resultList rs) (DB.resultHasMore rs) + pure $! Public.InvitationList (DB.resultList rs) (DB.resultHasMore rs) getInvitationH :: JSON ::: UserId ::: TeamId ::: InvitationId -> (Handler r) Response getInvitationH (_ ::: uid ::: tid ::: iid) = do inv <- getInvitation uid tid iid - return $ case inv of + pure $ case inv of Just i -> json i Nothing -> setStatus status404 empty @@ -406,12 +406,12 @@ getInvitationByCodeH (_ ::: c) = do getInvitationByCode :: Public.InvitationCode -> (Handler r) Public.Invitation getInvitationByCode c = do inv <- lift . wrapClient $ DB.lookupInvitationByCode c - maybe (throwStd $ errorToWai @'E.InvalidInvitationCode) return inv + maybe (throwStd $ errorToWai @'E.InvalidInvitationCode) pure inv headInvitationByEmailH :: JSON ::: Email -> (Handler r) Response headInvitationByEmailH (_ ::: e) = do inv <- lift $ wrapClient $ DB.lookupInvitationInfoByEmail e - return $ case inv of + pure $ case inv of DB.InvitationByEmail _ -> setStatus status200 empty DB.InvitationByEmailNotFound -> setStatus status404 empty DB.InvitationByEmailMoreThanOne -> setStatus status409 empty @@ -426,7 +426,7 @@ getInvitationByEmailH (_ ::: email) = getInvitationByEmail :: Email -> (Handler r) Public.Invitation getInvitationByEmail email = do inv <- lift $ wrapClient $ DB.lookupInvitationByEmail email - maybe (throwStd (notFound "Invitation not found")) return inv + maybe (throwStd (notFound "Invitation not found")) pure inv suspendTeamH :: JSON ::: TeamId -> (Handler r) Response suspendTeamH (_ ::: tid) = do @@ -458,5 +458,5 @@ changeTeamAccountStatuses tid s = do uids <- toList1 =<< lift (fmap (view Team.userId) . view Team.teamMembers <$> wrapHttp (Intra.getTeamMembers tid)) wrapHttpClientE (API.changeAccountStatus uids s) !>> accountStatusError where - toList1 (x : xs) = return $ List1.list1 x xs + toList1 (x : xs) = pure $ List1.list1 x xs toList1 [] = throwStd (notFound "Team not found or no members") diff --git a/services/brig/src/Brig/Team/DB.hs b/services/brig/src/Brig/Team/DB.hs index 920abedd76..6a28ec19b8 100644 --- a/services/brig/src/Brig/Team/DB.hs +++ b/services/brig/src/Brig/Team/DB.hs @@ -99,7 +99,7 @@ insertInvitation iid t role (toUTCTimeMillis -> now) minviter email inviteeName addPrepQuery cqlInvitation (t, role, iid, code, email, now, minviter, inviteeName, phone, round timeout) addPrepQuery cqlInvitationInfo (code, t, iid, round timeout) addPrepQuery cqlInvitationByEmail (email, t, iid, code, round timeout) - return (inv, code) + pure (inv, code) where cqlInvitationInfo :: PrepQuery W (InvitationCode, TeamId, InvitationId, Int32) () cqlInvitationInfo = "INSERT INTO team_invitation_info (code, team, id) VALUES (?, ?, ?) USING TTL ?" @@ -121,7 +121,7 @@ lookupInvitationByCode :: MonadClient m => InvitationCode -> m (Maybe Invitation lookupInvitationByCode i = lookupInvitationInfo i >>= \case Just InvitationInfo {..} -> lookupInvitation iiTeam iiInvId - _ -> return Nothing + _ -> pure Nothing lookupInvitationCode :: MonadClient m => TeamId -> InvitationId -> m (Maybe InvitationCode) lookupInvitationCode t r = @@ -142,7 +142,7 @@ lookupInvitations team start (fromRange -> size) = do page <- case start of Just ref -> retry x1 $ paginate cqlSelectFrom (paramsP LocalQuorum (team, ref) (size + 1)) Nothing -> retry x1 $ paginate cqlSelect (paramsP LocalQuorum (Identity team) (size + 1)) - return $ toResult (hasMore page) $ map toInvitation (trim page) + pure $ toResult (hasMore page) $ map toInvitation (trim page) where trim p = take (fromIntegral size) (result p) toResult more invs = @@ -188,7 +188,7 @@ deleteInvitations t = lookupInvitationInfo :: MonadClient m => InvitationCode -> m (Maybe InvitationInfo) lookupInvitationInfo ic@(InvitationCode c) - | c == mempty = return Nothing + | c == mempty = pure Nothing | otherwise = fmap (toInvitationInfo ic) <$> retry x1 (query1 cqlInvitationInfo (params LocalQuorum (Identity ic))) @@ -201,29 +201,29 @@ lookupInvitationByEmail :: (Log.MonadLogger m, MonadClient m) => Email -> m (May lookupInvitationByEmail e = lookupInvitationInfoByEmail e >>= \case InvitationByEmail InvitationInfo {..} -> lookupInvitation iiTeam iiInvId - _ -> return Nothing + _ -> pure Nothing lookupInvitationInfoByEmail :: (Log.MonadLogger m, MonadClient m) => Email -> m InvitationByEmail lookupInvitationInfoByEmail email = do res <- retry x1 (query cqlInvitationEmail (params LocalQuorum (Identity email))) case res of - [] -> return InvitationByEmailNotFound - (tid, invId, code) : [] -> + [] -> pure InvitationByEmailNotFound + [(tid, invId, code)] -> -- one invite pending - return $ InvitationByEmail (InvitationInfo code tid invId) + pure $ InvitationByEmail (InvitationInfo code tid invId) _ : _ : _ -> do -- edge case: more than one pending invite from different teams Log.info $ Log.msg (Log.val "team_invidation_email: multiple pending invites from different teams for the same email") Log.~~ Log.field "email" (show email) - return InvitationByEmailMoreThanOne + pure InvitationByEmailMoreThanOne where 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 t = - fromMaybe 0 . fmap runIdentity + maybe 0 runIdentity <$> retry x1 (query1 cqlSelect (params LocalQuorum (Identity t))) where cqlSelect :: PrepQuery R (Identity TeamId) (Identity Int64) diff --git a/services/brig/src/Brig/Unique.hs b/services/brig/src/Brig/Unique.hs index c30884ca10..88e325e8c4 100644 --- a/services/brig/src/Brig/Unique.hs +++ b/services/brig/src/Brig/Unique.hs @@ -61,7 +61,7 @@ withClaim u v t io = do case claims of [] -> claim -- Free [u'] | u == u' -> claim -- Claimed by 'u' (retries are allowed). - _ -> return Nothing -- Conflicting claims, TTL must expire. + _ -> pure Nothing -- Conflicting claims, TTL must expire. where -- [Note: Guarantees] claim = do @@ -70,7 +70,7 @@ withClaim u v t io = do claimed <- (== [u]) <$> lookupClaims v if claimed then liftIO $ timeout (fromIntegral ttl # Second) io - else return Nothing + else pure Nothing cql :: PrepQuery W (Int32, C.Set (Id a), Text) () cql = "UPDATE unique_claims USING TTL ? SET claims = claims + ? WHERE value = ?" diff --git a/services/brig/src/Brig/User/API/Auth.hs b/services/brig/src/Brig/User/API/Auth.hs index 757aba32a8..daa60d91f2 100644 --- a/services/brig/src/Brig/User/API/Auth.hs +++ b/services/brig/src/Brig/User/API/Auth.hs @@ -219,7 +219,7 @@ sendLoginCode :: Public.SendLoginCode -> (Handler r) Public.LoginCodeTimeout sendLoginCode (Public.SendLoginCode phone call force) = do checkWhitelist (Right phone) c <- wrapClientE (Auth.sendLoginCode phone call force) !>> sendLoginCodeError - return $ Public.LoginCodeTimeout (pendingLoginTimeout c) + pure $ Public.LoginCodeTimeout (pendingLoginTimeout c) getLoginCodeH :: JSON ::: Phone -> (Handler r) Response getLoginCodeH (_ ::: phone) = json <$> getLoginCode phone @@ -227,12 +227,12 @@ getLoginCodeH (_ ::: phone) = json <$> getLoginCode phone getLoginCode :: Phone -> (Handler r) Public.PendingLoginCode getLoginCode phone = do code <- lift $ wrapClient $ Auth.lookupLoginCode phone - maybe (throwStd loginCodeNotFound) return code + maybe (throwStd loginCodeNotFound) pure code reAuthUserH :: UserId ::: JsonRequest ReAuthUser -> (Handler r) Response reAuthUserH (uid ::: req) = do reAuthUser uid =<< parseJsonBody req - return empty + pure empty reAuthUser :: UserId -> ReAuthUser -> (Handler r) () reAuthUser uid body = do @@ -401,7 +401,7 @@ tokenRequest = opt (userToken ||| legalHoldUserToken) .&. opt (accessToken ||| l bearer (Okay _ b) = let (prefix, suffix) = BS.splitAt 7 b in if prefix == "Bearer " - then return suffix + then pure suffix else Fail ( setReason @@ -419,7 +419,7 @@ tokenRequest = opt (userToken ||| legalHoldUserToken) .&. opt (accessToken ||| l TypeError (setMessage "Invalid access token" (err status403)) ) - Just t -> return t + Just t -> pure t tokenResponse :: ZAuth.UserTokenLike u => Auth.Access u -> (AppT r) Response tokenResponse (Auth.Access t Nothing) = pure $ json t @@ -438,7 +438,7 @@ cookies k r = cc -> case mapMaybe fromByteString cc of [] -> Fail . addLabel "cookie" . typeError k $ "Failed to get zuid cookies" - (x : xs) -> return $ List1.list1 x xs + (x : xs) -> pure $ List1.list1 x xs notAvailable :: ByteString -> P.Error notAvailable k = e400 & setReason NotAvailable . setSource k diff --git a/services/brig/src/Brig/User/API/Handle.hs b/services/brig/src/Brig/User/API/Handle.hs index 3f40f8767c..db71c04406 100644 --- a/services/brig/src/Brig/User/API/Handle.hs +++ b/services/brig/src/Brig/User/API/Handle.hs @@ -63,12 +63,12 @@ getLocalHandleInfo self handle = do lift . Log.info $ Log.msg $ Log.val "getHandleInfo - local lookup" maybeOwnerId <- lift . wrapClient $ API.lookupHandle handle case maybeOwnerId of - Nothing -> return Nothing + Nothing -> pure Nothing Just ownerId -> do domain <- viewFederationDomain ownerProfile <- wrapHttpClientE (API.lookupProfile self (Qualified ownerId domain)) !>> fedError owner <- filterHandleResults self (maybeToList ownerProfile) - return $ listToMaybe owner + pure $ listToMaybe owner -- | Checks search permissions and filters accordingly filterHandleResults :: Local UserId -> [Public.UserProfile] -> (Handler r) [Public.UserProfile] @@ -77,10 +77,10 @@ filterHandleResults searchingUser us = do if sameTeamSearchOnly then do fromTeam <- lift . wrapClient $ Data.lookupUserTeam (tUnqualified searchingUser) - return $ case fromTeam of + pure $ case fromTeam of Just team -> filter (\x -> Public.profileTeam x == Just team) us Nothing -> us - else return us + else pure us contactFromProfile :: Public.UserProfile -> Public.Contact contactFromProfile profile = diff --git a/services/brig/src/Brig/User/API/Search.hs b/services/brig/src/Brig/User/API/Search.hs index 41dbeb51b1..50ab3490aa 100644 --- a/services/brig/src/Brig/User/API/Search.hs +++ b/services/brig/src/Brig/User/API/Search.hs @@ -180,11 +180,11 @@ searchLocally searcherId searchTerm maybeMaxResults = do mkTeamSearchInfo searcherTeamId = lift $ do sameTeamSearchOnly <- fromMaybe False <$> view (settings . Opts.searchSameTeamOnly) case searcherTeamId of - Nothing -> return Search.NoTeam + Nothing -> pure Search.NoTeam Just t -> -- This flag in brig overrules any flag on galley - it is system wide if sameTeamSearchOnly - then return (Search.TeamOnly t) + then pure (Search.TeamOnly t) else do -- For team users, we need to check the visibility flag handleTeamVisibility t <$> wrapHttp (Intra.getTeamSearchVisibility t) diff --git a/services/brig/src/Brig/User/Auth.hs b/services/brig/src/Brig/User/Auth.hs index 65f81bdc64..3088a6eb61 100644 --- a/services/brig/src/Brig/User/Auth.hs +++ b/services/brig/src/Brig/User/Auth.hs @@ -100,7 +100,7 @@ sendLoginCode phone call force = do pk <- maybe (throwE $ SendLoginInvalidPhone phone) - (return . userPhoneKey) + (pure . userPhoneKey) =<< lift (validatePhone phone) user <- lift $ Data.lookupKey pk case user of @@ -117,7 +117,7 @@ sendLoginCode phone call force = do if call then sendLoginCall ph (pendingLoginCode c) l else sendLoginSms ph (pendingLoginCode c) l - return c + pure c lookupLoginCode :: ( MonadClient m, @@ -128,7 +128,7 @@ lookupLoginCode :: m (Maybe PendingLoginCode) lookupLoginCode phone = Data.lookupKey (userPhoneKey phone) >>= \case - Nothing -> return Nothing + Nothing -> pure Nothing Just u -> do Log.debug $ field "user" (toByteString u) . field "action" (Log.val "User.lookupLoginCode") Data.lookupLoginCode u @@ -196,7 +196,7 @@ verifyCode mbCode action uid = do (mbEmail, mbTeamId) <- getEmailAndTeamId uid featureEnabled <- lift $ do mbFeatureEnabled <- Intra.getVerificationCodeEnabled `traverse` mbTeamId - pure $ fromMaybe (Public.tfwoapsStatus Public.defaultTeamFeatureSndFactorPasswordChallengeStatus == Public.TeamFeatureEnabled) mbFeatureEnabled + pure $ fromMaybe (Public.tfwoapsStatus (Public.defTeamFeatureStatus @'Public.TeamFeatureSndFactorPasswordChallenge) == Public.TeamFeatureEnabled) mbFeatureEnabled when featureEnabled $ do case (mbCode, mbEmail) of (Just code, Just email) -> do @@ -277,10 +277,10 @@ renewAccess uts at = do catchSuspendInactiveUser uid ZAuth.Expired ck' <- lift $ nextCookie ck at' <- lift $ newAccessToken (fromMaybe ck ck') at - return $ Access at' ck' + pure $ Access at' ck' revokeAccess :: - (MonadClient m, Log.MonadLogger m) => + (MonadClient m, Log.MonadLogger m, MonadReader Env m) => UserId -> PlainTextPassword -> [CookieId] -> @@ -288,7 +288,7 @@ revokeAccess :: ExceptT AuthError m () revokeAccess u pw cc ll = do lift $ Log.debug $ field "user" (toByteString u) . field "action" (Log.val "User.revokeAccess") - Data.authenticate u pw + unlessM (Data.isSamlUser u) $ Data.authenticate u pw lift $ revokeCookies u cc ll -------------------------------------------------------------------------------- @@ -348,7 +348,7 @@ newAccess uid ct cl = do Left delay -> throwE $ LoginThrottled delay Right ck -> do t <- lift $ newAccessToken @u @a ck Nothing - return $ Access t (Just ck) + pure $ Access t (Just ck) resolveLoginId :: (MonadClient m, MonadReader Env m) => LoginId -> ExceptT LoginError m UserId resolveLoginId li = do @@ -360,32 +360,32 @@ resolveLoginId li = do if pending then LoginPendingActivation else LoginFailed - Just uid -> return uid + Just uid -> pure uid validateLoginId :: (MonadClient m, MonadReader Env m) => LoginId -> ExceptT LoginError m (Either UserKey Handle) validateLoginId (LoginByEmail email) = either (const $ throwE LoginFailed) - (return . Left . userEmailKey) + (pure . Left . userEmailKey) (validateEmail email) validateLoginId (LoginByPhone phone) = maybe (throwE LoginFailed) - (return . Left . userPhoneKey) + (pure . Left . userPhoneKey) =<< lift (validatePhone phone) validateLoginId (LoginByHandle h) = - return (Right h) + pure (Right h) isPendingActivation :: (MonadClient m, MonadReader Env m) => LoginId -> m Bool isPendingActivation ident = case ident of - (LoginByHandle _) -> return False + (LoginByHandle _) -> pure False (LoginByEmail e) -> checkKey (userEmailKey e) (LoginByPhone p) -> checkKey (userPhoneKey p) where checkKey k = do usr <- (>>= fst) <$> Data.lookupActivationCode k case usr of - Nothing -> return False + Nothing -> pure False Just u -> maybe False (checkAccount k) <$> Data.lookupAccount u checkAccount k a = let i = userIdentity (accountUser a) @@ -421,7 +421,7 @@ validateTokens uts at = do 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 - (_, suc : _) -> return suc + (_, suc : _) -> pure suc (e : _, _) -> throwE e _ -> throwE ZAuth.Invalid -- Impossible @@ -442,8 +442,8 @@ validateToken ut at = do ExceptT (ZAuth.validateToken token) `catchE` \e -> unless (e == ZAuth.Expired) (throwE e) - ck <- lift (lookupCookie ut) >>= maybe (throwE ZAuth.Invalid) return - return (ZAuth.userTokenOf ut, ck) + ck <- lift (lookupCookie ut) >>= maybe (throwE ZAuth.Invalid) pure + pure (ZAuth.userTokenOf ut, ck) -- | Allow to login as any user without having the credentials. ssoLogin :: diff --git a/services/brig/src/Brig/User/Auth/Cookie.hs b/services/brig/src/Brig/User/Auth/Cookie.hs index 222a78422e..461f136a3c 100644 --- a/services/brig/src/Brig/User/Auth/Cookie.hs +++ b/services/brig/src/Brig/User/Auth/Cookie.hs @@ -95,7 +95,7 @@ newCookie uid typ label = do cookieValue = tok } DB.insertCookie uid c Nothing - return c + pure c -- | Renew the given cookie with a fresh token, if its age -- exceeds the configured minimum threshold. @@ -119,7 +119,7 @@ nextCookie c = do -- a different zauth key index, regardless of age. if persist c && diffUTCTime now created > renewAge then Just <$> getNext - else return Nothing + else pure Nothing where persist = (PersistentCookie ==) . cookieType getNext = case cookieSucc c of @@ -132,7 +132,7 @@ nextCookie c = do Nothing -> renewCookie c Just c' -> do t <- ZAuth.mkUserToken uid (cookieIdNum ck) (cookieExpires c') - return c' {cookieValue = t} + pure c' {cookieValue = t} -- | Renew the given cookie with a fresh token. renewCookie :: @@ -154,7 +154,7 @@ renewCookie old = do let old' = old {cookieSucc = Just (cookieId new)} ttl <- setUserCookieRenewAge <$> view settings DB.insertCookie uid old' (Just (DB.TTL (fromIntegral ttl))) - return new + pure new -- | Whether a user has not renewed any of her cookies for longer than -- 'suspendCookiesOlderThanSecs'. Call this always before 'newCookie', 'nextCookie', @@ -189,7 +189,7 @@ newAccessToken c mt = do Just t -> ZAuth.renewAccessToken t zSettings <- view (zauthEnv . ZAuth.settings) let ttl = view (ZAuth.settingsTTL (Proxy @a)) zSettings - return $ + pure $ bearerToken (ZAuth.accessTokenOf t') (toByteString t') @@ -248,7 +248,7 @@ newCookieLimited u typ label = do if null evict then Right <$> newCookie u typ label else case throttleCookies now thr cs of - Just wait -> return (Left wait) + Just wait -> pure (Left wait) Nothing -> do revokeCookies u evict [] Right <$> newCookie u typ label @@ -263,7 +263,7 @@ setResponseCookie :: m Response setResponseCookie c r = do hdr <- toByteString' . WebCookie.renderSetCookie <$> toWebCookie c - return (addHeader "Set-Cookie" hdr r) + pure (addHeader "Set-Cookie" hdr r) toWebCookie :: (Monad m, MonadReader Env m, ZAuth.UserTokenLike u) => Cookie (ZAuth.Token u) -> m WebCookie.SetCookie toWebCookie c = do diff --git a/services/brig/src/Brig/User/Auth/DB/Instances.hs b/services/brig/src/Brig/User/Auth/DB/Instances.hs index 9e4e60436b..a724bf1bcf 100644 --- a/services/brig/src/Brig/User/Auth/DB/Instances.hs +++ b/services/brig/src/Brig/User/Auth/DB/Instances.hs @@ -39,7 +39,7 @@ instance Cql CookieId where ctype = Tagged BigIntColumn toCql = CqlBigInt . fromIntegral . cookieIdNum - fromCql (CqlBigInt i) = return (CookieId (fromIntegral i)) + fromCql (CqlBigInt i) = pure (CookieId (fromIntegral i)) fromCql _ = Left "fromCql: invalid cookie id" instance Cql CookieType where @@ -48,6 +48,6 @@ instance Cql CookieType where toCql SessionCookie = CqlInt 0 toCql PersistentCookie = CqlInt 1 - fromCql (CqlInt 0) = return SessionCookie - fromCql (CqlInt 1) = return PersistentCookie + fromCql (CqlInt 0) = pure SessionCookie + fromCql (CqlInt 1) = pure PersistentCookie fromCql _ = Left "fromCql: invalid cookie type" diff --git a/services/brig/src/Brig/User/Handle.hs b/services/brig/src/Brig/User/Handle.hs index 1cee4911a8..245679ae51 100644 --- a/services/brig/src/Brig/User/Handle.hs +++ b/services/brig/src/Brig/User/Handle.hs @@ -39,7 +39,7 @@ claimHandle uid oldHandle newHandle = isJust <$> do owner <- lookupHandle newHandle case owner of - Just uid' | uid /= uid' -> return Nothing + Just uid' | uid /= uid' -> pure Nothing _ -> do env <- ask let key = "@" <> fromHandle newHandle @@ -53,7 +53,7 @@ claimHandle uid oldHandle newHandle = -- Free old handle (if it changed) for_ (mfilter (/= newHandle) oldHandle) $ wrapClient . freeHandle uid - return result + pure result -- | Free a 'Handle', making it available to be claimed again. freeHandle :: MonadClient m => UserId -> Handle -> m () diff --git a/services/brig/src/Brig/User/Search/Index.hs b/services/brig/src/Brig/User/Search/Index.hs index bee7ad759f..1211c5ff8d 100644 --- a/services/brig/src/Brig/User/Search/Index.hs +++ b/services/brig/src/Brig/User/Search/Index.hs @@ -384,7 +384,7 @@ resetIndex ciSettings = liftIndexIO $ do gone <- ES.indexExists idx >>= \case True -> ES.isSuccess <$> traceES "Delete Index" (ES.deleteIndex idx) - False -> return True + False -> pure True if gone then createIndex ciSettings else throwM (IndexError "Index deletion failed.") @@ -432,7 +432,7 @@ traceES descr act = liftIndexIO $ do info (msg descr) r <- act info . msg $ (r & statusCode . responseStatus) +++ val " - " +++ responseBody r - return r + pure r -- | This mapping defines how elasticsearch will treat each field in a document. Here -- is how it treats each field: @@ -865,18 +865,16 @@ reindexRowToIndexUser version :: [Maybe (Writetime Name)] -> m IndexVersion version = mkIndexVersion . getMax . mconcat . fmap Max . catMaybes shouldIndex = - and - [ case status of - Nothing -> True - Just Active -> True - Just Suspended -> True - Just Deleted -> False - Just Ephemeral -> False - Just PendingInvitation -> False, - activated, -- FUTUREWORK: how is this adding to the first case? - isNothing service - ] - + ( case status of + Nothing -> True + Just Active -> True + Just Suspended -> True + Just Deleted -> False + Just Ephemeral -> False + Just PendingInvitation -> False + ) + && activated -- FUTUREWORK: how is this adding to the first case? + && isNothing service idpUrl :: UserSSOId -> Maybe Text idpUrl (UserSSOId (SAML.UserRef (SAML.Issuer uri) _subject)) = Just $ fromUri uri @@ -928,7 +926,7 @@ getTeamSearchVisibilityInboundMulti tids = do res <- try $ RPC.httpLbs rq id case res of Left x -> throwM $ RPCException nm rq x - Right x -> return x + Right x -> pure x where mkEndpoint service = RPC.host (encodeUtf8 (service ^. epHost)) . RPC.port (service ^. epPort) $ RPC.empty diff --git a/services/brig/src/Brig/User/Search/SearchIndex.hs b/services/brig/src/Brig/User/Search/SearchIndex.hs index f25ce87680..8f18d0d659 100644 --- a/services/brig/src/Brig/User/Search/SearchIndex.hs +++ b/services/brig/src/Brig/User/Search/SearchIndex.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StrictData #-} diff --git a/services/brig/src/Brig/User/Search/TeamSize.hs b/services/brig/src/Brig/User/Search/TeamSize.hs index b26d7286f0..2949c8e2fc 100644 --- a/services/brig/src/Brig/User/Search/TeamSize.hs +++ b/services/brig/src/Brig/User/Search/TeamSize.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE StrictData #-} -- This file is part of the Wire Server implementation. diff --git a/services/brig/src/Brig/Whitelist.hs b/services/brig/src/Brig/Whitelist.hs index 1e2beeb4da..5dc27a352b 100644 --- a/services/brig/src/Brig/Whitelist.hs +++ b/services/brig/src/Brig/Whitelist.hs @@ -55,13 +55,13 @@ instance FromJSON Whitelist verify :: (MonadIO m, MonadMask m, MonadHttp m) => Whitelist -> Either Email Phone -> m Bool verify (Whitelist url user pass) key = if isKnownDomain key - then return True + then pure True else recovering x3 httpHandlers . const $ do rq <- parseRequest $ unpack url rsp <- get' rq $ req (encodeUtf8 user) (encodeUtf8 pass) case statusCode rsp of - 200 -> return True - 404 -> return False + 200 -> pure True + 404 -> pure False _ -> throwM $ HttpExceptionRequest rq (StatusCodeException (rsp {responseBody = ()}) mempty) diff --git a/services/brig/src/Brig/ZAuth.hs b/services/brig/src/Brig/ZAuth.hs index a7ba3d520f..e5579aa1cd 100644 --- a/services/brig/src/Brig/ZAuth.hs +++ b/services/brig/src/Brig/ZAuth.hs @@ -237,7 +237,7 @@ mkEnv :: NonEmpty SecretKey -> NonEmpty PublicKey -> Settings -> IO Env mkEnv sk pk sets = do zc <- ZC.mkEnv (NonEmpty.head sk) (NonEmpty.tail sk) let zv = ZV.mkEnv (NonEmpty.head pk) (NonEmpty.tail pk) - return $! Env zc zv sets + pure $! Env zc zv sets class (UserTokenLike u, AccessTokenLike a) => TokenPair u a where newAccessToken :: MonadZAuth m => Token u -> m (Token a) diff --git a/services/brig/test/integration/API/Calling.hs b/services/brig/test/integration/API/Calling.hs index d6df765201..bc09a07712 100644 --- a/services/brig/test/integration/API/Calling.hs +++ b/services/brig/test/integration/API/Calling.hs @@ -46,7 +46,7 @@ import Wire.API.Call.Config tests :: Manager -> Brig -> Opts.Opts -> FilePath -> FilePath -> IO TestTree tests m b opts turn turnV2 = do - return $ + pure $ testGroup "calling" $ [ testGroup "turn" $ [ test m "basic /calls/config - 200" $ testCallsConfig b, @@ -253,7 +253,7 @@ toTurnURILegacy :: ByteString -> Port -> TurnURI toTurnURILegacy h p = toTurnURI SchemeTurn h p Nothing toTurnURI :: Scheme -> ByteString -> Port -> Maybe Transport -> TurnURI -toTurnURI s h p t = turnURI s ip p t +toTurnURI s h = turnURI s ip where ip = fromMaybe (error "Failed to parse host address") $ diff --git a/services/brig/test/integration/API/Federation.hs b/services/brig/test/integration/API/Federation.hs index f099586e80..74612a2919 100644 --- a/services/brig/test/integration/API/Federation.hs +++ b/services/brig/test/integration/API/Federation.hs @@ -61,7 +61,7 @@ import Wire.API.UserMap (UserMap (UserMap)) -- Note: POST /federation/send-connection-action is implicitly tested in API.User.Connection tests :: Manager -> Opt.Opts -> Brig -> Cannon -> FedClient 'Brig -> IO TestTree tests m opts brig cannon fedBrigClient = - return $ + pure $ testGroup "federation" [ test m "POST /federation/search-users : Found" (testSearchSuccess opts brig), diff --git a/services/brig/test/integration/API/Internal.hs b/services/brig/test/integration/API/Internal.hs index cf1e1e7612..6d4ab3f1a7 100644 --- a/services/brig/test/integration/API/Internal.hs +++ b/services/brig/test/integration/API/Internal.hs @@ -21,39 +21,55 @@ module API.Internal where import API.Internal.Util +import API.MLS (createClient) +import API.MLS.Util (SetKey (SetKey), uploadKeyPackages) import Bilge import Bilge.Assert import Brig.Data.User (lookupFeatureConferenceCalling, lookupStatus, userExists) import qualified Brig.Options as Opt import Brig.Types.Intra -import Brig.Types.User (userId) +import Brig.Types.User (User (userQualifiedId), userId) import qualified Cassandra as Cass import Control.Exception (ErrorCall (ErrorCall), throwIO) import Control.Lens ((^.), (^?!)) import Control.Monad.Catch +import Data.Aeson (decode) import qualified Data.Aeson.Lens as Aeson import qualified Data.Aeson.Types as Aeson import Data.ByteString.Conversion (toByteString') import Data.Id +import Data.Qualified (Qualified (qDomain, qUnqualified)) import qualified Data.Set as Set import Imports +import Servant.API (ToHttpApiData (toUrlPiece)) +import Test.QuickCheck (Arbitrary (arbitrary), generate) import Test.Tasty import Test.Tasty.HUnit +import UnliftIO (withSystemTempFile) import Util import Util.Options (Endpoint) import qualified Wire.API.Connection as Conn +import Wire.API.MLS.KeyPackage import Wire.API.Routes.Internal.Brig.EJPD as EJPD import qualified Wire.API.Team.Feature as ApiFt import qualified Wire.API.Team.Member as Team tests :: Opt.Opts -> Manager -> Cass.ClientState -> Brig -> Endpoint -> Gundeck -> Galley -> IO TestTree tests opts mgr db brig brigep gundeck galley = do - return $ + pure $ testGroup "api/internal" $ [ test mgr "ejpd requests" $ testEJPDRequest mgr brig brigep gundeck, - test mgr "account features: conferenceCalling" $ testFeatureConferenceCallingByAccount opts mgr db brig brigep galley, + test mgr "account features: conferenceCalling" $ + testFeatureConferenceCallingByAccount opts mgr db brig brigep galley, test mgr "suspend and unsuspend user" $ testSuspendUser db brig, - test mgr "suspend non existing user and verify no db entry" $ testSuspendNonExistingUser db brig + test mgr "suspend non existing user and verify no db entry" $ + testSuspendNonExistingUser db brig, + testGroup "mls/key-packages" $ + [ test mgr "fresh get" $ testKpcFreshGet brig, + test mgr "put,get" $ testKpcPutGet brig, + test mgr "get,get" $ testKpcGetGet brig, + test mgr "put,put" $ testKpcPutPut brig + ] ] testSuspendUser :: forall m. TestConstraints m => Cass.ClientState -> Brig -> m () @@ -201,6 +217,87 @@ testFeatureConferenceCallingByAccount (Opt.optSettings -> settings) mgr db brig check $ ApiFt.TeamFeatureStatusNoConfig ApiFt.TeamFeatureDisabled check' +keyPackageCreate :: HasCallStack => Brig -> Http KeyPackageRef +keyPackageCreate brig = do + uid <- userQualifiedId <$> randomUser brig + clid <- createClient brig uid 0 + withSystemTempFile "api.internal.kpc" $ \store _ -> + uploadKeyPackages brig store SetKey uid clid 2 + + uid2 <- userQualifiedId <$> randomUser brig + claimResp <- + post + ( brig + . paths + [ "mls", + "key-packages", + "claim", + toByteString' (qDomain uid), + toByteString' (qUnqualified uid) + ] + . zUser (qUnqualified uid2) + . contentJson + ) + liftIO $ + assertEqual "POST mls/key-packages/claim/:domain/:user failed" 200 (statusCode claimResp) + case responseBody claimResp >>= decode of + Nothing -> liftIO $ assertFailure "Claim response empty" + Just bundle -> case toList $ kpbEntries bundle of + [] -> liftIO $ assertFailure "Claim response held no bundles" + (h : _) -> pure $ kpbeRef h + +kpcPut :: HasCallStack => Brig -> KeyPackageRef -> Qualified ConvId -> Http () +kpcPut brig ref qConv = do + resp <- + put + ( brig + . paths ["i", "mls", "key-packages", toByteString' $ toUrlPiece ref, "conversation"] + . contentJson + . json qConv + ) + liftIO $ assertEqual "PUT i/mls/key-packages/:ref/conversation failed" 204 (statusCode resp) + +kpcGet :: HasCallStack => Brig -> KeyPackageRef -> Http (Maybe (Qualified ConvId)) +kpcGet brig ref = do + resp <- + get (brig . paths ["i", "mls", "key-packages", toByteString' $ toUrlPiece ref, "conversation"]) + liftIO $ case statusCode resp of + 404 -> pure Nothing + 200 -> pure $ responseBody resp >>= decode + _ -> assertFailure "GET i/mls/key-packages/:ref/conversation failed" + +testKpcFreshGet :: Brig -> Http () +testKpcFreshGet brig = do + ref <- keyPackageCreate brig + mqConv <- kpcGet brig ref + liftIO $ assertEqual "(fresh) Get ~= Nothing" Nothing mqConv + +testKpcPutGet :: Brig -> Http () +testKpcPutGet brig = do + ref <- keyPackageCreate brig + qConv <- liftIO $ generate arbitrary + kpcPut brig ref qConv + mqConv <- kpcGet brig ref + liftIO $ assertEqual "Put x; Get ~= x" (Just qConv) mqConv + +testKpcGetGet :: Brig -> Http () +testKpcGetGet brig = do + ref <- keyPackageCreate brig + liftIO (generate arbitrary) >>= kpcPut brig ref + mqConv1 <- kpcGet brig ref + mqConv2 <- kpcGet brig ref + liftIO $ assertEqual "Get; Get ~= Get" mqConv1 mqConv2 + +testKpcPutPut :: Brig -> Http () +testKpcPutPut brig = do + ref <- keyPackageCreate brig + qConv <- liftIO $ generate arbitrary + qConv2 <- liftIO $ generate arbitrary + kpcPut brig ref qConv + kpcPut brig ref qConv2 + mqConv <- kpcGet brig ref + liftIO $ assertEqual "Put x; Put y ~= Put y" (Just qConv2) mqConv + getFeatureConfig :: (MonadIO m, MonadHttp m, HasCallStack) => ApiFt.TeamFeatureName -> (Request -> Request) -> UserId -> m ResponseLBS getFeatureConfig feature galley uid = do get $ galley . paths ["feature-configs", toByteString' feature] . zUser uid diff --git a/services/brig/test/integration/API/Internal/Util.hs b/services/brig/test/integration/API/Internal/Util.hs index b526990ab6..06e0c4832d 100644 --- a/services/brig/test/integration/API/Internal/Util.hs +++ b/services/brig/test/integration/API/Internal/Util.hs @@ -113,8 +113,8 @@ scaffolding brig gundeck = do randomToken :: MonadIO m => m PushToken.PushToken randomToken = liftIO $ do c <- liftIO $ newClientId <$> (randomIO :: IO Word64) - tok <- PushToken.Token . T.decodeUtf8 <$> B16.encode <$> randomBytes 32 - return $ PushToken.pushToken PushToken.APNSSandbox (PushToken.AppName "test") tok c + tok <- (PushToken.Token . T.decodeUtf8) . B16.encode <$> randomBytes 32 + pure $ PushToken.pushToken PushToken.APNSSandbox (PushToken.AppName "test") tok c ejpdRequestClientM :: Maybe Bool -> EJPDRequestBody -> Client.ClientM EJPDResponseBody ejpdRequestClientM = Client.client (Proxy @("i" :> IAPI.EJPDRequest)) diff --git a/services/brig/test/integration/API/MLS.hs b/services/brig/test/integration/API/MLS.hs index 7f66272578..0fefc518e3 100644 --- a/services/brig/test/integration/API/MLS.hs +++ b/services/brig/test/integration/API/MLS.hs @@ -166,9 +166,7 @@ testKeyPackageRemoteClaim opts brig = do liftIO . replicateM 2 . generate $ -- claimed key packages are not validated by the backend, so it is fine to -- make up some random data here - KeyPackageBundleEntry - <$> pure u - <*> arbitrary + KeyPackageBundleEntry u <$> arbitrary <*> (KeyPackageRef . BS.pack <$> vector 32) <*> (KeyPackageData . BS.pack <$> vector 64) let mockBundle = KeyPackageBundle (Set.fromList entries) diff --git a/services/brig/test/integration/API/Metrics.hs b/services/brig/test/integration/API/Metrics.hs index 4153a016b0..fa735a391c 100644 --- a/services/brig/test/integration/API/Metrics.hs +++ b/services/brig/test/integration/API/Metrics.hs @@ -1,8 +1,5 @@ -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ViewPatterns #-} -- This file is part of the Wire Server implementation. -- @@ -39,7 +36,7 @@ import Util tests :: Manager -> Brig -> IO TestTree tests manager brig = do - return $ + pure $ testGroup "metrics" [ testCase "prometheus" . void $ runHttpT manager (testPrometheusMetrics brig), @@ -79,7 +76,7 @@ testMetricsEndpoint brig = do rsp <- responseBody <$> get (brig . path "i/metrics") -- is there some responseBodyAsText function used elsewhere? let asText = fromMaybe "" (fromByteString' (fromMaybe "" rsp)) - return $ fromRight 0 (parseOnly (parseCount endpoint m) asText) + pure $ fromRight 0 (parseOnly (parseCount endpoint m) asText) parseCount :: Text -> Text -> Parser Integer parseCount endpoint m = manyTill anyChar (string ("http_request_duration_seconds_count{handler=\"" <> endpoint <> "\",method=\"" <> m <> "\",status_code=\"200\"} ")) diff --git a/services/brig/test/integration/API/Provider.hs b/services/brig/test/integration/API/Provider.hs index 0c5904bf2c..7cd730553b 100644 --- a/services/brig/test/integration/API/Provider.hs +++ b/services/brig/test/integration/API/Provider.hs @@ -1,5 +1,4 @@ {-# LANGUAGE NondecreasingIndentation #-} -{-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -- This file is part of the Wire Server implementation. @@ -93,7 +92,7 @@ import qualified Wire.API.Team.Feature as Public tests :: Domain -> Config -> Manager -> DB.ClientState -> Brig -> Cannon -> Galley -> IO TestTree tests dom conf p db b c g = do - return $ + pure $ testGroup "provider" [ testGroup @@ -457,14 +456,14 @@ testListServices config db brig = do ("search for " <> show name <> " without and with tags") (serviceProfilePageResults r1) (serviceProfilePageResults r2) - return r1 + 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] searchAndCheck name = do result <- search name assertServiceDetails ("name " <> show name) (select name services) result - return (serviceProfilePageResults result) + pure (serviceProfilePageResults result) -- Search for our unique prefix and check that all services are found search (Name uniq) >>= assertServiceDetails ("all with prefix " <> show uniq) services -- Search by exact name and check that only one service is found @@ -594,7 +593,7 @@ testMessageBot config db brig galley cannon = withTestService config db brig def usr <- createUser "User" brig let uid = userId usr let quid = userQualifiedId usr - let new = defNewClient PermanentClientType [somePrekeys !! 0] (someLastPrekeys !! 0) + let new = defNewClient PermanentClientType [head somePrekeys] (head someLastPrekeys) _rs <- addClient brig uid new responseJsonMaybe _rs -- Create conversation @@ -616,7 +615,7 @@ testBadFingerprint config db brig galley _cannon = do -- Prepare user with client usr <- createUser "User" brig let uid = userId usr - let new = defNewClient PermanentClientType [somePrekeys !! 0] (someLastPrekeys !! 0) + let new = defNewClient PermanentClientType [head somePrekeys] (head someLastPrekeys) _rs <- addClient brig uid new responseJsonMaybe _rs -- Whitelist the bot @@ -804,7 +803,7 @@ testSearchWhitelist config db brig galley = do ("search for " <> show mbName <> " with and without filtering") r1 r2 - return r1 + pure r1 -- Check that search finds all services that we created search (Just uniq) >>= assertServiceDetails ("all with prefix " <> show uniq) services @@ -826,7 +825,7 @@ testSearchWhitelist config db brig galley = do searchAndCheck (Name name) = do result <- search (Just name) assertServiceDetails ("name " <> show name) (select name services) result - return (serviceProfilePageResults result) + pure (serviceProfilePageResults result) -- Search by exact name and check that only one service is found forM_ (take 3 services) $ \(sid, Name name) -> search (Just name) >>= assertServiceDetails ("name " <> show name) [(sid, Name name)] @@ -1491,7 +1490,7 @@ randomProvider db brig = do -- Fetch _rs <- getProvider brig pid Brig -> ProviderId -> NewService -> Http Service addGetService brig pid new = do @@ -1500,7 +1499,7 @@ addGetService brig pid new = do let sid = rsNewServiceId srs _rs <- getService brig pid sid Brig -> ProviderId -> ServiceId -> Http () enableService brig pid sid = do @@ -1555,7 +1554,7 @@ dewhitelistService brig uid tid pid sid = defNewService :: MonadIO m => Config -> m NewService defNewService config = liftIO $ do key <- readServiceKey (publicKey config) - return + pure NewService { newServiceName = defServiceName, newServiceSummary = unsafeRange defProviderSummary, @@ -1617,19 +1616,19 @@ readServiceKey :: MonadIO m => FilePath -> m ServiceKeyPEM readServiceKey fp = liftIO $ do bs <- BS.readFile fp let Right [k] = pemParseBS bs - return (ServiceKeyPEM k) + pure (ServiceKeyPEM k) randServiceKey :: MonadIO m => m ServiceKeyPEM randServiceKey = liftIO $ do kp <- generateRSAKey' 4096 65537 Right [k] <- pemParseBS . C8.pack <$> writePublicKey kp - return (ServiceKeyPEM k) + pure (ServiceKeyPEM k) waitFor :: MonadIO m => Timeout -> (a -> Bool) -> m a -> m a waitFor t f ma = do a <- ma if - | f a -> return a + | f a -> pure a | t <= 0 -> liftIO $ throwM TimedOut | otherwise -> do liftIO $ threadDelay (1 # Second) @@ -1659,7 +1658,7 @@ registerService config db brig = do let pid = providerId prv let sid = serviceId svc enableService brig pid sid - return (newServiceRef sid pid) + pure (newServiceRef sid pid) runService :: Config -> @@ -1706,8 +1705,8 @@ defServiceApp buf = case eitherDecode js of Left e -> k $ responseLBS status400 [] (LC8.pack e) Right new -> do - let pks = [somePrekeys !! 0] - let lpk = someLastPrekeys !! 0 + let pks = [head somePrekeys] + let lpk = head someLastPrekeys let rsp = Ext.NewBotResponse { Ext.rsNewBotPrekeys = pks, @@ -1842,7 +1841,7 @@ svcAssertBotCreated buf bid cid = liftIO $ do assertEqual "conv" cid (testBotConv b ^. Ext.botConvId) -- TODO: Verify the conversation name -- TODO: Verify the list of members - return b + pure b _ -> throwM $ HUnitFailure Nothing "Event timeout (TestBotCreated)" svcAssertMessage :: MonadIO m => Chan TestBotEvent -> Qualified UserId -> OtrMessage -> Qualified ConvId -> m () @@ -1949,7 +1948,7 @@ testAddRemoveBotUtil localDomain pid sid cid u1 u2 h sref buf brig galley cannon forM_ [ws1, ws2] $ \ws -> wsAssertMemberJoin ws qcid quid1 [qbuid] -- Member join event for the bot svcAssertMemberJoin buf quid1 [qbuid] qcid - return (rs, bot) + pure (rs, bot) let bid = rsAddBotId rs buid = botUserId bid -- Check that the bot token grants access to the right user and conversation @@ -2033,11 +2032,11 @@ testMessageBotUtil quid uc cid pid sid sref buf brig galley cannon = do assertEqual "service" (Just sref) (omService =<< other) -- The bot greets the user WS.bracketR cannon uid $ \ws -> do - postBotMessage galley bid bc cid [(uid, uc, (toBase64Text "Hi User!"))] + postBotMessage galley bid bc cid [(uid, uc, toBase64Text "Hi User!")] !!! const 201 === statusCode wsAssertMessage ws qcid (qUntagged lbuid) bc uc (toBase64Text "Hi User!") -- The user replies - postMessage galley uid uc cid [(buid, bc, (toBase64Text "Hi Bot"))] + postMessage galley uid uc cid [(buid, bc, toBase64Text "Hi Bot")] !!! const 201 === statusCode let msg = OtrMessage uc bc (toBase64Text "Hi Bot") (Just "data") svcAssertMessage buf quid msg qcid @@ -2070,7 +2069,7 @@ prepareBotUsersTeam brig galley sref = do whitelistService brig uid1 tid pid sid -- Create conversation cid <- Team.createTeamConv galley tid uid1 [uid2] Nothing - return (u1, u2, h, tid, cid, pid, sid) + pure (u1, u2, h, tid, cid, pid, sid) addBotConv :: HasCallStack => @@ -2101,7 +2100,7 @@ addBotConv localDomain brig cannon uid1 uid2 cid pid sid buf = do forM_ [ws1, ws2] $ \ws -> wsAssertMemberJoin ws qcid quid1 [qbotId] -- Member join event for the bot svcAssertMemberJoin buf quid1 [qbotId] qcid - return (rsAddBotId rs) + pure (rsAddBotId rs) ---------------------------------------------------------------------------- -- Service search utilities (abstracted out because we have more than one diff --git a/services/brig/test/integration/API/Settings.hs b/services/brig/test/integration/API/Settings.hs index 639961890e..5f062f1bbe 100644 --- a/services/brig/test/integration/API/Settings.hs +++ b/services/brig/test/integration/API/Settings.hs @@ -38,7 +38,7 @@ import Test.Tasty.HUnit import Util tests :: Opts -> Manager -> Brig -> Galley -> IO TestTree -tests defOpts manager brig galley = return $ do +tests defOpts manager brig galley = pure $ do testGroup "settings" [ testGroup diff --git a/services/brig/test/integration/API/Team.hs b/services/brig/test/integration/API/Team.hs index 5f59e08115..dfc02eeb6d 100644 --- a/services/brig/test/integration/API/Team.hs +++ b/services/brig/test/integration/API/Team.hs @@ -66,7 +66,7 @@ tests :: Opt.Opts -> Manager -> Nginz -> Brig -> Cannon -> Galley -> AWS.Env -> tests conf m n b c g aws = do let tl = TeamSizeLimit . Opt.setMaxTeamSize . Opt.optSettings $ conf let it = Opt.setTeamInvitationTimeout . Opt.optSettings $ conf - return $ + pure $ testGroup "team" [ testGroup "invitation" $ @@ -303,7 +303,7 @@ testInvitationEmailAndPhoneAccepted brig galley = do (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) (join (userPhone . selfUser <$> profile)) + 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 @@ -314,7 +314,7 @@ createAndVerifyInvitation :: InvitationRequest -> Brig -> Galley -> - Http ((Maybe SelfProfile), Invitation) + Http (Maybe SelfProfile, Invitation) createAndVerifyInvitation acceptFn invite brig galley = do createAndVerifyInvitation' Nothing acceptFn invite brig galley @@ -335,7 +335,7 @@ createAndVerifyInvitation' :: InvitationRequest -> Brig -> Galley -> - m ((Maybe SelfProfile), Invitation) + m (Maybe SelfProfile, Invitation) createAndVerifyInvitation' replacementBrigApp acceptFn invite brig galley = do (inviter, tid) <- createUserWithTeam brig let invitationHandshake :: @@ -375,7 +375,7 @@ createAndVerifyInvitation' replacementBrigApp acceptFn invite brig galley = do liftIO $ assertEqual "Member has no/wrong invitation metadata" invmeta (mem ^. Team.invitation) conns <- listConnections invitee brig liftIO $ assertBool "User should have no connections" (null (clConnections conns) && not (clHasMore conns)) - return (responseJsonMaybe rsp2, invitation) + pure (responseJsonMaybe rsp2, invitation) testCreateTeam :: Brig -> Galley -> AWS.Env -> Http () testCreateTeam brig galley aws = do @@ -592,7 +592,7 @@ testInvitationPaging brig = do liftIO $ assertEqual "page size" actualPageLen (length invs) liftIO $ assertEqual "has more" (count' < total) more liftIO $ validateInv `mapM_` invs - return (count', fmap inInvitation . listToMaybe . reverse $ invs) + pure (count', fmap inInvitation . listToMaybe . reverse $ invs) validateInv :: Invitation -> Assertion validateInv inv = do assertEqual "tid" tid (inTeam inv) diff --git a/services/brig/test/integration/API/Team/Util.hs b/services/brig/test/integration/API/Team/Util.hs index 9257bc2678..59e62af52b 100644 --- a/services/brig/test/integration/API/Team/Util.hs +++ b/services/brig/test/integration/API/Team/Util.hs @@ -62,11 +62,11 @@ createPopulatedBindingTeamWithNamesAndHandles :: Int -> m (TeamId, User, [User]) createPopulatedBindingTeamWithNamesAndHandles brig numMembers = do - names <- forM [1 .. numMembers] $ \_ -> randomName + names <- forM [1 .. numMembers] $ const randomName (tid, owner, mems) <- createPopulatedBindingTeamWithNames brig names membersWithHandle <- mapM (setRandomHandle brig) mems ownerWithHandle <- setRandomHandle brig owner - return (tid, ownerWithHandle, membersWithHandle) + pure (tid, ownerWithHandle, membersWithHandle) createPopulatedBindingTeam :: (MonadIO m, MonadCatch m, MonadFail m, MonadHttp m, HasCallStack) => @@ -74,9 +74,9 @@ createPopulatedBindingTeam :: Int -> m (TeamId, UserId, [User]) createPopulatedBindingTeam brig numMembers = do - names <- forM [1 .. numMembers] $ \_ -> randomName + names <- forM [1 .. numMembers] $ const randomName (tid, owner, others) <- createPopulatedBindingTeamWithNames brig names - return (tid, userId owner, others) + pure (tid, userId owner, others) createPopulatedBindingTeamWithNames :: (MonadIO m, MonadCatch m, MonadFail m, MonadHttp m, HasCallStack) => @@ -118,7 +118,7 @@ createTeam u galley = do . expect2xx . lbytes (encode newTeam) ) - maybe (error "invalid team id") return $ + maybe (error "invalid team id") pure $ fromByteString $ getHeader' "Location" r @@ -128,7 +128,7 @@ createTeam u galley = do createUserWithTeam :: (MonadIO m, MonadHttp m, MonadCatch m, MonadThrow m) => Brig -> m (UserId, TeamId) createUserWithTeam brig = do (user, tid) <- createUserWithTeam' brig - return (userId user, tid) + pure (userId user, tid) -- | Create user and binding team. -- @@ -149,7 +149,7 @@ createUserWithTeam' brig = do let Just tid = userTeam user selfTeam <- userTeam . selfUser <$> getSelfProfile brig (userId user) liftIO $ assertBool "Team ID in self profile and team table do not match" (selfTeam == Just tid) - return (user, tid) + pure (user, tid) -- | Create a team member with given permissions. createTeamMember :: @@ -165,7 +165,7 @@ createTeamMember :: createTeamMember brig galley owner tid perm = do user <- inviteAndRegisterUser owner tid brig updatePermissions owner tid (userId user, perm) galley - return user + pure user inviteAndRegisterUser :: (MonadIO m, MonadCatch m, MonadFail m, MonadHttp m, HasCallStack) => @@ -192,7 +192,7 @@ inviteAndRegisterUser u tid brig = do liftIO $ assertEqual "Team ID in registration and team table do not match" (Just tid) (userTeam invitee) selfTeam <- userTeam . selfUser <$> getSelfProfile brig (userId invitee) liftIO $ assertEqual "Team ID in self profile and team table do not match" selfTeam (Just tid) - return invitee + pure invitee updatePermissions :: HasCallStack => UserId -> TeamId -> (UserId, Team.Permissions) -> Galley -> Http () updatePermissions from tid (to, perm) galley = @@ -224,7 +224,7 @@ createTeamConv g tid u us mtimer = do ) InvitationCode -> RequestBody -accept email code = acceptWithName (Name "Bob") email code +accept = acceptWithName (Name "Bob") acceptWithName :: Name -> Email -> InvitationCode -> RequestBody acceptWithName name email code = @@ -357,7 +357,7 @@ getInvitation brig c = do brig . path "/teams/invitations/info" . queryItem "code" (toByteString' c) - return . decode . fromMaybe "" $ responseBody r + pure . decode . fromMaybe "" $ responseBody r postInvitation :: (MonadIO m, MonadHttp m, HasCallStack) => @@ -407,7 +407,7 @@ getInvitationCode brig t ref = do . queryItem "invitation_id" (toByteString' ref) ) let lbs = fromMaybe "" $ responseBody r - return $ fromByteString . fromMaybe (error "No code?") $ T.encodeUtf8 <$> (lbs ^? key "code" . _String) + 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 brig t i = diff --git a/services/brig/test/integration/API/TeamUserSearch.hs b/services/brig/test/integration/API/TeamUserSearch.hs index dc7f59af06..7fbf184cb7 100644 --- a/services/brig/test/integration/API/TeamUserSearch.hs +++ b/services/brig/test/integration/API/TeamUserSearch.hs @@ -46,7 +46,7 @@ type TestConstraints m = (MonadFail m, MonadCatch m, MonadIO m, MonadHttp m) tests :: Opt.Opts -> Manager -> Galley -> Brig -> IO TestTree tests opts mgr _galley brig = do - return $ + pure $ testGroup "/teams/:tid/search" $ [ testWithNewIndex "can find user by email" (testSearchByEmailSameTeam brig), testWithNewIndex "empty query returns the whole team sorted" (testEmptyQuerySorted brig), diff --git a/services/brig/test/integration/API/User.hs b/services/brig/test/integration/API/User.hs index de4e9bcdd1..f2c41833e2 100644 --- a/services/brig/test/integration/API/User.hs +++ b/services/brig/test/integration/API/User.hs @@ -59,7 +59,7 @@ tests conf fbc fgc p b c ch g n aws db = do let cl = ConnectionLimit $ Opt.setUserMaxConnections (Opt.optSettings conf) let at = Opt.setActivationTimeout (Opt.optSettings conf) z <- mkZAuthEnv (Just conf) - return $ + pure $ testGroup "user" [ API.User.Client.tests cl at conf p db b c g, diff --git a/services/brig/test/integration/API/User/Account.hs b/services/brig/test/integration/API/User/Account.hs index b45ebf2db2..86883e9615 100644 --- a/services/brig/test/integration/API/User/Account.hs +++ b/services/brig/test/integration/API/User/Account.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE NumericUnderscores #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -- This file is part of the Wire Server implementation. @@ -68,6 +67,7 @@ import qualified Data.Vector as Vec import Federator.MockServer (FederatedRequest (..), MockException (..)) import Galley.Types.Teams (noPermissions) import Imports hiding (head) +import qualified Imports import qualified Network.HTTP.Types as HTTP import qualified Network.HTTP.Types as Http import qualified Network.Wai as Wai @@ -393,7 +393,7 @@ testCreateUserPending _ brig = do const 200 === statusCode const (Just True) === \rs' -> do self <- responseJsonMaybe rs' - return $! isNothing (userIdentity (selfUser self)) + pure $! isNothing (userIdentity (selfUser self)) -- should not appear in search suid <- userId <$> randomUser brig Search.refreshIndex brig @@ -767,12 +767,12 @@ testCreateUserAnonExpiry b = do alice <- randomUser b now <- liftIO getCurrentTime bob <- createAnonUserExpiry (Just 2) "bob" b - liftIO $ assertBool "expiry not set on regular creation" (not $ isJust $ userExpire alice) + liftIO $ assertBool "expiry not set on regular creation" (isNothing (userExpire alice)) ensureExpiry now (fromUTCTimeMillis <$> userExpire bob) "bob/register" resAlice <- getProfile (userId u1) (userId alice) resBob <- getProfile (userId u1) (userId bob) selfBob <- get (b . zUser (userId bob) . path "self") deleted selfBob)) + liftIO $ assertBool "Bob must not be in a deleted state initially" (maybe True not (deleted selfBob)) liftIO $ assertBool "Regular user should not have any expiry" (null $ expire resAlice) ensureExpiry now (expire resBob) "bob/public" ensureExpiry now (expire selfBob) "bob/self" @@ -786,7 +786,7 @@ testCreateUserAnonExpiry b = do awaitExpiry n zusr uid = do -- after expiration, a profile lookup should trigger garbage collection of ephemeral users r <- getProfile zusr uid - when (statusCode r == 200 && deleted r == Nothing && n > 0) $ do + when (statusCode r == 200 && isNothing (deleted r) && n > 0) $ do liftIO $ threadDelay 1000000 awaitExpiry (n -1) zusr uid ensureExpiry :: UTCTime -> Maybe UTCTime -> String -> Http () @@ -799,9 +799,9 @@ testCreateUserAnonExpiry b = do liftIO $ assertBool "expiry must in be the future" (diff >= fromIntegral minExp) liftIO $ assertBool "expiry must be less than 10 days" (diff < fromIntegral maxExp) expire :: ResponseLBS -> Maybe UTCTime - expire r = join $ field "expires_at" <$> responseJsonMaybe r + expire r = field "expires_at" =<< responseJsonMaybe r deleted :: ResponseLBS -> Maybe Bool - deleted r = join $ field "deleted" <$> responseJsonMaybe r + deleted r = field "deleted" =<< responseJsonMaybe r field :: FromJSON a => Text -> Value -> Maybe a field f u = u ^? key f >>= maybeFromJSON @@ -1030,7 +1030,7 @@ testGetByIdentity brig = do const 200 === statusCode const (Just [uid]) === getUids where - getUids r = return . fmap (userId . accountUser) =<< responseJsonMaybe r + getUids r = fmap (userId . accountUser) <$> responseJsonMaybe r testPasswordSet :: Brig -> Http () testPasswordSet brig = do @@ -1254,7 +1254,7 @@ testDeleteUserByPassword brig cannon aws = do con32 <- putConnection brig uid3 uid2 Accepted (responseJsonError =<< get (brig . path "/self" . zUser (userId member))) let ssoids1 = [UserSSOId (mkSampleUref "1" "1"), UserSSOId (mkSampleUref "1" "2")] @@ -1487,8 +1487,8 @@ testUpdateSSOId brig galley = do -- , mkMember False False -- , mkMember False True ] - sequence_ $ zipWith go users ssoids1 - sequence_ $ zipWith go users ssoids2 + zipWithM_ go users ssoids1 + zipWithM_ go users ssoids2 testDomainsBlockedForRegistration :: Opt.Opts -> Brig -> Http () testDomainsBlockedForRegistration opts brig = withDomainsBlockedForRegistration opts ["bad1.domain.com", "bad2.domain.com"] $ do diff --git a/services/brig/test/integration/API/User/Auth.hs b/services/brig/test/integration/API/User/Auth.hs index 215832218e..b13b261d5a 100644 --- a/services/brig/test/integration/API/User/Auth.hs +++ b/services/brig/test/integration/API/User/Auth.hs @@ -171,7 +171,7 @@ 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 = (Id <$> liftIO UUID.nextRandom) >>= ZAuth.newUserToken +randomUserToken = liftIO UUID.nextRandom >>= ZAuth.newUserToken . Id ------------------------------------------------------------------------------- -- Nginz authentication tests (end-to-end sanity checks) @@ -192,14 +192,14 @@ testNginz b n = do -- Note: If you get 403 test failures: -- 1. check that the private/public keys in brig and nginz match. -- 2. check that the nginz acl file is correct. - _rs <- get (n . path "/clients" . header "Authorization" ("Bearer " <> (toByteString' t))) + _rs <- get (n . path "/clients" . header "Authorization" ("Bearer " <> toByteString' t)) liftIO $ assertEqual "Ensure nginz is started. Ensure nginz and brig share the same private/public zauth keys. Ensure ACL file is correct." 200 (statusCode _rs) -- ensure nginz allows refresh at /access _rs <- - post (n . path "/access" . cookie c . header "Authorization" ("Bearer " <> (toByteString' t))) toByteString' t)) (toByteString' t))) !!! const 200 === statusCode + get (n . path "/notifications" . header "Authorization" ("Bearer " <> toByteString' t)) !!! const 200 === statusCode testNginzLegalHold :: Brig -> Galley -> Nginz -> Http () testNginzLegalHold b g n = do @@ -226,13 +226,13 @@ testNginzLegalHold b g n = do pure (c, t) -- ensure nginz allows passing legalhold cookies / tokens through to /access - post (n . path "/access" . cookie c . header "Authorization" ("Bearer " <> (toByteString' t))) !!! do + post (n . path "/access" . cookie c . header "Authorization" ("Bearer " <> toByteString' t)) !!! do const 200 === statusCode -- ensure legalhold tokens CANNOT fetch /clients - get (n . path "/clients" . header "Authorization" ("Bearer " <> (toByteString' t))) !!! const 403 === statusCode - get (n . path "/self" . header "Authorization" ("Bearer " <> (toByteString' t))) !!! const 403 === statusCode + get (n . path "/clients" . header "Authorization" ("Bearer " <> toByteString' t)) !!! const 403 === statusCode + get (n . path "/self" . header "Authorization" ("Bearer " <> toByteString' t)) !!! const 403 === statusCode -- ensure legal hold tokens can fetch notifications - get (n . path "/notifications" . header "Authorization" ("Bearer " <> (toByteString' t))) !!! const 200 === statusCode + get (n . path "/notifications" . header "Authorization" ("Bearer " <> toByteString' t)) !!! const 200 === statusCode -- | Corner case for 'testNginz': when upgrading a wire backend from the old behavior (setting -- cookie domain to eg. @*.wire.com@) to the new behavior (leaving cookie domain empty, @@ -901,7 +901,7 @@ getAndTestDBSupersededCookieAndItsValidSuccessor config b n = do [Nothing] @=? map cookieSucc _cs -- Return non-expired cookie but removed from DB (because it was renewed) -- and a valid cookie - return (c, c') + pure (c, c') testNewSessionCookie :: Opts.Opts -> Brig -> Http () testNewSessionCookie config b = do @@ -1073,7 +1073,7 @@ testTooManyCookies config b = do loginWhenAllowed pwl t = do x <- login b pwl t <* wait case statusCode x of - 200 -> return $ decodeCookie x + 200 -> pure $ decodeCookie x 429 -> do -- After the amount of time specified in "Retry-After", though, -- throttling should stop and login should work again @@ -1126,12 +1126,12 @@ testReauthentication b = do ----------------------------------------------------------------------------- -- Helpers -prepareLegalHoldUser :: Brig -> Galley -> Http (UserId) +prepareLegalHoldUser :: Brig -> Galley -> Http UserId prepareLegalHoldUser brig galley = do (uid, tid) <- createUserWithTeam brig -- enable it for this team - without that, legalhold login will fail. putLHWhitelistTeam galley tid !!! const 200 === statusCode - return uid + pure uid getCookieId :: forall u. (HasCallStack, ZAuth.UserTokenLike u) => Http.Cookie -> CookieId getCookieId c = @@ -1153,7 +1153,7 @@ listCookiesWithLabel b u l = do ) responseJsonMaybe rs - return cs + pure cs where labels = BS.intercalate "," $ map toByteString' l diff --git a/services/brig/test/integration/API/User/Connection.hs b/services/brig/test/integration/API/User/Connection.hs index 0b73129ce8..555f9e576f 100644 --- a/services/brig/test/integration/API/User/Connection.hs +++ b/services/brig/test/integration/API/User/Connection.hs @@ -624,7 +624,7 @@ testLocalConnectionsPaging b = do let (conns, more) = (fmap clConnections &&& fmap clHasMore) $ responseJsonMaybe r liftIO $ assertEqual "page size" (Just n) (length <$> conns) liftIO $ assertEqual "has more" (Just (count' < total)) more - return . (count',) $ (conns >>= fmap (qUnqualified . ucTo) . listToMaybe . reverse) + pure . (count',) $ (conns >>= fmap (qUnqualified . ucTo) . listToMaybe . reverse) testAllConnectionsPaging :: Brig -> DB.ClientState -> Http () testAllConnectionsPaging b db = do @@ -688,7 +688,7 @@ testConnectionLimit brig (ConnectionLimit l) = do newConn from = do to <- userId <$> randomUser brig postConnection brig from to !!! const 201 === statusCode - return to + pure to assertLimited = do const 403 === statusCode const (Just "connection-limit") === fmap Error.label . responseJsonMaybe @@ -713,7 +713,7 @@ testConnectionLimitQualified brig (ConnectionLimit l) = do newConn from = do to <- userQualifiedId <$> randomUser brig postConnectionQualified brig from to !!! const 201 === statusCode - return to + pure to assertLimited = do const 403 === statusCode const (Just "connection-limit") === fmap Error.label . responseJsonMaybe diff --git a/services/brig/test/integration/API/User/RichInfo.hs b/services/brig/test/integration/API/User/RichInfo.hs index 1597867584..66c8b9b247 100644 --- a/services/brig/test/integration/API/User/RichInfo.hs +++ b/services/brig/test/integration/API/User/RichInfo.hs @@ -124,7 +124,7 @@ testRichInfoSizeLimit brig conf = do ] bad2 = mkRichInfoAssocList $ - [0 .. ((maxSize `div` 2))] + [0 .. (maxSize `div` 2)] <&> \i -> RichField (CI.mk $ Text.pack $ show i) "#" putRichInfo brig owner bad1 !!! const 413 === statusCode putRichInfo brig owner bad2 !!! const 413 === statusCode diff --git a/services/brig/test/integration/API/User/Util.hs b/services/brig/test/integration/API/User/Util.hs index c13591cbf4..916c527260 100644 --- a/services/brig/test/integration/API/User/Util.hs +++ b/services/brig/test/integration/API/User/Util.hs @@ -105,7 +105,7 @@ setRandomHandle brig user = do ) !!! const 200 === statusCode - return user {userHandle = Just (Handle h)} + pure user {userHandle = Just (Handle h)} -- Note: This actually _will_ send out an email, so we ensure that the email -- used here has a domain 'simulator.amazonses.com'. @@ -139,7 +139,7 @@ createRandomPhoneUser brig = do get (brig . path "/self" . zUser uid) !!! do const 200 === statusCode const (Just phn) === (userPhone <=< responseJsonMaybe) - return (uid, phn) + pure (uid, phn) initiatePasswordReset :: Brig -> Email -> (MonadIO m, MonadHttp m) => m ResponseLBS initiatePasswordReset brig email = @@ -205,7 +205,7 @@ preparePasswordReset brig cs email uid newpw = do let Just pwcode = PasswordResetCode . Ascii.unsafeFromText <$> (lbs ^? key "code" . _String) ident <- PasswordResetIdentityKey <$> runSem (mkPasswordResetKey uid) let complete = CompletePasswordReset ident pwcode newpw - return complete + pure complete where runSem = liftIO . runFinal @IO . interpretClientToIO cs . codeStoreToCassandra @DB.Client @@ -331,7 +331,7 @@ countCookies brig u label = do ) (preview (key "cookies" . _Array) =<< responseJsonMaybe @Value r) + pure $ Vec.length <$> (preview (key "cookies" . _Array) =<< responseJsonMaybe @Value r) assertConnections :: (MonadCatch m, MonadIO m, MonadHttp m, HasCallStack) => Brig -> UserId -> [ConnectionStatus] -> m () assertConnections brig u connections = diff --git a/services/brig/test/integration/API/UserPendingActivation.hs b/services/brig/test/integration/API/UserPendingActivation.hs index 4e3e02b60b..b42b51868a 100644 --- a/services/brig/test/integration/API/UserPendingActivation.hs +++ b/services/brig/test/integration/API/UserPendingActivation.hs @@ -70,7 +70,7 @@ import Wire.API.User.Scim (CreateScimToken (..), ScimToken, ScimUserExtra (ScimU tests :: Opts -> Manager -> ClientState -> Brig -> Galley -> Spar -> IO TestTree tests opts m db brig galley spar = do - return $ + pure $ testGroup "cleanExpiredPendingInvitations" [ test m "expired users get cleaned" (testCleanExpiredPendingInvitations opts db brig galley spar), @@ -139,7 +139,7 @@ userExists uid = do case x of Nothing -> False Just (_, mbStatus) -> - maybe True (/= Deleted) mbStatus + Just Deleted /= mbStatus where usersSelect :: PrepQuery R (Identity UserId) (UserId, Maybe AccountStatus) usersSelect = "SELECT id, status FROM user where id = ?" @@ -176,7 +176,7 @@ createUserWithTeamDisableSSO brg gly = do () <- Control.Exception.assert {- "Team ID in self profile and team table do not match" -} (selfTeam == Just tid) $ pure () - return (uid, tid) + pure (uid, tid) randomScimUser :: (HasCallStack, MonadRandom m, MonadIO m) => m (Scim.User.User SparTag) randomScimUser = fst <$> randomScimUserWithSubject @@ -310,7 +310,7 @@ getInvitationCode brig t ref = do . queryItem "invitation_id" (toByteString' ref) ) let lbs = fromMaybe "" $ responseBody r - return $ fromByteString . fromMaybe (error "No code?") $ encodeUtf8 <$> (lbs ^? key "code" . _String) + pure $ fromByteString (maybe (error "No code?") encodeUtf8 (lbs ^? key "code" . _String)) -- | Create a SCIM token. createToken_ :: diff --git a/services/brig/test/integration/Federation/End2end.hs b/services/brig/test/integration/Federation/End2end.hs index 3f7ad9d58b..9e11e07d72 100644 --- a/services/brig/test/integration/Federation/End2end.hs +++ b/services/brig/test/integration/Federation/End2end.hs @@ -498,7 +498,7 @@ testSendMessage brig1 brig2 galley2 cannon1 = do <$> addClient brig1 (userId alice) - (defNewClient PermanentClientType [] (someLastPrekeys !! 0)) + (defNewClient PermanentClientType [] (Imports.head someLastPrekeys)) -- create bob user and client on domain 2 bob <- randomUser brig2 @@ -523,7 +523,7 @@ testSendMessage brig1 brig2 galley2 cannon1 = do rcpts = [(userQualifiedId alice, aliceClient, msgText)] msg = mkQualifiedOtrPayload bobClient rcpts "" MismatchReportAll - WS.bracketR cannon1 (userId alice) $ \(wsAlice) -> do + WS.bracketR cannon1 (userId alice) $ \wsAlice -> do post ( galley2 . paths @@ -562,7 +562,7 @@ testSendMessageToRemoteConv brig1 brig2 galley1 galley2 cannon1 = do alice <- randomUser brig1 aliceClient <- fmap clientId . responseJsonError - =<< addClient brig1 (userId alice) (defNewClient PermanentClientType [] (someLastPrekeys !! 0)) + =<< addClient brig1 (userId alice) (defNewClient PermanentClientType [] (Imports.head someLastPrekeys)) do + WS.bracketR cannon1 (userId alice) $ \wsAlice -> do post ( galley2 . paths diff --git a/services/brig/test/integration/Federation/Util.hs b/services/brig/test/integration/Federation/Util.hs index 9131cd1fa7..a78bf654a7 100644 --- a/services/brig/test/integration/Federation/Util.hs +++ b/services/brig/test/integration/Federation/Util.hs @@ -1,5 +1,4 @@ {-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE QuasiQuotes #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# OPTIONS_GHC -Wno-partial-type-signatures #-} {-# OPTIONS_GHC -Wno-unused-imports #-} diff --git a/services/brig/test/integration/Index/Create.hs b/services/brig/test/integration/Index/Create.hs index 1b703647a3..686af9e33f 100644 --- a/services/brig/test/integration/Index/Create.hs +++ b/services/brig/test/integration/Index/Create.hs @@ -51,7 +51,7 @@ testCreateIndexWhenNotPresent brigOpts = do case parseURI strictURIParserOptions (Text.encodeUtf8 esURL) of Left e -> fail $ "Invalid ES URL: " <> show esURL <> "\nerror: " <> show e Right esURI -> do - indexName <- ES.IndexName . Text.pack <$> (replicateM 20 $ Random.randomRIO ('a', 'z')) + indexName <- ES.IndexName . Text.pack <$> replicateM 20 (Random.randomRIO ('a', 'z')) let replicas = 2 shards = 2 refreshInterval = 5 @@ -59,7 +59,7 @@ testCreateIndexWhenNotPresent brigOpts = do IndexOpts.localElasticSettings & IndexOpts.esServer .~ esURI & IndexOpts.esIndex .~ indexName - & IndexOpts.esIndexReplicas .~ (ES.ReplicaCount replicas) + & IndexOpts.esIndexReplicas .~ ES.ReplicaCount replicas & IndexOpts.esIndexShardCount .~ shards & IndexOpts.esIndexRefreshInterval .~ refreshInterval devNullLogger <- Log.create (Log.Path "/dev/null") @@ -83,7 +83,7 @@ testCreateIndexWhenPresent brigOpts = do case parseURI strictURIParserOptions (Text.encodeUtf8 esURL) of Left e -> fail $ "Invalid ES URL: " <> show esURL <> "\nerror: " <> show e Right esURI -> do - indexName <- ES.IndexName . Text.pack <$> (replicateM 20 $ Random.randomRIO ('a', 'z')) + indexName <- ES.IndexName . Text.pack <$> replicateM 20 (Random.randomRIO ('a', 'z')) ES.withBH HTTP.defaultManagerSettings (ES.Server esURL) $ do _ <- ES.createIndex (ES.IndexSettings (ES.ShardCount 1) (ES.ReplicaCount 1)) indexName indexExists <- ES.indexExists indexName @@ -96,7 +96,7 @@ testCreateIndexWhenPresent brigOpts = do IndexOpts.localElasticSettings & IndexOpts.esServer .~ esURI & IndexOpts.esIndex .~ indexName - & IndexOpts.esIndexReplicas .~ (ES.ReplicaCount replicas) + & IndexOpts.esIndexReplicas .~ ES.ReplicaCount replicas & IndexOpts.esIndexShardCount .~ shards & IndexOpts.esIndexRefreshInterval .~ refreshInterval devNullLogger <- Log.create (Log.Path "/dev/null") diff --git a/services/brig/test/integration/Main.hs b/services/brig/test/integration/Main.hs index e39c075e45..586273d439 100644 --- a/services/brig/test/integration/Main.hs +++ b/services/brig/test/integration/Main.hs @@ -117,9 +117,9 @@ runTests iConf brigOpts otherArgs = do Opts.TurnSourceFiles files -> files Opts.TurnSourceDNS _ -> error "The integration tests can only be run when TurnServers are sourced from files" localDomain = brigOpts ^. Opts.optionSettings . Opts.federationDomain - casHost = (\v -> (Opts.cassandra v) ^. casEndpoint . epHost) brigOpts - casPort = (\v -> (Opts.cassandra v) ^. casEndpoint . epPort) brigOpts - casKey = (\v -> (Opts.cassandra v) ^. casKeyspace) brigOpts + casHost = (\v -> Opts.cassandra v ^. casEndpoint . epHost) brigOpts + casPort = (\v -> Opts.cassandra v ^. casEndpoint . epPort) brigOpts + casKey = (\v -> Opts.cassandra v ^. casKeyspace) brigOpts awsOpts = Opts.aws brigOpts lg <- Logger.new Logger.defSettings -- TODO: use mkLogger'? db <- defInitCassandra casKey casHost casPort lg @@ -176,8 +176,8 @@ runTests iConf brigOpts otherArgs = do parseEmailAWSOpts :: IO (Maybe Opts.EmailAWSOpts) parseEmailAWSOpts = case Opts.email . Opts.emailSMS $ brigOpts of - (Opts.EmailAWS aws) -> return (Just aws) - (Opts.EmailSMTP _) -> return Nothing + (Opts.EmailAWS aws) -> pure (Just aws) + (Opts.EmailSMTP _) -> pure Nothing main :: IO () main = withOpenSSL $ do @@ -187,8 +187,8 @@ main = withOpenSSL $ do let configArgs = getConfigArgs args let otherArgs = args \\ configArgs (iPath, bPath) <- withArgs configArgs parseConfigPaths - iConf <- join $ handleParseError <$> decodeFileEither iPath - bConf <- join $ handleParseError <$> decodeFileEither bPath + iConf <- handleParseError =<< decodeFileEither iPath + bConf <- handleParseError =<< decodeFileEither bPath brigOpts <- maybe (fail "failed to parse brig options file") pure bConf integrationConfig <- maybe (fail "failed to parse integration.yaml file") pure iConf runTests integrationConfig brigOpts otherArgs @@ -211,17 +211,17 @@ parseConfigPaths = do pathParser :: Parser (String, String) pathParser = (,) - <$> ( strOption $ - long "integration-config" - <> short 'i' - <> help "Integration config to load" - <> showDefault - <> value defaultIntPath - ) - <*> ( strOption $ - long "service-config" - <> short 's' - <> help "Brig application config to load" - <> showDefault - <> value defaultBrigPath - ) + <$> strOption + ( long "integration-config" + <> short 'i' + <> help "Integration config to load" + <> showDefault + <> value defaultIntPath + ) + <*> strOption + ( long "service-config" + <> short 's' + <> help "Brig application config to load" + <> showDefault + <> value defaultBrigPath + ) diff --git a/services/brig/test/integration/Util.hs b/services/brig/test/integration/Util.hs index ef7894df17..a6f8138f15 100644 --- a/services/brig/test/integration/Util.hs +++ b/services/brig/test/integration/Util.hs @@ -190,7 +190,7 @@ instance ToJSON SESNotification where [ "notificationType" .= ("Bounce" :: Text), "bounce" .= object - [ "bouncedRecipients" .= (fmap (\e -> object ["emailAddress" .= e]) ems), + [ "bouncedRecipients" .= fmap (\e -> object ["emailAddress" .= e]) ems, "bounceType" .= typ ] ] @@ -199,7 +199,7 @@ instance ToJSON SESNotification where [ "notificationType" .= ("Complaint" :: Text), "complaint" .= object - [ "complainedRecipients" .= (fmap (\e -> object ["emailAddress" .= e]) ems) + [ "complainedRecipients" .= fmap (\e -> object ["emailAddress" .= e]) ems ] ] @@ -322,13 +322,13 @@ getActivationCode brig ep = do let lbs = fromMaybe "" $ responseBody r let akey = ActivationKey . Ascii.unsafeFromText <$> (lbs ^? key "key" . _String) let acode = ActivationCode . Ascii.unsafeFromText <$> (lbs ^? key "code" . _String) - return $ (,) <$> akey <*> acode + pure $ (,) <$> akey <*> acode getPhoneLoginCode :: Brig -> Phone -> Http (Maybe LoginCode) getPhoneLoginCode brig p = do r <- get $ brig . path "/i/users/login-code" . queryItem "phone" (toByteString' p) let lbs = fromMaybe "" $ responseBody r - return (LoginCode <$> (lbs ^? key "code" . _String)) + pure (LoginCode <$> (lbs ^? key "code" . _String)) assertUpdateNotification :: WS.WebSocket -> UserId -> UserUpdate -> IO Notification assertUpdateNotification ws uid upd = WS.assertMatch (5 # Second) ws $ \n -> do @@ -411,12 +411,12 @@ postUserWithEmail hasPassword validateBody name email havePhone ssoid teamid bri postUserInternal :: Object -> Brig -> Http User postUserInternal payload brig = do rs <- post (brig . path "/i/users" . contentJson . body (RequestBodyLBS $ encode payload)) Brig -> Http User postUserRegister payload brig = do rs <- postUserRegister' payload brig Object -> Brig -> m ResponseLBS postUserRegister' payload brig = do @@ -748,8 +748,8 @@ isMember g usr cnv = do . paths ["i", "conversations", toByteString' cnv, "members", toByteString' (tUnqualified usr)] . expect2xx case responseJsonMaybe res of - Nothing -> return False - Just m -> return (qUntagged usr == memId m) + Nothing -> pure False + Just m -> pure (qUntagged usr == memId m) getStatus :: HasCallStack => Brig -> UserId -> (MonadIO m, MonadHttp m) => m AccountStatus getStatus brig u = @@ -802,7 +802,7 @@ mkEmailRandomLocalSuffix :: MonadIO m => Text -> m Email mkEmailRandomLocalSuffix e = do uid <- liftIO UUID.nextRandom case parseEmail e of - Just (Email loc dom) -> return $ Email (loc <> "+" <> UUID.toText uid) dom + Just (Email loc dom) -> pure $ Email (loc <> "+" <> UUID.toText uid) dom Nothing -> error $ "Invalid email address: " ++ Text.unpack e -- | Generate emails that are in the trusted whitelist of domains whose @+@ suffices count for email @@ -825,7 +825,7 @@ 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 - return $ fromMaybe (error "Invalid random phone#") phone + pure $ fromMaybe (error "Invalid random phone#") phone randomActivationCode :: (HasCallStack, MonadIO m) => m ActivationCode randomActivationCode = @@ -938,7 +938,7 @@ randomBytes n = BS.pack <$> replicateM n randomIO randomHandle :: MonadIO m => m Text randomHandle = liftIO $ do nrs <- replicateM 21 (randomRIO (97, 122)) -- a-z - return (Text.pack (map chr nrs)) + pure (Text.pack (map chr nrs)) randomName :: MonadIO m => m Name randomName = randomNameWithMaxLen 128 @@ -956,9 +956,9 @@ randomNameWithMaxLen :: MonadIO m => Word -> m Name randomNameWithMaxLen maxLen = liftIO $ do len <- randomRIO (2, maxLen) chars <- fill len [] - return $ Name (Text.pack chars) + pure $ Name (Text.pack chars) where - fill 0 chars = return chars + fill 0 chars = pure chars fill 1 chars = (: chars) <$> randLetter fill n chars = do c <- randChar @@ -969,14 +969,14 @@ randomNameWithMaxLen maxLen = liftIO $ do randLetter = do c <- randChar if isLetter c - then return c + then pure c else randLetter retryWhileN :: (MonadIO m) => Int -> (a -> Bool) -> m a -> m a retryWhileN n f m = retrying (constantDelay 1000000 <> limitRetries n) - (const (return . f)) + (const (pure . f)) (const m) recoverN :: (MonadIO m, MonadMask m) => Int -> m a -> m a @@ -1036,7 +1036,7 @@ aFewTimes retrying (exponentialBackoff 1000 <> limitRetries retries) (\_ -> pure . not . good) - (\_ -> action) + (const action) assertOne :: (HasCallStack, MonadIO m, Show a) => [a] -> m a assertOne [a] = pure a diff --git a/services/brig/test/integration/Util/AWS.hs b/services/brig/test/integration/Util/AWS.hs index 92a3d8e687..8e10d0cfea 100644 --- a/services/brig/test/integration/Util/AWS.hs +++ b/services/brig/test/integration/Util/AWS.hs @@ -109,7 +109,7 @@ assertUserId :: String -> UserId -> PU.UserEvent -> IO () assertUserId l uid ev = assertEqual (l <> "userId") uid (Id $ fromMaybe (error "failed to decode userId") $ UUID.fromByteString $ Lazy.fromStrict (ev ^. PU.userId)) assertTeamId :: String -> Maybe TeamId -> PU.UserEvent -> IO () -assertTeamId l (Just tid) ev = assertEqual (l <> "teamId should exist") tid (Id . fromMaybe (error "failed to parse teamId") . join $ fmap (UUID.fromByteString . Lazy.fromStrict) (ev ^? PU.teamId)) +assertTeamId l (Just tid) ev = assertEqual (l <> "teamId should exist") tid ((Id . fromMaybe (error "failed to parse teamId")) ((UUID.fromByteString . Lazy.fromStrict) =<< (ev ^? PU.teamId))) assertTeamId l Nothing ev = assertEqual (l <> "teamId should not exist") Nothing (ev ^. PU.maybe'teamId) assertName :: String -> Maybe Name -> PU.UserEvent -> IO () diff --git a/services/cannon/cannon.cabal b/services/cannon/cannon.cabal index d488fc427b..d625b5738f 100644 --- a/services/cannon/cannon.cabal +++ b/services/cannon/cannon.cabal @@ -89,6 +89,7 @@ library , data-timeout >=0.3 , exceptions >=0.6 , extended + , extra , gundeck-types , hashable >=1.2 , http-types >=0.8 @@ -107,6 +108,8 @@ library , text >=1.1 , tinylog >=0.10 , types-common >=0.16 + , unix + , unliftio , uuid >=1.3 , vector >=0.10 , wai >=3.0 diff --git a/services/cannon/cannon.integration.yaml b/services/cannon/cannon.integration.yaml index 0052516ad1..5bd5d2a706 100644 --- a/services/cannon/cannon.integration.yaml +++ b/services/cannon/cannon.integration.yaml @@ -16,5 +16,10 @@ gundeck: host: 127.0.0.1 port: 8086 +drainOpts: + gracePeriodSeconds: 1 + millisecondsBetweenBatches: 500 + minBatchSize: 5 + logLevel: Info logNetStrings: false diff --git a/services/cannon/cannon2.integration.yaml b/services/cannon/cannon2.integration.yaml index d3032eee1d..5c25937652 100644 --- a/services/cannon/cannon2.integration.yaml +++ b/services/cannon/cannon2.integration.yaml @@ -16,5 +16,10 @@ gundeck: host: 127.0.0.1 port: 8086 +drainOpts: + gracePeriodSeconds: 1 + millisecondsBetweenBatches: 5 + minBatchSize: 100 + logLevel: Info logNetStrings: false diff --git a/services/cannon/package.yaml b/services/cannon/package.yaml index dbbe3a73f0..a40cad3fa7 100644 --- a/services/cannon/package.yaml +++ b/services/cannon/package.yaml @@ -26,6 +26,7 @@ library: - data-default >=0.5 - data-timeout >=0.3 - exceptions >=0.6 + - extra - gundeck-types - hashable >=1.2 - http-types >=0.8 @@ -43,6 +44,8 @@ library: - text >=1.1 - tinylog >=0.10 - types-common >=0.16 + - unix + - unliftio - uuid >=1.3 - vector >=0.10 - wai >=3.0 diff --git a/services/cannon/src/Cannon/API/Internal.hs b/services/cannon/src/Cannon/API/Internal.hs index df1f98445c..be9141e791 100644 --- a/services/cannon/src/Cannon/API/Internal.hs +++ b/services/cannon/src/Cannon/API/Internal.hs @@ -1,6 +1,5 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingVia #-} -{-# LANGUAGE StandaloneDeriving #-} -- This file is part of the Wire Server implementation. -- @@ -63,7 +62,7 @@ singlePush n (PushTarget usrid conid) = do case c of Nothing -> do LC.debug $ client (key2bytes k) . msg (val "push: client gone") - return PushStatusGone + pure PushStatusGone Just x -> do e <- wsenv runWS e $ do diff --git a/services/cannon/src/Cannon/App.hs b/services/cannon/src/Cannon/App.hs index f4e08807ca..21d1973aa8 100644 --- a/services/cannon/src/Cannon/App.hs +++ b/services/cannon/src/Cannon/App.hs @@ -47,11 +47,11 @@ data State = State !Int !Timeout newtype TTL = TTL Word64 counter :: Functor f => LensLike' f State Int -counter f (State c p) = (\x -> State x p) `fmap` (f c) +counter f (State c p) = (\x -> State x p) `fmap` f c {-# INLINE counter #-} pingFreq :: Functor f => LensLike' f State Timeout -pingFreq f (State c p) = (\x -> State c x) `fmap` (f p) +pingFreq f (State c p) = (\x -> State c x) `fmap` f p {-# INLINE pingFreq #-} -- | Maximum ping interval in seconds. The ping interval controls @@ -92,14 +92,14 @@ continue ws clock k = do (Right (Left x)) -> let text = client (key2bytes k) . msg (val "write: " +++ show x) in runInIO $ Logger.debug text - _ -> return () + _ -> pure () terminate :: Key -> Websocket -> WS () terminate k ws = do success <- unregisterLocal k ws debug $ client (key2bytes k) ~~ "websocket" .= connIdent ws ~~ "removed" .= success when success $ - close k ws `catchAll` const (return ()) + close k ws `catchAll` const (pure ()) writeLoop :: Websocket -> Clock -> TTL -> IORef State -> IO () writeLoop ws clock (TTL ttl) st = loop @@ -116,7 +116,7 @@ writeLoop ws clock (TTL ttl) st = loop send (connection ws) ping threadDelay $ (10 # Second) `min` (s ^. pingFreq) keepAlive - | otherwise -> return () + | otherwise -> pure () keepAlive = do time <- getTime clock unless (time > ttl) loop @@ -132,14 +132,14 @@ readLoop ws s = loop reset counter s 0 send (connection ws) (pong p) loop - ControlMessage (Close _ _) -> return () + ControlMessage (Close _ _) -> pure () perhapsPingMsg -> do reset counter s 0 when (isAppLevelPing perhapsPingMsg) sendAppLevelPong loop adjustPingFreq p = case fromByteString (toStrict p) of Just i | i > 0 && i < maxPingInterval -> reset pingFreq s (i # Second) - _ -> return () + _ -> pure () -- control messages are internal to the browser that manages the websockets -- . -- since the browser may silently lose a websocket connection, wire clients are allowed send diff --git a/services/cannon/src/Cannon/Dict.hs b/services/cannon/src/Cannon/Dict.hs index 6ba3edea14..a937db8569 100644 --- a/services/cannon/src/Cannon/Dict.hs +++ b/services/cannon/src/Cannon/Dict.hs @@ -24,6 +24,7 @@ module Cannon.Dict removeIf, lookup, size, + toList, ) where @@ -32,13 +33,14 @@ import Data.SizedHashMap (SizedHashMap) import qualified Data.SizedHashMap as SHM import Data.Vector (Vector, (!)) import qualified Data.Vector as V -import Imports hiding (lookup) +import Imports hiding (lookup, toList) newtype Dict a b = Dict - {_map :: Vector (IORef (SizedHashMap a b))} + { _map :: Vector (IORef (SizedHashMap a b)) + } size :: MonadIO m => Dict a b -> m Int -size d = liftIO $ sum <$> mapM (\r -> SHM.size <$> readIORef r) (_map d) +size d = liftIO $ sum <$> mapM (fmap SHM.size . readIORef) (_map d) empty :: MonadIO m => Int -> m (Dict a b) empty w = @@ -68,6 +70,12 @@ removeIf f k d = liftIO . atomicModifyIORef' (getSlice k d) $ \m -> lookup :: (Eq a, Hashable a, MonadIO m) => a -> Dict a b -> m (Maybe b) lookup k = liftIO . fmap (SHM.lookup k) . readIORef . getSlice k +toList :: (MonadIO m, Hashable a) => Dict a b -> m [(a, b)] +toList = + fmap (mconcat . V.toList) + . V.mapM (fmap SHM.toList . readIORef) + . _map + ----------------------------------------------------------------------------- -- Internal diff --git a/services/cannon/src/Cannon/Options.hs b/services/cannon/src/Cannon/Options.hs index e28ebbb294..e2117ee8c3 100644 --- a/services/cannon/src/Cannon/Options.hs +++ b/services/cannon/src/Cannon/Options.hs @@ -29,7 +29,12 @@ module Cannon.Options logLevel, logNetStrings, logFormat, + drainOpts, Opts, + gracePeriodSeconds, + millisecondsBetweenBatches, + minBatchSize, + DrainOpts, ) where @@ -60,12 +65,30 @@ makeFields ''Gundeck deriveApiFieldJSON ''Gundeck +data DrainOpts = DrainOpts + { -- | Maximum amount of time draining should take. Must not be set to 0. + _drainOptsGracePeriodSeconds :: Word64, + -- | Maximum amount of time between batches, this speeds up draining in case + -- there are not many users connected. Must not be set to 0. + _drainOptsMillisecondsBetweenBatches :: Word64, + -- | Batch size is calculated considering actual number of websockets and + -- gracePeriod. If this number is too little, '_drainOptsMinBatchSize' is + -- used. + _drainOptsMinBatchSize :: Word64 + } + deriving (Eq, Show, Generic) + +makeFields ''DrainOpts + +deriveApiFieldJSON ''DrainOpts + data Opts = Opts { _optsCannon :: !Cannon, _optsGundeck :: !Gundeck, _optsLogLevel :: !Level, _optsLogNetStrings :: !(Maybe (Last Bool)), - _optsLogFormat :: !(Maybe (Last LogFormat)) + _optsLogFormat :: !(Maybe (Last LogFormat)), + _optsDrainOpts :: DrainOpts } deriving (Eq, Show, Generic) diff --git a/services/cannon/src/Cannon/Run.hs b/services/cannon/src/Cannon/Run.hs index 6d7ca5a644..635e414a9f 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 qualified Cannon.Dict as D import Cannon.Options -import Cannon.Types (Cannon, applog, clients, mkEnv, monitor, runCannon', runCannonToServant) +import Cannon.Types (Cannon, applog, clients, env, mkEnv, monitor, runCannon', runCannonToServant) import Cannon.WS hiding (env) import qualified Control.Concurrent.Async as Async import Control.Exception.Safe (catchAny) @@ -48,7 +48,10 @@ import Servant import qualified System.IO.Strict as Strict import qualified System.Logger.Class as LC import qualified System.Logger.Extended as L +import System.Posix.Signals +import qualified System.Posix.Signals as Signals import System.Random.MWC (createSystemRandom) +import UnliftIO.Concurrent (myThreadId, throwTo) import qualified Wire.API.Routes.Internal.Cannon as Internal import Wire.API.Routes.Public.Cannon import Wire.API.Routes.Version.Wai @@ -57,15 +60,16 @@ type CombinedAPI = PublicAPI :<|> Internal.API run :: Opts -> IO () run o = do + when (o ^. drainOpts . millisecondsBetweenBatches == 0) $ + error "drainOpts.millisecondsBetweenBatches must not be set to 0." + 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 <$> pure m - <*> pure ext - <*> pure o - <*> pure g - <*> D.empty 128 + mkEnv m ext o g + <$> D.empty 128 <*> newManager defaultManagerSettings {managerConnCount = 128} <*> createSystemRandom <*> mkClock @@ -83,6 +87,9 @@ run o = do server = hoistServer (Proxy @PublicAPI) (runCannonToServant e) publicAPIServer :<|> hoistServer (Proxy @Internal.API) (runCannonToServant e) internalServer + tid <- myThreadId + void $ installHandler sigTERM (signalHandler (env e) tid) Nothing + void $ installHandler sigINT (signalHandler (env e) tid) Nothing runSettings s app `finally` do Async.cancel refreshMetricsThread L.close (applog e) @@ -93,10 +100,20 @@ run o = do loadExternal :: IO ByteString loadExternal = do let extFile = fromMaybe (error "One of externalHost or externalHostFile must be defined") (o ^. cannon . externalHostFile) - fromMaybe (readExternal extFile) (return . encodeUtf8 <$> o ^. cannon . externalHost) + maybe (readExternal extFile) (pure . encodeUtf8) (o ^. cannon . externalHost) readExternal :: FilePath -> IO ByteString readExternal f = encodeUtf8 . strip . pack <$> Strict.readFile f +signalHandler :: Env -> ThreadId -> Signals.Handler +signalHandler e mainThread = CatchOnce $ do + runWS e drain + throwTo mainThread SignalledToExit + +data SignalledToExit = SignalledToExit + deriving (Show) + +instance Exception SignalledToExit + refreshMetrics :: Cannon () refreshMetrics = do m <- monitor diff --git a/services/cannon/src/Cannon/Types.hs b/services/cannon/src/Cannon/Types.hs index 47962a8399..295160a601 100644 --- a/services/cannon/src/Cannon/Types.hs +++ b/services/cannon/src/Cannon/Types.hs @@ -109,7 +109,7 @@ mkEnv :: Env mkEnv m external o l d p g t = Env m o l d def $ - WS.env external (o ^. cannon . port) (encodeUtf8 $ o ^. gundeck . host) (o ^. gundeck . port) l p d g t + 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 = @@ -136,7 +136,7 @@ wsenv :: Cannon WS.Env wsenv = Cannon $ do e <- asks env r <- asks reqId - return $ WS.setRequestId r e + pure $ WS.setRequestId r e logger :: Cannon Logger logger = Cannon $ asks applog diff --git a/services/cannon/src/Cannon/WS.hs b/services/cannon/src/Cannon/WS.hs index caf339eed3..553e9eba8c 100644 --- a/services/cannon/src/Cannon/WS.hs +++ b/services/cannon/src/Cannon/WS.hs @@ -22,6 +22,7 @@ module Cannon.WS WS, env, runWS, + drain, close, mkWebSocket, setRequestId, @@ -50,8 +51,10 @@ import Bilge.RPC import Bilge.Retry import Cannon.Dict (Dict) import qualified Cannon.Dict as D +import Cannon.Options (DrainOpts, gracePeriodSeconds, millisecondsBetweenBatches, minBatchSize) import Conduit import Control.Concurrent.Timeout +import Control.Lens ((^.)) import Control.Monad.Catch import Control.Retry import Data.Aeson hiding (Error, Key) @@ -61,6 +64,7 @@ import qualified Data.ByteString.Lazy as L import Data.Default (def) import Data.Hashable import Data.Id (ClientId, ConnId (..), UserId) +import Data.List.Extra (chunksOf) import Data.Text.Encoding (decodeUtf8) import Data.Timeout (TimeoutUnit (..), (#)) import Gundeck.Types @@ -72,6 +76,7 @@ import Network.WebSockets hiding (Request) import qualified System.Logger as Logger import System.Logger.Class hiding (Error, Settings, close, (.=)) import System.Random.MWC (GenIO, uniform) +import UnliftIO.Async (async, cancel, pooledMapConcurrentlyN_) ----------------------------------------------------------------------------- -- Key @@ -119,7 +124,7 @@ mkClock = do void . forkIO . forever $ do threadDelay (1 # Second) modifyIORef' r (+ 1) - return $ Clock r + pure $ Clock r getClock :: WS Clock getClock = WS $ asks clock @@ -140,7 +145,8 @@ data Env = Env manager :: !Manager, dict :: !(Dict Key Websocket), rand :: !GenIO, - clock :: !Clock + clock :: !Clock, + drainOpts :: DrainOpts } setRequestId :: RequestId -> Env -> Env @@ -185,6 +191,7 @@ env :: Dict Key Websocket -> GenIO -> Clock -> + DrainOpts -> Env env leh lp gh gp = Env leh lp (host gh . port gp $ empty) def @@ -223,7 +230,7 @@ isRemoteRegistered u c = do const $ rpc' "gundeck" (upstream e) (method GET . paths ["/i/presences", toByteString' u] . expect2xx) cs <- map connId <$> parseResponse (mkError status502 "server-error") rs - return $ c `elem` cs + pure $ c `elem` cs sendMsgIO :: (WebSocketsData a) => a -> Websocket -> IO () sendMsgIO m c = @@ -242,6 +249,75 @@ sendMsg message k c = do kb = key2bytes k +-- | Closes all websockets connected to this instance of cannon. +-- +-- This function is not tested anywhere as it is difficult to write an automated +-- test for. Some pointers on testing this function: +-- +-- 1. Set values in cannon.integration.yaml for drainOpts such that it drains +-- "slowly", something like: +-- +-- @ +-- {gracePeriodSeconds: 1, millisecondsBetweenBatches: 500, minBatchSize: 5} +-- @ +-- +-- This will ensure that if there 10 or more websockets open, they get drained +-- in 2 batches of n/2. +-- +-- 2. Write a test in brig or galley using 'bracketRN' function from +-- tasty-cannon. This function doesn't require users to exist. Just pass it n +-- UserIds and threadDelay for a long-ish time. +-- +-- 3. During this threadDelay, send either SIGINT or SIGTERM to the cannon +-- process and use cannon logs to determine what is going on. +-- +-- Example test, which worked at the time of writing this comment: +-- +-- @ +-- testCannonDrain :: Cannon -> Http () +-- testCannonDrain cannon = do +-- users <- replicateM 50 randomId +-- WS.bracketRN cannon users $ \_websockets -> do +-- putStrLn "-------------------> Before delay" +-- threadDelay 100_000_000 +-- putStrLn "-------------------> After delay" +-- putStrLn "-------------------> After bracket" +-- @ +-- +-- Use @pkill -INT -f cannon.integration.yaml@ to send SIGINT to the cannon +-- process. +drain :: WS () +drain = do + opts <- asks drainOpts + websockets <- asks dict + numberOfConns <- fromIntegral <$> D.size websockets + let maxNumberOfBatches = (opts ^. gracePeriodSeconds * 1000) `div` (opts ^. millisecondsBetweenBatches) + computedBatchSize = numberOfConns `div` maxNumberOfBatches + batchSize = max (opts ^. minBatchSize) computedBatchSize + conns <- D.toList websockets + info $ + msg (val "draining all websockets") + . field "numberOfConns" numberOfConns + . field "computedBatchSize" computedBatchSize + . field "minBatchSize" (opts ^. minBatchSize) + . field "batchSize" batchSize + . field "maxNumberOfBatches" maxNumberOfBatches + + -- Sleeps for the grace period + 1 second. If the sleep completes, it means + -- that draining didn't finish, and we should log that. + timeoutAction <- async $ do + -- Allocate 1 second more than the grace period to allow for overhead of + -- spawning threads. + liftIO $ threadDelay ((opts ^. gracePeriodSeconds) # Second + 1 # Second) + err $ msg (val "Drain grace period expired") . field "gracePeriodSeconds" (opts ^. gracePeriodSeconds) + + for_ (chunksOf (fromIntegral batchSize) conns) $ \batch -> do + -- 16 was chosen with a roll of a fair dice. + void . async $ pooledMapConcurrentlyN_ 16 (uncurry close) batch + liftIO $ threadDelay ((opts ^. millisecondsBetweenBatches) # MilliSecond) + cancel timeoutAction + info $ msg (val "Draining complete") + close :: Key -> Websocket -> WS () close k c = do let kb = key2bytes k @@ -254,7 +330,7 @@ regInfo k c = do let h = externalHostname e p = portnum e r = "http://" <> h <> ":" <> pack (show p) <> "/i/push/" - return . lbytes . encode . object $ + pure . lbytes . encode . object $ [ "user_id" .= decodeUtf8 (keyUserBytes k), "device_id" .= decodeUtf8 (keyConnBytes k), "resource" .= decodeUtf8 (r <> keyUserBytes k <> "/" <> keyConnBytes k), diff --git a/services/cannon/test/Test/Cannon/Dict.hs b/services/cannon/test/Test/Cannon/Dict.hs index 051daf847c..0b4b4e8c46 100644 --- a/services/cannon/test/Test/Cannon/Dict.hs +++ b/services/cannon/test/Test/Cannon/Dict.hs @@ -52,16 +52,16 @@ someDict :: ([Key], [ByteString]) -> PropertyM IO (Dict Key ByteString) someDict (ks, vs) = do let entries = zip (List.nub ks) vs d <- run $ D.empty 64 - run $ forM_ entries $ \e -> D.insert (fst e) (snd e) d + run $ forM_ entries $ \e -> uncurry D.insert e d s <- run $ D.size d assertEq "entries length" s (length entries) - return d + pure d insertRemove :: ([Key], [ByteString]) -> PropertyM IO () insertRemove kv = do d <- someDict kv - a <- head <$> (run $ sample' arbitrary) - b <- head <$> (run $ sample' arbitrary) + a <- head <$> run (sample' arbitrary) + b <- head <$> run (sample' arbitrary) exists <- run $ isJust <$> D.lookup a d pre $ not exists x <- run $ D.size d @@ -75,16 +75,16 @@ insertRemove kv = do insertRemoveIf :: ([Key], [ByteString]) -> PropertyM IO () insertRemoveIf kv = do d <- someDict kv - a <- head <$> (run $ sample' arbitrary) - b <- head <$> (run $ sample' arbitrary) + a <- head <$> run (sample' arbitrary) + b <- head <$> run (sample' arbitrary) b' <- run $ do D.insert a b d D.lookup a d pre $ Just b == b' - x <- run $ D.removeIf (maybe False (b ==)) a d + x <- run $ D.removeIf (Just b ==) a d assert x - c <- head <$> (run $ sample' arbitrary) - y <- run $ D.removeIf (maybe False (c ==)) a d + c <- head <$> run (sample' arbitrary) + y <- run $ D.removeIf (Just c ==) a d assert (not y) insertLookup :: Assertion @@ -106,7 +106,7 @@ insertLookup = do assertEq :: (Show a, Eq a, Monad m) => String -> a -> a -> PropertyM m () assertEq m a b - | a == b = return () + | a == b = pure () | otherwise = fail $ "assertEq: " ++ m ++ ": " ++ show a ++ " =/= " ++ show b @@ -115,7 +115,7 @@ samples :: Int -> Gen a -> IO [a] samples n (MkGen f) = do gen <- newQCGen let rands g = g1 : rands g2 where (g1, g2) = split g - return $ [f r i | i <- repeat n, r <- rands gen] + pure $ [f r i | i <- repeat n, r <- rands gen] runProp :: (Show a, Arbitrary a, Testable b) => (a -> PropertyM IO b) -> Property runProp = monadicIO . forAllM arbitrary diff --git a/services/cargohold/src/CargoHold/API/Federation.hs b/services/cargohold/src/CargoHold/API/Federation.hs index 33b8f2f585..934aedca3f 100644 --- a/services/cargohold/src/CargoHold/API/Federation.hs +++ b/services/cargohold/src/CargoHold/API/Federation.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE RecordWildCards #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2022 Wire Swiss GmbH diff --git a/services/cargohold/src/CargoHold/API/Legacy.hs b/services/cargohold/src/CargoHold/API/Legacy.hs index a28da0d79c..d203e52c62 100644 --- a/services/cargohold/src/CargoHold/API/Legacy.hs +++ b/services/cargohold/src/CargoHold/API/Legacy.hs @@ -32,18 +32,18 @@ import URI.ByteString download :: UserId -> ConvId -> AssetId -> Handler (Maybe URI) download _ _ ast = S3.getMetadata ast >>= maybe notFound found where - notFound = return Nothing + notFound = pure Nothing found public = if not public - then return Nothing + then pure Nothing else do url <- genSignedURL (S3.plainKey ast) - return $! Just $! url + pure $! Just $! url downloadOtr :: UserId -> ConvId -> AssetId -> Handler (Maybe URI) downloadOtr _ cnv ast = S3.getOtrMetadata cnv ast >>= maybe notFound found where - notFound = return Nothing + notFound = pure Nothing found _ = do url <- genSignedURL (S3.otrKey cnv ast) - return $! Just $! url + pure $! Just $! url diff --git a/services/cargohold/src/CargoHold/API/Public.hs b/services/cargohold/src/CargoHold/API/Public.hs index 7278124e69..43cc72b1d1 100644 --- a/services/cargohold/src/CargoHold/API/Public.hs +++ b/services/cargohold/src/CargoHold/API/Public.hs @@ -167,7 +167,7 @@ downloadAssetV4 usr qkey tok1 tok2 = qkey deleteAssetV3 :: MakePrincipal tag id => id -> AssetKey -> Handler () -deleteAssetV3 usr key = V3.delete (mkPrincipal usr) key +deleteAssetV3 usr = V3.delete (mkPrincipal usr) deleteAssetV4 :: Local UserId -> Qualified AssetKey -> Handler () deleteAssetV4 usr qkey = do @@ -179,7 +179,7 @@ renewTokenV3 (tUnqualified -> usr) key = NewAssetToken <$> V3.renewToken (V3.UserPrincipal usr) key deleteTokenV3 :: Local UserId -> AssetKey -> Handler () -deleteTokenV3 (tUnqualified -> usr) key = V3.deleteToken (V3.UserPrincipal usr) key +deleteTokenV3 (tUnqualified -> usr) = V3.deleteToken (V3.UserPrincipal usr) legacyDownloadPlain :: Local UserId -> ConvId -> AssetId -> Handler (Maybe (AssetLocation Absolute)) legacyDownloadPlain (tUnqualified -> usr) cnv ast = diff --git a/services/cargohold/src/CargoHold/API/V3.hs b/services/cargohold/src/CargoHold/API/V3.hs index dfd3f7305b..5cd52a6683 100644 --- a/services/cargohold/src/CargoHold/API/V3.hs +++ b/services/cargohold/src/CargoHold/API/V3.hs @@ -37,7 +37,7 @@ import qualified CargoHold.Types.V3 as V3 import CargoHold.Util import qualified Codec.MIME.Parse as MIME import qualified Codec.MIME.Type as MIME -import qualified Conduit as Conduit +import qualified Conduit import Control.Applicative (optional) import Control.Error import Control.Lens (set, view, (^.)) @@ -73,7 +73,7 @@ upload own bdy = do when (cl > maxTotalBytes) $ throwE assetTooLarge ast <- liftIO $ Id <$> nextRandom - tok <- if sets ^. V3.setAssetPublic then return Nothing else Just <$> randToken + tok <- if sets ^. V3.setAssetPublic then pure Nothing else Just <$> randToken let ret = fromMaybe V3.AssetPersistent (sets ^. V3.setAssetRetention) key <- qualifyLocal (V3.AssetKeyV3 ast ret) void $ S3.uploadV3 own (tUnqualified key) hdrs tok src @@ -81,8 +81,8 @@ upload own bdy = do Metrics.s3UploadSize cl expires <- case V3.assetRetentionSeconds ret of Just n -> Just . addUTCTime n <$> liftIO getCurrentTime - Nothing -> return Nothing - return $! V3.mkAsset key + Nothing -> pure Nothing + pure $! V3.mkAsset key & set V3.assetExpires expires & set V3.assetToken tok @@ -90,14 +90,14 @@ renewToken :: V3.Principal -> V3.AssetKey -> Handler V3.AssetToken renewToken own key = do tok <- randToken updateToken own key (Just tok) - return tok + pure tok deleteToken :: V3.Principal -> V3.AssetKey -> Handler () deleteToken own key = updateToken own key Nothing updateToken :: V3.Principal -> V3.AssetKey -> Maybe V3.AssetToken -> Handler () updateToken own key tok = do - m <- S3.getMetadataV3 key >>= maybe (throwE assetNotFound) return + m <- S3.getMetadataV3 key >>= maybe (throwE assetNotFound) pure unless (S3.v3AssetOwner m == own) $ throwE unauthorised let m' = m {S3.v3AssetToken = tok} @@ -118,7 +118,7 @@ checkMetadata mown key tok = do delete :: V3.Principal -> V3.AssetKey -> Handler () delete own key = do - m <- S3.getMetadataV3 key >>= maybe (throwE assetNotFound) return + m <- S3.getMetadataV3 key >>= maybe (throwE assetNotFound) pure unless (S3.v3AssetOwner m == own) $ throwE unauthorised S3.deleteV3 key @@ -156,7 +156,7 @@ assetSettings = do unless (MIME.mimeType ct == MIME.Application "json") $ fail "Invalid metadata Content-Type. Expected 'application/json'." bs <- take (fromIntegral cl) - either fail return (eitherDecodeStrict' bs) + either fail pure (eitherDecodeStrict' bs) metadataHeaders :: Parser (MIME.Type, Word) metadataHeaders = @@ -168,7 +168,7 @@ metadataHeaders = go hdrs = do ct <- contentType hdrs cl <- contentLength hdrs - return (ct, cl) + pure (ct, cl) assetHeaders :: Parser AssetHeaders assetHeaders = @@ -186,14 +186,14 @@ contentType :: [(HeaderName, ByteString)] -> Parser MIME.Type contentType hdrs = maybe (fail "Missing Content-Type") - (maybe (fail "Invalid MIME type") return . MIME.parseMIMEType . decodeLatin1) + (maybe (fail "Invalid MIME type") pure . MIME.parseMIMEType . decodeLatin1) (lookup (CI.mk "Content-Type") hdrs) contentLength :: [(HeaderName, ByteString)] -> Parser Word contentLength hdrs = maybe (fail "Missing Content-Type") - (either fail return . parseOnly decimal) + (either fail pure . parseOnly decimal) (lookup (CI.mk "Content-Length") hdrs) boundary :: Parser () diff --git a/services/cargohold/src/CargoHold/AWS.hs b/services/cargohold/src/CargoHold/AWS.hs index bacb72ac89..f7d0fd2df4 100644 --- a/services/cargohold/src/CargoHold/AWS.hs +++ b/services/cargohold/src/CargoHold/AWS.hs @@ -111,10 +111,10 @@ mkEnv lgr s3End s3Download bucket cfOpts mgr = do let g = Logger.clone (Just "aws.cargohold") lgr e <- mkAwsEnv g (setAWSEndpoint s3End S3.defaultService) cf <- mkCfEnv cfOpts - return (Env g bucket e s3Download cf) + pure (Env g bucket e s3Download cf) where mkCfEnv (Just o) = Just <$> initCloudFront (o ^. cfPrivateKey) (o ^. cfKeyPairId) 300 (o ^. cfDomain) - mkCfEnv Nothing = return Nothing + mkCfEnv Nothing = pure Nothing mkAwsEnv g s3 = do baseEnv <- AWS.newEnv AWS.discover @@ -161,7 +161,7 @@ send :: AWSRequest r => AWS.Env -> r -> Amazon (AWSResponse r) send env r = throwA =<< sendCatch env r throwA :: Either AWS.Error a -> Amazon a -throwA = either (throwM . GeneralError) return +throwA = either (throwM . GeneralError) pure exec :: (AWSRequest r, Show r, MonadLogger m, MonadIO m, MonadThrow m) => @@ -180,7 +180,7 @@ exec env request = do -- We just re-throw the error, but logging it here also gives us the request -- that caused it. throwM (GeneralError err) - Right r -> return r + Right r -> pure r execStream :: (AWSRequest r, Show r) => @@ -215,8 +215,8 @@ execCatch env request = do Log.field "remote" (Log.val "S3") ~~ Log.msg (show err) ~~ Log.msg (show req) - return Nothing - Right r -> return $ Just r + pure Nothing + Right r -> pure $ Just r canRetry :: MonadIO m => Either AWS.Error a -> m Bool canRetry (Right _) = pure False diff --git a/services/cargohold/src/CargoHold/App.hs b/services/cargohold/src/CargoHold/App.hs index 63e4d10baa..bd0635e456 100644 --- a/services/cargohold/src/CargoHold/App.hs +++ b/services/cargohold/src/CargoHold/App.hs @@ -95,11 +95,10 @@ newEnv o = do mgr <- initHttpManager (o ^. optAws . awsS3Compatibility) ama <- initAws (o ^. optAws) lgr mgr let loc = toLocalUnsafe (o ^. optSettings . Opt.setFederationDomain) () - return $ Env ama met lgr mgr def o loc + pure $ Env ama met lgr mgr def o loc initAws :: AWSOpts -> Logger -> Manager -> IO AWS.Env -initAws o l m = - AWS.mkEnv l (o ^. awsS3Endpoint) downloadEndpoint (o ^. awsS3Bucket) (o ^. awsCloudFront) m +initAws o l = AWS.mkEnv l (o ^. awsS3Endpoint) downloadEndpoint (o ^. awsS3Bucket) (o ^. awsCloudFront) where downloadEndpoint = fromMaybe (o ^. awsS3Endpoint) (o ^. awsS3DownloadEndpoint) @@ -136,7 +135,7 @@ initSSLContext = do SSL.contextLoadSystemCerts ctx SSL.contextSetVerificationMode ctx $ SSL.VerifyPeer True True Nothing - return ctx + pure ctx closeEnv :: Env -> IO () closeEnv e = Log.close $ e ^. appLogger diff --git a/services/cargohold/src/CargoHold/CloudFront.hs b/services/cargohold/src/CargoHold/CloudFront.hs index 5ac34b0c5b..be93827aa2 100644 --- a/services/cargohold/src/CargoHold/CloudFront.hs +++ b/services/cargohold/src/CargoHold/CloudFront.hs @@ -74,7 +74,7 @@ signedURL :: (MonadIO m, ToByteString p) => CloudFront -> p -> m URI signedURL (CloudFront base kid ttl clock sign) path = liftIO $ do time <- (+ ttl) . round <$> clock sig <- sign (toStrict (toLazyByteString (policy url time))) - return + pure $! url { uriQuery = Query @@ -105,10 +105,10 @@ sha1Rsa fp = do sha1 <- liftIO $ getDigestByName "SHA1" - >>= maybe (error "OpenSSL: SHA1 not found") return + >>= maybe (error "OpenSSL: SHA1 not found") pure kbs <- readFile fp key <- readPrivateKey kbs PwNone - return (SSL.signBS sha1 key) + pure (SSL.signBS sha1 key) mkPOSIXClock :: IO (IO POSIXTime) mkPOSIXClock = diff --git a/services/cargohold/src/CargoHold/S3.hs b/services/cargohold/src/CargoHold/S3.hs index f0a34a241f..404abb79e8 100644 --- a/services/cargohold/src/CargoHold/S3.hs +++ b/services/cargohold/src/CargoHold/S3.hs @@ -1,5 +1,4 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StrictData #-} -- This file is part of the Wire Server implementation. @@ -51,6 +50,7 @@ import qualified Codec.MIME.Type as MIME import Conduit import Control.Error (ExceptT, throwE) import Control.Lens hiding (parts, (.=), (:<), (:>)) +import Data.Bifunctor (first) import Data.ByteString.Builder (toLazyByteString) import Data.ByteString.Conversion import qualified Data.ByteString.Lazy as LBS @@ -159,13 +159,13 @@ getMetadataV3 (s3Key . mkKey -> key) = do ~~ "asset.key" .= key ~~ msg (val "Getting asset metadata") - maybe (return Nothing) handle =<< execCatch req + maybe (pure Nothing) handle =<< execCatch req where req b = newHeadObject (BucketName b) (ObjectKey key) handle r = do let ct = fromMaybe octets (MIME.parseMIMEType =<< r ^. headObjectResponse_contentType) let meta = HML.toList $ r ^. headObjectResponse_metadata - return $ parse ct meta + pure $ parse ct meta parse ct h = S3AssetMeta <$> getAmzMetaPrincipal h @@ -225,7 +225,7 @@ signedURL path = do ~~ msg (val "Failed to generate a signed URI") ~~ msg (show e) throwE serverError - Right u -> return u + Right u -> pure u mkKey :: V3.AssetKey -> S3AssetKey mkKey (V3.AssetKeyV3 i r) = S3AssetKey $ "v3/" <> retention <> "/" <> key @@ -280,7 +280,7 @@ setAmzMetaPrincipal (V3.ProviderPrincipal p) = setAmzMetaProvider p -- S3 Metadata Getters lookupCI :: (CI.FoldCase a, Eq a) => a -> [(a, b)] -> Maybe b -lookupCI k = lookup (CI.mk k) . fmap (\(a, b) -> (CI.mk a, b)) +lookupCI k = lookup (CI.mk k) . fmap (first CI.mk) getAmzMetaPrincipal :: [(Text, Text)] -> Maybe V3.Principal getAmzMetaPrincipal h = @@ -336,7 +336,7 @@ otrKey c a = S3AssetKey $ "otr/" <> Text.pack (show c) <> "/" <> Text.pack (show getMetadata :: AssetId -> ExceptT Error App (Maybe Bool) getMetadata ast = do r <- execCatch req - return $ parse <$> HML.toList <$> view headObjectResponse_metadata <$> r + pure $ (parse <$> HML.toList) . view headObjectResponse_metadata <$> r where req b = newHeadObject (BucketName b) (ObjectKey . Text.pack $ show ast) parse = @@ -347,6 +347,6 @@ getOtrMetadata :: ConvId -> AssetId -> ExceptT Error App (Maybe UserId) getOtrMetadata cnv ast = do let S3AssetKey key = otrKey cnv ast r <- execCatch (req key) - return $ getAmzMetaUser =<< HML.toList <$> view headObjectResponse_metadata <$> r + pure $ getAmzMetaUser . (HML.toList <$> view headObjectResponse_metadata) =<< r where req k b = newHeadObject (BucketName b) (ObjectKey k) diff --git a/services/cargohold/src/CargoHold/Util.hs b/services/cargohold/src/CargoHold/Util.hs index cbc43db380..f14a6a2b7b 100644 --- a/services/cargohold/src/CargoHold/Util.hs +++ b/services/cargohold/src/CargoHold/Util.hs @@ -32,4 +32,4 @@ genSignedURL path = do view (aws . cloudFront) >>= \case Nothing -> S3.signedURL path Just cf -> CloudFront.signedURL cf path - return $! uri + pure $! uri diff --git a/services/cargohold/test/integration/API.hs b/services/cargohold/test/integration/API.hs index c1c81a0143..39b35dac67 100644 --- a/services/cargohold/test/integration/API.hs +++ b/services/cargohold/test/integration/API.hs @@ -108,7 +108,7 @@ testSimpleRoundtrip = do let Just date = C8.unpack <$> lookup "Date" (responseHeaders r1) let utc = parseTimeOrError False defaultTimeLocale rfc822DateFormat date :: UTCTime -- Potentially check for the expires header - when (isJust $ join (V3.assetRetentionSeconds <$> (sets ^. V3.setAssetRetention))) $ do + when (isJust $ V3.assetRetentionSeconds =<< (sets ^. V3.setAssetRetention)) $ do liftIO $ assertBool "invalid expiration" (Just utc < view V3.assetExpires ast) -- Lookup with token and download via redirect. r2 <- diff --git a/services/cargohold/test/integration/API/V3.hs b/services/cargohold/test/integration/API/V3.hs index 4204510f32..380205bdea 100644 --- a/services/cargohold/test/integration/API/V3.hs +++ b/services/cargohold/test/integration/API/V3.hs @@ -72,7 +72,7 @@ testSimpleRoundtrip = do let Just date = C8.unpack <$> lookup "Date" (responseHeaders r1) let utc = parseTimeOrError False defaultTimeLocale rfc822DateFormat date :: UTCTime -- Potentially check for the expires header - when (isJust $ join (assetRetentionSeconds <$> (sets ^. setAssetRetention))) $ do + when (isJust $ assetRetentionSeconds =<< (sets ^. setAssetRetention)) $ do liftIO $ assertBool "invalid expiration" (Just utc < view assetExpires ast) -- Lookup with token and download via redirect. r2 <- diff --git a/services/cargohold/test/integration/Main.hs b/services/cargohold/test/integration/Main.hs index 419786e39d..ec5be0ba91 100644 --- a/services/cargohold/test/integration/Main.hs +++ b/services/cargohold/test/integration/Main.hs @@ -39,12 +39,12 @@ newtype ServiceConfigFile = ServiceConfigFile String instance IsOption ServiceConfigFile where defaultValue = ServiceConfigFile "/etc/wire/cargohold/conf/cargohold.yaml" parseValue = fmap ServiceConfigFile . safeRead - optionName = return "service-config" - optionHelp = return "Service config file to read from" + optionName = pure "service-config" + optionHelp = pure "Service config file to read from" optionCLParser = fmap ServiceConfigFile $ strOption $ - ( short (untag (return 's' :: Tagged ServiceConfigFile Char)) + ( short (untag (pure 's' :: Tagged ServiceConfigFile Char)) <> long (untag (optionName :: Tagged ServiceConfigFile String)) <> help (untag (optionHelp :: Tagged ServiceConfigFile String)) ) diff --git a/services/federator/src/Federator/Response.hs b/services/federator/src/Federator/Response.hs index 7dac50589d..7cc670ad3d 100644 --- a/services/federator/src/Federator/Response.hs +++ b/services/federator/src/Federator/Response.hs @@ -88,7 +88,7 @@ runWaiError = where logError :: Members '[Error Wai.Error, TinyLog] r => Wai.Error -> Sem r a logError e = do - err $ Wai.logErrorMsg Nothing e + err $ Wai.logErrorMsg e throw e serve :: diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index 07dd05a2cd..f9c9339e90 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -210,6 +210,7 @@ library , http-types >=0.8 , imports , insert-ordered-containers + , kan-extensions , lens >=4.4 , memory , metrics-wai >=0.4 @@ -437,6 +438,7 @@ executable galley-integration , http-media , http-types , imports + , kan-extensions , lens , lens-aeson , metrics-wai diff --git a/services/galley/package.yaml b/services/galley/package.yaml index 003df7f883..7a8b3f658d 100644 --- a/services/galley/package.yaml +++ b/services/galley/package.yaml @@ -61,6 +61,7 @@ library: - http-media - http-types >=0.8 - insert-ordered-containers + - kan-extensions - lens >=4.4 - memory - metrics-wai >=0.4 @@ -193,6 +194,7 @@ executables: - http-client-tls - http-media - http-types + - kan-extensions - lens - lens-aeson - mtl diff --git a/services/galley/src/Galley/API/Clients.hs b/services/galley/src/Galley/API/Clients.hs index 7031614419..c4d4859a38 100644 --- a/services/galley/src/Galley/API/Clients.hs +++ b/services/galley/src/Galley/API/Clients.hs @@ -50,7 +50,7 @@ getClients usr = do if isInternal then fromUserClients <$> E.lookupClients [usr] else E.getClients [usr] - return $ clientIds usr clts + pure (clientIds usr clts) addClientH :: Member ClientStore r => @@ -58,7 +58,7 @@ addClientH :: Sem r Response addClientH (usr ::: clt) = do E.createClient usr clt - return empty + pure empty rmClientH :: Member ClientStore r => @@ -66,4 +66,4 @@ rmClientH :: Sem r Response rmClientH (usr ::: clt) = do E.deleteClient usr clt - return empty + pure empty diff --git a/services/galley/src/Galley/API/Create.hs b/services/galley/src/Galley/API/Create.hs index c7b3933743..d3148350e9 100644 --- a/services/galley/src/Galley/API/Create.hs +++ b/services/galley/src/Galley/API/Create.hs @@ -426,35 +426,34 @@ createConnectConversation lusr conn j = do update n conv = do let mems = Data.convLocalMembers conv in conversationExisted lusr - =<< if - | (tUnqualified lusr) `isMember` mems -> - -- we already were in the conversation, maybe also other - connect n conv - | otherwise -> do - let lcid = qualifyAs lusr (Data.convId conv) - mm <- E.createMember lcid lusr - let conv' = - conv - { Data.convLocalMembers = Data.convLocalMembers conv <> toList mm - } - if null mems - then do - -- the conversation was empty - connect n conv' - else do - -- we were not in the conversation, but someone else - conv'' <- acceptOne2One lusr conv' conn - if Data.convType conv'' == ConnectConv - then connect n conv'' - else return conv'' + =<< if tUnqualified lusr `isMember` mems + then -- we already were in the conversation, maybe also other + connect n conv + else do + let lcid = qualifyAs lusr (Data.convId conv) + mm <- E.createMember lcid lusr + let conv' = + conv + { Data.convLocalMembers = Data.convLocalMembers conv <> toList mm + } + if null mems + then do + -- the conversation was empty + connect n conv' + else do + -- we were not in the conversation, but someone else + conv'' <- acceptOne2One lusr conv' conn + if Data.convType conv'' == ConnectConv + then connect n conv'' + else pure conv'' connect n conv | Data.convType conv == ConnectConv = do let lcnv = qualifyAs lusr (Data.convId conv) n' <- case n of Just x -> do E.setConversationName (Data.convId conv) x - return . Just $ fromRange x - Nothing -> return $ Data.convName conv + pure . Just $ fromRange x + Nothing -> pure $ Data.convName conv t <- input let e = Event (qUntagged lcnv) (qUntagged lusr) t (EdConnect j) for_ (newPushLocal ListComplete (tUnqualified lusr) (ConvEvent e) (recipient <$> Data.convLocalMembers conv)) $ \p -> @@ -463,7 +462,7 @@ createConnectConversation lusr conn j = do & pushRoute .~ RouteDirect & pushConn .~ conn pure $ Data.convSetName n' conv - | otherwise = return conv + | otherwise = pure conv -------------------------------------------------------------------------------- -- Conversation creation records @@ -525,7 +524,7 @@ notifyCreatedConversation :: Data.Conversation -> Sem r () notifyCreatedConversation dtime lusr conn c = do - now <- maybe (input) pure dtime + now <- maybe input pure dtime -- FUTUREWORK: Handle failures in notifying so it does not abort half way -- through (either when notifying remotes or locals) -- @@ -542,7 +541,7 @@ notifyCreatedConversation dtime lusr conn c = do let lconv = qualifyAs lusr (Data.convId c) c' <- conversationView (qualifyAs lusr (lmId m)) c let e = Event (qUntagged lconv) (qUntagged lusr) t (EdConversation c') - return $ + pure $ newPushLocal1 ListComplete (tUnqualified lusr) (ConvEvent e) (list1 (recipient m) []) & pushConn .~ conn & pushRoute .~ route @@ -564,7 +563,7 @@ toUUIDs :: toUUIDs a b = do a' <- U.fromUUID (toUUID a) & note InvalidUUID4 b' <- U.fromUUID (toUUID b) & note InvalidUUID4 - return (a', b') + pure (a', b') accessRoles :: NewConv -> Set AccessRoleV2 accessRoles b = fromMaybe Data.defRole (newConvAccessRoles b) diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index bbfd6642e8..9a3e1a55e2 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -19,6 +19,7 @@ module Galley.API.Federation where import Brig.Types.Connection (Relation (Accepted)) +import Control.Error import Control.Lens (itraversed, (<.>)) import Data.ByteString.Conversion (toByteString') import Data.Containers.ListUtils (nubOrd) @@ -32,13 +33,15 @@ import Data.Qualified import Data.Range (Range (fromRange)) import qualified Data.Set as Set import Data.Singletons (SingI (..), demote, sing) +import Data.Tagged import qualified Data.Text.Lazy as LT import Data.Time.Clock import Galley.API.Action import Galley.API.Error +import Galley.API.MLS.KeyPackage +import Galley.API.MLS.Welcome import qualified Galley.API.Mapping as Mapping import Galley.API.Message -import Galley.API.Push import Galley.API.Util import Galley.App import qualified Galley.Data.Conversation as Data @@ -72,6 +75,9 @@ import Wire.API.Federation.API.Common (EmptyResponse (..)) import Wire.API.Federation.API.Galley (ConversationUpdateResponse) import qualified Wire.API.Federation.API.Galley as F import Wire.API.Federation.Error +import Wire.API.MLS.Credential +import Wire.API.MLS.Serialisation +import Wire.API.MLS.Welcome import Wire.API.Routes.Internal.Brig.Connection import Wire.API.Routes.Named import Wire.API.ServantProto @@ -290,7 +296,7 @@ leaveConversation requestingDomain lc = do pure (update, conv) case res of - Left err -> pure $ F.LeaveConversationResponse (Left err) + Left e -> pure $ F.LeaveConversationResponse (Left e) Right (_update, conv) -> do let action = pure (qUntagged leaver) @@ -299,7 +305,6 @@ leaveConversation requestingDomain lc = do _event <- notifyConversationAction SConversationLeaveTag (qUntagged leaver) Nothing lcnv botsAndMembers action pure $ F.LeaveConversationResponse (Right ()) - where -- FUTUREWORK: report errors to the originating backend -- FUTUREWORK: error handling for missing / mismatched clients @@ -529,26 +534,32 @@ instance mlsSendWelcome :: Members - '[ GundeckAccess, + '[ BrigAccess, + Error InternalError, + GundeckAccess, Input (Local ()), Input UTCTime ] r => Domain -> F.MLSWelcomeRequest -> - Sem r () -mlsSendWelcome _origDomain (F.MLSWelcomeRequest b64RawWelcome rcpts) = do - loc <- input @(Local ()) - now <- input @UTCTime - let rawWelcome = fromBase64ByteString b64RawWelcome - void $ - runMessagePush loc Nothing $ - foldMap (uncurry $ mkPush rawWelcome loc now) (F.unMLSWelRecipient <$> rcpts) - where - mkPush :: ByteString -> Local x -> UTCTime -> UserId -> ClientId -> MessagePush 'Broadcast - mkPush rawWelcome l time u c = - -- FUTUREWORK: use the conversation ID stored in the key package mapping table - let lcnv = qualifyAs l (Data.selfConv u) - lusr = qualifyAs l u - e = Event (qUntagged lcnv) (qUntagged lusr) time $ EdMLSWelcome rawWelcome - in newMessagePush l () Nothing defMessageMetadata (u, c) e + Sem r EmptyResponse +mlsSendWelcome _origDomain (fromBase64ByteString . F.unMLSWelcomeRequest -> rawWelcome) = do + loc <- qualifyLocal () + now <- input + welcome <- either (throw . InternalErrorWithDescription . LT.fromStrict) pure $ decodeMLS' rawWelcome + -- Extract only recipients local to this backend + rcpts <- + fmap catMaybes $ + traverse + ( fmap (fmap cidQualifiedClient . hush) + . runError @(Tagged 'MLSKeyPackageRefNotFound ()) + . derefKeyPackage + . gsNewMember + ) + $ welSecrets welcome + let lrcpts = qualifyAs loc $ fst $ partitionQualified loc rcpts + + sendLocalWelcomes Nothing now rawWelcome lrcpts + + pure EmptyResponse diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index f4fdf6f691..c267fc2846 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -443,7 +443,7 @@ featureAPI = internalSitemap :: Routes a (Sem GalleyEffects) () internalSitemap = do -- Conversation API (internal) ---------------------------------------- - put "/i/conversations/:cnv/channel" (continue $ const (return empty)) $ + put "/i/conversations/:cnv/channel" (continue $ const (pure empty)) $ zauthUserId .&. (capture "cnv" :: HasCaptures r => Predicate r Predicate.Error ConvId) .&. request @@ -581,7 +581,7 @@ rmUser lusr conn = do cc <- getConversations ids now <- input pp <- for cc $ \c -> case Data.convType c of - SelfConv -> return Nothing + SelfConv -> pure Nothing One2OneConv -> deleteMembers (Data.convId c) (UserList [tUnqualified lusr] []) $> Nothing ConnectConv -> deleteMembers (Data.convId c) (UserList [tUnqualified lusr] []) $> Nothing RegularConv @@ -598,7 +598,7 @@ rmUser lusr conn = do Intra.newPushLocal ListComplete (tUnqualified lusr) (Intra.ConvEvent e) (Intra.recipient <$> Data.convLocalMembers c) <&> set Intra.pushConn conn . set Intra.pushRoute Intra.RouteDirect - | otherwise -> return Nothing + | otherwise -> pure Nothing for_ (maybeList1 (catMaybes pp)) diff --git a/services/galley/src/Galley/API/LegalHold.hs b/services/galley/src/Galley/API/LegalHold.hs index dc7af811cd..8e7823ee6e 100644 --- a/services/galley/src/Galley/API/LegalHold.hs +++ b/services/galley/src/Galley/API/LegalHold.hs @@ -105,7 +105,7 @@ isLegalHoldEnabledForTeam tid = do FeatureLegalHoldDisabledByDefault -> do statusValue <- Public.tfwoStatus <$$> TeamFeatures.getFeatureStatusNoConfig @'Public.TeamFeatureLegalHold tid - return $ case statusValue of + pure $ case statusValue of Just Public.TeamFeatureEnabled -> True Just Public.TeamFeatureDisabled -> False Nothing -> False @@ -471,7 +471,7 @@ requestDevice lzusr tid uid = do LegalHoldData.dropPendingPrekeys (tUnqualified luid) lhDevice <- LHService.requestNewDevice tid (tUnqualified luid) let NewLegalHoldClient prekeys lastKey = lhDevice - return (lastKey, prekeys) + pure (lastKey, prekeys) -- | Approve the adding of a Legal Hold device to the user. -- diff --git a/services/galley/src/Galley/API/MLS/Welcome.hs b/services/galley/src/Galley/API/MLS/Welcome.hs index b8445b62cb..65194d085c 100644 --- a/services/galley/src/Galley/API/MLS/Welcome.hs +++ b/services/galley/src/Galley/API/MLS/Welcome.hs @@ -15,9 +15,14 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS.Welcome (postMLSWelcome) where +module Galley.API.MLS.Welcome + ( postMLSWelcome, + sendLocalWelcomes, + ) +where import Control.Comonad +import Data.Domain import Data.Id import Data.Json.Util import Data.Qualified @@ -29,13 +34,17 @@ import Galley.Effects.BrigAccess import Galley.Effects.FederatorAccess import Galley.Effects.GundeckAccess import Imports +import Network.Wai.Utilities.Server import Polysemy import Polysemy.Input +import qualified Polysemy.TinyLog as P +import qualified System.Logger.Class as Logger import Wire.API.Error import Wire.API.Error.Galley import Wire.API.Event.Conversation import Wire.API.Federation.API import Wire.API.Federation.API.Galley +import Wire.API.Federation.Error import Wire.API.MLS.Credential import Wire.API.MLS.Serialisation import Wire.API.MLS.Welcome @@ -46,7 +55,8 @@ postMLSWelcome :: FederatorAccess, GundeckAccess, ErrorS 'MLSKeyPackageRefNotFound, - Input UTCTime + Input UTCTime, + P.TinyLog ] r => Local UserId -> @@ -54,8 +64,11 @@ postMLSWelcome :: RawMLS Welcome -> Sem r () postMLSWelcome lusr con wel = do + now <- input rcpts <- welcomeRecipients (rmValue wel) - traverse_ (sendWelcomes lusr con (rmRaw wel)) (bucketQualified rcpts) + let (locals, remotes) = partitionQualified lusr rcpts + sendLocalWelcomes (Just con) now (rmRaw wel) (qualifyAs lusr locals) + sendRemoteWelcomes (rmRaw wel) remotes welcomeRecipients :: Members @@ -73,25 +86,9 @@ welcomeRecipients = ) . welSecrets -sendWelcomes :: - Members - '[ FederatorAccess, - GundeckAccess, - Input UTCTime - ] - r => - Local x -> - ConnId -> - ByteString -> - Qualified [(UserId, ClientId)] -> - Sem r () -sendWelcomes loc con rawWelcome recipients = do - now <- input - foldQualified loc (sendLocalWelcomes con now rawWelcome) (sendRemoteWelcomes rawWelcome) recipients - sendLocalWelcomes :: Members '[GundeckAccess] r => - ConnId -> + Maybe ConnId -> UTCTime -> ByteString -> Local [(UserId, ClientId)] -> @@ -106,18 +103,28 @@ sendLocalWelcomes con now rawWelcome lclients = do let lcnv = qualifyAs lclients (selfConv u) lusr = qualifyAs lclients u e = Event (qUntagged lcnv) (qUntagged lusr) now $ EdMLSWelcome rawWelcome - in newMessagePush lclients () (Just con) defMessageMetadata (u, c) e + in newMessagePush lclients () con defMessageMetadata (u, c) e sendRemoteWelcomes :: - Members '[FederatorAccess] r => + Members + '[ FederatorAccess, + P.TinyLog + ] + r => ByteString -> - Remote [(UserId, ClientId)] -> + [Remote (UserId, ClientId)] -> Sem r () -sendRemoteWelcomes rawWelcome rClients = do - let req = - MLSWelcomeRequest - { mwrRawWelcome = Base64ByteString rawWelcome, - mwrRecipients = MLSWelcomeRecipient <$> tUnqualified rClients - } +sendRemoteWelcomes rawWelcome clients = do + let req = MLSWelcomeRequest . Base64ByteString $ rawWelcome rpc = fedClient @'Galley @"mls-welcome" req - void $ runFederated rClients rpc + (traverse_ handleError =<<) + . runFederatedConcurrentlyEither clients + $ \_ -> rpc + where + handleError :: Member P.TinyLog r => Either (Remote [a], FederationError) x -> Sem r () + handleError (Right _) = pure () + handleError (Left (r, e)) = + P.warn $ + Logger.msg ("A welcome message could not be delivered to a remote backend" :: ByteString) + . Logger.field "remote_domain" (domainText (tDomain r)) + . (logErrorMsg (toWai e)) diff --git a/services/galley/src/Galley/API/Mapping.hs b/services/galley/src/Galley/API/Mapping.hs index aae65f2de3..3481feb6f6 100644 --- a/services/galley/src/Galley/API/Mapping.hs +++ b/services/galley/src/Galley/API/Mapping.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE RecordWildCards #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2022 Wire Swiss GmbH @@ -39,7 +37,7 @@ import Polysemy import Polysemy.Error import qualified Polysemy.TinyLog as P import System.Logger.Message (msg, val, (+++)) -import Wire.API.Conversation hiding (Member (..)) +import Wire.API.Conversation import qualified Wire.API.Conversation as Conversation import Wire.API.Federation.API.Galley diff --git a/services/galley/src/Galley/API/Public.hs b/services/galley/src/Galley/API/Public.hs index 4fe677e653..3c795bfcde 100644 --- a/services/galley/src/Galley/API/Public.hs +++ b/services/galley/src/Galley/API/Public.hs @@ -110,24 +110,6 @@ errorSResponse = errorResponse (toWai (dynError @(MapError e))) sitemap :: Routes ApiBuilder (Sem GalleyEffects) () sitemap = do - -- Team Member API ----------------------------------------------------- - - get "/teams/:tid/members/csv" (continueE Teams.getTeamMembersCSVH) $ - -- we could discriminate based on accept header only, but having two paths makes building - -- nginz metrics dashboards easier. - zauthUserId - .&. capture "tid" - .&. accept "text" "csv" - document "GET" "getTeamMembersCSV" $ do - summary "Get all members of the team as a CSV file" - notes - "The endpoint returns data in chunked transfer encoding.\ - \ Internal server errors might result in a failed transfer instead of a 500 response." - parameter Path "tid" bytes' $ - description "Team ID" - response 200 "Team members CSV file" end - errorSResponse @'AccessDenied - get "/teams/notifications" (continueE Teams.getTeamNotificationsH) $ zauthUserId .&. opt (query "since") @@ -213,12 +195,12 @@ filterMissing :: HasQuery r => Predicate r P.Error Public.OtrFilterMissing filterMissing = (>>= go) <$> (query "ignore_missing" ||| query "report_missing") where go (Left ign) = case fromByteString ign of - Just True -> return Public.OtrIgnoreAllMissing - Just False -> return Public.OtrReportAllMissing + Just True -> pure Public.OtrIgnoreAllMissing + Just False -> pure Public.OtrReportAllMissing Nothing -> Public.OtrIgnoreMissing <$> users "ignore_missing" ign go (Right rep) = case fromByteString rep of - Just True -> return Public.OtrReportAllMissing - Just False -> return Public.OtrIgnoreAllMissing + Just True -> pure Public.OtrReportAllMissing + Just False -> pure Public.OtrIgnoreAllMissing Nothing -> Public.OtrReportMissing <$> users "report_missing" rep users :: ByteString -> ByteString -> P.Result P.Error (Set UserId) users src bs = case fromByteString bs of diff --git a/services/galley/src/Galley/API/Public/Servant.hs b/services/galley/src/Galley/API/Public/Servant.hs index c98c887cd8..ca4e5c0d7b 100644 --- a/services/galley/src/Galley/API/Public/Servant.hs +++ b/services/galley/src/Galley/API/Public/Servant.hs @@ -228,8 +228,8 @@ servantSitemap = setSndFactorPasswordChallengeInternal . DoAuth ) - <@> mkNamedAPI @"get-all-feature-configs" getAllFeatureConfigs - <@> mkNamedAPI @"get-all-features" (\luid tid -> AllFeatureConfigs <$> getAllFeatures luid tid) + <@> mkNamedAPI @"get-all-feature-configs" getAllFeatureConfigsForUser + <@> mkNamedAPI @"get-all-features" getAllFeatureConfigsForTeam <@> mkNamedAPI @'("get-config", 'TeamFeatureLegalHold) ( getFeatureConfig @'WithoutLockStatus @'TeamFeatureLegalHold getLegalholdStatusInternal @@ -307,3 +307,4 @@ servantSitemap = <@> mkNamedAPI @"delete-team-member" deleteTeamMember <@> mkNamedAPI @"delete-non-binding-team-member" deleteNonBindingTeamMember <@> mkNamedAPI @"update-team-member" updateTeamMember + <@> mkNamedAPI @"get-team-members-csv" getTeamMembersCSV diff --git a/services/galley/src/Galley/API/Query.hs b/services/galley/src/Galley/API/Query.hs index dbd6cf86a2..9ea2ca16b6 100644 --- a/services/galley/src/Galley/API/Query.hs +++ b/services/galley/src/Galley/API/Query.hs @@ -381,7 +381,7 @@ getConversationsInternal luser mids mstart msize = do let localConvIds = ids cs <- E.getConversations localConvIds - >>= filterM (removeDeleted) + >>= filterM removeDeleted >>= filterM (pure . isMember (tUnqualified luser) . Data.convLocalMembers) pure $ Public.ConversationList cs more where diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index 283279c6d3..dfd9ed97f9 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -14,6 +14,7 @@ -- -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . +{-# LANGUAGE LambdaCase #-} module Galley.API.Teams ( createBindingTeam, @@ -32,7 +33,7 @@ module Galley.API.Teams getTeamNotificationsH, getTeamConversationRoles, getTeamMembers, - getTeamMembersCSVH, + getTeamMembersCSV, bulkGetTeamMembers, getTeamMember, deleteTeamMember, @@ -114,7 +115,6 @@ import Galley.Types.Teams.Intra import Galley.Types.Teams.SearchVisibility import Galley.Types.UserList import Imports hiding (forkIO) -import Network.HTTP.Types import Network.Wai import Network.Wai.Predicate hiding (Error, or, result, setStatus) import Network.Wai.Utilities hiding (Error) @@ -294,11 +294,11 @@ updateTeamStatus tid (TeamStatusUpdate newStatus cur) = do journal _ _ = throwS @'InvalidTeamStatusUpdate validateTransition :: Member (ErrorS 'InvalidTeamStatusUpdate) r => (TeamStatus, TeamStatus) -> Sem r Bool validateTransition = \case - (PendingActive, Active) -> return True - (Active, Active) -> return False - (Active, Suspended) -> return True - (Suspended, Active) -> return True - (Suspended, Suspended) -> return False + (PendingActive, Active) -> pure True + (Active, Active) -> pure False + (Active, Suspended) -> pure True + (Suspended, Active) -> pure True + (Suspended, Suspended) -> pure False (_, _) -> throwS @'InvalidTeamStatusUpdate updateTeamH :: @@ -327,7 +327,7 @@ updateTeamH zusr zcon tid updateData = do memList <- getTeamMembersForFanout tid let e = newEvent tid now (EdTeamUpdate updateData) let r = list1 (userRecipient zusr) (membersToRecipients (Just zusr) (memList ^. teamMembers)) - E.push1 $ newPushLocal1 (memList ^. teamMemberListType) zusr (TeamEvent e) r & pushConn .~ Just zcon + E.push1 $ newPushLocal1 (memList ^. teamMemberListType) zusr (TeamEvent e) r & pushConn ?~ zcon deleteTeam :: forall r. @@ -358,7 +358,7 @@ deleteTeam zusr zcon tid body = do where checkPermissions team = do void $ permissionCheck DeleteTeam =<< E.getTeamMember tid zusr - when ((tdTeam team) ^. teamBinding == Binding) $ do + when (tdTeam team ^. teamBinding == Binding) $ do ensureReAuthorised zusr (body ^. tdAuthPassword) (body ^. tdVerificationCode) (Just U.DeleteTeam) -- This can be called by stern @@ -439,8 +439,8 @@ uncheckedDeleteTeam lusr zcon tid = do -- To avoid DoS on gundeck, send team deletion events in chunks let chunkSize = fromMaybe defConcurrentDeletionEvents (o ^. setConcurrentDeletionEvents) let chunks = List.chunksOf chunkSize (toList r) - forM_ chunks $ \chunk -> case chunk of - [] -> return () + forM_ chunks $ \case + [] -> pure () -- push TeamDelete events. Note that despite having a complete list, we are guaranteed in the -- push module to never fan this out to more than the limit x : xs -> E.push1 (newPushLocal1 ListComplete (tUnqualified lusr) (TeamEvent e) (list1 x xs) & pushConn .~ zcon) @@ -497,12 +497,13 @@ outputToStreamingBody action = withWeavingToFinal @IO $ \state weave _inspect -> flush void . weave . (<$ state) $ runOutputSem writeChunk action -getTeamMembersCSVH :: +getTeamMembersCSV :: (Members '[BrigAccess, ErrorS 'AccessDenied, TeamMemberStore InternalPaging, TeamStore, Final IO] r) => - UserId ::: TeamId ::: JSON -> - Sem r Response -getTeamMembersCSVH (zusr ::: tid ::: _) = do - E.getTeamMember tid zusr >>= \case + Local UserId -> + TeamId -> + Sem r StreamingBody +getTeamMembersCSV lusr tid = do + E.getTeamMember tid (tUnqualified lusr) >>= \case Nothing -> throwS @'AccessDenied Just member -> unless (member `hasPermission` DownloadTeamMembersCsv) $ throwS @'AccessDenied @@ -510,7 +511,7 @@ getTeamMembersCSVH (zusr ::: tid ::: _) = do -- the response will not contain a correct error message, but rather be an -- http error such as 'InvalidChunkHeaders'. The exception however still -- reaches the middleware and is being tracked in logging and metrics. - body <- outputToStreamingBody $ do + outputToStreamingBody $ do output headerLine E.withChunks (\mps -> E.listTeamMembers @InternalPaging tid mps maxBound) $ \members -> do @@ -519,18 +520,12 @@ getTeamMembersCSVH (zusr ::: tid ::: _) = do lookupUser <$> E.lookupActivatedUsers (fmap (view userId) members) richInfos <- lookupRichInfo <$> E.getRichInfoMultiUser (fmap (view userId) members) + numUserClients <- lookupClients <$> E.lookupClients (fmap (view userId) members) output @LByteString ( encodeDefaultOrderedByNameWith defaultEncodeOptions - (mapMaybe (teamExportUser users inviters richInfos) members) + (mapMaybe (teamExportUser users inviters richInfos numUserClients) members) ) - pure $ - responseStream - status200 - [ (hContentType, "text/csv"), - ("Content-Disposition", "attachment; filename=\"wire_team_members.csv\"") - ] - body where headerLine :: LByteString headerLine = encodeDefaultOrderedByNameWith (defaultEncodeOptions {encIncludeHeader = True}) ([] :: [TeamExportUser]) @@ -548,9 +543,10 @@ getTeamMembersCSVH (zusr ::: tid ::: _) = do (UserId -> Maybe User) -> (UserId -> Maybe Handle.Handle) -> (UserId -> Maybe RichInfo) -> + (UserId -> Int) -> TeamMember -> Maybe TeamExportUser - teamExportUser users inviters richInfos member = do + teamExportUser users inviters richInfos numClients member = do let uid = member ^. userId user <- users uid pure $ @@ -566,7 +562,8 @@ getTeamMembersCSVH (zusr ::: tid ::: _) = do tExportSAMLNamedId = fromMaybe "" (samlNamedId user), tExportSCIMExternalId = fromMaybe "" (userSCIMExternalId user), tExportSCIMRichInfo = richInfos uid, - tExportUserId = U.userId user + tExportUserId = U.userId user, + tExportNumDevices = numClients uid } lookupInviterHandle :: Member BrigAccess r => [TeamMember] -> Sem r (UserId -> Maybe Handle.Handle) @@ -595,6 +592,9 @@ getTeamMembersCSVH (zusr ::: tid ::: _) = do lookupRichInfo :: [(UserId, RichInfo)] -> (UserId -> Maybe RichInfo) lookupRichInfo pairs = (`M.lookup` M.fromList pairs) + lookupClients :: Conv.UserClients -> UserId -> Int + lookupClients userClients uid = maybe 0 length (M.lookup uid (Conv.userClients userClients)) + samlNamedId :: User -> Maybe Text samlNamedId = userSSOId >=> \case @@ -653,7 +653,7 @@ uncheckedGetTeamMembers :: TeamId -> Range 1 HardTruncationLimit Int32 -> Sem r TeamMemberList -uncheckedGetTeamMembers tid maxResults = E.getTeamMembersWithLimit tid maxResults +uncheckedGetTeamMembers = E.getTeamMembersWithLimit addTeamMember :: Members @@ -813,7 +813,7 @@ updateTeamMember lzusr zcon tid newMember = do let ePriv = newEvent tid now privilegedUpdate -- push to all members (user is privileged) let pushPriv = newPushLocal (updatedMembers ^. teamMemberListType) zusr (TeamEvent ePriv) $ privilegedRecipients - for_ pushPriv $ \p -> E.push1 $ p & pushConn .~ Just zcon + for_ pushPriv $ \p -> E.push1 $ p & pushConn ?~ zcon deleteTeamMember :: Members @@ -1131,7 +1131,7 @@ ensureUnboundUsers uids = do -- can only be part of one team. teams <- Map.elems <$> E.getUsersTeams uids binds <- E.getTeamsBindings teams - when (any (== Binding) binds) $ + when (Binding `elem` binds) $ throwS @'UserBindingExists ensureNonBindingTeam :: @@ -1140,7 +1140,7 @@ ensureNonBindingTeam :: Sem r () ensureNonBindingTeam tid = do team <- noteS @'TeamNotFound =<< E.getTeam tid - when ((tdTeam team) ^. teamBinding == Binding) $ + when (tdTeam team ^. teamBinding == Binding) $ throwS @'NoAddToBinding -- ensure that the permissions are not "greater" than the user's copy permissions @@ -1162,7 +1162,7 @@ ensureNotTooLarge tid = do (TeamSize size) <- E.getSize tid unless (size < fromIntegral (o ^. optSettings . setMaxTeamSize)) $ throwS @'TooManyTeamMembers - return $ TeamSize size + pure $ TeamSize size -- | Ensure that a team doesn't exceed the member count limit for the LegalHold -- feature. A team with more members than the fanout limit is too large, because @@ -1240,7 +1240,7 @@ addTeamMemberInternal tid origin originConn (ntmNewTeamMember -> new) memList = E.push1 $ newPushLocal1 (memList ^. teamMemberListType) (new ^. userId) (TeamEvent e) (recipients origin new) & pushConn .~ originConn APITeamQueue.pushTeamEvent tid e - return sizeBeforeAdd + pure sizeBeforeAdd where recipients (Just o) n = list1 diff --git a/services/galley/src/Galley/API/Teams/Features.hs b/services/galley/src/Galley/API/Teams/Features.hs index c8acdc510b..060eeac741 100644 --- a/services/galley/src/Galley/API/Teams/Features.hs +++ b/services/galley/src/Galley/API/Teams/Features.hs @@ -14,15 +14,14 @@ -- -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -{-# LANGUAGE RecordWildCards #-} module Galley.API.Teams.Features ( getFeatureStatus, getFeatureStatusNoConfig, setFeatureStatus, getFeatureConfig, - getAllFeatureConfigs, - getAllFeatures, + getAllFeatureConfigsForUser, + getAllFeatureConfigsForTeam, getSSOStatusInternal, setSSOStatusInternal, getLegalholdStatusInternal, @@ -54,17 +53,13 @@ module Galley.API.Teams.Features DoAuth (..), FeatureGetter, FeatureSetter, - GetFeatureInternalParam, + FeatureScope, guardSecondFactorDisabled, ) where import Control.Lens -import qualified Data.Aeson as Aeson -import qualified Data.Aeson.Key as AesonKey -import qualified Data.Aeson.KeyMap as KeyMap import Data.ByteString.Conversion hiding (fromList) -import Data.Either.Extra (eitherToMaybe) import Data.Id import Data.Proxy (Proxy (Proxy)) import Data.Qualified @@ -106,7 +101,12 @@ import Wire.API.Team.Feature data DoAuth = DoAuth UserId | DontDoAuth -type FeatureGetter l f r = Tagged '(l, f) (GetFeatureInternalParam -> Sem r (TeamFeatureStatus l f)) +data FeatureScope + = FeatureScopeServer + | FeatureScopeTeam TeamId + | FeatureScopeUser UserId + +type FeatureGetter l f r = Tagged '(l, f) (FeatureScope -> Sem r (TeamFeatureStatus l f)) type FeatureSetter f r = Tagged @@ -140,7 +140,7 @@ getFeatureStatus (Tagged getter) doauth tid = do void $ permissionCheck ViewTeamFeature zusrMembership DontDoAuth -> assertTeamExists tid - getter (Right tid) + getter (FeatureScopeTeam tid) -- | For team-settings, like 'getFeatureStatus'. setFeatureStatus :: @@ -208,14 +208,16 @@ getFeatureConfig :: getFeatureConfig (Tagged getter) zusr = do mbTeam <- getOneUserTeam zusr case mbTeam of - Nothing -> getter (Left (Just zusr)) + Nothing -> getter (FeatureScopeUser zusr) Just tid -> do zusrMembership <- getTeamMember tid zusr void $ permissionCheck ViewTeamFeature zusrMembership assertTeamExists tid - getter (Right tid) + getter (FeatureScopeTeam tid) -getAllFeatureConfigs :: +-- | Get feature config for a user. If the user is a member of a team and has the required permissions, this will return the team's feature configs. +-- If the user is not a member of a team, this will return the personal feature configs (the server defaults). +getAllFeatureConfigsForUser :: Members '[ BrigAccess, ErrorS 'NotATeamMember, @@ -228,41 +230,16 @@ getAllFeatureConfigs :: r => UserId -> Sem r AllFeatureConfigs -getAllFeatureConfigs zusr = do +getAllFeatureConfigsForUser zusr = do mbTeam <- getOneUserTeam zusr - zusrMembership <- maybe (pure Nothing) (flip getTeamMember zusr) mbTeam - let getStatus :: - forall (ps :: IncludeLockStatus) (a :: TeamFeatureName) r. - ( KnownTeamFeatureName a, - Aeson.ToJSON (TeamFeatureStatus ps a), - Members '[ErrorS 'NotATeamMember, ErrorS OperationDenied, TeamStore] r - ) => - FeatureGetter ps a r -> - Sem r (Aeson.Key, Aeson.Value) - getStatus (Tagged getter) = do - when (isJust mbTeam) $ do - void $ permissionCheck ViewTeamFeature zusrMembership - status <- getter (maybe (Left (Just zusr)) Right mbTeam) - let feature = knownTeamFeatureName @a - pure $ AesonKey.fromText (cs (toByteString' feature)) Aeson..= status - - AllFeatureConfigs . KeyMap.fromList - <$> sequence - [ getStatus @'WithoutLockStatus @'TeamFeatureLegalHold getLegalholdStatusInternal, - getStatus @'WithoutLockStatus @'TeamFeatureSSO getSSOStatusInternal, - getStatus @'WithoutLockStatus @'TeamFeatureSearchVisibility getTeamSearchVisibilityAvailableInternal, - getStatus @'WithoutLockStatus @'TeamFeatureValidateSAMLEmails getValidateSAMLEmailsInternal, - getStatus @'WithoutLockStatus @'TeamFeatureDigitalSignatures getDigitalSignaturesInternal, - getStatus @'WithoutLockStatus @'TeamFeatureAppLock getAppLockInternal, - getStatus @'WithLockStatus @'TeamFeatureFileSharing getFileSharingInternal, - getStatus @'WithoutLockStatus @'TeamFeatureClassifiedDomains getClassifiedDomainsInternal, - getStatus @'WithoutLockStatus @'TeamFeatureConferenceCalling getConferenceCallingInternal, - getStatus @'WithLockStatus @'TeamFeatureSelfDeletingMessages getSelfDeletingMessagesInternal, - getStatus @'WithLockStatus @'TeamFeatureGuestLinks getGuestLinkInternal, - getStatus @'WithLockStatus @'TeamFeatureSndFactorPasswordChallenge getSndFactorPasswordChallengeInternal - ] - -getAllFeatures :: + when (isJust mbTeam) $ do + zusrMembership <- maybe (pure Nothing) (`getTeamMember` zusr) mbTeam + void $ permissionCheck ViewTeamFeature zusrMembership + let scope = maybe (FeatureScopeUser zusr) FeatureScopeTeam mbTeam + getAllFeatureConfigsInternal scope + +-- | Get feature configs for a team. User must be a member of the team and have permission to view team features. +getAllFeatureConfigsForTeam :: forall r. Members '[ BrigAccess, @@ -277,35 +254,39 @@ getAllFeatures :: r => Local UserId -> TeamId -> - Sem r Aeson.Object -getAllFeatures luid tid = do - KeyMap.fromList - <$> sequence - [ getStatus @'WithoutLockStatus @'TeamFeatureSSO getSSOStatusInternal, - getStatus @'WithoutLockStatus @'TeamFeatureLegalHold getLegalholdStatusInternal, - getStatus @'WithoutLockStatus @'TeamFeatureSearchVisibility getTeamSearchVisibilityAvailableInternal, - getStatus @'WithoutLockStatus @'TeamFeatureValidateSAMLEmails getValidateSAMLEmailsInternal, - getStatus @'WithoutLockStatus @'TeamFeatureDigitalSignatures getDigitalSignaturesInternal, - getStatus @'WithoutLockStatus @'TeamFeatureAppLock getAppLockInternal, - getStatus @'WithLockStatus @'TeamFeatureFileSharing getFileSharingInternal, - getStatus @'WithoutLockStatus @'TeamFeatureClassifiedDomains getClassifiedDomainsInternal, - getStatus @'WithoutLockStatus @'TeamFeatureConferenceCalling getConferenceCallingInternal, - getStatus @'WithLockStatus @'TeamFeatureSelfDeletingMessages getSelfDeletingMessagesInternal, - getStatus @'WithLockStatus @'TeamFeatureGuestLinks getGuestLinkInternal, - getStatus @'WithLockStatus @'TeamFeatureSndFactorPasswordChallenge getSndFactorPasswordChallengeInternal - ] - where - getStatus :: - forall (ps :: IncludeLockStatus) (a :: TeamFeatureName). - ( KnownTeamFeatureName a, - Aeson.ToJSON (TeamFeatureStatus ps a) - ) => - FeatureGetter ps a r -> - Sem r (Aeson.Key, Aeson.Value) - getStatus getter = do - status <- getFeatureStatus @ps @a getter (DoAuth (tUnqualified luid)) tid - let feature = knownTeamFeatureName @a - pure $ AesonKey.fromText (cs (toByteString' feature)) Aeson..= status + Sem r AllFeatureConfigs +getAllFeatureConfigsForTeam luid tid = do + zusrMembership <- getTeamMember tid (tUnqualified luid) + void $ permissionCheck ViewTeamFeature zusrMembership + getAllFeatureConfigsInternal (FeatureScopeTeam tid) + +getAllFeatureConfigsInternal :: + Members + '[ BrigAccess, + ErrorS 'NotATeamMember, + ErrorS OperationDenied, + Input Opts, + LegalHoldStore, + TeamFeatureStore, + TeamStore + ] + r => + FeatureScope -> + Sem r AllFeatureConfigs +getAllFeatureConfigsInternal byUserOrTeam = + AllFeatureConfigs + <$> unTagged getLegalholdStatusInternal byUserOrTeam + <*> unTagged getSSOStatusInternal byUserOrTeam + <*> unTagged getTeamSearchVisibilityAvailableInternal byUserOrTeam + <*> unTagged getValidateSAMLEmailsInternal byUserOrTeam + <*> unTagged getDigitalSignaturesInternal byUserOrTeam + <*> unTagged getAppLockInternal byUserOrTeam + <*> unTagged getFileSharingInternal byUserOrTeam + <*> unTagged getClassifiedDomainsInternal byUserOrTeam + <*> unTagged getConferenceCallingInternal byUserOrTeam + <*> unTagged getSelfDeletingMessagesInternal byUserOrTeam + <*> unTagged getGuestLinkInternal byUserOrTeam + <*> unTagged getSndFactorPasswordChallengeInternal byUserOrTeam getFeatureStatusNoConfig :: forall (a :: TeamFeatureName) r. @@ -336,18 +317,15 @@ setFeatureStatusNoConfig applyState = Tagged $ \tid status -> do Event.Event Event.Update (knownTeamFeatureName @a) (EdFeatureWithoutConfigChanged newStatus) pure newStatus --- | FUTUREWORK(fisx): (thanks pcapriotti) this should probably be a type family dependent on --- the feature flag, so that we get more type safety. -type GetFeatureInternalParam = Either (Maybe UserId) TeamId - getSSOStatusInternal :: Members '[Input Opts, TeamFeatureStore] r => FeatureGetter 'WithoutLockStatus 'TeamFeatureSSO r getSSOStatusInternal = - Tagged $ - either - (const $ TeamFeatureStatusNoConfig <$> getDef) - (getFeatureStatusNoConfig @'TeamFeatureSSO getDef) + Tagged $ \case + FeatureScopeTeam tid -> + getFeatureStatusNoConfig @'TeamFeatureSSO getDef tid + FeatureScopeUser _ -> TeamFeatureStatusNoConfig <$> getDef + FeatureScopeServer -> TeamFeatureStatusNoConfig <$> getDef where getDef :: Member (Input Opts) r => Sem r TeamFeatureStatusValue getDef = @@ -366,10 +344,10 @@ getTeamSearchVisibilityAvailableInternal :: Members '[Input Opts, TeamFeatureStore] r => FeatureGetter 'WithoutLockStatus 'TeamFeatureSearchVisibility r getTeamSearchVisibilityAvailableInternal = - Tagged $ - either - (const $ TeamFeatureStatusNoConfig <$> getDef) - (getFeatureStatusNoConfig @'TeamFeatureSearchVisibility getDef) + Tagged $ \case + FeatureScopeTeam tid -> getFeatureStatusNoConfig @'TeamFeatureSearchVisibility getDef tid + FeatureScopeUser _ -> TeamFeatureStatusNoConfig <$> getDef + FeatureScopeServer -> TeamFeatureStatusNoConfig <$> getDef where getDef = do inputs (view (optSettings . setFeatureFlags . flagTeamSearchVisibility)) <&> \case @@ -390,10 +368,12 @@ getValidateSAMLEmailsInternal :: ) => FeatureGetter 'WithoutLockStatus 'TeamFeatureValidateSAMLEmails r getValidateSAMLEmailsInternal = - Tagged $ - getFeatureStatusWithDefaultConfig @'TeamFeatureValidateSAMLEmails - flagsTeamFeatureValidateSAMLEmailsStatus - . eitherToMaybe + Tagged $ getFeatureStatusWithDefaultConfig @'TeamFeatureValidateSAMLEmails flagsTeamFeatureValidateSAMLEmailsStatus . mbTeam + where + mbTeam = \case + FeatureScopeTeam tid -> Just tid + FeatureScopeUser _ -> Nothing + FeatureScopeServer -> Nothing setValidateSAMLEmailsInternal :: Members '[GundeckAccess, TeamFeatureStore, TeamStore, P.TinyLog] r => @@ -404,10 +384,10 @@ getDigitalSignaturesInternal :: Member TeamFeatureStore r => FeatureGetter 'WithoutLockStatus 'TeamFeatureDigitalSignatures r getDigitalSignaturesInternal = - Tagged $ - either - (const $ TeamFeatureStatusNoConfig <$> getDef) - (getFeatureStatusNoConfig @'TeamFeatureDigitalSignatures getDef) + Tagged $ \case + FeatureScopeTeam tid -> getFeatureStatusNoConfig @'TeamFeatureDigitalSignatures getDef tid + FeatureScopeUser _ -> TeamFeatureStatusNoConfig <$> getDef + FeatureScopeServer -> TeamFeatureStatusNoConfig <$> getDef where -- FUTUREWORK: we may also want to get a default from the server config file here, like for -- sso, and team search visibility. @@ -423,11 +403,12 @@ getLegalholdStatusInternal :: Members '[LegalHoldStore, TeamFeatureStore, TeamStore] r => FeatureGetter 'WithoutLockStatus 'TeamFeatureLegalHold r getLegalholdStatusInternal = Tagged $ \case - (Left _) -> pure $ TeamFeatureStatusNoConfig TeamFeatureDisabled - (Right tid) -> do + FeatureScopeTeam tid -> do isLegalHoldEnabledForTeam tid <&> \case True -> TeamFeatureStatusNoConfig TeamFeatureEnabled False -> TeamFeatureStatusNoConfig TeamFeatureDisabled + FeatureScopeUser _ -> pure $ TeamFeatureStatusNoConfig TeamFeatureDisabled + FeatureScopeServer -> pure $ TeamFeatureStatusNoConfig TeamFeatureDisabled setLegalholdStatusInternal :: forall p r. @@ -493,11 +474,12 @@ getFileSharingInternal :: ) => FeatureGetter 'WithLockStatus 'TeamFeatureFileSharing r getFileSharingInternal = Tagged $ \case - Left _ -> getCfgDefault - Right tid -> do + FeatureScopeTeam tid -> do cfgDefault <- getCfgDefault (mbFeatureStatus, fromMaybe (tfwoapsLockStatus cfgDefault) -> lockStatus) <- TeamFeatures.getFeatureStatusNoConfigAndLockStatus @'TeamFeatureFileSharing tid pure $ determineFeatureStatus cfgDefault lockStatus mbFeatureStatus + FeatureScopeUser _ -> getCfgDefault + FeatureScopeServer -> getCfgDefault where getCfgDefault :: Sem r (TeamFeatureStatus 'WithLockStatus 'TeamFeatureFileSharing) getCfgDefault = input <&> view (optSettings . setFeatureFlags . flagFileSharing . unDefaults) @@ -563,11 +545,16 @@ setFileSharingInternal = Tagged $ \tid status -> do getAppLockInternal :: Members '[Input Opts, TeamFeatureStore] r => FeatureGetter 'WithoutLockStatus 'TeamFeatureAppLock r -getAppLockInternal = Tagged $ \mbtid -> do - Defaults defaultStatus <- inputs (view (optSettings . setFeatureFlags . flagAppLockDefaults)) - status <- - join <$> (TeamFeatures.getApplockFeatureStatus `mapM` either (const Nothing) Just mbtid) - pure $ fromMaybe defaultStatus status +getAppLockInternal = Tagged $ \case + FeatureScopeTeam tid -> do + cfgDefault <- getCfgDefault + mStatus <- TeamFeatures.getApplockFeatureStatus tid + pure $ fromMaybe cfgDefault mStatus + FeatureScopeUser _ -> getCfgDefault + FeatureScopeServer -> getCfgDefault + where + getCfgDefault = do + inputs (view (optSettings . setFeatureFlags . flagAppLockDefaults . unDefaults)) setAppLockInternal :: Members '[GundeckAccess, TeamFeatureStore, TeamStore, Error TeamFeatureError, P.TinyLog] r => @@ -587,18 +574,16 @@ getClassifiedDomainsInternal = Tagged . const $ do globalConfig <- inputs (view (optSettings . setFeatureFlags . flagClassifiedDomains)) let config = globalConfig pure $ case tfwcStatus config of - TeamFeatureDisabled -> defaultClassifiedDomains + TeamFeatureDisabled -> defTeamFeatureStatus @'TeamFeatureClassifiedDomains TeamFeatureEnabled -> config getConferenceCallingInternal :: Members '[BrigAccess, Input Opts, TeamFeatureStore] r => FeatureGetter 'WithoutLockStatus 'TeamFeatureConferenceCalling r getConferenceCallingInternal = Tagged $ \case - (Left (Just uid)) -> getFeatureConfigViaAccount @'TeamFeatureConferenceCalling uid - (Left Nothing) -> - getFeatureStatusWithDefaultConfig @'TeamFeatureConferenceCalling flagConferenceCalling Nothing - (Right tid) -> - getFeatureStatusWithDefaultConfig @'TeamFeatureConferenceCalling flagConferenceCalling (Just tid) + FeatureScopeTeam tid -> getFeatureStatusWithDefaultConfig @'TeamFeatureConferenceCalling flagConferenceCalling (Just tid) + FeatureScopeUser uid -> getFeatureConfigViaAccount @'TeamFeatureConferenceCalling uid + FeatureScopeServer -> getFeatureStatusWithDefaultConfig @'TeamFeatureConferenceCalling flagConferenceCalling Nothing setConferenceCallingInternal :: Members '[GundeckAccess, TeamFeatureStore, TeamStore, P.TinyLog] r => @@ -613,8 +598,7 @@ getSelfDeletingMessagesInternal :: ) => FeatureGetter 'WithLockStatus 'TeamFeatureSelfDeletingMessages r getSelfDeletingMessagesInternal = Tagged $ \case - Left _ -> getCfgDefault - Right tid -> do + FeatureScopeTeam tid -> do cfgDefault <- getCfgDefault let defLockStatus = tfwcapsLockStatus cfgDefault (mbFeatureStatus, fromMaybe defLockStatus -> lockStatus) <- TeamFeatures.getSelfDeletingMessagesStatus tid @@ -626,6 +610,8 @@ getSelfDeletingMessagesInternal = Tagged $ \case Unlocked (Unlocked, Nothing) -> cfgDefault {tfwcapsLockStatus = Unlocked} (Locked, _) -> cfgDefault {tfwcapsLockStatus = Locked} + FeatureScopeUser _ -> getCfgDefault + FeatureScopeServer -> getCfgDefault where getCfgDefault :: Sem r (TeamFeatureStatusWithConfigAndLockStatus TeamFeatureSelfDeletingMessagesConfig) getCfgDefault = input <&> view (optSettings . setFeatureFlags . flagSelfDeletingMessages . unDefaults) @@ -655,11 +641,12 @@ getGuestLinkInternal :: (Member (Input Opts) r, Member TeamFeatureStore r) => FeatureGetter 'WithLockStatus 'TeamFeatureGuestLinks r getGuestLinkInternal = Tagged $ \case - Left _ -> getCfgDefault - Right tid -> do + FeatureScopeTeam tid -> do cfgDefault <- getCfgDefault (mbFeatureStatus, fromMaybe (tfwoapsLockStatus cfgDefault) -> lockStatus) <- TeamFeatures.getFeatureStatusNoConfigAndLockStatus @'TeamFeatureGuestLinks tid pure $ determineFeatureStatus cfgDefault lockStatus mbFeatureStatus + FeatureScopeUser _ -> getCfgDefault + FeatureScopeServer -> getCfgDefault where getCfgDefault :: Sem r (TeamFeatureStatus 'WithLockStatus 'TeamFeatureGuestLinks) getCfgDefault = input <&> view (optSettings . setFeatureFlags . flagConversationGuestLinks . unDefaults) @@ -694,11 +681,12 @@ getSndFactorPasswordChallengeInternal :: (Member (Input Opts) r, Member TeamFeatureStore r) => FeatureGetter 'WithLockStatus 'TeamFeatureSndFactorPasswordChallenge r getSndFactorPasswordChallengeInternal = Tagged $ \case - Left _ -> getCfgDefault - Right tid -> do + FeatureScopeTeam tid -> do cfgDefault <- getCfgDefault (mbFeatureStatus, fromMaybe (tfwoapsLockStatus cfgDefault) -> lockStatus) <- TeamFeatures.getFeatureStatusNoConfigAndLockStatus @'TeamFeatureSndFactorPasswordChallenge tid pure $ determineFeatureStatus cfgDefault lockStatus mbFeatureStatus + FeatureScopeUser _ -> getCfgDefault + FeatureScopeServer -> getCfgDefault where getCfgDefault :: Sem r (TeamFeatureStatus 'WithLockStatus 'TeamFeatureSndFactorPasswordChallenge) getCfgDefault = input <&> view (optSettings . setFeatureFlags . flagTeamFeatureSndFactorPasswordChallengeStatus . unDefaults) @@ -713,21 +701,21 @@ getSndFactorPasswordChallengeNoAuth :: Maybe UserId -> Sem r TeamFeatureStatusNoConfig getSndFactorPasswordChallengeNoAuth mbUserId = do - byUserOrTeamParam <- getParam mbUserId - TeamFeatureStatusNoConfig . tfwoapsStatus <$> unTagged getSndFactorPasswordChallengeInternal byUserOrTeamParam + scope <- getScope mbUserId + TeamFeatureStatusNoConfig . tfwoapsStatus <$> unTagged getSndFactorPasswordChallengeInternal scope where - getParam :: Maybe UserId -> Sem r GetFeatureInternalParam - getParam = \case + getScope :: Maybe UserId -> Sem r FeatureScope + getScope = \case Just uid -> do mbTeam <- getOneUserTeam uid case mbTeam of - Nothing -> pure (Left (Just uid)) + Nothing -> pure $ FeatureScopeUser uid Just tid -> do teamExists <- isJust <$> getTeam tid if teamExists - then pure (Right tid) - else pure (Left (Just uid)) - Nothing -> pure (Left Nothing) + then pure $ FeatureScopeTeam tid + else pure $ FeatureScopeUser uid + Nothing -> pure FeatureScopeServer -- | 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.) -- @@ -754,7 +742,7 @@ guardSecondFactorDisabled uid cid action = do Just tid -> do teamExists <- isJust <$> getTeam tid if teamExists - then TeamFeatureStatusNoConfig . tfwoapsStatus <$> unTagged getSndFactorPasswordChallengeInternal (Right tid) + then TeamFeatureStatusNoConfig . tfwoapsStatus <$> unTagged getSndFactorPasswordChallengeInternal (FeatureScopeTeam tid) else getSndFactorPasswordChallengeNoAuth (Just uid) case tfwoStatus teamFeature of TeamFeatureDisabled -> action @@ -789,10 +777,10 @@ getTeamSearchVisibilityInboundInternal :: Members '[Input Opts, TeamFeatureStore] r => FeatureGetter 'WithoutLockStatus 'TeamFeatureSearchVisibilityInbound r getTeamSearchVisibilityInboundInternal = - Tagged $ - either - (const $ getFeatureStatusWithDefaultConfig @'TeamFeatureSearchVisibilityInbound flagTeamFeatureSearchVisibilityInbound Nothing) - (getFeatureStatusWithDefaultConfig @'TeamFeatureSearchVisibilityInbound flagTeamFeatureSearchVisibilityInbound . Just) + Tagged $ \case + FeatureScopeTeam tid -> getFeatureStatusWithDefaultConfig @'TeamFeatureSearchVisibilityInbound flagTeamFeatureSearchVisibilityInbound (Just tid) + FeatureScopeUser _ -> getFeatureStatusWithDefaultConfig @'TeamFeatureSearchVisibilityInbound flagTeamFeatureSearchVisibilityInbound Nothing + FeatureScopeServer -> getFeatureStatusWithDefaultConfig @'TeamFeatureSearchVisibilityInbound flagTeamFeatureSearchVisibilityInbound Nothing setTeamSearchVisibilityInboundInternal :: Members '[Error InternalError, GundeckAccess, TeamStore, TeamFeatureStore, BrigAccess, P.TinyLog] r => diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index e6d2c03d42..c0f08564b5 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -413,8 +413,7 @@ updateConversationReceiptModeUnqualified :: ConvId -> ConversationReceiptModeUpdate -> Sem r (UpdateResult Event) -updateConversationReceiptModeUnqualified lusr zcon cnv update = - updateConversationReceiptMode lusr zcon (qUntagged (qualifyAs lusr cnv)) update +updateConversationReceiptModeUnqualified lusr zcon cnv = updateConversationReceiptMode lusr zcon (qUntagged (qualifyAs lusr cnv)) updateConversationMessageTimer :: Members @@ -460,8 +459,7 @@ updateConversationMessageTimerUnqualified :: ConvId -> ConversationMessageTimerUpdate -> Sem r (UpdateResult Event) -updateConversationMessageTimerUnqualified lusr zcon cnv update = - updateConversationMessageTimer lusr zcon (qUntagged (qualifyAs lusr cnv)) update +updateConversationMessageTimerUnqualified lusr zcon cnv = updateConversationMessageTimer lusr zcon (qUntagged (qualifyAs lusr cnv)) deleteLocalConversation :: Members @@ -1086,7 +1084,7 @@ removeMemberFromRemoteConv cnv lusr victim | qUntagged lusr == victim = do let lc = LeaveConversationRequest (tUnqualified cnv) (qUnqualified victim) let rpc = fedClient @'Galley @"leave-conversation" lc - (either handleError handleSuccess =<<) . fmap leaveResponse $ + (either handleError handleSuccess . leaveResponse =<<) $ E.runFederated cnv rpc | otherwise = throwS @('ActionDenied 'RemoveConversationMember) where @@ -1195,7 +1193,7 @@ postProteusBroadcast :: ConnId -> QualifiedNewOtrMessage -> Sem r (PostOtrResponse MessageSendingStatus) -postProteusBroadcast sender zcon msg = postBroadcast sender (Just zcon) msg +postProteusBroadcast sender zcon = postBroadcast sender (Just zcon) unqualifyEndpoint :: Functor f => @@ -1435,7 +1433,7 @@ addServiceH :: Sem r Response addServiceH req = do E.createService =<< fromJsonBody req - return empty + pure empty rmServiceH :: Members '[ServiceStore, WaiRoutes] r => @@ -1443,7 +1441,7 @@ rmServiceH :: Sem r Response rmServiceH req = do E.deleteService =<< fromJsonBody req - return empty + pure empty addBotH :: Members @@ -1526,7 +1524,7 @@ addBot lusr zcon b = do unless (any ((== b ^. addBotId) . botMemId) bots) $ do let botId = qualifyAs lusr (botUserId (b ^. addBotId)) ensureMemberLimit (toList $ Data.convLocalMembers c) [qUntagged botId] - return (bots, users) + pure (bots, users) rmBotH :: Members diff --git a/services/galley/src/Galley/API/Util.hs b/services/galley/src/Galley/API/Util.hs index f50bce8dca..edfcde581e 100644 --- a/services/galley/src/Galley/API/Util.hs +++ b/services/galley/src/Galley/API/Util.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-} -- This file is part of the Wire Server implementation. @@ -219,7 +218,7 @@ permissionCheckS :: permissionCheckS p = \case Just m -> do - if m `hasPermission` (fromSing p) + if m `hasPermission` fromSing p then pure m else throwS @(PermError p) -- FUTUREWORK: factor `noteS` out of this function. @@ -253,7 +252,7 @@ assertOnTeam :: Members '[ErrorS 'NotATeamMember, TeamStore] r => UserId -> Team assertOnTeam uid tid = getTeamMember tid uid >>= \case Nothing -> throwS @'NotATeamMember - Just _ -> return () + Just _ -> pure () -- | Try to accept a 1-1 conversation, promoting connect conversations as appropriate. acceptOne2One :: @@ -277,10 +276,10 @@ acceptOne2One lusr conv conn = do case Data.convType conv of One2OneConv -> if tUnqualified lusr `isMember` mems - then return conv + then pure conv else do mm <- createMember lcid lusr - return $ conv {Data.convLocalMembers = mems <> toList mm} + pure conv {Data.convLocalMembers = mems <> toList mm} ConnectConv -> case mems of [_, _] | tUnqualified lusr `isMember` mems -> promote [_, _] -> throwS @'ConvNotFound @@ -294,7 +293,7 @@ acceptOne2One lusr conv conn = do let mems' = mems <> toList mm for_ (newPushLocal ListComplete (tUnqualified lusr) (ConvEvent e) (recipient <$> mems')) $ \p -> push1 $ p & pushConn .~ conn & pushRoute .~ RouteDirect - return $ conv' {Data.convLocalMembers = mems'} + pure conv' {Data.convLocalMembers = mems'} _ -> throwS @'InvalidOperation where cid = Data.convId conv @@ -457,8 +456,7 @@ getSelfMemberFromLocals :: UserId -> t LocalMember -> Sem r LocalMember -getSelfMemberFromLocals usr lmems = - getMember @'ConvNotFound lmId usr lmems +getSelfMemberFromLocals = getMember @'ConvNotFound lmId -- | Throw 'ConvMemberNotFound' if the given user is not part of a -- conversation (either locally or remotely). @@ -558,7 +556,7 @@ verifyReusableCode convCode = do >>= noteS @'CodeNotFound unless (DataTypes.codeValue c == conversationCode convCode) $ throwS @'CodeNotFound - return c + pure c ensureConversationAccess :: Members @@ -794,7 +792,7 @@ allLegalholdConsentGiven uids = do -- conversation with user under legalhold. flip allM (chunksOf 32 uids) $ \uidsPage -> do teamsPage <- nub . Map.elems <$> getUsersTeams uidsPage - allM (isTeamLegalholdWhitelisted) teamsPage + allM isTeamLegalholdWhitelisted teamsPage -- | Add to every uid the legalhold status getLHStatusForUsers :: @@ -803,11 +801,13 @@ getLHStatusForUsers :: Sem r [(UserId, UserLegalHoldStatus)] getLHStatusForUsers uids = mconcat - <$> ( for (chunksOf 32 uids) $ \uidsChunk -> do - teamsOfUsers <- getUsersTeams uidsChunk - for uidsChunk $ \uid -> do - (uid,) <$> getLHStatus (Map.lookup uid teamsOfUsers) uid - ) + <$> for + (chunksOf 32 uids) + ( \uidsChunk -> do + teamsOfUsers <- getUsersTeams uidsChunk + for uidsChunk $ \uid -> do + (uid,) <$> getLHStatus (Map.lookup uid teamsOfUsers) uid + ) getTeamMembersForFanout :: Member TeamStore r => TeamId -> Sem r TeamMemberList getTeamMembersForFanout tid = do diff --git a/services/galley/src/Galley/App.hs b/services/galley/src/Galley/App.hs index 72a221a3e7..868bd15e3d 100644 --- a/services/galley/src/Galley/App.hs +++ b/services/galley/src/Galley/App.hs @@ -152,7 +152,7 @@ createEnv m o = do Env def m o l mgr (o ^. optFederator) (o ^. optBrig) cass <$> Q.new 16000 <*> initExtEnv - <*> maybe (return Nothing) (fmap Just . Aws.mkEnv l mgr) (o ^. optJournal) + <*> maybe (pure Nothing) (fmap Just . Aws.mkEnv l mgr) (o ^. optJournal) initCassandra :: Opts -> Logger -> IO ClientState initCassandra o l = do @@ -214,7 +214,7 @@ interpretErrorToException :: (err -> exc) -> Sem (Error err ': r) a -> Sem r a -interpretErrorToException f = (either (embed @IO . UnliftIO.throwIO . f) pure =<<) . runError +interpretErrorToException f = either (embed @IO . UnliftIO.throwIO . f) pure <=< runError interpretWaiErrorToException :: (APIError e, Member (Embed IO) r) => diff --git a/services/galley/src/Galley/Aws.hs b/services/galley/src/Galley/Aws.hs index d5d9b81e1e..149ebf6ad6 100644 --- a/services/galley/src/Galley/Aws.hs +++ b/services/galley/src/Galley/Aws.hs @@ -103,7 +103,7 @@ mkEnv lgr mgr opts = do let g = Logger.clone (Just "aws.galley") lgr e <- mkAwsEnv g q <- getQueueUrl e (opts ^. awsQueueName) - return (Env e g q) + pure (Env e g q) where sqs e = AWS.setEndpoint (e ^. awsSecure) (e ^. awsHost) (e ^. awsPort) SQS.defaultService mkAwsEnv g = do @@ -153,7 +153,7 @@ mkEnv lgr mgr opts = do AWS.send e (SQS.newGetQueueUrl q) either (throwM . GeneralError) - (return . QueueUrl . view SQS.getQueueUrlResponse_queueUrl) + (pure . QueueUrl . view SQS.getQueueUrlResponse_queueUrl) x execute :: MonadIO m => Env -> Amazon a -> m a @@ -165,7 +165,7 @@ enqueue e = do rnd <- liftIO nextRandom amaznkaEnv <- view awsEnv res <- retrying (limitRetries 5 <> exponentialBackoff 1000000) (const canRetry) $ const (sendCatch amaznkaEnv (req url rnd)) - either (throwM . GeneralError) (const (return ())) res + either (throwM . GeneralError) (const (pure ())) res where event = decodeLatin1 $ B64.encode $ encodeMessage e req url dedup = diff --git a/services/galley/src/Galley/Cassandra/Conversation.hs b/services/galley/src/Galley/Cassandra/Conversation.hs index fc61117427..d806b2e492 100644 --- a/services/galley/src/Galley/Cassandra/Conversation.hs +++ b/services/galley/src/Galley/Cassandra/Conversation.hs @@ -190,9 +190,10 @@ localConversations :: [ConvId] -> Sem r [Conversation] localConversations = - (collectAndLog =<<) - . embedClient - . UnliftIO.pooledMapConcurrentlyN 8 localConversation' + collectAndLog + <=< ( embedClient + . UnliftIO.pooledMapConcurrentlyN 8 localConversation' + ) where collectAndLog cs = case partitionEithers cs of (errs, convs) -> traverse_ (warn . Log.msg) errs $> convs diff --git a/services/galley/src/Galley/Cassandra/Conversation/Members.hs b/services/galley/src/Galley/Cassandra/Conversation/Members.hs index 2fabd1d1d6..d121e496ae 100644 --- a/services/galley/src/Galley/Cassandra/Conversation/Members.hs +++ b/services/galley/src/Galley/Cassandra/Conversation/Members.hs @@ -115,7 +115,7 @@ removeRemoteMembersFromLocalConv cnv victims = do members :: ConvId -> Client [LocalMember] members conv = - fmap (catMaybes . map toMember) . retry x1 $ + fmap (mapMaybe toMember) . retry x1 $ query Cql.selectMembers (params LocalQuorum (Identity conv)) toMemberStatus :: diff --git a/services/galley/src/Galley/Cassandra/Instances.hs b/services/galley/src/Galley/Cassandra/Instances.hs index bce3737e83..67cc7bd42e 100644 --- a/services/galley/src/Galley/Cassandra/Instances.hs +++ b/services/galley/src/Galley/Cassandra/Instances.hs @@ -52,10 +52,10 @@ instance Cql ConvType where toCql ConnectConv = CqlInt 3 fromCql (CqlInt i) = case i of - 0 -> return RegularConv - 1 -> return SelfConv - 2 -> return One2OneConv - 3 -> return ConnectConv + 0 -> pure RegularConv + 1 -> pure SelfConv + 2 -> pure One2OneConv + 3 -> pure ConnectConv n -> Left $ "unexpected conversation-type: " ++ show n fromCql _ = Left "conv-type: int expected" @@ -68,10 +68,10 @@ instance Cql Access where toCql CodeAccess = CqlInt 4 fromCql (CqlInt i) = case i of - 1 -> return PrivateAccess - 2 -> return InviteAccess - 3 -> return LinkAccess - 4 -> return CodeAccess + 1 -> pure PrivateAccess + 2 -> pure InviteAccess + 3 -> pure LinkAccess + 4 -> pure CodeAccess n -> Left $ "Unexpected Access value: " ++ show n fromCql _ = Left "Access value: int expected" @@ -84,10 +84,10 @@ instance Cql AccessRoleLegacy where toCql NonActivatedAccessRole = CqlInt 4 fromCql (CqlInt i) = case i of - 1 -> return PrivateAccessRole - 2 -> return TeamAccessRole - 3 -> return ActivatedAccessRole - 4 -> return NonActivatedAccessRole + 1 -> pure PrivateAccessRole + 2 -> pure TeamAccessRole + 3 -> pure ActivatedAccessRole + 4 -> pure NonActivatedAccessRole n -> Left $ "Unexpected AccessRole value: " ++ show n fromCql _ = Left "AccessRole value: int expected" @@ -101,10 +101,10 @@ instance Cql AccessRoleV2 where ServiceAccessRole -> CqlInt 4 fromCql (CqlInt i) = case i of - 1 -> return TeamMemberAccessRole - 2 -> return NonTeamMemberAccessRole - 3 -> return GuestAccessRole - 4 -> return ServiceAccessRole + 1 -> pure TeamMemberAccessRole + 2 -> pure NonTeamMemberAccessRole + 3 -> pure GuestAccessRole + 4 -> pure ServiceAccessRole n -> Left $ "Unexpected AccessRoleV2 value: " ++ show n fromCql _ = Left "AccessRoleV2 value: int expected" @@ -138,11 +138,11 @@ instance Cql TeamStatus where toCql PendingActive = CqlInt 4 fromCql (CqlInt i) = case i of - 0 -> return Active - 1 -> return PendingDelete - 2 -> return Deleted - 3 -> return Suspended - 4 -> return PendingActive + 0 -> pure Active + 1 -> pure PendingDelete + 2 -> pure Deleted + 3 -> pure Suspended + 4 -> pure PendingActive n -> Left $ "unexpected team-status: " ++ show n fromCql _ = Left "team-status: int expected" @@ -181,8 +181,8 @@ instance Cql ProtocolTag where toCql ProtocolMLSTag = CqlInt 1 fromCql (CqlInt i) = case i of - 0 -> return ProtocolProteusTag - 1 -> return ProtocolMLSTag + 0 -> pure ProtocolProteusTag + 1 -> pure ProtocolMLSTag n -> Left $ "unexpected protocol: " ++ show n fromCql _ = Left "protocol: int expected" diff --git a/services/galley/src/Galley/Cassandra/LegalHold.hs b/services/galley/src/Galley/Cassandra/LegalHold.hs index 76673ba8ab..4c74494a5b 100644 --- a/services/galley/src/Galley/Cassandra/LegalHold.hs +++ b/services/galley/src/Galley/Cassandra/LegalHold.hs @@ -145,22 +145,22 @@ validateServiceKey :: MonadIO m => ServiceKeyPEM -> m (Maybe (ServiceKey, Finger validateServiceKey pem = liftIO $ readPublicKey >>= \pk -> - case join (SSL.toPublicKey <$> pk) of - Nothing -> return Nothing + case SSL.toPublicKey =<< pk of + Nothing -> pure Nothing Just pk' -> do Just sha <- SSL.getDigestByName "SHA256" let size = SSL.rsaSize (pk' :: SSL.RSAPubKey) if size < minRsaKeySize - then return Nothing + then pure Nothing else do fpr <- Fingerprint <$> SSL.rsaFingerprint sha pk' let bits = fromIntegral size * 8 let key = ServiceKey RsaServiceKey bits pem - return $ Just (key, fpr) + pure (Just (key, fpr)) where readPublicKey = handleAny - (const $ return Nothing) - (SSL.readPublicKey (LC8.unpack (toByteString pem)) >>= return . Just) + (const $ pure Nothing) + (SSL.readPublicKey (LC8.unpack (toByteString pem)) <&> Just) minRsaKeySize :: Int minRsaKeySize = 256 -- Bytes (= 2048 bits) diff --git a/services/galley/src/Galley/Cassandra/Queries.hs b/services/galley/src/Galley/Cassandra/Queries.hs index e2df9eb6ac..81a1c4e85d 100644 --- a/services/galley/src/Galley/Cassandra/Queries.hs +++ b/services/galley/src/Galley/Cassandra/Queries.hs @@ -391,7 +391,7 @@ insertLegalHoldSettings = where team_id = ? |] -selectLegalHoldSettings :: PrepQuery R (Identity TeamId) (HttpsUrl, (Fingerprint Rsa), ServiceToken, ServiceKey) +selectLegalHoldSettings :: PrepQuery R (Identity TeamId) (HttpsUrl, Fingerprint Rsa, ServiceToken, ServiceKey) selectLegalHoldSettings = [r| select base_url, fingerprint, auth_token, pubkey diff --git a/services/galley/src/Galley/Cassandra/SearchVisibility.hs b/services/galley/src/Galley/Cassandra/SearchVisibility.hs index 58277e9c5b..9a11ffe436 100644 --- a/services/galley/src/Galley/Cassandra/SearchVisibility.hs +++ b/services/galley/src/Galley/Cassandra/SearchVisibility.hs @@ -44,7 +44,7 @@ getSearchVisibility tid = retry x1 $ query1 selectSearchVisibility (params LocalQuorum (Identity tid)) where -- The value is either set or we return the default - toSearchVisibility :: (Maybe (Identity (Maybe TeamSearchVisibility))) -> TeamSearchVisibility + toSearchVisibility :: Maybe (Identity (Maybe TeamSearchVisibility)) -> TeamSearchVisibility toSearchVisibility (Just (Identity (Just status))) = status toSearchVisibility _ = SearchVisibilityStandard diff --git a/services/galley/src/Galley/Cassandra/Team.hs b/services/galley/src/Galley/Cassandra/Team.hs index 670c4b6a06..15c12c171e 100644 --- a/services/galley/src/Galley/Cassandra/Team.hs +++ b/services/galley/src/Galley/Cassandra/Team.hs @@ -143,7 +143,7 @@ createTeam :: TeamBinding -> Client Team createTeam t uid (fromRange -> n) i k b = do - tid <- maybe (Id <$> liftIO nextRandom) return t + tid <- maybe (Id <$> liftIO nextRandom) pure t retry x5 $ write Cql.insertTeam (params LocalQuorum (tid, uid, n, i, fromRange <$> k, initialStatus b, b)) pure (newTeam tid uid n i b & teamIconKey .~ (fromRange <$> k)) where @@ -284,7 +284,7 @@ teamMembersCollectedWithPagination lh tid = do tMembers <- mapM (newTeamMember' lh tid) (result mems) if hasMore mems then collectTeamMembersPaginated (tMembers ++ acc) =<< nextPage mems - else return (tMembers ++ acc) + else pure (tMembers ++ acc) -- Lookup only specific team members: this is particularly useful for large teams when -- needed to look up only a small subset of members (typically 2, user to perform the action diff --git a/services/galley/src/Galley/Cassandra/TeamNotifications.hs b/services/galley/src/Galley/Cassandra/TeamNotifications.hs index cd20b80789..5084be13bf 100644 --- a/services/galley/src/Galley/Cassandra/TeamNotifications.hs +++ b/services/galley/src/Galley/Cassandra/TeamNotifications.hs @@ -60,10 +60,10 @@ interpretTeamNotificationStoreToCassandra = interpret $ \case mkNotificationId :: IO NotificationId mkNotificationId = do ni <- fmap Id <$> retrying x10 fun (const (liftIO UUID.nextUUID)) - maybe (throwM err) return ni + maybe (throwM err) pure ni where x10 = limitRetries 10 <> exponentialBackoff 10 - fun = const (return . isNothing) + fun = const (pure . isNothing) err = mkError status500 "internal-error" "unable to generate notification ID" -- FUTUREWORK: the magic 32 should be made configurable, so it can be tuned @@ -102,7 +102,7 @@ fetch tid since (fromRange -> size) = do -- This can probably simplified a lot further, but we need to understand -- 'Seq' in order to do that. If you find a bug, this may be a good -- place to start looking. - return $! case Seq.viewl (trim (isize - 1) ns) of + pure $! case Seq.viewl (trim (isize - 1) ns) of EmptyL -> ResultPage Seq.empty False (x :< xs) -> ResultPage (x <| xs) more where @@ -118,7 +118,7 @@ fetch tid since (fromRange -> size) = do num' = num - Seq.length nseq acc' = acc >< nseq in if not more || num' == 0 - then return (acc', more || not (null (snd ns))) + then pure (acc', more || not (null (snd ns))) else liftClient (nextPage page) >>= collect acc' num' trim :: Int -> Seq a -> Seq a trim l ns diff --git a/services/galley/src/Galley/Data/Scope.hs b/services/galley/src/Galley/Data/Scope.hs index f7546e6b4b..8d649e0a69 100644 --- a/services/galley/src/Galley/Data/Scope.hs +++ b/services/galley/src/Galley/Data/Scope.hs @@ -30,5 +30,5 @@ instance Cql Scope where toCql ReusableCode = CqlInt 1 - fromCql (CqlInt 1) = return ReusableCode + fromCql (CqlInt 1) = pure ReusableCode fromCql _ = Left "unknown Scope" diff --git a/services/galley/src/Galley/Data/Services.hs b/services/galley/src/Galley/Data/Services.hs index 099070685b..9fc2167f7a 100644 --- a/services/galley/src/Galley/Data/Services.hs +++ b/services/galley/src/Galley/Data/Services.hs @@ -43,7 +43,7 @@ instance Ord BotMember where compare = compare `on` botMemId newBotMember :: LocalMember -> Maybe BotMember -newBotMember m = const (BotMember m) <$> lmService m +newBotMember m = BotMember m <$ lmService m botMemId :: BotMember -> BotId botMemId = BotId . lmId . fromBotMember diff --git a/services/galley/src/Galley/Data/Types.hs b/services/galley/src/Galley/Data/Types.hs index 74b7067587..e3eedc4edb 100644 --- a/services/galley/src/Galley/Data/Types.hs +++ b/services/galley/src/Galley/Data/Types.hs @@ -74,7 +74,7 @@ generate :: MonadIO m => ConvId -> Scope -> Timeout -> m Code generate cnv s t = do key <- mkKey cnv val <- liftIO $ Value . unsafeRange . Ascii.encodeBase64Url <$> randBytes 15 - return + pure Code { codeKey = key, codeValue = val, @@ -86,4 +86,4 @@ generate cnv s t = do mkKey :: MonadIO m => ConvId -> m Key mkKey cnv = do sha256 <- liftIO $ fromJust <$> getDigestByName "SHA256" - return $ Key . unsafeRange . Ascii.encodeBase64Url . BS.take 15 $ digestBS sha256 (toByteString' cnv) + pure $ Key . unsafeRange . Ascii.encodeBase64Url . BS.take 15 $ digestBS sha256 (toByteString' cnv) diff --git a/services/galley/src/Galley/Effects/TeamStore.hs b/services/galley/src/Galley/Effects/TeamStore.hs index 215a67e620..5836300ac6 100644 --- a/services/galley/src/Galley/Effects/TeamStore.hs +++ b/services/galley/src/Galley/Effects/TeamStore.hs @@ -148,5 +148,5 @@ lookupBindingTeam zusr = do tid <- getOneUserTeam zusr >>= noteS @'TeamNotFound binding <- getTeamBinding tid >>= noteS @'TeamNotFound case binding of - Binding -> return tid + Binding -> pure tid NonBinding -> throwS @'NonBindingTeam diff --git a/services/galley/src/Galley/Effects/WaiRoutes/IO.hs b/services/galley/src/Galley/Effects/WaiRoutes/IO.hs index 9a5da38e86..358513d8da 100644 --- a/services/galley/src/Galley/Effects/WaiRoutes/IO.hs +++ b/services/galley/src/Galley/Effects/WaiRoutes/IO.hs @@ -32,8 +32,8 @@ interpretWaiRoutes :: Sem (WaiRoutes ': r) a -> Sem r a interpretWaiRoutes = interpret $ \case - FromJsonBody r -> exceptT (throw . InvalidPayload) return (parseBody r) - FromOptionalJsonBody r -> exceptT (throw . InvalidPayload) return (parseOptionalBody r) + FromJsonBody r -> exceptT (throw . InvalidPayload) pure (parseBody r) + FromOptionalJsonBody r -> exceptT (throw . InvalidPayload) pure (parseOptionalBody r) FromProtoBody r -> do b <- readBody r - either (throw . InvalidPayload . fromString) return (runGetLazy Proto.decodeMessage b) + either (throw . InvalidPayload . fromString) pure (runGetLazy Proto.decodeMessage b) diff --git a/services/galley/src/Galley/Env.hs b/services/galley/src/Galley/Env.hs index ef3d3a32b7..d085c0289e 100644 --- a/services/galley/src/Galley/Env.hs +++ b/services/galley/src/Galley/Env.hs @@ -85,7 +85,7 @@ initExtEnv = do managerConnCount = 100 } Just sha <- getDigestByName "SHA256" - return $ ExtEnv (mgr, mkVerify sha) + pure $ ExtEnv (mgr, mkVerify sha) where mkVerify sha fprs = let pinset = map toByteString' fprs @@ -97,6 +97,6 @@ reqIdMsg = ("request" .=) . unRequestId currentFanoutLimit :: Opts -> Range 1 Teams.HardTruncationLimit Int32 currentFanoutLimit o = do - let optFanoutLimit = fromIntegral . fromRange $ fromMaybe defFanoutLimit (o ^. optSettings ^. setMaxFanoutSize) - let maxTeamSize = fromIntegral (o ^. optSettings ^. setMaxTeamSize) + let optFanoutLimit = fromIntegral . fromRange $ fromMaybe defFanoutLimit (o ^. (optSettings . setMaxFanoutSize)) + let maxTeamSize = fromIntegral (o ^. (optSettings . setMaxTeamSize)) unsafeRange (min maxTeamSize optFanoutLimit) diff --git a/services/galley/src/Galley/External.hs b/services/galley/src/Galley/External.hs index a695155f30..c0c4e1806c 100644 --- a/services/galley/src/Galley/External.hs +++ b/services/galley/src/Galley/External.hs @@ -72,10 +72,10 @@ deliver pp = mapM (async . exec) pp >>= foldM eval [] . zip (map fst pp) exec :: (BotMember, Event) -> App Bool exec (b, e) = lookupService (botMemService b) >>= \case - Nothing -> return False + Nothing -> pure False Just s -> do deliver1 s b e - return True + pure True eval :: [BotMember] -> (BotMember, Async Bool) -> App [BotMember] eval gone (b, a) = do let s = botMemService b @@ -87,14 +87,14 @@ deliver pp = mapM (async . exec) pp >>= foldM eval [] . zip (map fst pp) ~~ field "service" (toByteString (s ^. serviceRefId)) ~~ field "bot" (toByteString (botMemId b)) ~~ msg (val "External delivery success") - return gone + pure gone Right False -> do Log.debug $ field "provider" (toByteString (s ^. serviceRefProvider)) ~~ field "service" (toByteString (s ^. serviceRefId)) ~~ field "bot" (toByteString (botMemId b)) ~~ msg (val "External service gone") - return (b : gone) + pure (b : gone) Left ex | Just (Http.HttpExceptionRequest _ (Http.StatusCodeException rs _)) <- fromException ex, Http.responseStatus rs == status410 -> do @@ -103,7 +103,7 @@ deliver pp = mapM (async . exec) pp >>= foldM eval [] . zip (map fst pp) ~~ field "service" (toByteString (s ^. serviceRefId)) ~~ field "bot" (toByteString (botMemId b)) ~~ msg (val "External bot gone") - return (b : gone) + pure (b : gone) Left ex -> do Log.info $ field "provider" (toByteString (s ^. serviceRefProvider)) @@ -111,7 +111,7 @@ deliver pp = mapM (async . exec) pp >>= foldM eval [] . zip (map fst pp) ~~ field "bot" (toByteString (botMemId b)) ~~ field "error" (show ex) ~~ msg (val "External delivery failure") - return gone + pure gone -- Internal ------------------------------------------------------------------- @@ -134,7 +134,7 @@ deliver1 s bm e . timeout 5000 . secure . expect2xx - | otherwise = return () + | otherwise = pure () urlHost :: HttpsUrl -> Maybe ByteString urlHost (HttpsUrl u) = u ^. authorityL <&> view (authorityHostL . hostBSL) @@ -143,13 +143,13 @@ urlPort :: HttpsUrl -> Maybe Word16 urlPort (HttpsUrl u) = do a <- u ^. authorityL p <- a ^. authorityPortL - return (fromIntegral (p ^. portNumberL)) + pure (fromIntegral (p ^. portNumberL)) sendMessage :: [Fingerprint Rsa] -> (Request -> Request) -> App () sendMessage fprs reqBuilder = do (man, verifyFingerprints) <- view (extEnv . extGetManager) liftIO . withVerifiedSslConnection (verifyFingerprints fprs) man reqBuilder $ \req -> - Http.withResponse req man (const $ return ()) + Http.withResponse req man (const $ pure ()) x3 :: RetryPolicy x3 = limitRetries 3 <> constantDelay 1000000 diff --git a/services/galley/src/Galley/External/LegalHoldService.hs b/services/galley/src/Galley/External/LegalHoldService.hs index 5d7c570e2b..979c34b553 100644 --- a/services/galley/src/Galley/External/LegalHoldService.hs +++ b/services/galley/src/Galley/External/LegalHoldService.hs @@ -63,11 +63,11 @@ checkLegalHoldServiceStatus :: Sem r () checkLegalHoldServiceStatus fpr url = do resp <- makeVerifiedRequestFreshManager fpr url reqBuilder - if - | Bilge.statusCode resp < 400 -> pure () - | otherwise -> do - P.info . Log.msg $ showResponse resp - throwS @'LegalHoldServiceBadResponse + if Bilge.statusCode resp < 400 + then pure () + else do + P.info . Log.msg $ showResponse resp + throwS @'LegalHoldServiceBadResponse where reqBuilder :: Http.Request -> Http.Request reqBuilder = diff --git a/services/galley/src/Galley/Intra/Client.hs b/services/galley/src/Galley/Intra/Client.hs index 33c9596c97..95563d9c07 100644 --- a/services/galley/src/Galley/Intra/Client.hs +++ b/services/galley/src/Galley/Intra/Client.hs @@ -70,7 +70,7 @@ lookupClients uids = do . json (UserSet $ Set.fromList uids) . expect2xx clients <- parseResponse (mkError status502 "server-error") r - return $ filterClients (not . Set.null) clients + pure $ filterClients (not . Set.null) clients -- | Calls 'Brig.API.internalListClientsFullH'. lookupClientsFull :: @@ -84,7 +84,7 @@ lookupClientsFull uids = do . json (UserSet $ Set.fromList uids) . expect2xx clients <- parseResponse (mkError status502 "server-error") r - return $ filterClientsFull (not . Set.null) clients + pure $ filterClientsFull (not . Set.null) clients -- | Calls 'Brig.API.legalHoldClientRequestedH'. notifyClientsAboutLegalHoldRequest :: diff --git a/services/galley/src/Galley/Intra/Federator.hs b/services/galley/src/Galley/Intra/Federator.hs index caa0d499e8..8f8f871e9c 100644 --- a/services/galley/src/Galley/Intra/Federator.hs +++ b/services/galley/src/Galley/Intra/Federator.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2022 Wire Swiss GmbH diff --git a/services/galley/src/Galley/Intra/Push/Internal.hs b/services/galley/src/Galley/Intra/Push/Internal.hs index 5d25aff8ff..24273dd4c8 100644 --- a/services/galley/src/Galley/Intra/Push/Internal.hs +++ b/services/galley/src/Galley/Intra/Push/Internal.hs @@ -131,7 +131,7 @@ pushLocal ps = do filter ( \p -> (pushRecipientListType p == Teams.ListComplete) - && (length (_pushRecipients p) <= (fromIntegral $ fromRange limit)) + && (length (_pushRecipients p) <= fromIntegral (fromRange limit)) ) recipient :: LocalMember -> Recipient @@ -155,14 +155,14 @@ newPush1 recipientListType from e rr = } newPushLocal1 :: Teams.ListType -> UserId -> PushEvent -> List1 Recipient -> Push -newPushLocal1 lt uid e rr = newPush1 lt (Just uid) e rr +newPushLocal1 lt uid = newPush1 lt (Just uid) newPush :: Teams.ListType -> Maybe UserId -> PushEvent -> [Recipient] -> Maybe Push newPush _ _ _ [] = Nothing newPush t u e (r : rr) = Just $ newPush1 t u e (list1 r rr) newPushLocal :: Teams.ListType -> UserId -> PushEvent -> [Recipient] -> Maybe Push -newPushLocal lt uid e rr = newPush lt (Just uid) e rr +newPushLocal lt uid = newPush lt (Just uid) newConversationEventPush :: Event -> Local [UserId] -> Maybe Push newConversationEventPush e users = @@ -172,7 +172,7 @@ newConversationEventPush e users = pushSlowly :: Foldable f => f Push -> App () pushSlowly ps = do mmillis <- view (options . optSettings . setDeleteConvThrottleMillis) - let delay = 1000 * (fromMaybe defDeleteConvThrottleMillis mmillis) + let delay = 1000 * fromMaybe defDeleteConvThrottleMillis mmillis forM_ ps $ \p -> do push [p] threadDelay delay diff --git a/services/galley/src/Galley/Intra/Util.hs b/services/galley/src/Galley/Intra/Util.hs index 06fadd4ff5..0cf3bf1271 100644 --- a/services/galley/src/Galley/Intra/Util.hs +++ b/services/galley/src/Galley/Intra/Util.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2022 Wire Swiss GmbH diff --git a/services/galley/src/Galley/Options.hs b/services/galley/src/Galley/Options.hs index be010a3a9d..72c5561916 100644 --- a/services/galley/src/Galley/Options.hs +++ b/services/galley/src/Galley/Options.hs @@ -95,7 +95,7 @@ data Settings = Settings -- allowedDomains: -- - wire.com -- - example.com - _setFederationDomain :: !(Domain), + _setFederationDomain :: !Domain, -- | When true, galley will assume data in `billing_team_member` table is -- consistent and use it for billing. -- When false, billing information for large teams is not guaranteed to have all diff --git a/services/galley/src/Galley/Run.hs b/services/galley/src/Galley/Run.hs index 7466522cfd..21148ef78c 100644 --- a/services/galley/src/Galley/Run.hs +++ b/services/galley/src/Galley/Run.hs @@ -27,6 +27,7 @@ import Cassandra.Schema (versionCheck) import qualified Control.Concurrent.Async as Async import Control.Exception (finally) import Control.Lens (view, (.~), (^.)) +import Control.Monad.Codensity import qualified Data.Aeson as Aeson import Data.Default import Data.Id @@ -59,45 +60,44 @@ import qualified Wire.API.Routes.Public.Galley as GalleyAPI import Wire.API.Routes.Version.Wai run :: Opts -> IO () -run o = do - (app, e, appFinalizer) <- mkApp o - let l = e ^. App.applog - s <- - newSettings $ - defaultServer - (unpack $ o ^. optGalley . epHost) - (portNumber $ fromIntegral $ o ^. optGalley . epPort) - l - (e ^. monitor) - deleteQueueThread <- Async.async $ runApp e deleteLoop - refreshMetricsThread <- Async.async $ runApp e refreshMetrics - runSettingsWithShutdown s app 5 `finally` do - Async.cancel deleteQueueThread - Async.cancel refreshMetricsThread - shutdown (e ^. cstate) - appFinalizer +run opts = lowerCodensity $ do + (app, env) <- mkApp opts + settings <- + lift $ + newSettings $ + defaultServer + (unpack $ opts ^. optGalley . epHost) + (portNumber $ fromIntegral $ opts ^. optGalley . epPort) + (env ^. App.applog) + (env ^. monitor) -mkApp :: Opts -> IO (Application, Env, IO ()) -mkApp o = do - m <- M.metrics - e <- App.createEnv m o - let l = e ^. App.applog - runClient (e ^. cstate) $ - versionCheck schemaVersion - let finalizer = do - Log.info l $ Log.msg @Text "Galley application finished." - Log.flush l - Log.close l - middlewares = - versionMiddleware - . servantPlusWAIPrometheusMiddleware API.sitemap (Proxy @CombinedAPI) - . GZip.gunzip - . GZip.gzip GZip.def - . catchErrors l [Right m] - return (middlewares $ servantApp e, e, finalizer) + void $ Codensity $ Async.withAsync $ runApp env deleteLoop + void $ Codensity $ Async.withAsync $ runApp env refreshMetrics + lift $ finally (runSettingsWithShutdown settings app 5) (shutdown (env ^. cstate)) + +mkApp :: Opts -> Codensity IO (Application, Env) +mkApp opts = + do + metrics <- lift $ M.metrics + env <- lift $ App.createEnv metrics opts + lift $ runClient (env ^. cstate) $ versionCheck schemaVersion + + let logger = env ^. App.applog + + let middlewares = + versionMiddleware + . servantPlusWAIPrometheusMiddleware API.sitemap (Proxy @CombinedAPI) + . GZip.gunzip + . GZip.gzip GZip.def + . catchErrors logger [Right metrics] + Codensity $ \k -> finally (k ()) $ do + Log.info logger $ Log.msg @Text "Galley application finished." + Log.flush logger + Log.close logger + pure (middlewares $ servantApp env, env) where rtree = compile API.sitemap - app e r k = evalGalley e (route rtree r k) + runGalley e r k = evalGalley e (route rtree r k) -- the servant API wraps the one defined using wai-routing servantApp e0 r = let e = reqId .~ lookupReqId r $ e0 @@ -110,7 +110,7 @@ mkApp o = do ( hoistAPIHandler (toServantHandler e) API.servantSitemap :<|> hoistAPIHandler (toServantHandler e) internalAPI :<|> hoistServerWithDomain @FederationAPI (toServantHandler e) federationSitemap - :<|> Servant.Tagged (app e) + :<|> Servant.Tagged (runGalley e) ) r diff --git a/services/galley/src/Galley/Validation.hs b/services/galley/src/Galley/Validation.hs index 4e988a9f11..4ff62e03e2 100644 --- a/services/galley/src/Galley/Validation.hs +++ b/services/galley/src/Galley/Validation.hs @@ -35,14 +35,14 @@ import Polysemy import Polysemy.Error rangeChecked :: (Member (Error InvalidInput) r, Within a n m) => a -> Sem r (Range n m a) -rangeChecked = either throwErr return . checkedEither +rangeChecked = either throwErr pure . checkedEither {-# INLINE rangeChecked #-} rangeCheckedMaybe :: (Member (Error InvalidInput) r, Within a n m) => Maybe a -> Sem r (Maybe (Range n m a)) -rangeCheckedMaybe Nothing = return Nothing +rangeCheckedMaybe Nothing = pure Nothing rangeCheckedMaybe (Just a) = Just <$> rangeChecked a {-# INLINE rangeCheckedMaybe #-} @@ -63,7 +63,7 @@ checkedConvSize o x = do let minV :: Integer = 0 limit = o ^. optSettings . setMaxConvSize - 1 if length x <= fromIntegral limit - then return (ConvSizeChecked x) + then pure (ConvSizeChecked x) else throwErr (errorMsg minV limit "") throwErr :: Member (Error InvalidInput) r => String -> Sem r a diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index 2678707c58..40e2a423d6 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -67,7 +67,7 @@ import Data.Time.Clock (getCurrentTime) import Federator.Discovery (DiscoveryFailure (..)) import Federator.MockServer (FederatedRequest (..), MockException (..)) import Galley.API.Mapping -import Galley.Options (Opts, optFederator) +import Galley.Options (optFederator) import Galley.Types hiding (LocalMember (..)) import Galley.Types.Conversations.Intra import Galley.Types.Conversations.Members @@ -2021,13 +2021,12 @@ postConvQualifiedNonExistentDomain = do postConvQualifiedFederationNotEnabled :: TestM () postConvQualifiedFederationNotEnabled = do - g <- view tsGalley alice <- randomUser bob <- flip Qualified (Domain "some-remote-backend.example.com") <$> randomId - opts <- view tsGConf connectWithRemoteUser alice bob - let federatorNotConfigured :: Opts = opts & optFederator .~ Nothing - withSettingsOverrides federatorNotConfigured $ + let federatorNotConfigured = optFederator .~ Nothing + withSettingsOverrides federatorNotConfigured $ do + g <- view tsGalley postConvHelper g alice [bob] !!! do const 400 === statusCode const (Just "federation-not-enabled") === fmap label . responseJsonUnsafe @@ -2585,10 +2584,9 @@ testAddRemoteMemberFederationDisabled = do convId <- decodeConvId <$> postConv alice [] (Just "remote gossip") [] Nothing Nothing connectWithRemoteUser alice remoteBob - opts <- view tsGConf -- federator endpoint not configured is equivalent to federation being disabled -- This is the case on staging/production in May 2021. - let federatorNotConfigured :: Opts = opts & optFederator .~ Nothing + let federatorNotConfigured = optFederator .~ Nothing withSettingsOverrides federatorNotConfigured $ postQualifiedMembers alice (remoteBob :| []) convId !!! do const 400 === statusCode @@ -2605,12 +2603,11 @@ testAddRemoteMemberFederationUnavailable = do convId <- decodeConvId <$> postConv alice [] (Just "remote gossip") [] Nothing Nothing connectWithRemoteUser alice remoteBob - opts <- view tsGConf -- federator endpoint being configured in brig and/or galley, but not being -- available (i.e. no service listing on that IP/port) can happen due to a -- misconfiguration of federator. That should give a 500. -- Port 1 should always be wrong hopefully. - let federatorUnavailable :: Opts = opts & optFederator ?~ Endpoint "127.0.0.1" 1 + let federatorUnavailable = optFederator ?~ Endpoint "127.0.0.1" 1 withSettingsOverrides federatorUnavailable $ postQualifiedMembers alice (remoteBob :| []) convId !!! do const 500 === statusCode diff --git a/services/galley/test/integration/API/Federation.hs b/services/galley/test/integration/API/Federation.hs index a68d428dd8..6f4ec83254 100644 --- a/services/galley/test/integration/API/Federation.hs +++ b/services/galley/test/integration/API/Federation.hs @@ -23,7 +23,6 @@ import API.MLS.Util import API.Util import Bilge import Bilge.Assert -import Bilge.TestSession (liftSession) import Control.Lens hiding ((#)) import Data.Aeson (ToJSON (..)) import qualified Data.Aeson as A @@ -32,7 +31,7 @@ import Data.Default import Data.Domain import Data.Id (ConvId, Id (..), UserId, newClientId, randomId) import Data.Json.Util hiding ((#)) -import Data.List.NonEmpty (NonEmpty (..), head) +import Data.List.NonEmpty (NonEmpty (..)) import Data.List1 import qualified Data.List1 as List1 import qualified Data.Map as Map @@ -93,7 +92,8 @@ tests s = test s "POST /federation/send-message : Post a message sent from another backend" sendMessage, test s "POST /federation/on-user-deleted-conversations : Remove deleted remote user from local conversations" onUserDeleted, test s "POST /federation/update-conversation : Update local conversation by a remote admin " updateConversationByRemoteAdmin, - test s "POST /federation/mls-welcome : Post an MLS welcome message received from another backend" sendMLSWelcome + test s "POST /federation/mls-welcome : Post an MLS welcome message received from another backend" sendMLSWelcome, + test s "POST /federation/mls-welcome : Post an MLS welcome message (key package ref not found)" sendMLSWelcomeKeyPackageNotFound ] getConversationsAllFound :: TestM () @@ -1088,11 +1088,9 @@ updateConversationByRemoteAdmin = do curConvId = qUnqualified cnv, curAction = action } - resp <- - liftSession $ - runWaiTestFedClient bdomain $ - createWaiTestFedClient @"update-conversation" @'Galley $ - cnvUpdateRequest + resp <- do + fedGalleyClient <- view tsFedGalleyClient + runFedClient @"update-conversation" fedGalleyClient bdomain cnvUpdateRequest cnvUpdate' <- liftIO $ case resp of ConversationUpdateResponseError err -> assertFailure ("Expected ConversationUpdateResponseUpdate but got " <> show err) @@ -1151,23 +1149,52 @@ sendMLSWelcome = do -- Alice is from the originating domain and Bob is local, i.e., on the receiving domain MessagingSetup {..} <- aliceInvitesBob (1, LocalUser) def {creatorOrigin = RemoteUser aliceDomain} let bob = users !! 0 - bobClient = snd . Data.List.NonEmpty.head . pClients $ bob fedGalleyClient <- view tsFedGalleyClient cannon <- view tsCannon WS.bracketR cannon (qUnqualified (pUserId bob)) $ \wsB -> do -- send welcome message - runFedClient @"mls-welcome" fedGalleyClient aliceDomain $ - MLSWelcomeRequest - (Base64ByteString welcome) - [MLSWelcomeRecipient (qUnqualified . pUserId $ bob, bobClient)] + void $ + runFedClient @"mls-welcome" fedGalleyClient aliceDomain $ + MLSWelcomeRequest + (Base64ByteString welcome) -- check that the corresponding event is received - void . liftIO $ - WS.assertMatch (5 # WS.Second) wsB $ + liftIO $ do + WS.assertMatch_ (5 # WS.Second) wsB $ wsAssertMLSWelcome (pUserId bob) welcome +sendMLSWelcomeKeyPackageNotFound :: TestM () +sendMLSWelcomeKeyPackageNotFound = do + let aliceDomain = Domain "a.far-away.example.com" + -- Alice is from the originating domain and Bob is local, i.e., on the receiving domain + MessagingSetup {..} <- + aliceInvitesBob + (1, LocalUser) + def + { creatorOrigin = RemoteUser aliceDomain, + createClients = DontCreateClients -- no key package upload will happen + } + let bob = users !! 0 + + fedGalleyClient <- view tsFedGalleyClient + cannon <- view tsCannon + + WS.bracketR cannon (qUnqualified (pUserId bob)) $ \wsB -> do + -- send welcome message + void $ + runFedClient @"mls-welcome" fedGalleyClient aliceDomain $ + MLSWelcomeRequest + (Base64ByteString welcome) + + liftIO $ do + -- check that no event is received + WS.assertNoEvent (1 # Second) [wsB] + +-- success is reported, even though no client receives the welcome +-- message due to missing key package references + getConvAction :: Sing tag -> SomeConversationAction -> Maybe (ConversationAction tag) getConvAction tquery (SomeConversationAction tag action) = case (tag, tquery) of diff --git a/services/galley/test/integration/API/MLS.hs b/services/galley/test/integration/API/MLS.hs index 5cf7e4eb77..9ec030941f 100644 --- a/services/galley/test/integration/API/MLS.hs +++ b/services/galley/test/integration/API/MLS.hs @@ -28,6 +28,7 @@ import qualified Data.Aeson as Aeson import Data.Default import Data.Domain import Data.Id +import Data.Json.Util hiding ((#)) import qualified Data.List.NonEmpty as NonEmpty import Data.List1 import Data.Qualified @@ -47,6 +48,7 @@ import TestHelpers import TestSetup import Wire.API.Conversation import Wire.API.Conversation.Role +import Wire.API.Federation.API.Common import Wire.API.Federation.API.Galley import Wire.API.Message @@ -142,11 +144,11 @@ testRemoteWelcome = do opts = def {createConv = CreateConv, createClients = DontCreateClients} MessagingSetup {..} <- aliceInvitesBob (1, RemoteUser bobDomain) opts let alice = creator - bob = Imports.head users + let okResp = EmptyResponse let mockedResponse fedReq = case frRPC fedReq of - "mls-welcome" -> pure (Aeson.encode ()) + "mls-welcome" -> pure (Aeson.encode okResp) ms -> assertFailure ("unmocked endpoint called: " <> cs ms) (_resp, reqs) <- @@ -156,15 +158,8 @@ testRemoteWelcome = do -- Assert the correct federated call is made. fedWelcome <- assertOne (filter ((== "mls-welcome") . frRPC) reqs) - let welcomeRequest :: Maybe MLSWelcomeRequest = Aeson.decode (frBody fedWelcome) - liftIO $ - fmap mwrRecipients welcomeRequest - @?= Just - [ MLSWelcomeRecipient - ( qUnqualified . pUserId $ bob, - snd . NonEmpty.head . pClients $ bob - ) - ] + let req :: Maybe MLSWelcomeRequest = Aeson.decode (frBody fedWelcome) + liftIO $ req @?= (Just . MLSWelcomeRequest . Base64ByteString) welcome -- | Send a commit message, and assert that all participants see an event with -- the given list of new members. diff --git a/services/galley/test/integration/API/Teams.hs b/services/galley/test/integration/API/Teams.hs index 3803e17628..3b2623515e 100644 --- a/services/galley/test/integration/API/Teams.hs +++ b/services/galley/test/integration/API/Teams.hs @@ -46,6 +46,7 @@ import Data.Json.Util hiding ((#)) import qualified Data.LegalHold as LH import Data.List1 import qualified Data.List1 as List1 +import qualified Data.Map as Map import Data.Misc (HttpsUrl, PlainTextPassword (..), mkHttpsUrl) import Data.Qualified import Data.Range @@ -86,6 +87,8 @@ import qualified Wire.API.Team.Member as Member import qualified Wire.API.Team.Member as TM import qualified Wire.API.User as Public import qualified Wire.API.User as U +import qualified Wire.API.User.Client as C +import qualified Wire.API.User.Client.Prekey as PC tests :: IO TestSetup -> TestTree tests s = @@ -286,7 +289,9 @@ testListTeamMembersCsv :: HasCallStack => Int -> TestM () testListTeamMembersCsv numMembers = do let teamSize = numMembers + 1 - (owner, tid, _mbs) <- Util.createBindingTeamWithNMembersWithHandles True numMembers + (owner, tid, mbs) <- Util.createBindingTeamWithNMembersWithHandles True numMembers + let numClientMappings = Map.fromList $ (owner : mbs) `zip` (cycle [1, 2, 3] :: [Int]) + addClients numClientMappings resp <- Util.getTeamMembersCsv owner tid let rbody = fromMaybe (error "no body") . responseBody $ resp usersInCsv <- either (error "could not decode csv") pure (decodeCSV @TeamExportUser rbody) @@ -322,6 +327,7 @@ testListTeamMembersCsv numMembers = do assertEqual ("tExportIdpIssuer: " <> show (U.userId user)) (userToIdPIssuer user) (tExportIdpIssuer export) assertEqual ("tExportManagedBy: " <> show (U.userId user)) (U.userManagedBy user) (tExportManagedBy export) 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 usr = case (U.userIdentity >=> U.ssoIdentity) usr of @@ -335,6 +341,20 @@ testListTeamMembersCsv numMembers = do 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 () + addClients xs = forM_ (Map.toList xs) addClientForUser + + addClientForUser :: (UserId, Int) -> TestM () + addClientForUser (uid, n) = forM_ [0 .. (n -1)] (addClient uid) + + addClient :: UserId -> Int -> TestM () + addClient uid i = do + brig <- view tsBrig + post (brig . paths ["i", "clients", toByteString' uid] . contentJson . json (newClient (someLastPrekeys !! i)) . queryItem "skip_reauth" "true") !!! const 201 === statusCode + + newClient :: PC.LastPrekey -> C.NewClient + newClient lpk = C.newClient C.PermanentClientType lpk + testListTeamMembersTruncated :: TestM () testListTeamMembersTruncated = do (owner, tid, _) <- Util.createBindingTeamWithNMembers 4 @@ -429,27 +449,30 @@ testEnableSSOPerTeam = do testEnableTeamSearchVisibilityPerTeam :: TestM () testEnableTeamSearchVisibilityPerTeam = do - g <- view tsGalley (tid, owner, member : _) <- Util.createBindingTeamWithMembers 2 - let check :: (HasCallStack, MonadCatch m, MonadIO m, Monad m, MonadHttp m) => String -> Public.TeamFeatureStatusValue -> m () + let check :: String -> Public.TeamFeatureStatusValue -> TestM () check msg enabledness = do + g <- view tsGalley status :: Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureSearchVisibility <- responseJsonUnsafe <$> (Util.getTeamSearchVisibilityAvailableInternal g tid m () + let putSearchVisibilityCheckNotAllowed :: TestM () putSearchVisibilityCheckNotAllowed = do + g <- view tsGalley Wai.Error status label _ _ <- responseJsonUnsafe <$> putSearchVisibility g owner tid SearchVisibilityNoNameOutsideTeam liftIO $ do assertEqual "bad status" status403 status assertEqual "bad label" "team-search-visibility-not-enabled" label - let getSearchVisibilityCheck :: (HasCallStack, MonadCatch m, MonadIO m, MonadHttp m) => TeamSearchVisibility -> m () - getSearchVisibilityCheck vis = + let getSearchVisibilityCheck :: TeamSearchVisibility -> TestM () + getSearchVisibilityCheck vis = do + g <- view tsGalley getSearchVisibility g owner tid !!! do const 200 === statusCode const (Just (TeamSearchVisibilityView vis)) === responseJsonUnsafe Util.withCustomSearchFeature FeatureTeamSearchVisibilityEnabledByDefault $ do + g <- view tsGalley check "Teams should start with Custom Search Visibility enabled" Public.TeamFeatureEnabled putSearchVisibility g owner tid SearchVisibilityNoNameOutsideTeam !!! const 204 === statusCode putSearchVisibility g owner tid SearchVisibilityStandard !!! const 204 === statusCode @@ -457,6 +480,7 @@ testEnableTeamSearchVisibilityPerTeam = do check "Teams should start with Custom Search Visibility disabled" Public.TeamFeatureDisabled putSearchVisibilityCheckNotAllowed + g <- view tsGalley Util.putTeamSearchVisibilityAvailableInternal g tid Public.TeamFeatureEnabled -- Nothing was set, default value getSearchVisibilityCheck SearchVisibilityStandard @@ -1649,7 +1673,7 @@ testBillingInLargeTeamWithoutIndexedBillingTeamMembers = do opts <- view tsGConf galley <- view tsGalley let withoutIndexedBillingTeamMembers = - withSettingsOverrides (opts & optSettings . setEnableIndexedBillingTeamMembers ?~ False) + withSettingsOverrides (\o -> o & optSettings . setEnableIndexedBillingTeamMembers ?~ False) let fanoutLimit = fromRange $ Galley.currentFanoutLimit opts -- Billing should work properly upto fanout limit @@ -1678,8 +1702,9 @@ testBillingInLargeTeamWithoutIndexedBillingTeamMembers = do let memFanoutPlusTwo = json $ Member.mkNewTeamMember ownerFanoutPlusTwo (rolePermissions RoleOwner) Nothing -- We cannot properly add the new owner with an invite as we don't have a way to -- override galley settings while making a call to brig - withoutIndexedBillingTeamMembers $ - post (galley . paths ["i", "teams", toByteString' team, "members"] . memFanoutPlusTwo) + withoutIndexedBillingTeamMembers $ do + g <- view tsGalley + post (g . paths ["i", "teams", toByteString' team, "members"] . memFanoutPlusTwo) !!! const 200 === statusCode assertQueue ("add " <> show (fanoutLimit + 2) <> "th billing member: " <> show ownerFanoutPlusTwo) $ \s maybeEvent -> @@ -1888,7 +1913,6 @@ postCryptoBroadcastMessageFilteredTooLargeTeam bcast = do localDomain <- viewFederationDomain let q :: Id a -> Qualified (Id a) q = (`Qualified` localDomain) - opts <- view tsGConf c <- view tsCannon -- Team1: alice, bob and 3 unnamed (alice, tid) <- Util.createBindingTeam @@ -1923,8 +1947,8 @@ postCryptoBroadcastMessageFilteredTooLargeTeam bcast = do WS.bracketR (c . queryItem "client" (toByteString' ac)) alice $ \wsA1 -> do -- We change also max conv size due to the invariants that galley forces us to keep let newOpts = - opts & optSettings . setMaxFanoutSize .~ Just (unsafeRange 4) - & optSettings . setMaxConvSize .~ 4 + ((optSettings . setMaxFanoutSize) ?~ unsafeRange 4) + . (optSettings . setMaxConvSize .~ 4) withSettingsOverrides newOpts $ do -- Untargeted, Alice's team is too large Util.postBroadcast (q alice) ac bcast {bMessage = msg} !!! do diff --git a/services/galley/test/integration/API/Teams/Feature.hs b/services/galley/test/integration/API/Teams/Feature.hs index dfd3af3c2d..0f529b85dc 100644 --- a/services/galley/test/integration/API/Teams/Feature.hs +++ b/services/galley/test/integration/API/Teams/Feature.hs @@ -172,43 +172,31 @@ testSearchVisibility = do Util.connectUsers owner (list1 member []) Util.addTeamMember owner tid member (rolePermissions RoleMember) Nothing - g <- view tsGalley - let getTeamSearchVisibility :: - (Monad m, MonadHttp m, MonadIO m, MonadCatch m, HasCallStack) => - TeamId -> - Public.TeamFeatureStatusValue -> - m () - getTeamSearchVisibility teamid expected = + let getTeamSearchVisibility :: TeamId -> Public.TeamFeatureStatusValue -> TestM () + getTeamSearchVisibility teamid expected = do + g <- view tsGalley Util.getTeamSearchVisibilityAvailable g owner teamid !!! do statusCode === const 200 responseJsonEither === const (Right (Public.TeamFeatureStatusNoConfig expected)) - let getTeamSearchVisibilityInternal :: - (Monad m, MonadHttp m, MonadIO m, MonadCatch m, HasCallStack) => - TeamId -> - Public.TeamFeatureStatusValue -> - m () - getTeamSearchVisibilityInternal teamid expected = + let getTeamSearchVisibilityInternal :: TeamId -> Public.TeamFeatureStatusValue -> TestM () + getTeamSearchVisibilityInternal teamid expected = do + g <- view tsGalley Util.getTeamSearchVisibilityAvailableInternal g teamid !!! do statusCode === const 200 responseJsonEither === const (Right (Public.TeamFeatureStatusNoConfig expected)) - let getTeamSearchVisibilityFeatureConfig :: - (Monad m, MonadHttp m, MonadIO m, MonadCatch m, HasCallStack) => - UserId -> - Public.TeamFeatureStatusValue -> - m () - getTeamSearchVisibilityFeatureConfig uid expected = + let getTeamSearchVisibilityFeatureConfig :: UserId -> Public.TeamFeatureStatusValue -> TestM () + getTeamSearchVisibilityFeatureConfig uid expected = do + g <- view tsGalley Util.getFeatureConfigWithGalley Public.TeamFeatureSearchVisibility g uid !!! do statusCode === const 200 responseJsonEither === const (Right (Public.TeamFeatureStatusNoConfig expected)) - let setTeamSearchVisibilityInternal :: - (Monad m, MonadHttp m, MonadIO m, HasCallStack) => - TeamId -> - Public.TeamFeatureStatusValue -> - m () - setTeamSearchVisibilityInternal = Util.putTeamSearchVisibilityAvailableInternal g + let setTeamSearchVisibilityInternal :: TeamId -> Public.TeamFeatureStatusValue -> TestM () + setTeamSearchVisibilityInternal teamid val = do + g <- view tsGalley + Util.putTeamSearchVisibilityAvailableInternal g teamid val assertFlagForbidden $ Util.getTeamFeatureFlag Public.TeamFeatureSearchVisibility nonMember tid @@ -311,8 +299,7 @@ testClassifiedDomainsDisabled = do assertFlagWithConfig @Public.TeamFeatureClassifiedDomainsConfig $ Util.getFeatureConfig Public.TeamFeatureClassifiedDomains uid - opts <- view tsGConf - let classifiedDomainsDisabled = + let classifiedDomainsDisabled = \opts -> opts & over (optSettings . setFeatureFlags . flagClassifiedDomains) diff --git a/services/galley/test/integration/API/Teams/LegalHold.hs b/services/galley/test/integration/API/Teams/LegalHold.hs index 048efe592d..c44dab965b 100644 --- a/services/galley/test/integration/API/Teams/LegalHold.hs +++ b/services/galley/test/integration/API/Teams/LegalHold.hs @@ -29,7 +29,6 @@ import qualified API.SQS as SQS import API.Util import Bilge hiding (accept, head, timeout, trace) import Bilge.Assert -import qualified Bilge.TestSession as BilgeTest import Brig.Types.Client import Brig.Types.Intra (UserSet (..)) import Brig.Types.Provider @@ -1564,11 +1563,11 @@ 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 -> BilgeTest.SessionT TestM a -> TestM a +withLHWhitelist :: forall a. HasCallStack => TeamId -> TestM a -> TestM a withLHWhitelist tid action = do void $ putLHWhitelistTeam tid opts <- view tsGConf - withSettingsOverrides opts action + withSettingsOverrides (const opts) action -- | 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. diff --git a/services/galley/test/integration/API/Util.hs b/services/galley/test/integration/API/Util.hs index f72eb36c8e..3f4bddeaa8 100644 --- a/services/galley/test/integration/API/Util.hs +++ b/services/galley/test/integration/API/Util.hs @@ -30,15 +30,14 @@ import Brig.Types.User.Auth (CookieLabel (..)) import Control.Concurrent.Async import Control.Exception (throw) import Control.Lens hiding (from, to, (#), (.=)) -import Control.Monad.Catch (MonadCatch, MonadMask, finally) +import Control.Monad.Catch (MonadCatch, MonadMask) +import Control.Monad.Codensity (lowerCodensity) import Control.Monad.Except (ExceptT, runExceptT) import Control.Retry (constantDelay, exponentialBackoff, limitRetries, retrying) import Data.Aeson hiding (json) import Data.Aeson.Lens (key, _String) import qualified Data.ByteString as BS -import Data.ByteString.Builder (toLazyByteString) import qualified Data.ByteString.Char8 as C -import qualified Data.ByteString.Char8 as C8 import Data.ByteString.Conversion import qualified Data.ByteString.Lazy as Lazy import qualified Data.CaseInsensitive as CI @@ -60,7 +59,6 @@ import qualified Data.ProtoLens as Protolens import Data.ProtocolBuffers (encodeMessage) import Data.Qualified import Data.Range -import qualified Data.Sequence as Seq import Data.Serialize (runPut) import qualified Data.Set as Set import Data.Singletons @@ -74,7 +72,6 @@ import qualified Data.UUID as UUID import Data.UUID.V4 import Federator.MockServer (FederatedRequest (..)) import qualified Federator.MockServer as Mock -import GHC.TypeLits import Galley.Intra.User (chunkify) import qualified Galley.Options as Opts import qualified Galley.Run as Run @@ -89,19 +86,12 @@ import Galley.Types.Teams.Intra import Galley.Types.UserList import Imports import Network.HTTP.Media.MediaType -import Network.HTTP.Media.RenderHeader (renderHeader) -import Network.HTTP.Types (http11, renderQuery) import qualified Network.HTTP.Types as HTTP import Network.Wai (Application, defaultRequest) import qualified Network.Wai as Wai import qualified Network.Wai.Test as Wai -import qualified Network.Wai.Test as WaiTest +import Network.Wai.Utilities.MockServer (withMockServer) import Servant (Handler, HasServer, Server, ServerT, serve, (:<|>) (..)) -import Servant.Client (ClientError (FailureResponse)) -import qualified Servant.Client as Servant -import Servant.Client.Core (RunClient (throwClientError)) -import qualified Servant.Client.Core as Servant -import qualified Servant.Client.Core.Request as ServantRequest import System.Exit import System.Process import System.Random @@ -661,10 +651,9 @@ defNewMLSConv :: NewConv defNewMLSConv = defNewProteusConv {newConvProtocol = ProtocolMLSTag} postConvQualified :: - (HasCallStack, HasGalley m, MonadIO m, MonadMask m, MonadHttp m) => UserId -> NewConv -> - m ResponseLBS + TestM ResponseLBS postConvQualified u n = do g <- viewGalley post $ @@ -2338,14 +2327,20 @@ postSSOUser name hasEmail ssoid teamid = do defCookieLabel :: CookieLabel defCookieLabel = CookieLabel "auth" --- | This allows you to run requests against a galley instantiated using the given options. --- Note that ONLY 'galley' calls should occur within the provided action, calls to other --- services will fail. -withSettingsOverrides :: (HasGalley m, MonadIO m, MonadMask m) => Opts.Opts -> SessionT m a -> m a -withSettingsOverrides opts action = do - (galleyApp, _, finalizer) <- liftIO $ Run.mkApp opts - runSessionT action galleyApp - `finally` liftIO finalizer +withSettingsOverrides :: (Opts.Opts -> Opts.Opts) -> TestM a -> TestM a +withSettingsOverrides f action = do + ts :: TestSetup <- ask + let opts = f (ts ^. tsGConf) + liftIO . lowerCodensity $ do + (galleyApp, _env) <- Run.mkApp opts + port' <- withMockServer galleyApp + liftIO $ + runReaderT + (runTestM action) + ( ts + & tsGalley .~ Bilge.host "127.0.0.1" . Bilge.port port' + & tsFedGalleyClient .~ FedClient (ts ^. tsManager) (Endpoint "127.0.0.1" port') + ) waitForMemberDeletion :: UserId -> TeamId -> UserId -> TestM () waitForMemberDeletion zusr tid uid = do @@ -2483,36 +2478,30 @@ mkProfile quid name = -- federator response (of an arbitrary JSON-serialisable type a) for every -- expected request. withTempMockFederator :: - (MonadIO m, ToJSON a, HasGalley m, MonadMask m) => + ToJSON a => (FederatedRequest -> a) -> - SessionT m b -> - m (b, [FederatedRequest]) + TestM b -> + TestM (b, [FederatedRequest]) withTempMockFederator resp = withTempMockFederator' $ pure . encode . resp withTempMockFederator' :: - (MonadIO m, HasGalley m, MonadMask m) => (FederatedRequest -> IO LByteString) -> - SessionT m b -> - m (b, [FederatedRequest]) + TestM b -> + TestM (b, [FederatedRequest]) withTempMockFederator' resp action = do - opts <- viewGalleyOpts Mock.withTempMockFederator [("Content-Type", "application/json")] ((\r -> pure ("application" // "json", r)) <=< resp) $ \mockPort -> do - let opts' = - opts & Opts.optFederator - ?~ Endpoint "127.0.0.1" (fromIntegral mockPort) - withSettingsOverrides opts' action + withSettingsOverrides (\opts -> opts & Opts.optFederator ?~ Endpoint "127.0.0.1" (fromIntegral mockPort)) action -- Start a mock federator. Use proveded Servant handler for the mocking mocking function. withTempServantMockFederator :: - (MonadMask m, MonadIO m, HasGalley m) => (Domain -> ServerT (FedApi 'Brig) Handler) -> (Domain -> ServerT (FedApi 'Galley) Handler) -> Domain -> - SessionT m b -> - m (b, [FederatedRequest]) + TestM b -> + TestM (b, [FederatedRequest]) withTempServantMockFederator brigApi galleyApi originDomain = withTempMockFederator' mock where @@ -2793,90 +2782,3 @@ wsAssertConvReceiptModeUpdate conv usr new n = do evtType e @?= ConvReceiptModeUpdate evtFrom e @?= usr evtData e @?= EdConvReceiptModeUpdate (ConversationReceiptModeUpdate new) - -newtype WaiTestFedClient a = WaiTestFedClient {unWaiTestFedClient :: ReaderT Domain WaiTest.Session a} - deriving (Functor, Applicative, Monad, MonadIO) - -instance Servant.RunClient WaiTestFedClient where - runRequestAcceptStatus expectedStatuses servantRequest = WaiTestFedClient $ do - domain <- ask - let req' = fromServantRequest domain servantRequest - res <- lift $ WaiTest.srequest req' - let servantResponse = toServantResponse res - let status = Servant.responseStatusCode servantResponse - let statusIsSuccess = - case expectedStatuses of - Nothing -> HTTP.statusIsSuccessful status - Just ex -> status `elem` ex - unless statusIsSuccess $ - unWaiTestFedClient $ throwClientError (FailureResponse (bimap (const ()) (\x -> (Servant.BaseUrl Servant.Http "" 80 "", cs (toLazyByteString x))) servantRequest) servantResponse) - pure servantResponse - throwClientError = liftIO . throw - -fromServantRequest :: Domain -> Servant.Request -> WaiTest.SRequest -fromServantRequest domain r = - let pathBS = "/federation" <> Data.String.Conversions.cs (toLazyByteString (Servant.requestPath r)) - bodyBS = case Servant.requestBody r of - Nothing -> "" - Just (bdy, _) -> case bdy of - Servant.RequestBodyLBS lbs -> Data.String.Conversions.cs lbs - Servant.RequestBodyBS bs -> bs - Servant.RequestBodySource _ -> error "fromServantRequest: not implemented for RequestBodySource" - - -- Content-Type and Accept are specified by requestBody and requestAccept - headers = - filter (\(h, _) -> h /= "Accept" && h /= "Content-Type") $ - toList $ Servant.requestHeaders r - acceptHdr - | null hs = Nothing - | otherwise = Just ("Accept", renderHeader hs) - where - hs = toList $ ServantRequest.requestAccept r - contentTypeHdr = case ServantRequest.requestBody r of - Nothing -> Nothing - Just (_', typ) -> Just (HTTP.hContentType, renderHeader typ) - req = - Wai.defaultRequest - { Wai.requestMethod = Servant.requestMethod r, - Wai.rawPathInfo = pathBS, - Wai.rawQueryString = renderQuery True (toList (Servant.requestQueryString r)), - Wai.requestHeaders = - -- Inspired by 'Servant.Client.Internal.HttpClient.defaultMakeClientRequest', - -- the Servant function that maps @Request@ to @Client.Request@. - -- This solution is a bit sophisticated due to two constraints: - -- - Accept header may contain a list of accepted media types. - -- - Accept and Content-Type headers should only appear once in the result. - maybeToList acceptHdr - <> maybeToList contentTypeHdr - <> headers - <> [(originDomainHeaderName, Text.encodeUtf8 (domainText domain))], - Wai.isSecure = True, - Wai.pathInfo = filter (not . Text.null) (map Data.String.Conversions.cs (C8.split '/' pathBS)), - Wai.queryString = toList (Servant.requestQueryString r) - } - in WaiTest.SRequest req (cs bodyBS) - -toServantResponse :: WaiTest.SResponse -> Servant.Response -toServantResponse res = - Servant.Response - { Servant.responseStatusCode = WaiTest.simpleStatus res, - Servant.responseHeaders = Seq.fromList (WaiTest.simpleHeaders res), - Servant.responseBody = WaiTest.simpleBody res, - Servant.responseHttpVersion = http11 - } - -createWaiTestFedClient :: - forall (name :: Symbol) comp api. - ( HasFedEndpoint comp api name, - Servant.HasClient WaiTestFedClient api - ) => - Servant.Client WaiTestFedClient api -createWaiTestFedClient = - Servant.clientIn (Proxy @api) (Proxy @WaiTestFedClient) - -runWaiTestFedClient :: - Domain -> - WaiTestFedClient a -> - WaiTest.Session a -runWaiTestFedClient domain action = - runReaderT (unWaiTestFedClient action) domain diff --git a/services/galley/test/integration/API/Util/TeamFeature.hs b/services/galley/test/integration/API/Util/TeamFeature.hs index e97a13d4fa..3824839026 100644 --- a/services/galley/test/integration/API/Util/TeamFeature.hs +++ b/services/galley/test/integration/API/Util/TeamFeature.hs @@ -20,7 +20,6 @@ module API.Util.TeamFeature where import API.Util (HasGalley (viewGalley), zUser) import qualified API.Util as Util import Bilge -import qualified Bilge.TestSession as BilgeTest import Control.Lens (view, (.~)) import Data.Aeson (ToJSON) import Data.ByteString.Conversion (toByteString') @@ -31,11 +30,9 @@ import Imports import TestSetup import qualified Wire.API.Team.Feature as Public -withCustomSearchFeature :: FeatureTeamSearchVisibility -> BilgeTest.SessionT TestM () -> TestM () +withCustomSearchFeature :: FeatureTeamSearchVisibility -> TestM () -> TestM () withCustomSearchFeature flag action = do - opts <- view tsGConf - let opts' = opts & optSettings . setFeatureFlags . flagTeamSearchVisibility .~ flag - Util.withSettingsOverrides opts' action + Util.withSettingsOverrides (\opts -> opts & optSettings . setFeatureFlags . flagTeamSearchVisibility .~ flag) action getTeamSearchVisibilityAvailable :: HasCallStack => (Request -> Request) -> UserId -> TeamId -> (MonadIO m, MonadHttp m) => m ResponseLBS getTeamSearchVisibilityAvailable = getTeamFeatureFlagWithGalley Public.TeamFeatureSearchVisibility diff --git a/services/gundeck/src/Gundeck/API/Internal.hs b/services/gundeck/src/Gundeck/API/Internal.hs index 554890aa48..23138ef109 100644 --- a/services/gundeck/src/Gundeck/API/Internal.hs +++ b/services/gundeck/src/Gundeck/API/Internal.hs @@ -38,8 +38,8 @@ import qualified Wire.API.Push.Token as PushTok sitemap :: Routes a Gundeck () sitemap = do - head "/i/status" (continue $ const (return empty)) true - get "/i/status" (continue $ const (return empty)) true + head "/i/status" (continue $ const (pure empty)) true + get "/i/status" (continue $ const (pure empty)) true -- Push API ----------------------------------------------------------- diff --git a/services/gundeck/src/Gundeck/API/Public.hs b/services/gundeck/src/Gundeck/API/Public.hs index 8a0e2cfbdb..a410c068a3 100644 --- a/services/gundeck/src/Gundeck/API/Public.hs +++ b/services/gundeck/src/Gundeck/API/Public.hs @@ -144,7 +144,7 @@ type JSON = Media "application" "json" docsH :: ByteString ::: JSON -> Gundeck Response docsH (url ::: _) = let doc = mkSwaggerApi (decodeLatin1 url) Public.Swagger.models sitemap - in return $ json doc + in pure $ json doc addTokenH :: UserId ::: ConnId ::: JsonRequest Public.PushToken ::: JSON -> Gundeck Response addTokenH (uid ::: cid ::: req ::: _) = do @@ -236,7 +236,7 @@ paginateH (_ ::: uid ::: sinceRaw ::: clt ::: size) = do since :: Maybe (Maybe NotificationId) since = parseUUID <$> sinceRaw parseUUID :: ByteString -> Maybe NotificationId - parseUUID = UUID.fromASCIIBytes >=> isV1UUID >=> return . Id + parseUUID = UUID.fromASCIIBytes >=> isV1UUID >=> pure . Id isV1UUID :: UUID -> Maybe UUID isV1UUID u = if UUID.version u == 1 then Just u else Nothing updStatus :: Bool -> Response -> Response diff --git a/services/gundeck/src/Gundeck/Aws.hs b/services/gundeck/src/Gundeck/Aws.hs index 31f6f1dee7..0694f07923 100644 --- a/services/gundeck/src/Gundeck/Aws.hs +++ b/services/gundeck/src/Gundeck/Aws.hs @@ -151,7 +151,7 @@ mkEnv lgr opts mgr = do (mkEndpoint SQS.defaultService (opts ^. optAws . awsSqsEndpoint)) (mkEndpoint SNS.defaultService (opts ^. optAws . awsSnsEndpoint)) q <- getQueueUrl e (opts ^. optAws . awsQueueName) - return (Env e g q (opts ^. optAws . awsRegion) (opts ^. optAws . awsAccount)) + pure (Env e g q (opts ^. optAws . awsRegion) (opts ^. optAws . awsAccount)) where mkEndpoint svc e = AWS.setEndpoint (e ^. awsSecure) (e ^. awsHost) (e ^. awsPort) svc mkAwsEnv g sqs sns = do @@ -204,7 +204,7 @@ mkEnv lgr opts mgr = do AWS.send e (SQS.newGetQueueUrl q) either (throwM . GeneralError) - (return . QueueUrl . view SQS.getQueueUrlResponse_queueUrl) + (pure . QueueUrl . view SQS.getQueueUrlResponse_queueUrl) x execute :: MonadIO m => Env -> Amazon a -> m a @@ -234,7 +234,7 @@ updateEndpoint us tk arn = do env <- ask res <- retrying (limitRetries 1) (const isTimeout) (const (sendCatch (env ^. awsEnv) req)) case res of - Right _ -> return () + Right _ -> pure () Left x@(AWS.ServiceError e) | is "SNS" 400 x && AWS.newErrorCode "InvalidParameter" == e ^. serviceCode && isMetadataLengthError (e ^. serviceMessage) -> @@ -255,13 +255,13 @@ updateEndpoint us tk arn = do let prefix = "Invalid parameter: Attributes Reason: " _ <- string prefix _ <- string "Invalid value for attribute: CustomUserData: must be at most 2048 bytes long in UTF-8 encoding" - return () + pure () deleteEndpoint :: EndpointArn -> Amazon () deleteEndpoint arn = do e <- view awsEnv res <- retrying (limitRetries 1) (const isTimeout) (const (sendCatch e req)) - either (throwM . GeneralError) (const (return ())) res + either (throwM . GeneralError) (const (pure ())) res where req = SNS.newDeleteEndpoint (toText arn) @@ -272,14 +272,14 @@ lookupEndpoint arn = do let attrs = fromMaybe mempty . view SNS.getEndpointAttributesResponse_attributes <$> res case attrs of Right a -> Just <$> mkEndpoint a - Left x -> if is "SNS" 404 x then return Nothing else throwM (GeneralError x) + Left x -> if is "SNS" 404 x then pure Nothing else throwM (GeneralError x) where req = SNS.newGetEndpointAttributes (toText arn) mkEndpoint a = do - t <- maybe (throwM $ NoToken arn) return (Map.lookup "Token" a) + t <- maybe (throwM $ NoToken arn) pure (Map.lookup "Token" a) let e = either (const Nothing) Just . fromText =<< Map.lookup "Enabled" a d = maybe Set.empty mkUsers $ Map.lookup "CustomUserData" a - return (SNSEndpoint (Push.Token t) (fromMaybe False e) d) + pure (SNSEndpoint (Push.Token t) (fromMaybe False e) d) mkUsers = Set.fromList . mapMaybe (hush . fromText) . Text.split (== ':') createEndpoint :: UserId -> Push.Transport -> ArnEnv -> AppName -> Push.Token -> Amazon (Either CreateEndpointError EndpointArn) @@ -301,21 +301,21 @@ createEndpoint u tr arnEnv app token = do Left x@(AWS.ServiceError e) | is "SNS" 400 x && AWS.newErrorCode "InvalidParameter" == e ^. serviceCode, Just ep <- parseExistsError (e ^. serviceMessage) -> - return (Left (EndpointInUse ep)) + pure (Left (EndpointInUse ep)) | is "SNS" 400 x && AWS.newErrorCode "InvalidParameter" == e ^. serviceCode && isLengthError (e ^. serviceMessage) -> - return (Left (TokenTooLong $ tokenLength token)) + pure (Left (TokenTooLong $ tokenLength token)) | is "SNS" 400 x && AWS.newErrorCode "InvalidParameter" == e ^. serviceCode && isTokenError (e ^. serviceMessage) -> - return (Left (InvalidToken token)) + pure (Left (InvalidToken token)) | is "SNS" 404 x -> - return (Left (AppNotFound app)) + pure (Left (AppNotFound app)) | is "SNS" 403 x -> do warn $ "arn" .= toText arn ~~ msg (val "Not authorized.") - return (Left (AppNotFound app)) + pure (Left (AppNotFound app)) Left x -> throwM (GeneralError x) where - readArn r = either (throwM . InvalidArn r) return (fromText r) + readArn r = either (throwM . InvalidArn r) pure (fromText r) tokenLength = toInteger . Text.length . Push.tokenText -- Thank you Amazon for not having granular error codes! parseExistsError Nothing = Nothing @@ -324,11 +324,11 @@ createEndpoint u tr arnEnv app token = do let endParser = string " already exists with the same Token, but different attributes." a <- manyTill anyChar endParser >>= either fail pure . AWS.fromText . Text.pack _ <- endParser - return a + pure a isTokenError Nothing = False isTokenError (Just s) = isRight . flip parseOnly (toText s) $ do _ <- string "Invalid parameter: Token" - return () + pure () isLengthError Nothing = False isLengthError (Just s) = isRight . flip parseOnly (toText s) $ do let prefix = "Invalid parameter: Token Reason: " @@ -336,7 +336,7 @@ createEndpoint u tr arnEnv app token = do _ <- string "must be at most 8192 bytes long in UTF-8 encoding" <|> string "iOS device tokens must be no more than 400 hexadecimal characters" - return () + pure () -------------------------------------------------------------------------------- -- Publish @@ -398,19 +398,19 @@ publish arn txt attrs = do env <- ask res <- retrying (limitRetries 3) (const isTimeout) (const (sendCatch (env ^. awsEnv) req)) case res of - Right _ -> return (Right ()) + Right _ -> pure (Right ()) Left x@(AWS.ServiceError e) | is "SNS" 400 x && AWS.newErrorCode "EndpointDisabled" == e ^. serviceCode -> - return (Left (EndpointDisabled arn)) + pure (Left (EndpointDisabled arn)) | is "SNS" 400 x && AWS.newErrorCode "InvalidParameter" == e ^. serviceCode && isProtocolSizeError (e ^. serviceMessage) -> - return (Left (PayloadTooLarge arn)) + pure (Left (PayloadTooLarge arn)) | is "SNS" 400 x && AWS.newErrorCode "InvalidParameter" == e ^. serviceCode && isSnsSizeError (e ^. serviceMessage) -> - return (Left (PayloadTooLarge arn)) + pure (Left (PayloadTooLarge arn)) | is "SNS" 400 x && AWS.newErrorCode "InvalidParameter" == e ^. serviceCode && isArnError (e ^. serviceMessage) -> - return (Left (InvalidEndpoint arn)) + pure (Left (InvalidEndpoint arn)) Left x -> throwM (GeneralError x) where -- Thank you Amazon for not having granular error codes! @@ -424,15 +424,15 @@ publish arn txt attrs = do _ <- case t of Push.GCM -> string ": Notification data is larger than allowed limit" _ -> string ": Notification is too long" - return () + pure () isSnsSizeError Nothing = False isSnsSizeError (Just s) = isRight . flip parseOnly (toText s) $ do _ <- string "Invalid parameter: Message too long" - return () + pure () isArnError Nothing = False isArnError (Just s) = isRight . flip parseOnly (toText s) $ do _ <- string "Invalid parameter: TargetArn Reason: No endpoint found for the target arn specified" - return () + pure () -------------------------------------------------------------------------------- -- Feedback @@ -452,7 +452,7 @@ listen throttleMillis callback = do & set SQS.receiveMessage_waitTimeSeconds (Just 20) . set SQS.receiveMessage_maxNumberOfMessages (Just 10) onMessage awsE url m = - case decodeStrict =<< Text.encodeUtf8 <$> m ^. SQS.message_body of + case decodeStrict . Text.encodeUtf8 =<< (m ^. SQS.message_body) of Nothing -> err . msg $ val "Failed to parse SQS event notification" Just e -> do @@ -473,7 +473,7 @@ sendCatch :: AWSRequest r => AWS.Env -> r -> Amazon (Either AWS.Error (AWSRespon sendCatch env = AWS.trying AWS._Error . AWS.send env send :: AWSRequest r => AWS.Env -> r -> Amazon (AWSResponse r) -send env r = either (throwM . GeneralError) return =<< sendCatch env r +send env r = either (throwM . GeneralError) pure =<< sendCatch env r is :: AWS.Abbrev -> Int -> AWS.Error -> Bool is srv s (AWS.ServiceError e) = srv == e ^. serviceAbbrev && s == statusCode (e ^. serviceStatus) diff --git a/services/gundeck/src/Gundeck/Aws/Arn.hs b/services/gundeck/src/Gundeck/Aws/Arn.hs index bd82d9f538..f88bc3f138 100644 --- a/services/gundeck/src/Gundeck/Aws/Arn.hs +++ b/services/gundeck/src/Gundeck/Aws/Arn.hs @@ -142,10 +142,10 @@ arnTransportText APNSVoIPSandbox = "APNS_VOIP_SANDBOX" snsArnParser :: (FromText t, ToText t) => Parser (SnsArn t) snsArnParser = do _ <- string "arn" *> char ':' *> string "aws" *> char ':' *> string "sns" - r <- char ':' *> takeTill (== ':') >>= either fail return . fromText + r <- char ':' *> takeTill (== ':') >>= either fail pure . fromText a <- char ':' *> takeTill (== ':') - t <- char ':' *> takeText >>= either fail return . fromText - return $ mkSnsArn r (Account a) t + t <- char ':' *> takeText >>= either fail pure . fromText + pure $ mkSnsArn r (Account a) t endpointTopicParser :: Parser EndpointTopic endpointTopicParser = do @@ -154,7 +154,7 @@ endpointTopicParser = do e <- char '/' *> takeTill (== '-') a <- char '-' *> takeTill (== '/') i <- char '/' *> takeWhile1 (not . isSpace) - return $ mkEndpointTopic (ArnEnv e) t (AppName a) (EndpointId i) + pure $ mkEndpointTopic (ArnEnv e) t (AppName a) (EndpointId i) transportParser :: Parser Transport transportParser = diff --git a/services/gundeck/src/Gundeck/Aws/Sns.hs b/services/gundeck/src/Gundeck/Aws/Sns.hs index 5e4241ab06..3c0315d649 100644 --- a/services/gundeck/src/Gundeck/Aws/Sns.hs +++ b/services/gundeck/src/Gundeck/Aws/Sns.hs @@ -89,8 +89,8 @@ instance ToText EventType where instance FromJSON Event where -- n.b. The SNS topic publishing these events must be configured for raw -- message delivery: cf. https://aws.amazon.com/sns/faqs/#raw-message-delivery - parseJSON m = maybe (fail "Failed to parse SNS event") return $ do + parseJSON m = maybe (fail "Failed to parse SNS event") pure $ do e <- m ^? key "EndpointArn" . _String >>= hush . fromText t <- m ^? key "EventType" . _String let f = m ^? key "FailureType" . _String - return $! Event (readEventType t f) e + pure $! Event (readEventType t f) e diff --git a/services/gundeck/src/Gundeck/Env.hs b/services/gundeck/src/Gundeck/Env.hs index fcc5a77082..0d66896a2d 100644 --- a/services/gundeck/src/Gundeck/Env.hs +++ b/services/gundeck/src/Gundeck/Env.hs @@ -107,7 +107,7 @@ createEnv m o = do { updateAction = Ms . round . (* 1000) <$> getPOSIXTime } mtbs <- mkThreadBudgetState `mapM` (o ^. optSettings . setMaxConcurrentNativePushes) - return $! Env def m o l n p r rAdditional a io mtbs + pure $! Env def m o l n p r rAdditional a io mtbs reqIdMsg :: RequestId -> Logger.Msg -> Logger.Msg reqIdMsg = ("request" Logger..=) . unRequestId @@ -151,4 +151,4 @@ checkedConnectCluster l connInfo = do Left r -> error ("could not ping redis cluster: " <> show r) Right _ -> pure () Log.info l $ Log.msg (Log.val "ping went through") - return conn + pure conn diff --git a/services/gundeck/src/Gundeck/Instances.hs b/services/gundeck/src/Gundeck/Instances.hs index 5dc0665bc4..9b2087b5b7 100644 --- a/services/gundeck/src/Gundeck/Instances.hs +++ b/services/gundeck/src/Gundeck/Instances.hs @@ -44,11 +44,11 @@ instance Cql Transport where toCql APNSVoIPSandbox = CqlInt 4 fromCql (CqlInt i) = case i of - 0 -> return GCM - 1 -> return APNS - 2 -> return APNSSandbox - 3 -> return APNSVoIP - 4 -> return APNSVoIPSandbox + 0 -> pure GCM + 1 -> pure APNS + 2 -> pure APNSSandbox + 3 -> pure APNSVoIP + 4 -> pure APNSVoIPSandbox n -> Left $ "unexpected transport: " ++ show n fromCql _ = Left "transport: int expected" @@ -57,13 +57,13 @@ instance Cql ConnId where toCql (ConnId c) = CqlBlob (Bytes.fromStrict c) - fromCql (CqlBlob b) = return . ConnId $ Bytes.toStrict b + fromCql (CqlBlob b) = pure . ConnId $ Bytes.toStrict b fromCql _ = Left "ConnId: Blob expected" instance Cql EndpointArn where ctype = Tagged TextColumn toCql = CqlText . toText - fromCql (CqlText txt) = either Left return (fromText txt) + fromCql (CqlText txt) = either Left pure (fromText txt) fromCql _ = Left "EndpointArn: Text expected" instance Cql Token where @@ -87,4 +87,4 @@ instance FromText (Id a) where Parser.take 36 >>= \txt -> txt & Text.encodeUtf8 & Uuid.fromASCIIBytes - & maybe (fail "Invalid UUID") (return . Id) + & maybe (fail "Invalid UUID") (pure . Id) diff --git a/services/gundeck/src/Gundeck/Monad.hs b/services/gundeck/src/Gundeck/Monad.hs index 440e007d44..a95f5d9c36 100644 --- a/services/gundeck/src/Gundeck/Monad.hs +++ b/services/gundeck/src/Gundeck/Monad.hs @@ -168,11 +168,11 @@ lookupReqId = maybe def RequestId . lookup requestIdName . requestHeaders {-# INLINE lookupReqId #-} fromJsonBody :: FromJSON a => JsonRequest a -> Gundeck a -fromJsonBody r = exceptT (throwM . mkError status400 "bad-request") return (parseBody r) +fromJsonBody r = exceptT (throwM . mkError status400 "bad-request") pure (parseBody r) {-# INLINE fromJsonBody #-} ifNothing :: Error -> Maybe a -> Gundeck a -ifNothing e = maybe (throwM e) return +ifNothing e = maybe (throwM e) pure {-# INLINE ifNothing #-} posixTime :: Gundeck Milliseconds diff --git a/services/gundeck/src/Gundeck/Notification.hs b/services/gundeck/src/Gundeck/Notification.hs index d5e8a0e691..d7529611af 100644 --- a/services/gundeck/src/Gundeck/Notification.hs +++ b/services/gundeck/src/Gundeck/Notification.hs @@ -55,9 +55,9 @@ paginate uid since clt size = do getById :: UserId -> NotificationId -> Maybe ClientId -> Gundeck QueuedNotification getById uid nid clt = do mn <- Data.fetchId uid nid clt - maybe (throwM notificationNotFound) return mn + maybe (throwM notificationNotFound) pure mn getLast :: UserId -> Maybe ClientId -> Gundeck QueuedNotification getLast uid clt = do mn <- Data.fetchLast uid clt - maybe (throwM notificationNotFound) return mn + maybe (throwM notificationNotFound) pure mn diff --git a/services/gundeck/src/Gundeck/Notification/Data.hs b/services/gundeck/src/Gundeck/Notification/Data.hs index c4337a5ad6..85d3428f8c 100644 --- a/services/gundeck/src/Gundeck/Notification/Data.hs +++ b/services/gundeck/src/Gundeck/Notification/Data.hs @@ -86,7 +86,7 @@ fetchLast :: MonadClient m => UserId -> Maybe ClientId -> m (Maybe QueuedNotific fetchLast u c = do ls <- query cqlLast (params LocalQuorum (Identity u)) & retry x1 case ls of - [] -> return Nothing + [] -> pure Nothing ns@(n : _) -> ns `getFirstOrElse` do p <- paginate cqlSeek (paramsP LocalQuorum (u, n ^. _1) 100) & retry x1 @@ -96,10 +96,10 @@ fetchLast u c = do result p `getFirstOrElse` if hasMore p then liftClient (nextPage p) >>= seek - else return Nothing + else pure Nothing getFirstOrElse ns f = case listToMaybe (foldr' (toNotif c) [] ns) of - Just n -> return (Just n) + Just n -> pure (Just n) Nothing -> f cqlLast :: PrepQuery R (Identity UserId) (TimeUuid, Blob, Maybe (C.Set ClientId)) cqlLast = @@ -128,7 +128,7 @@ fetch u c since (fromRange -> size) = do (ns, more) <- collect Seq.empty isize page1 -- Drop the extra element from the end as well as the inclusive start -- value (if a 'since' was given and found). - return $! case Seq.viewl (trim (isize - 1) ns) of + pure $! case Seq.viewl (trim (isize - 1) ns) of EmptyL -> ResultPage Seq.empty False (isJust since) x :< xs -> case since of Just s @@ -143,7 +143,7 @@ fetch u c since (fromRange -> size) = do num' = num - Seq.length nseq acc' = acc >< nseq in if not more || num' == 0 - then return (acc', more || not (null (snd ns))) + then pure (acc', more || not (null (snd ns))) else liftClient (nextPage page) >>= collect acc' num' trim l ns | Seq.length ns <= l = ns diff --git a/services/gundeck/src/Gundeck/Presence.hs b/services/gundeck/src/Gundeck/Presence.hs index 8894e04b4a..42c0d320e2 100644 --- a/services/gundeck/src/Gundeck/Presence.hs +++ b/services/gundeck/src/Gundeck/Presence.hs @@ -47,11 +47,11 @@ add :: Request ::: JSON -> Gundeck Response add (req ::: _) = do p <- fromJsonBody (JsonRequest req) Data.add p - return $ + pure $ ( setStatus status201 . addHeader hLocation (toByteString' (resource p)) ) empty remove :: UserId ::: ConnId ::: CannonId -> Gundeck Response -remove _ = return (empty & setStatus status204) +remove _ = pure (empty & setStatus status204) diff --git a/services/gundeck/src/Gundeck/Presence/Data.hs b/services/gundeck/src/Gundeck/Presence/Data.hs index 9268413818..e5e4a571d2 100644 --- a/services/gundeck/src/Gundeck/Presence/Data.hs +++ b/services/gundeck/src/Gundeck/Presence/Data.hs @@ -63,7 +63,7 @@ add p = do let v = toField (connId p) let d = Lazy.toStrict $ encode $ PresenceData (resource p) (clientId p) now runWithAdditionalRedis . retry x3 $ do - void . (fromTxResult =<<) . liftRedis . multiExec $ do + void . fromTxResult <=< (liftRedis . multiExec) $ do void $ hset k v d -- nb. All presences of a user are expired 'maxIdleTime' after the -- last presence was registered. A client who keeps a presence @@ -74,7 +74,7 @@ add p = do maxIdleTime = 7 * 24 * 60 * 60 -- 7 days in seconds deleteAll :: (MonadRedis m, MonadMask m, MonadThrow m, MonadIO m, RedisCtx m (Either Reply), MonadLogger m) => [Presence] -> m () -deleteAll [] = return () +deleteAll [] = pure () deleteAll pp = for_ pp $ \p -> do let k = toKey (userId p) let f = Lazy.toStrict $ __field p @@ -102,7 +102,7 @@ list' u = mapMaybe (readPresence u) <$$> hgetall (toKey u) -- FUTUREWORK: Make this not fail if it fails only for a few users. listAll :: (MonadRedis m, MonadThrow m) => [UserId] -> m [[Presence]] -listAll [] = return [] +listAll [] = pure [] listAll uu = mapM list uu -- Helpers ------------------------------------------------------------------- @@ -139,4 +139,4 @@ readPresence u (f, b) = do if "http" `Strict.isPrefixOf` b then PresenceData <$> fromByteString b <*> pure Nothing <*> pure 0 else decodeStrict' b - return (Presence u (fromField f) uri clt tme (Lazy.fromStrict f)) + pure (Presence u (fromField f) uri clt tme (Lazy.fromStrict f)) diff --git a/services/gundeck/src/Gundeck/Push.hs b/services/gundeck/src/Gundeck/Push.hs index 09ab034251..486d9d5a27 100644 --- a/services/gundeck/src/Gundeck/Push.hs +++ b/services/gundeck/src/Gundeck/Push.hs @@ -79,7 +79,7 @@ push ps = do then (Right <$> pushAll ps) `catch` (pure . Left . Seq.singleton) else pushAny ps case rs of - Right () -> return () + Right () -> pure () Left exs -> do forM_ exs $ Log.err . msg . (val "Push failed: " +++) . show throwM (mkError status500 "server-error" "Server Error") @@ -305,7 +305,7 @@ shouldActuallyPush psh rcp pres = not isOrigin && okByPushWhitelist && okByRecip isOrigin = psh ^. pushOrigin == Just (userId pres) && psh ^. pushOriginConnection == Just (connId pres) - okByPushWhitelist = if whitelistExists then isWhitelisted else True + okByPushWhitelist = not whitelistExists || isWhitelisted where whitelist = psh ^. pushConnections whitelistExists = not $ Set.null whitelist @@ -319,7 +319,7 @@ shouldActuallyPush psh rcp pres = not isOrigin && okByPushWhitelist && okByRecip -- | Failures to push natively can be ignored. Logging already happens in -- 'Gundeck.Push.Native.push1', and we cannot recover from any of the error cases. pushNative :: Notification -> Priority -> [Address] -> Gundeck () -pushNative _ _ [] = return () +pushNative _ _ [] = pure () pushNative notif prio rcps = do Native.push (Native.NativePush (ntfId notif) prio Nothing) rcps @@ -348,7 +348,7 @@ nativeTargets psh rcps' alreadySent = addresses :: Recipient -> m [Address] addresses u = do addrs <- mntgtLookupAddresses (u ^. recipientId) - return $ + pure $ preference . filter (eligible u) $ addrs @@ -398,8 +398,8 @@ nativeTargets psh rcps' alreadySent = LowPriority -> ApsStdPreference HighPriority -> ApsVoIPPreference check :: Either SomeException [a] -> m [a] - check (Left e) = mntgtLogErr e >> return [] - check (Right r) = return r + check (Left e) = mntgtLogErr e >> pure [] + check (Right r) = pure r data AddTokenResponse = AddTokenSuccess Public.PushToken @@ -418,10 +418,10 @@ addToken uid cid newtok = mpaRunWithBudget 1 AddTokenNoBudget $ do ~~ msg (val "Registering push token") continue newtok cur >>= either - return + pure ( \a -> do Native.deleteTokens old (Just a) - return (AddTokenSuccess newtok) + pure (AddTokenSuccess newtok) ) where matching :: @@ -462,18 +462,18 @@ addToken uid cid newtok = mpaRunWithBudget 1 AddTokenNoBudget $ do update (n + 1) t arn Left (Aws.AppNotFound app') -> do Log.info $ msg ("Push token of unknown application: '" <> appNameText app' <> "'") - return (Left AddTokenNotFound) + pure (Left AddTokenNotFound) Left (Aws.InvalidToken _) -> do Log.info $ "token" .= tokenText tok ~~ msg (val "Invalid push token.") - return (Left AddTokenInvalid) + pure (Left AddTokenInvalid) Left (Aws.TokenTooLong l) -> do Log.info $ msg ("Push token is too long: token length = " ++ show l) - return (Left AddTokenTooLong) + pure (Left AddTokenTooLong) Right arn -> do Data.insert uid trp app tok arn cid (t ^. tokenClient) - return (Right (mkAddr t arn)) + pure (Right (mkAddr t arn)) update :: Int -> @@ -499,7 +499,7 @@ addToken uid cid newtok = mpaRunWithBudget 1 AddTokenNoBudget $ do arn cid (t ^. tokenClient) - return (Right (mkAddr t arn)) + pure (Right (mkAddr t arn)) `catch` \case -- Note: If the endpoint was recently deleted (not necessarily -- concurrently), we may get an EndpointNotFound error despite @@ -508,7 +508,7 @@ addToken uid cid newtok = mpaRunWithBudget 1 AddTokenNoBudget $ do -- possibly updates in general). We make another attempt to (re-)create -- the endpoint in these cases instead of failing immediately. Aws.EndpointNotFound {} -> create (n + 1) t - Aws.InvalidCustomData {} -> return (Left AddTokenMetadataTooLong) + Aws.InvalidCustomData {} -> pure (Left AddTokenMetadataTooLong) ex -> throwM ex mkAddr :: diff --git a/services/gundeck/src/Gundeck/Push/Data.hs b/services/gundeck/src/Gundeck/Push/Data.hs index af690e160b..f8bc4b8c3c 100644 --- a/services/gundeck/src/Gundeck/Push/Data.hs +++ b/services/gundeck/src/Gundeck/Push/Data.hs @@ -64,7 +64,7 @@ mkAddr :: (UserId, Transport, AppName, Token, Maybe EndpointArn, ConnId, Maybe ClientId) -> m (Maybe Address) mkAddr (usr, trp, app, tok, arn, con, clt) = case (clt, arn) of - (Just c, Just a) -> return $! Just $! Address usr a con (pushToken trp app tok c) + (Just c, Just a) -> pure $! Just $! Address usr a con (pushToken trp app tok c) _ -> do Log.info $ field "user" (toByteString usr) @@ -73,4 +73,4 @@ mkAddr (usr, trp, app, tok, arn, con, clt) = case (clt, arn) of ~~ field "token" (tokenText tok) ~~ msg (val "Deleting legacy push token without a client or ARN.") delete usr trp app tok - return Nothing + pure Nothing diff --git a/services/gundeck/src/Gundeck/Push/Native.hs b/services/gundeck/src/Gundeck/Push/Native.hs index dc9bef858b..96b602c634 100644 --- a/services/gundeck/src/Gundeck/Push/Native.hs +++ b/services/gundeck/src/Gundeck/Push/Native.hs @@ -127,7 +127,7 @@ publish m a = flip catches pushException $ do ~~ field "prio" (show (npPriority m)) ~~ Log.msg (val "Native push") case txt of - Left f -> return $! Failure f a + Left f -> pure $! Failure f a Right v -> toResult <$> Aws.publish ept v mempty where toResult (Left (Aws.EndpointDisabled _)) = Failure EndpointDisabled a @@ -138,7 +138,7 @@ publish m a = flip catches pushException $ do [ Handler (\(ex :: SomeAsyncException) -> throwM ex), Handler ( \(ex :: SomeException) -> - return (Failure (PushException ex) a) + pure (Failure (PushException ex) a) ) ] diff --git a/services/gundeck/src/Gundeck/Push/Native/Serialise.hs b/services/gundeck/src/Gundeck/Push/Native/Serialise.hs index 75cd3fa08f..0077594710 100644 --- a/services/gundeck/src/Gundeck/Push/Native/Serialise.hs +++ b/services/gundeck/src/Gundeck/Push/Native/Serialise.hs @@ -36,10 +36,10 @@ serialise :: HasCallStack => NativePush -> UserId -> Transport -> IO (Either Fai serialise m uid transport = do let rs = prepare m uid case rs of - Left failure -> return $! Left $! failure + Left failure -> pure $! Left $! failure Right (v, prio) -> case renderText transport prio v of - Nothing -> return $ Left PayloadTooLarge - Just txt -> return $ Right txt + Nothing -> pure $ Left PayloadTooLarge + Just txt -> pure $ Right txt prepare :: NativePush -> UserId -> Either Failure (Value, Priority) prepare m uid = case m of diff --git a/services/gundeck/src/Gundeck/Push/Websocket.hs b/services/gundeck/src/Gundeck/Push/Websocket.hs index 8f3a8666d0..61b8ab3490 100644 --- a/services/gundeck/src/Gundeck/Push/Websocket.hs +++ b/services/gundeck/src/Gundeck/Push/Websocket.hs @@ -315,7 +315,7 @@ push notif (toList -> tgts) originUser originConn conns = do pp <- handleAny noPresences listPresences (ok, gone) <- foldM onResult ([], []) =<< send notif pp runWithAdditionalRedis $ Presence.deleteAll gone - return ok + pure ok where listPresences = excludeOrigin @@ -328,7 +328,7 @@ push notif (toList -> tgts) originUser originConn conns = do Log.err $ Log.field "error" (show exn) ~~ Log.msg (val "Failed to get presences.") - return [] + pure [] filterByClient = map $ \(tgt, ps) -> let cs = tgt ^. targetClients in if null cs @@ -344,10 +344,10 @@ push notif (toList -> tgts) originUser originConn conns = do in filter (\p -> neqUser p || neqConn p) onResult (ok, gone) (PushSuccess p) = do Log.debug $ logPresence p ~~ Log.msg (val "WebSocket push success") - return (p : ok, gone) + pure (p : ok, gone) onResult (ok, gone) (PushGone p) = do Log.debug $ logPresence p ~~ Log.msg (val "WebSocket presence gone") - return (ok, p : gone) + pure (ok, p : gone) onResult (ok, gone) (PushFailure p _) = do view monitor >>= Metrics.counterIncr (Metrics.path "push.ws.unreachable") Log.info $ @@ -356,8 +356,8 @@ push notif (toList -> tgts) originUser originConn conns = do ~~ Log.msg (val "WebSocket presence unreachable: " +++ toByteString (resource p)) now <- posixTime if now - createdAt p > 10 * posixDay - then return (ok, p : gone) - else return (ok, gone) + then pure (ok, p : gone) + else pure (ok, gone) posixDay = Ms (round (1000 * posixDayLength)) ----------------------------------------------------------------------------- diff --git a/services/gundeck/src/Gundeck/React.hs b/services/gundeck/src/Gundeck/React.hs index 2d9af3359b..bca14ea6b1 100644 --- a/services/gundeck/src/Gundeck/React.hs +++ b/services/gundeck/src/Gundeck/React.hs @@ -78,7 +78,7 @@ 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 -> return () + | null sup -> pure () | null cur -> deleteEndpoint ev | otherwise -> updateEndpoint ev e (map (view addrUser) cur) diff --git a/services/gundeck/src/Gundeck/ThreadBudget/Internal.hs b/services/gundeck/src/Gundeck/ThreadBudget/Internal.hs index 7c8c59aeee..a0ecd813c0 100644 --- a/services/gundeck/src/Gundeck/ThreadBudget/Internal.hs +++ b/services/gundeck/src/Gundeck/ThreadBudget/Internal.hs @@ -60,7 +60,7 @@ budgetSpent' = sum . fmap fst . filter (isJust . snd) . HM.elems . bmap cancelAllThreads :: ThreadBudgetState -> IO () cancelAllThreads (ThreadBudgetState _ ref) = readIORef ref - >>= mapM_ cancel . catMaybes . fmap snd . HM.elems . bmap + >>= mapM_ cancel . mapMaybe snd . HM.elems . bmap mkThreadBudgetState :: HasCallStack => MaxConcurrentNativePushes -> IO ThreadBudgetState mkThreadBudgetState limits = ThreadBudgetState limits <$> newIORef (BudgetMap 0 HM.empty) @@ -81,7 +81,7 @@ register :: register ref key handle = atomicModifyIORef' ref $ \(BudgetMap spent hm) -> - ( BudgetMap spent (HM.adjust (_2 .~ Just handle) key hm), + ( BudgetMap spent (HM.adjust (_2 ?~ handle) key hm), spent ) @@ -219,7 +219,7 @@ removeStaleHandles ref = do unless (null staleHandles) $ do warnStaleHandles (Set.size staleHandles) =<< readIORef ref forM_ staleHandles $ \key -> do - mapM_ waitCatch . join . fmap snd =<< HM.lookup key . bmap <$> readIORef ref + (mapM_ waitCatch . (snd =<<)) . HM.lookup key . bmap =<< readIORef ref unregister ref key isSanitary <- (\bm -> bspent bm == budgetSpent' bm) <$> readIORef ref unless isSanitary . LC.warn . LC.msg . LC.val $ diff --git a/services/gundeck/src/Gundeck/Util.hs b/services/gundeck/src/Gundeck/Util.hs index 88263063a0..bbcc42fba9 100644 --- a/services/gundeck/src/Gundeck/Util.hs +++ b/services/gundeck/src/Gundeck/Util.hs @@ -34,10 +34,10 @@ type JSON = Media "application" "json" mkNotificationId :: (MonadIO m, MonadThrow m) => m NotificationId mkNotificationId = do ni <- fmap Id <$> retrying x10 fun (const (liftIO nextUUID)) - maybe (throwM err) return ni + maybe (throwM err) pure ni where x10 = limitRetries 10 <> exponentialBackoff 10 - fun = const (return . isNothing) + fun = const (pure . isNothing) err = mkError status500 "internal-error" "unable to generate notification ID" mapAsync :: diff --git a/services/gundeck/src/Gundeck/Util/DelayQueue.hs b/services/gundeck/src/Gundeck/Util/DelayQueue.hs index 453fe22622..c04f4f123e 100644 --- a/services/gundeck/src/Gundeck/Util/DelayQueue.hs +++ b/services/gundeck/src/Gundeck/Util/DelayQueue.hs @@ -52,7 +52,7 @@ newtype Limit = Limit {getLimit :: Int} new :: Clock -> Delay -> Limit -> IO (DelayQueue k v) new c d l = do queue <- newIORef PSQ.empty - return $! DelayQueue queue c d l + pure $! DelayQueue queue c d l enqueue :: Ord k => DelayQueue k v -> k -> v -> IO Bool enqueue (DelayQueue queue clock d l) k v = do diff --git a/services/gundeck/test/bench/Main.hs b/services/gundeck/test/bench/Main.hs index cbc7d99b05..a10feb5434 100644 --- a/services/gundeck/test/bench/Main.hs +++ b/services/gundeck/test/bench/Main.hs @@ -61,12 +61,12 @@ notice = do uid = a ^. addrUser transp = a ^. addrTransport Right txt <- serialise msg uid transp - return $! LT.toStrict txt + pure $! LT.toStrict txt bench_BudgetSpent' :: IORef BudgetMap -> IO () bench_BudgetSpent' ref = do budgetmap <- readIORef ref - void $ return $ budgetSpent' budgetmap + void $ pure $ budgetSpent' budgetmap ----------------------------------------------------------------------------- -- Utilities @@ -79,7 +79,7 @@ mkAddress t = do let tok = Token "test" let con = ConnId "conn" let clt = ClientId "client" - return $! Address u ept con (pushToken t app tok clt) + pure $! Address u ept con (pushToken t app tok clt) mkEndpoint :: Transport -> AppName -> EndpointArn mkEndpoint t a = mkSnsArn Ireland (Account "test") topic @@ -93,4 +93,4 @@ prepareBudgetState size = do key <- nextRandom weight <- randomRIO (1, 1000) allocate ref key weight - return ref + pure ref diff --git a/services/gundeck/test/integration/Main.hs b/services/gundeck/test/integration/Main.hs index f6c691a732..dd7978b3fb 100644 --- a/services/gundeck/test/integration/Main.hs +++ b/services/gundeck/test/integration/Main.hs @@ -61,12 +61,12 @@ newtype ServiceConfigFile = ServiceConfigFile String instance IsOption ServiceConfigFile where defaultValue = ServiceConfigFile "/etc/wire/gundeck/conf/gundeck.yaml" parseValue = fmap ServiceConfigFile . safeRead - optionName = return "service-config" - optionHelp = return "Service config file to read from" + optionName = pure "service-config" + optionHelp = pure "Service config file to read from" optionCLParser = ServiceConfigFile <$> strOption - ( short (untag (return 's' :: Tagged ServiceConfigFile Char)) + ( short (untag (pure 's' :: Tagged ServiceConfigFile Char)) <> long (untag (optionName :: Tagged ServiceConfigFile String)) <> help (untag (optionHelp :: Tagged ServiceConfigFile String)) ) @@ -111,6 +111,6 @@ main = withOpenSSL $ runTests go ck = gConf ^. optCassandra . casKeyspace lg <- Logger.new Logger.defSettings db <- defInitCassandra ck ch cp lg - return $ TestSetup m g c c2 b db lg gConf (redis2 iConf) - releaseOpts _ = return () + pure $ TestSetup m g c c2 b db lg gConf (redis2 iConf) + releaseOpts _ = pure () mkRequest (Endpoint h p) = host (encodeUtf8 h) . port p diff --git a/services/gundeck/test/integration/Util.hs b/services/gundeck/test/integration/Util.hs index ad0b921eb4..c6d0cef678 100644 --- a/services/gundeck/test/integration/Util.hs +++ b/services/gundeck/test/integration/Util.hs @@ -41,7 +41,7 @@ runRedisProxy redisHost redisPort proxyPort = do where getServerSocket servAddr = do server <- socket (addrFamily servAddr) Stream defaultProtocol - connect server (addrAddress servAddr) >> return server + connect server (addrAddress servAddr) >> pure server p1 <~~> p2 = finally (race_ (p1 `mapData` p2) (p2 `mapData` p1)) (close p1 >> close p2) mapData f t = do content <- recv f 4096 @@ -58,7 +58,7 @@ runTCPServer mhost port server = withSocketsDo $ do where open addr = E.bracketOnError (openServerSocket addr) close $ \sock -> do listen sock 1024 - return sock + pure sock loop clientThreads sock = forever $ do E.bracketOnError (accept sock) (close . fst) $ \(conn, _peer) -> do @@ -76,7 +76,7 @@ resolve socketType mhost port passive = hints = defaultHints { addrSocketType = socketType, - addrFlags = if passive then [AI_PASSIVE] else [] + addrFlags = [AI_PASSIVE | passive] } openServerSocket :: AddrInfo -> IO Socket @@ -84,7 +84,7 @@ openServerSocket addr = E.bracketOnError (openSocket addr) close $ \sock -> do setSocketOption sock ReuseAddr 1 withFdSocket sock $ setCloseOnExecIfNeeded bind sock $ addrAddress addr - return sock + pure sock openSocket :: AddrInfo -> IO Socket openSocket addr = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) diff --git a/services/gundeck/test/unit/DelayQueue.hs b/services/gundeck/test/unit/DelayQueue.hs index 383a9c2640..59bf0ad137 100644 --- a/services/gundeck/test/unit/DelayQueue.hs +++ b/services/gundeck/test/unit/DelayQueue.hs @@ -38,28 +38,28 @@ tests = enqueueLimitProp :: Positive Int -> Property enqueueLimitProp (Positive l) = ioProperty $ do - q <- DelayQueue.new (Clock (return 1)) (Delay 1) (Limit l) + q <- DelayQueue.new (Clock (pure 1)) (Delay 1) (Limit l) r <- forM [1 .. l + 1] $ \(i :: Int) -> DelayQueue.enqueue q i i l' <- DelayQueue.length q - return $ + pure $ r == replicate l True ++ [False] && l' == l enqueueUniqueProp :: Positive Int -> Property enqueueUniqueProp (Positive n) = ioProperty $ do - q <- DelayQueue.new (Clock (return 1)) (Delay 1) (Limit (n + 1)) + q <- DelayQueue.new (Clock (pure 1)) (Delay 1) (Limit (n + 1)) r <- forM [1 .. n] $ \(i :: Int) -> DelayQueue.enqueue q (1 :: Int) i l <- DelayQueue.length q - return $ all (== True) r && l == 1 + pure $ all (== True) r && l == 1 enqueueCancelProp :: Int -> Int -> Property enqueueCancelProp k v = ioProperty $ do - q <- DelayQueue.new (Clock (return 1)) (Delay 1) (Limit 1) + q <- DelayQueue.new (Clock (pure 1)) (Delay 1) (Limit 1) e <- DelayQueue.enqueue q k v l <- DelayQueue.length q c <- DelayQueue.cancel q k l' <- DelayQueue.length q - return $ e && c && l == 1 && l' == 0 + pure $ e && c && l == 1 && l' == 0 dequeueDelayProp :: Word16 -> Property dequeueDelayProp d = ioProperty $ do @@ -70,9 +70,9 @@ dequeueDelayProp d = ioProperty $ do x <- DelayQueue.dequeue q tick c let diff = fromIntegral (d - (i - 1)) - return $ x == Just (Left (Delay diff)) + pure $ x == Just (Left (Delay diff)) s <- DelayQueue.dequeue q - return $ e && and r && s == Just (Right 1) + pure $ e && and r && s == Just (Right 1) dequeueOrderProp :: Int -> Property dequeueOrderProp k = ioProperty $ do @@ -84,7 +84,7 @@ dequeueOrderProp k = ioProperty $ do tick c d1 <- DelayQueue.dequeue q d2 <- DelayQueue.dequeue q - return $ e1 && e2 && d1 == Just (Right 1) && d2 == Just (Right 2) + pure $ e1 && e2 && d1 == Just (Right 1) && d2 == Just (Right 2) -- Utilities diff --git a/services/gundeck/test/unit/Json.hs b/services/gundeck/test/unit/Json.hs index c4ec37fb98..49bdaf8e1b 100644 --- a/services/gundeck/test/unit/Json.hs +++ b/services/gundeck/test/unit/Json.hs @@ -77,7 +77,7 @@ genRecipient :: Gen Recipient genRecipient = do r <- recipient <$> arbitrary <*> elements [RouteAny, RouteDirect, RouteNative] c <- genRecipientClients - return $ r & set recipientClients c + pure $ r & set recipientClients c genRecipientClients :: Gen RecipientClients genRecipientClients = diff --git a/services/gundeck/test/unit/Native.hs b/services/gundeck/test/unit/Native.hs index d2d8373ca0..27fee4380d 100644 --- a/services/gundeck/test/unit/Native.hs +++ b/services/gundeck/test/unit/Native.hs @@ -53,10 +53,10 @@ serialiseOkProp t = ioProperty $ do let sn = either (const Nothing) Just r >>= decode' . LT.encodeUtf8 let equalTransport = fmap snsNotifTransport sn == Just t equalNotif <- case snsNotifBundle <$> sn of - Nothing -> return False - Just (NoticeBundle n') -> return $ ntfId n == n' + Nothing -> pure False + Just (NoticeBundle n') -> pure $ ntfId n == n' let debugInfo = (t, a, n, r, sn, equalTransport, equalNotif) - return . counterexample (show debugInfo) $ equalTransport && equalNotif + pure . counterexample (show debugInfo) $ equalTransport && equalNotif ----------------------------------------------------------------------------- -- Types diff --git a/services/nginz/Dockerfile b/services/nginz/Dockerfile index 6afb9e3d10..640a9774be 100644 --- a/services/nginz/Dockerfile +++ b/services/nginz/Dockerfile @@ -144,7 +144,9 @@ RUN mkdir -p /var/cache/nginx/client_temp && chown -R nginx:nginx /var/cache/ngi RUN apk add --no-cache inotify-tools dumb-init bash curl && \ # add libzauth runtime dependencies back in - apk add --no-cache libsodium llvm-libunwind libgcc + apk add --no-cache libsodium llvm-libunwind libgcc && \ + # add openssl runtime dependencies for TLS/SSL certificate support + apk add --no-cache openssl COPY services/nginz/nginz_reload.sh /usr/bin/nginz_reload.sh diff --git a/services/nginz/nginz_reload.sh b/services/nginz/nginz_reload.sh index f2ec41663e..0ed14d7444 100755 --- a/services/nginz/nginz_reload.sh +++ b/services/nginz/nginz_reload.sh @@ -7,6 +7,13 @@ nginx_pid=$! +cleanup () { + kill -QUIT $nginx_pid + wait $nginx_pid +} + +trap "cleanup" EXIT + watches=${WATCH_PATHS:-"/etc/wire/nginz/upstreams"} # only react on changes to upstreams.conf diff --git a/services/spar/.hlint.yaml b/services/spar/.hlint.yaml new file mode 120000 index 0000000000..f6977905d3 --- /dev/null +++ b/services/spar/.hlint.yaml @@ -0,0 +1 @@ +../../.hlint.yaml \ No newline at end of file diff --git a/services/spar/schema/src/V3.hs b/services/spar/schema/src/V3.hs index 43507af72c..7a7e544109 100644 --- a/services/spar/schema/src/V3.hs +++ b/services/spar/schema/src/V3.hs @@ -25,7 +25,7 @@ import Imports import Text.RawString.QQ migration :: Migration -migration = Migration 3 "Add cookie stash for binding existing users to sso identities" $ do +migration = Migration 3 "DEPRECATED AS OF https://github.com/wireapp/wire-server/pull/2441" $ do void $ schema' [r| diff --git a/services/spar/spar.cabal b/services/spar/spar.cabal index 768b3d65bd..0dc733def6 100644 --- a/services/spar/spar.cabal +++ b/services/spar/spar.cabal @@ -40,9 +40,6 @@ library Spar.Sem.AssIDStore Spar.Sem.AssIDStore.Cassandra Spar.Sem.AssIDStore.Mem - Spar.Sem.BindCookieStore - Spar.Sem.BindCookieStore.Cassandra - Spar.Sem.BindCookieStore.Mem Spar.Sem.BrigAccess Spar.Sem.BrigAccess.Http Spar.Sem.DefaultSsoCode diff --git a/services/spar/src/Spar/API.hs b/services/spar/src/Spar/API.hs index d1c81bbf58..6723ff3a06 100644 --- a/services/spar/src/Spar/API.hs +++ b/services/spar/src/Spar/API.hs @@ -1,7 +1,9 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} +{-# HLINT ignore "Use $>" #-} + -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2022 Wire Swiss GmbH @@ -45,7 +47,6 @@ where import Control.Lens import Control.Monad.Except import qualified Data.ByteString as SBS -import qualified Data.ByteString.Base64 as ES import Data.ByteString.Builder (toLazyByteString) import Data.Id import Data.Proxy @@ -67,8 +68,6 @@ import Spar.Orphans () import Spar.Scim import Spar.Sem.AReqIDStore (AReqIDStore) import Spar.Sem.AssIDStore (AssIDStore) -import Spar.Sem.BindCookieStore (BindCookieStore) -import qualified Spar.Sem.BindCookieStore as BindCookieStore import Spar.Sem.BrigAccess (BrigAccess) import qualified Spar.Sem.BrigAccess as BrigAccess import Spar.Sem.DefaultSsoCode (DefaultSsoCode) @@ -94,7 +93,6 @@ import Spar.Sem.VerdictFormatStore (VerdictFormatStore) import qualified Spar.Sem.VerdictFormatStore as VerdictFormatStore import System.Logger (Msg) import qualified URI.ByteString as URI -import Wire.API.Cookie import Wire.API.Routes.Public.Spar import Wire.API.User.IdentityProvider import Wire.API.User.Saml @@ -114,7 +112,6 @@ api :: '[ GalleyAccess, BrigAccess, Input Opts, - BindCookieStore, AssIDStore, AReqIDStore, VerdictFormatStore, @@ -141,8 +138,6 @@ api :: ServerT API (Sem r) api opts = apiSSO opts - :<|> authreqPrecheck - :<|> authreq (maxttlAuthreqDiffTime opts) DoInitiateBind :<|> apiIDP :<|> apiScim :<|> apiINTERNAL @@ -153,7 +148,6 @@ apiSSO :: Logger String, Input Opts, BrigAccess, - BindCookieStore, AssIDStore, VerdictFormatStore, AReqIDStore, @@ -171,10 +165,10 @@ apiSSO :: Opts -> ServerT APISSO (Sem r) apiSSO opts = - (SAML2.meta appName (SamlProtocolSettings.spIssuer Nothing) (SamlProtocolSettings.responseURI Nothing)) + SAML2.meta appName (SamlProtocolSettings.spIssuer Nothing) (SamlProtocolSettings.responseURI Nothing) :<|> (\tid -> SAML2.meta appName (SamlProtocolSettings.spIssuer (Just tid)) (SamlProtocolSettings.responseURI (Just tid))) :<|> authreqPrecheck - :<|> authreq (maxttlAuthreqDiffTime opts) DoInitiateLogin + :<|> authreq (maxttlAuthreqDiffTime opts) :<|> authresp Nothing :<|> authresp . Just :<|> ssoSettings @@ -235,14 +229,13 @@ authreqPrecheck :: authreqPrecheck msucc merr idpid = validateAuthreqParams msucc merr *> getIdPConfig idpid - *> return NoContent + *> pure NoContent authreq :: Members '[ Random, Input Opts, Logger String, - BindCookieStore, AssIDStore, VerdictFormatStore, AReqIDStore, @@ -253,15 +246,11 @@ authreq :: ] r => NominalDiffTime -> - DoInitiate -> - Maybe UserId -> Maybe URI.URI -> Maybe URI.URI -> SAML.IdPId -> - Sem r (WithSetBindCookie (SAML.FormRedirect SAML.AuthnRequest)) -authreq _ DoInitiateLogin (Just _) _ _ _ = throwSparSem SparInitLoginWithAuth -authreq _ DoInitiateBind Nothing _ _ _ = throwSparSem SparInitBindWithoutAuth -authreq authreqttl _ zusr msucc merr idpid = do + Sem r (SAML.FormRedirect SAML.AuthnRequest) +authreq authreqttl msucc merr idpid = do vformat <- validateAuthreqParams msucc merr form@(SAML.FormRedirect _ ((^. SAML.rqID) -> reqid)) <- do idp :: IdP <- IdPConfigStore.getConfig idpid >>= maybe (throwSparSem (SparIdPNotFound (cs $ show idpid))) pure @@ -271,34 +260,7 @@ authreq authreqttl _ zusr msucc merr idpid = do WireIdPAPIV2 -> Just $ idp ^. SAML.idpExtraInfo . wiTeam SAML2.authReq authreqttl (SamlProtocolSettings.spIssuer mbtid) idpid VerdictFormatStore.store authreqttl reqid vformat - cky <- initializeBindCookie zusr authreqttl - Logger.log Logger.Debug $ "setting bind cookie: " <> show cky - pure $ addHeader cky form - --- | If the user is already authenticated, create bind cookie with a given life expectancy and our --- domain, and store it in C*. If the user is not authenticated, return a deletion 'SetCookie' --- value that deletes any bind cookies on the client. -initializeBindCookie :: - Members - '[ Random, - SAML2, - Input Opts, - Logger String, - BindCookieStore - ] - r => - Maybe UserId -> - NominalDiffTime -> - Sem r SetBindCookie -initializeBindCookie zusr authreqttl = do - DerivedOpts {derivedOptsBindCookiePath} <- inputs derivedOpts - msecret <- - if isJust zusr - then Just . cs . ES.encode <$> Random.bytes 32 - else pure Nothing - cky <- fmap SetBindCookie . SAML2.toggleCookie derivedOptsBindCookiePath $ (,authreqttl) <$> msecret - forM_ zusr $ \userid -> BindCookieStore.insert cky userid authreqttl - pure cky + pure form redirectURLMaxLength :: Int redirectURLMaxLength = 140 @@ -315,7 +277,7 @@ 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" - unless ((SBS.length $ URI.serializeURIRef' uri) <= redirectURLMaxLength) $ do + unless (SBS.length (URI.serializeURIRef' uri) <= redirectURLMaxLength) $ do throwSparSem $ SparBadInitiateLoginQueryParams "url-too-long" authresp :: @@ -326,7 +288,6 @@ authresp :: Input Opts, GalleyAccess, BrigAccess, - BindCookieStore, AssIDStore, VerdictFormatStore, AReqIDStore, @@ -340,17 +301,13 @@ authresp :: ] r => Maybe TeamId -> - Maybe ST -> SAML.AuthnResponseBody -> Sem r Void -authresp mbtid ckyraw arbody = logErrors $ SAML2.authResp mbtid (SamlProtocolSettings.spIssuer mbtid) (SamlProtocolSettings.responseURI mbtid) go arbody +authresp mbtid arbody = logErrors $ SAML2.authResp mbtid (SamlProtocolSettings.spIssuer mbtid) (SamlProtocolSettings.responseURI mbtid) go arbody where - cky :: Maybe BindCookie - cky = ckyraw >>= bindCookieFromHeader - go :: SAML.AuthnResponse -> SAML.AccessVerdict -> Sem r Void go resp verdict = do - result :: SAML.ResponseVerdict <- verdictHandler cky mbtid resp verdict + result :: SAML.ResponseVerdict <- verdictHandler mbtid resp verdict throw @SparError $ SAML.CustomServant result logErrors :: Sem r Void -> Sem r Void @@ -361,10 +318,9 @@ authresp mbtid ckyraw arbody = logErrors $ SAML2.authResp mbtid (SamlProtocolSet errorPage e (Multipart.inputs (SAML.authnResponseBodyRaw arbody)) - ckyraw ssoSettings :: Member DefaultSsoCode r => Sem r SsoSettings -ssoSettings = do +ssoSettings = SsoSettings <$> DefaultSsoCode.get ---------------------------------------------------------------------------- @@ -464,7 +420,7 @@ idpDelete zusr idpid (fromMaybe False -> purge) = withDebugLog "idpDelete" (cons BrigAccess.delete uid SAMLUserStore.delete uid uref unless (null some) doPurge - when (not idpIsEmpty) $ do + unless idpIsEmpty $ if purge then doPurge else throwSparSem SparIdPHasBoundUsers @@ -480,7 +436,7 @@ idpDelete zusr idpid (fromMaybe False -> purge) = withDebugLog "idpDelete" (cons do IdPConfigStore.deleteConfig idp IdPRawMetadataStore.delete idpid - return NoContent + pure NoContent where updateOldIssuers :: IdP -> Sem r () updateOldIssuers _ = pure () @@ -492,7 +448,7 @@ idpDelete zusr idpid (fromMaybe False -> purge) = withDebugLog "idpDelete" (cons -- leave old issuers dangling for now. updateReplacingIdP :: IdP -> Sem r () - updateReplacingIdP idp = forM_ (idp ^. SAML.idpExtraInfo . wiOldIssuers) $ \oldIssuer -> do + updateReplacingIdP idp = forM_ (idp ^. SAML.idpExtraInfo . wiOldIssuers) $ \oldIssuer -> getIdPIdByIssuer oldIssuer (idp ^. SAML.idpExtraInfo . wiTeam) >>= \case GetIdPFound iid -> IdPConfigStore.clearReplacedBy $ Replaced iid GetIdPNotFound -> pure () @@ -519,7 +475,7 @@ idpCreate :: Maybe SAML.IdPId -> Maybe WireIdPAPIVersion -> Sem r IdP -idpCreate zusr (IdPMetadataValue raw xml) midpid apiversion = idpCreateXML zusr raw xml midpid apiversion +idpCreate zusr (IdPMetadataValue raw xml) = idpCreateXML zusr raw xml -- | We generate a new UUID for each IdP used as IdPConfig's path, thereby ensuring uniqueness. idpCreateXML :: @@ -547,7 +503,7 @@ idpCreateXML zusr raw idpmeta mReplaces (fromMaybe defWireIdPAPIVersion -> apive idp <- validateNewIdP apiversion idpmeta teamid mReplaces IdPRawMetadataStore.store (idp ^. SAML.idpId) raw storeIdPConfig idp - forM_ mReplaces $ \replaces -> do + forM_ mReplaces $ \replaces -> IdPConfigStore.setReplacedBy (Replaced replaces) (Replacing (idp ^. SAML.idpId)) pure idp @@ -567,7 +523,7 @@ assertNoScimOrNoIdP :: assertNoScimOrNoIdP teamid = do numTokens <- length <$> ScimTokenStore.lookupByTeam teamid numIdps <- length <$> IdPConfigStore.getConfigsByTeam teamid - when (numTokens > 0 && numIdps > 0) $ do + when (numTokens > 0 && numIdps > 0) $ throwSparSem $ SparProvisioningMoreThanOneIdP "Teams with SCIM tokens can only have at most one IdP" @@ -662,7 +618,7 @@ idpUpdate :: IdPMetadataInfo -> SAML.IdPId -> Sem r IdP -idpUpdate zusr (IdPMetadataValue raw xml) idpid = idpUpdateXML zusr raw xml idpid +idpUpdate zusr (IdPMetadataValue raw xml) = idpUpdateXML zusr raw xml idpUpdateXML :: Members @@ -685,9 +641,12 @@ idpUpdateXML zusr raw idpmeta idpid = withDebugLog "idpUpdate" (Just . show . (^ GalleyAccess.assertSSOEnabled teamid IdPRawMetadataStore.store (idp ^. SAML.idpId) raw -- (if raw metadata is stored and then spar goes out, raw metadata won't match the - -- structured idp config. since this will lead to a 5xx response, the client is epected to + -- structured idp config. since this will lead to a 5xx response, the client is expected to -- try again, which would clean up cassandra state.) storeIdPConfig idp + -- if the IdP issuer is updated, the old issuer must be removed explicitly. + -- if this step is ommitted (due to a crash) resending the update request should fix the inconsistent state. + forM_ (idp ^. SAML.idpExtraInfo . wiOldIssuers) IdPConfigStore.deleteIssuer pure idp -- | Check that: idp id is valid; calling user is admin in that idp's home team; team id in @@ -716,7 +675,7 @@ validateIdPUpdate zusr _idpMetadata _idpId = withDebugLog "validateNewIdP" (Just Nothing -> throw errUnknownIdPId Just idp -> pure idp teamId <- authorizeIdP zusr previousIdP - unless (previousIdP ^. SAML.idpExtraInfo . wiTeam == teamId) $ do + unless (previousIdP ^. SAML.idpExtraInfo . wiTeam == teamId) $ throw errUnknownIdP _idpExtraInfo <- do let previousIssuer = previousIdP ^. SAML.idpMetadata . SAML.edIssuer @@ -732,7 +691,7 @@ validateIdPUpdate zusr _idpMetadata _idpId = withDebugLog "validateNewIdP" (Just res@(GetIdPNonUnique _) -> throwSparSem . SparIdPNotFound . ("validateIdPUpdate: " <>) . cs . show $ res -- impossible (because team id was used in lookup) GetIdPWrongTeam _ -> pure False if notInUseByOthers - then pure $ (previousIdP ^. SAML.idpExtraInfo) & wiOldIssuers %~ nub . (previousIssuer :) + then pure $ previousIdP ^. SAML.idpExtraInfo & wiOldIssuers %~ nub . (previousIssuer :) else throwSparSem SparIdPIssuerInUse let requri = _idpMetadata ^. SAML.edRequestURI enforceHttps requri @@ -764,7 +723,7 @@ authorizeIdP (Just zusr) idp = do pure teamid enforceHttps :: Member (Error SparError) r => URI.URI -> Sem r () -enforceHttps uri = do +enforceHttps uri = unless ((uri ^. URI.uriSchemeL . URI.schemeBSL) == "https") $ do throwSparSem . SparNewIdPWantHttps . cs . SAML.renderURI $ uri @@ -793,7 +752,7 @@ internalPutSsoSettings :: internalPutSsoSettings SsoSettings {defaultSsoCode = Nothing} = do DefaultSsoCode.delete pure NoContent -internalPutSsoSettings SsoSettings {defaultSsoCode = Just code} = do +internalPutSsoSettings SsoSettings {defaultSsoCode = Just code} = IdPConfigStore.getConfig code >>= \case Nothing -> -- this will return a 404, which is not quite right, diff --git a/services/spar/src/Spar/App.hs b/services/spar/src/Spar/App.hs index 75dd6d7f84..1cb62f7186 100644 --- a/services/spar/src/Spar/App.hs +++ b/services/spar/src/Spar/App.hs @@ -44,7 +44,6 @@ where import Bilge import Brig.Types (ManagedBy (..), User, userId, userTeam) -import Brig.Types.Intra (AccountStatus (..), accountStatus, accountUser) import qualified Cassandra as Cas import Control.Exception (assert) import Control.Lens hiding ((.=)) @@ -79,8 +78,6 @@ import Spar.Error hiding (sparToServerErrorWithLogging) import qualified Spar.Intra.BrigApp as Intra import Spar.Orphans () import Spar.Sem.AReqIDStore (AReqIDStore) -import Spar.Sem.BindCookieStore (BindCookieStore) -import qualified Spar.Sem.BindCookieStore as BindCookieStore import Spar.Sem.BrigAccess (BrigAccess) import qualified Spar.Sem.BrigAccess as BrigAccess import Spar.Sem.GalleyAccess (GalleyAccess) @@ -100,7 +97,6 @@ import qualified Spar.Sem.VerdictFormatStore as VerdictFormatStore import qualified System.Logger as TinyLog import URI.ByteString as URI import Web.Cookie (SetCookie, renderSetCookie) -import Wire.API.Cookie import Wire.API.User.Identity (Email (..)) import Wire.API.User.IdentityProvider import Wire.API.User.Saml @@ -131,10 +127,10 @@ getIdPConfig :: r => IdPId -> Sem r IdP -getIdPConfig = (>>= maybe (throwSparSem (SparIdPNotFound mempty)) pure) . IdPConfigStore.getConfig +getIdPConfig = maybe (throwSparSem (SparIdPNotFound mempty)) pure <=< IdPConfigStore.getConfig storeIdPConfig :: Member IdPConfigStore r => IdP -> Sem r () -storeIdPConfig idp = IdPConfigStore.storeConfig idp +storeIdPConfig = IdPConfigStore.storeConfig getIdPConfigByIssuerOptionalSPId :: Members '[IdPConfigStore, Error SparError] r => Issuer -> Maybe TeamId -> Sem r IdP getIdPConfigByIssuerOptionalSPId issuer mbteam = do @@ -146,7 +142,7 @@ getIdPConfigByIssuerOptionalSPId issuer mbteam = do res@(GetIdPWrongTeam _) -> throwSparSem $ SparIdPNotFound (cs $ show res) insertUser :: Member SAMLUserStore r => SAML.UserRef -> UserId -> Sem r () -insertUser uref uid = SAMLUserStore.insert uref uid +insertUser = SAMLUserStore.insert -- | Look up user locally in table @spar.user@ or @spar.scim_user@ (depending on the -- argument), then in brig, then return the 'UserId'. If either lookup fails, or user is not @@ -198,7 +194,7 @@ instance Functor GetUserResult where -- FUTUREWORK: Remove and reinstatate getUser, in AuthID refactoring PR getUserIdByScimExternalId :: Members '[BrigAccess, ScimExternalIdStore] r => TeamId -> Email -> Sem r (Maybe UserId) getUserIdByScimExternalId tid email = do - muid <- (ScimExternalIdStore.lookup tid email) + muid <- ScimExternalIdStore.lookup tid email case muid of Nothing -> pure Nothing Just uid -> do @@ -312,50 +308,6 @@ validateEmail mbTid uid email = do when enabled $ do BrigAccess.updateEmail uid email --- | Check if 'UserId' is in the team that hosts the idp that owns the 'UserRef'. If so, --- register a the user under its SAML credentials and write the 'UserRef' into the --- 'UserIdentity'. Otherwise, throw an error. --- --- Before returning, change account status or fail if account is nto active or pending an --- invitation. -bindUser :: - forall r. - Members - '[ BrigAccess, - IdPConfigStore, - Error SparError, - SAMLUserStore - ] - r => - UserId -> - SAML.UserRef -> - Sem r UserId -bindUser buid userref = do - oldStatus <- do - let err :: Sem r a - err = throwSparSem . SparBindFromWrongOrNoTeam . cs . show $ buid - teamid :: TeamId <- - getIdPConfigByIssuerAllowOld (userref ^. uidTenant) Nothing >>= \case - GetIdPFound idp -> pure $ idp ^. idpExtraInfo . wiTeam - GetIdPNotFound -> err - GetIdPDanglingId _ -> err -- database inconsistency - GetIdPNonUnique is -> throwSparSem $ SparUserRefInNoOrMultipleTeams (cs $ show (buid, is)) - GetIdPWrongTeam _ -> err -- impossible - acc <- BrigAccess.getAccount Intra.WithPendingInvitations buid >>= maybe err pure - teamid' :: TeamId <- userTeam (accountUser acc) & maybe err pure - unless (teamid' == teamid) err - pure (accountStatus acc) - insertUser userref buid - buid <$ do - BrigAccess.setVeid buid (UrefOnly userref) - let err = throwSparSem . SparBindFromBadAccountStatus . cs . show - case oldStatus of - Active -> pure () - Suspended -> err oldStatus - Deleted -> err oldStatus - Ephemeral -> err oldStatus - PendingInvitation -> BrigAccess.setStatus buid Active - -- | The from of the response on the finalize-login request depends on the verdict (denied or -- granted), plus the choice that the client has made during the initiate-login request. Here we -- call either 'verdictHandlerWeb' or 'verdictHandlerMobile', resp., on the 'SAML.AccessVerdict'. @@ -372,7 +324,6 @@ verdictHandler :: Logger String, GalleyAccess, BrigAccess, - BindCookieStore, AReqIDStore, VerdictFormatStore, ScimTokenStore, @@ -382,23 +333,22 @@ verdictHandler :: SAMLUserStore ] r => - Maybe BindCookie -> Maybe TeamId -> SAML.AuthnResponse -> SAML.AccessVerdict -> Sem r SAML.ResponseVerdict -verdictHandler cky mbteam aresp verdict = do +verdictHandler mbteam aresp verdict = do -- [3/4.1.4.2] -- [...] If the containing message is in response to an , then -- the InResponseTo attribute MUST match the request's ID. - Logger.log Logger.Debug $ "entering verdictHandler: " <> show (fromBindCookie <$> cky, aresp, verdict) + Logger.log Logger.Debug $ "entering verdictHandler: " <> show (aresp, verdict) reqid <- either (throwSparSem . SparNoRequestRefInResponse . cs) pure $ SAML.rspInResponseTo aresp format :: Maybe VerdictFormat <- VerdictFormatStore.get reqid resp <- case format of - Just (VerdictFormatWeb) -> - verdictHandlerResult cky mbteam verdict >>= verdictHandlerWeb + Just VerdictFormatWeb -> + verdictHandlerResult mbteam verdict >>= verdictHandlerWeb Just (VerdictFormatMobile granted denied) -> - verdictHandlerResult cky mbteam verdict >>= verdictHandlerMobile granted denied + verdictHandlerResult mbteam verdict >>= verdictHandlerMobile granted denied Nothing -> -- (this shouldn't happen too often, see 'storeVerdictFormat') throwSparSem SparNoSuchRequest @@ -418,7 +368,6 @@ verdictHandlerResult :: Logger String, GalleyAccess, BrigAccess, - BindCookieStore, ScimTokenStore, IdPConfigStore, Error SparError, @@ -426,13 +375,12 @@ verdictHandlerResult :: SAMLUserStore ] r => - Maybe BindCookie -> Maybe TeamId -> SAML.AccessVerdict -> Sem r VerdictHandlerResult -verdictHandlerResult bindCky mbteam verdict = do - Logger.log Logger.Debug $ "entering verdictHandlerResult: " <> show (fromBindCookie <$> bindCky) - result <- catchVerdictErrors $ verdictHandlerResultCore bindCky mbteam verdict +verdictHandlerResult mbteam verdict = do + Logger.log Logger.Debug $ "entering verdictHandlerResult" + result <- catchVerdictErrors $ verdictHandlerResultCore mbteam verdict Logger.log Logger.Debug $ "leaving verdictHandlerResult" <> show result pure result @@ -493,26 +441,23 @@ verdictHandlerResultCore :: Logger String, GalleyAccess, BrigAccess, - BindCookieStore, ScimTokenStore, IdPConfigStore, Error SparError, SAMLUserStore ] r => - Maybe BindCookie -> Maybe TeamId -> SAML.AccessVerdict -> Sem r VerdictHandlerResult -verdictHandlerResultCore bindCky mbteam = \case +verdictHandlerResultCore mbteam = \case SAML.AccessDenied reasons -> do pure $ VerifyHandlerDenied reasons SAML.AccessGranted userref -> do uid :: UserId <- do - viaBindCookie <- maybe (pure Nothing) (BindCookieStore.lookup) bindCky viaSparCassandra <- getUserIdByUref mbteam userref -- race conditions: if the user has been created on spar, but not on brig, 'getUser' - -- returns 'Nothing'. this is ok assuming 'createUser', 'bindUser' (called below) are + -- returns 'Nothing'. this is ok assuming 'createUser' (called below) is -- idempotent. viaSparCassandraOldIssuer <- case viaSparCassandra of @@ -520,34 +465,20 @@ verdictHandlerResultCore bindCky mbteam = \case _ -> findUserIdWithOldIssuer mbteam userref let err = SparUserRefInNoOrMultipleTeams . cs $ - show (userref, viaBindCookie, viaSparCassandra, viaSparCassandraOldIssuer) - case (viaBindCookie, viaSparCassandra, viaSparCassandraOldIssuer) of - (_, GetUserNoTeam, _) -> throwSparSem err - (_, GetUserWrongTeam, _) -> throwSparSem err - (_, _, GetUserNoTeam) -> throwSparSem err - (_, _, GetUserWrongTeam) -> throwSparSem err + show (userref, viaSparCassandra, viaSparCassandraOldIssuer) + case (viaSparCassandra, viaSparCassandraOldIssuer) of + (GetUserNoTeam, _) -> throwSparSem err + (GetUserWrongTeam, _) -> throwSparSem err + (_, GetUserNoTeam) -> throwSparSem err + (_, GetUserWrongTeam) -> throwSparSem err -- This is the first SSO authentication, so we auto-create a user. We know the user -- has not been created via SCIM because then we would've ended up in the -- "reauthentication" branch. - (Nothing, GetUserNotFound, GetUserNotFound) -> autoprovisionSamlUser mbteam userref + (GetUserNotFound, GetUserNotFound) -> autoprovisionSamlUser mbteam userref -- If the user is only found under an old (previous) issuer, move it here. - (Nothing, GetUserNotFound, GetUserFound (oldUserRef, uid)) -> moveUserToNewIssuer oldUserRef userref uid >> pure uid + (GetUserNotFound, GetUserFound (oldUserRef, uid)) -> moveUserToNewIssuer oldUserRef userref uid >> pure uid -- SSO re-authentication (the most common case). - (Nothing, GetUserFound uid, _) -> pure uid - -- Bind existing user (non-SSO or SSO) to ssoid - (Just uid, GetUserNotFound, GetUserNotFound) -> bindUser uid userref - (Just uid, GetUserFound uid', GetUserNotFound) - -- Redundant binding (no change to Brig or Spar) - | uid == uid' -> pure uid - -- Attempt to use ssoid for a second Wire user - | otherwise -> throwSparSem SparBindUserRefTaken - -- same two cases as above, but between last login and bind there was an issuer update. - (Just uid, GetUserNotFound, GetUserFound (oldUserRef, uid')) - | uid == uid' -> moveUserToNewIssuer oldUserRef userref uid >> pure uid - | otherwise -> throwSparSem SparBindUserRefTaken - (Just _, GetUserFound _, GetUserFound _) -> - -- to see why, consider the condition on the call to 'findUserWithOldIssuer' above. - error "impossible." + (GetUserFound uid, _) -> pure uid Logger.log Logger.Debug ("granting sso login for " <> show uid) cky <- BrigAccess.ssoLogin uid pure $ VerifyHandlerGranted cky uid @@ -670,8 +601,8 @@ verdictHandlerMobile granted denied = \case -- | When getting stuck during login finalization, show a nice HTML error rather than the json -- blob. Show lots of debugging info for the customer to paste in any issue they might open. -errorPage :: SparError -> [Multipart.Input] -> Maybe Text -> ServerError -errorPage err mpInputs mcky = +errorPage :: SparError -> [Multipart.Input] -> ServerError +errorPage err mpInputs = ServerError { errHTTPCode = Http.statusCode $ Wai.code werr, errReasonPhrase = cs $ Wai.label werr, @@ -689,14 +620,14 @@ errorPage err mpInputs mcky = "", " sorry, something went wrong :(
", " please copy the following debug information to your clipboard and provide it when opening an issue in our customer support.

", - " 
" <> (cs . toText . encodeBase64 . cs . show $ (err, mpInputs, mcky)) <> "
", + " 
" <> (cs . toText . encodeBase64 . cs . show $ (err, mpInputs)) <> "
", "" ] -- | Like 'getIdPIdByIssuer', but do not require a 'TeamId'. If none is provided, see if a -- single solution can be found without. getIdPIdByIssuerAllowOld :: - (HasCallStack) => + HasCallStack => Member IdPConfigStore r => SAML.Issuer -> Maybe TeamId -> diff --git a/services/spar/src/Spar/CanonicalInterpreter.hs b/services/spar/src/Spar/CanonicalInterpreter.hs index 37c4736524..ab49bbce43 100644 --- a/services/spar/src/Spar/CanonicalInterpreter.hs +++ b/services/spar/src/Spar/CanonicalInterpreter.hs @@ -38,8 +38,6 @@ import Spar.Sem.AReqIDStore (AReqIDStore) import Spar.Sem.AReqIDStore.Cassandra (aReqIDStoreToCassandra) import Spar.Sem.AssIDStore (AssIDStore) import Spar.Sem.AssIDStore.Cassandra (assIDStoreToCassandra) -import Spar.Sem.BindCookieStore (BindCookieStore) -import Spar.Sem.BindCookieStore.Cassandra (bindCookieStoreToCassandra) import Spar.Sem.BrigAccess (BrigAccess) import Spar.Sem.BrigAccess.Http (brigAccessToHttp) import Spar.Sem.DefaultSsoCode (DefaultSsoCode) @@ -79,7 +77,6 @@ import Wire.Sem.Random.IO (randomToIO) type CanonicalEffs = '[ SAML2, SamlProtocolSettings, - BindCookieStore, AssIDStore, AReqIDStore, VerdictFormatStore, @@ -90,7 +87,7 @@ type CanonicalEffs = IdPConfigStore, IdPRawMetadataStore, SAMLUserStore, - Embed (Cas.Client), + Embed Cas.Client, BrigAccess, GalleyAccess, Error TTLError, @@ -133,7 +130,6 @@ runSparToIO ctx action = . verdictFormatStoreToCassandra . aReqIDStoreToCassandra . assIDStoreToCassandra - . bindCookieStoreToCassandra . sparRouteToServant (saml $ sparCtxOpts ctx) $ saml2ToSaml2WebSso action diff --git a/services/spar/src/Spar/Data.hs b/services/spar/src/Spar/Data.hs index be1cd5c59d..e513ac897c 100644 --- a/services/spar/src/Spar/Data.hs +++ b/services/spar/src/Spar/Data.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE RecordWildCards #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2022 Wire Swiss GmbH diff --git a/services/spar/src/Spar/Data/Instances.hs b/services/spar/src/Spar/Data/Instances.hs index 78ff47130e..da7c96d7b3 100644 --- a/services/spar/src/Spar/Data/Instances.hs +++ b/services/spar/src/Spar/Data/Instances.hs @@ -50,7 +50,7 @@ instance Cql SAML.XmlText where fromCql (CqlText t) = pure $ SAML.mkXmlText t fromCql _ = Left "XmlText: expected CqlText" -instance Cql (SignedCertificate) where +instance Cql SignedCertificate where ctype = Tagged BlobColumn toCql = CqlBlob . cs . renderKeyInfo @@ -88,8 +88,8 @@ instance Cql VerdictFormatCon where toCql VerdictFormatConMobile = CqlInt 1 fromCql (CqlInt i) = case i of - 0 -> return VerdictFormatConWeb - 1 -> return VerdictFormatConMobile + 0 -> pure VerdictFormatConWeb + 1 -> pure VerdictFormatConMobile n -> Left $ "unexpected VerdictFormatCon: " ++ show n fromCql _ = Left "member-status: int expected" diff --git a/services/spar/src/Spar/Error.hs b/services/spar/src/Spar/Error.hs index d4ce48c6ef..a936055512 100644 --- a/services/spar/src/Spar/Error.hs +++ b/services/spar/src/Spar/Error.hs @@ -73,16 +73,11 @@ data SparCustomError | SparNotInTeam | SparNoPermission LT | SparSSODisabled - | SparInitLoginWithAuth - | SparInitBindWithoutAuth | SparNoSuchRequest | SparNoRequestRefInResponse LT | SparCouldNotSubstituteSuccessURI LT | SparCouldNotSubstituteFailureURI LT | SparBadInitiateLoginQueryParams LT - | SparBindFromWrongOrNoTeam LT - | SparBindFromBadAccountStatus LT - | SparBindUserRefTaken | SparUserRefInNoOrMultipleTeams LT | SparBadUserName LT | SparCannotCreateUsersOnReplacedIdP LT @@ -139,9 +134,6 @@ renderSparError (SAML.CustomError (SparNoRequestRefInResponse msg)) = Right $ Wa renderSparError (SAML.CustomError (SparCouldNotSubstituteSuccessURI msg)) = Right $ Wai.mkError status400 "bad-success-redirect" ("re-parsing the substituted URI failed: " <> msg) renderSparError (SAML.CustomError (SparCouldNotSubstituteFailureURI msg)) = Right $ Wai.mkError status400 "bad-failure-redirect" ("re-parsing the substituted URI failed: " <> msg) renderSparError (SAML.CustomError (SparBadInitiateLoginQueryParams label)) = Right $ Wai.mkError status400 label label -renderSparError (SAML.CustomError (SparBindFromWrongOrNoTeam msg)) = Right $ Wai.mkError status403 "bad-team" ("Forbidden: wrong user team " <> msg) -renderSparError (SAML.CustomError (SparBindFromBadAccountStatus msg)) = Right $ Wai.mkError status403 "bad-account-status" ("Forbidden: user has account status " <> msg <> "; only Active, PendingInvitation are supported") -renderSparError (SAML.CustomError SparBindUserRefTaken) = Right $ Wai.mkError status403 "subject-id-taken" "Forbidden: SubjectID is used by another wire user. If you have an old user bound to this IdP, unbind or delete that user." renderSparError (SAML.CustomError (SparUserRefInNoOrMultipleTeams msg)) = Right $ Wai.mkError status403 "bad-team" ("Forbidden: multiple teams or no team for same UserRef " <> msg) renderSparError (SAML.CustomError (SparBadUserName msg)) = Right $ Wai.mkError status400 "bad-username" ("Bad UserName in SAML response, except len [1, 128]: " <> msg) renderSparError (SAML.CustomError (SparCannotCreateUsersOnReplacedIdP replacingIdPId)) = Right $ Wai.mkError status400 "cannont-provision-on-replaced-idp" ("This IdP has been replaced, users can only be auto-provisioned on the replacing IdP " <> replacingIdPId) @@ -158,10 +150,10 @@ renderSparError (SAML.Forbidden msg) = Right $ Wai.mkError status403 "forbidden" renderSparError (SAML.BadSamlResponseBase64Error msg) = Right $ Wai.mkError status400 "bad-response-encoding" ("Bad response: base64 error: " <> cs msg) renderSparError (SAML.BadSamlResponseXmlError msg) = Right $ Wai.mkError status400 "bad-response-xml" ("Bad response: XML parse error: " <> cs msg) renderSparError (SAML.BadSamlResponseSamlError msg) = Right $ Wai.mkError status400 "bad-response-saml" ("Bad response: SAML parse error: " <> cs msg) -renderSparError SAML.BadSamlResponseFormFieldMissing = Right $ Wai.mkError status400 "bad-response-saml" ("Bad response: SAMLResponse form field missing from HTTP body") -renderSparError SAML.BadSamlResponseIssuerMissing = Right $ Wai.mkError status400 "bad-response-saml" ("Bad response: no Issuer in AuthnResponse") -renderSparError SAML.BadSamlResponseNoAssertions = Right $ Wai.mkError status400 "bad-response-saml" ("Bad response: no assertions in AuthnResponse") -renderSparError SAML.BadSamlResponseAssertionWithoutID = Right $ Wai.mkError status400 "bad-response-saml" ("Bad response: assertion without ID") +renderSparError SAML.BadSamlResponseFormFieldMissing = Right $ Wai.mkError status400 "bad-response-saml" "Bad response: SAMLResponse form field missing from HTTP body" +renderSparError SAML.BadSamlResponseIssuerMissing = Right $ Wai.mkError status400 "bad-response-saml" "Bad response: no Issuer in AuthnResponse" +renderSparError SAML.BadSamlResponseNoAssertions = Right $ Wai.mkError status400 "bad-response-saml" "Bad response: no assertions in AuthnResponse" +renderSparError SAML.BadSamlResponseAssertionWithoutID = Right $ Wai.mkError status400 "bad-response-saml" "Bad response: assertion without ID" renderSparError (SAML.BadSamlResponseInvalidSignature msg) = Right $ Wai.mkError status400 "bad-response-signature" (cs msg) renderSparError (SAML.CustomError (SparIdPNotFound "")) = Right $ Wai.mkError status404 "not-found" "Could not find IdP." renderSparError (SAML.CustomError (SparIdPNotFound msg)) = Right $ Wai.mkError status404 "not-found" ("Could not find IdP: " <> msg) @@ -170,8 +162,6 @@ renderSparError (SAML.CustomError SparMissingZUsr) = Right $ Wai.mkError status4 renderSparError (SAML.CustomError SparNotInTeam) = Right $ Wai.mkError status403 "no-team-member" "Requesting user is not a team member or not a member of this team." renderSparError (SAML.CustomError (SparNoPermission perm)) = Right $ Wai.mkError status403 "insufficient-permissions" ("You need permission " <> cs perm <> ".") renderSparError (SAML.CustomError SparSSODisabled) = Right $ Wai.mkError status403 "sso-disabled" "Please ask customer support to enable this feature for your team." -renderSparError (SAML.CustomError SparInitLoginWithAuth) = Right $ Wai.mkError status403 "login-with-auth" "This end-point is only for login, not binding." -renderSparError (SAML.CustomError SparInitBindWithoutAuth) = Right $ Wai.mkError status403 "bind-without-auth" "This end-point is only for binding, not login." renderSparError SAML.UnknownError = Right $ Wai.mkError status500 "server-error" "Unknown server error." renderSparError (SAML.BadServerConfig msg) = Right $ Wai.mkError status500 "server-error" ("Error in server config: " <> msg) renderSparError (SAML.InvalidCert msg) = Right $ Wai.mkError status500 "invalid-certificate" ("Error in idp certificate: " <> msg) diff --git a/services/spar/src/Spar/Intra/Brig.hs b/services/spar/src/Spar/Intra/Brig.hs index 3e0a04cd89..8965710ec2 100644 --- a/services/spar/src/Spar/Intra/Brig.hs +++ b/services/spar/src/Spar/Intra/Brig.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2022 Wire Swiss GmbH @@ -165,7 +163,7 @@ getBrigUserAccount havePending buid = do ] case statusCode resp of - 200 -> do + 200 -> parseResponse @[UserAccount] "brig" resp >>= \case [account] -> pure $ @@ -220,11 +218,9 @@ setBrigUserName buid (Name name) = do . paths ["/i/users", toByteString' buid, "name"] . json (NameUpdate name) let sCode = statusCode resp - if - | sCode < 300 -> - pure () - | otherwise -> - rethrow "brig" resp + if sCode < 300 + then pure () + else rethrow "brig" resp -- | Set user's handle. Fails with status <500 if brig fails with <500, and with 500 if brig fails -- with >= 500. @@ -240,9 +236,9 @@ setBrigUserHandle buid handle = do . paths ["/i/users", toByteString' buid, "handle"] . json (HandleUpdate (fromHandle handle)) case (statusCode resp, Wai.label <$> responseJsonMaybe @Wai.Error resp) of - (200, Nothing) -> do + (200, Nothing) -> pure () - _ -> do + _ -> rethrow "brig" resp -- | Set user's managedBy. Fails with status <500 if brig fails with <500, and with 500 if @@ -355,7 +351,7 @@ ssoLogin buid = do . path "/i/sso-login" . json (SsoLogin buid Nothing) . queryItem "persist" "true" - if (statusCode resp == 200) + if statusCode resp == 200 then respToCookie resp else rethrow "brig" resp diff --git a/services/spar/src/Spar/Intra/BrigApp.hs b/services/spar/src/Spar/Intra/BrigApp.hs index 1c5506baa5..4825dcb0b6 100644 --- a/services/spar/src/Spar/Intra/BrigApp.hs +++ b/services/spar/src/Spar/Intra/BrigApp.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} -- This file is part of the Wire Server implementation. @@ -114,7 +113,7 @@ mkUserName (Just n) = const $ mkName n mkUserName Nothing = runValidExternalIdEither (\uref -> mkName (CI.original . SAML.unsafeShowNameID $ uref ^. SAML.uidSubject)) - (\email -> mkName (fromEmail email)) + (mkName . fromEmail) renderValidExternalId :: ValidExternalId -> Maybe Text renderValidExternalId = runValidExternalIdEither urefToExternalId (Just . fromEmail) diff --git a/services/spar/src/Spar/Intra/Galley.hs b/services/spar/src/Spar/Intra/Galley.hs index 998bb84c9f..e3c6399de8 100644 --- a/services/spar/src/Spar/Intra/Galley.hs +++ b/services/spar/src/Spar/Intra/Galley.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2022 Wire Swiss GmbH @@ -54,7 +52,7 @@ getTeamMembers tid = do call $ method GET . paths ["i", "teams", toByteString' tid, "members"] - if (statusCode resp == 200) + if statusCode resp == 200 then (^. teamMembers) <$> parseResponse @TeamMemberList "galley" resp else rethrow "galley" resp @@ -69,7 +67,7 @@ assertHasPermission tid perm uid = do resp <- call $ method GET - . (paths ["i", "teams", toByteString' tid, "members", toByteString' uid]) + . paths ["i", "teams", toByteString' tid, "members", toByteString' uid] case (statusCode resp, parseResponse @TeamMember "galley" resp) of (200, Right member) | hasPermission member perm -> pure () _ -> throwSpar (SparNoPermission (cs $ show perm)) @@ -93,8 +91,7 @@ isEmailValidationEnabledTeam :: (HasCallStack, MonadSparToGalley m) => TeamId -> isEmailValidationEnabledTeam tid = do resp <- call $ method GET . paths ["i", "teams", toByteString' tid, "features", "validateSAMLemails"] pure - ( (statusCode resp == 200) - && ( responseJsonMaybe @(TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureValidateSAMLEmails) resp - == Just (TeamFeatureStatusNoConfig TeamFeatureEnabled) - ) + ( statusCode resp == 200 + && responseJsonMaybe @(TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureValidateSAMLEmails) resp + == Just (TeamFeatureStatusNoConfig TeamFeatureEnabled) ) diff --git a/services/spar/src/Spar/Options.hs b/services/spar/src/Spar/Options.hs index e12635018e..de3eed04fb 100644 --- a/services/spar/src/Spar/Options.hs +++ b/services/spar/src/Spar/Options.hs @@ -37,7 +37,6 @@ import Options.Applicative import qualified SAML2.WebSSO as SAML import Text.Ascii (ascii) import URI.ByteString as URI -import Wire.API.Routes.Public.Spar import Wire.API.User.Saml type OptsRaw = Opts' (Maybe ()) @@ -53,11 +52,6 @@ getOpts = do deriveOpts :: OptsRaw -> IO Opts deriveOpts raw = do derived <- do - let respuri = - -- respuri is only needed for 'derivedOptsBindCookiePath'; we want the prefix of the - -- V2 path that includes the team id. - runWithConfig raw (sparResponseURI Nothing) - derivedOptsBindCookiePath = URI.uriPath respuri -- We could also make this selectable in the config file, but it seems easier to derive it from -- the SAML base uri. let derivedOptsScimBaseURI = (saml raw ^. SAML.cfgSPSsoURI) & pathL %~ derive @@ -80,9 +74,6 @@ newtype WithConfig a = WithConfig (Reader OptsRaw a) instance SAML.HasConfig WithConfig where getConfig = WithConfig $ asks saml -runWithConfig :: OptsRaw -> WithConfig a -> a -runWithConfig opts (WithConfig act) = act `runReader` opts - -- | Accept config file location as cli option. -- -- FUTUREWORK: it would be nicer for the Parser to return the contents of the file, and return an diff --git a/services/spar/src/Spar/Orphans.hs b/services/spar/src/Spar/Orphans.hs index ba96d1fe3d..5c0c644b57 100644 --- a/services/spar/src/Spar/Orphans.hs +++ b/services/spar/src/Spar/Orphans.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeSynonymInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} diff --git a/services/spar/src/Spar/Run.hs b/services/spar/src/Spar/Run.hs index d72fd2e241..1bf505a9a2 100644 --- a/services/spar/src/Spar/Run.hs +++ b/services/spar/src/Spar/Run.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-} -- This file is part of the Wire Server implementation. diff --git a/services/spar/src/Spar/Scim/Auth.hs b/services/spar/src/Spar/Scim/Auth.hs index bd62db7a8d..0a75c49fb2 100644 --- a/services/spar/src/Spar/Scim/Auth.hs +++ b/services/spar/src/Spar/Scim/Auth.hs @@ -130,7 +130,7 @@ createScimToken zusr Api.CreateScimToken {..} = do let descr = createScimTokenDescr teamid <- Intra.Brig.authorizeScimTokenManagement zusr BrigAccess.ensureReAuthorised zusr createScimTokenPassword createScimTokenCode (Just User.CreateScimToken) - tokenNumber <- fmap length $ ScimTokenStore.lookupByTeam teamid + tokenNumber <- length <$> ScimTokenStore.lookupByTeam teamid maxTokens <- inputs maxScimTokens unless (tokenNumber < maxTokens) $ throwSparSem E.SparProvisioningTokenLimitReached diff --git a/services/spar/src/Spar/Scim/Types.hs b/services/spar/src/Spar/Scim/Types.hs index 09deb0b723..0df82a6ecd 100644 --- a/services/spar/src/Spar/Scim/Types.hs +++ b/services/spar/src/Spar/Scim/Types.hs @@ -2,18 +2,9 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ViewPatterns #-} -- This file is part of the Wire Server implementation. -- @@ -96,4 +87,4 @@ normalizeLikeStored usr = tweakExtra = ScimUserExtra . RichInfo . normalizeRichInfoAssocList . unRichInfo . view sueRichInfo tweakActive :: Maybe Scim.ScimBool -> Maybe Scim.ScimBool - tweakActive = fmap Scim.ScimBool . maybe (Just True) Just . fmap Scim.unScimBool + tweakActive = Just . Scim.ScimBool . maybe True Scim.unScimBool diff --git a/services/spar/src/Spar/Scim/User.hs b/services/spar/src/Spar/Scim/User.hs index 9451deb7ff..c9e8acf977 100644 --- a/services/spar/src/Spar/Scim/User.hs +++ b/services/spar/src/Spar/Scim/User.hs @@ -7,7 +7,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} @@ -133,7 +132,7 @@ instance ScimTokenInfo -> Maybe Scim.Filter -> Scim.ScimHandler (Sem r) (Scim.ListResponse (Scim.StoredUser ST.SparTag)) - getUsers _ Nothing = do + getUsers _ Nothing = throwError $ Scim.badRequest Scim.TooMany (Just "Please specify a filter when getting users.") getUsers tokeninfo@ScimTokenInfo {stiTeam, stiIdP} (Just filter') = logScim @@ -209,7 +208,7 @@ validateScimUser errloc tokinfo user = do validateScimUser' errloc mIdpConfig richInfoLimit user tokenInfoToIdP :: Member IdPConfigStore r => ScimTokenInfo -> Scim.ScimHandler (Sem r) (Maybe IdP) -tokenInfoToIdP ScimTokenInfo {stiIdP} = do +tokenInfoToIdP ScimTokenInfo {stiIdP} = maybe (pure Nothing) (lift . IdPConfigStore.getConfig) stiIdP -- | Validate a handle (@userName@). @@ -307,7 +306,7 @@ mkValidExternalId :: Maybe IdP -> Maybe Text -> m ST.ValidExternalId -mkValidExternalId _ Nothing = do +mkValidExternalId _ Nothing = throwError $ Scim.badRequest Scim.InvalidValue @@ -332,7 +331,7 @@ mkValidExternalId (Just idp) (Just extid) = do unameId :: SAML.UnqualifiedNameID <- do let eEmail = SAML.mkUNameIDEmail txt unspec = SAML.mkUNameIDUnspecified txt - pure . either (const unspec) id $ eEmail + pure . fromRight unspec $ eEmail case SAML.mkNameID unameId Nothing Nothing Nothing of Right nameId -> pure nameId Left err -> @@ -451,7 +450,7 @@ createValidScimUser tokeninfo@ScimTokenInfo {stiTeam} vsu@(ST.ValidScimUser veid uid <- Id <$> Random.uuid BrigAccess.createSAML uref uid stiTeam name ManagedByScim ) - ( \email -> do + ( \email -> BrigAccess.createNoSAML email stiTeam name ) veid @@ -577,16 +576,16 @@ updateValidScimUser tokinfo@ScimTokenInfo {stiTeam} uid newValidScimUser = do let old = oldValidScimUser ^. ST.vsuExternalId new = newValidScimUser ^. ST.vsuExternalId - when (old /= new) $ do + when (old /= new) $ updateVsuUref stiTeam uid old new - when (newValidScimUser ^. ST.vsuName /= oldValidScimUser ^. ST.vsuName) $ do + when (newValidScimUser ^. ST.vsuName /= oldValidScimUser ^. ST.vsuName) $ BrigAccess.setName uid (newValidScimUser ^. ST.vsuName) - when (oldValidScimUser ^. ST.vsuHandle /= newValidScimUser ^. ST.vsuHandle) $ do + when (oldValidScimUser ^. ST.vsuHandle /= newValidScimUser ^. ST.vsuHandle) $ BrigAccess.setHandle uid (newValidScimUser ^. ST.vsuHandle) - when (oldValidScimUser ^. ST.vsuRichInfo /= newValidScimUser ^. ST.vsuRichInfo) $ do + when (oldValidScimUser ^. ST.vsuRichInfo /= newValidScimUser ^. ST.vsuRichInfo) $ BrigAccess.setRichInfo uid (newValidScimUser ^. ST.vsuRichInfo) BrigAccess.getStatusMaybe uid >>= \case @@ -698,7 +697,7 @@ deleteScimUser tokeninfo@ScimTokenInfo {stiTeam, stiIdP} uid = $ do mbBrigUser <- lift (Brig.getBrigUser Brig.WithPendingInvitations uid) case mbBrigUser of - Nothing -> do + Nothing -> -- double-deletion gets you a 404. throwError $ Scim.notFound "user" (idToText uid) Just brigUser -> do @@ -724,7 +723,7 @@ deleteScimUser tokeninfo@ScimTokenInfo {stiTeam, stiIdP} uid = lift $ ScimUserTimesStore.delete uid lift $ BrigAccess.delete uid - return () + pure () ---------------------------------------------------------------------------- -- Utilities @@ -753,13 +752,15 @@ calculateVersion uid usr = Scim.Weak (Text.pack (show h)) -- -- ASSUMPTION: every scim user has a 'SAML.UserRef', and the `SAML.NameID` in it corresponds -- to a single `externalId`. -assertExternalIdUnused :: Members '[BrigAccess, ScimExternalIdStore, SAMLUserStore] r => TeamId -> ST.ValidExternalId -> Scim.ScimHandler (Sem r) () -assertExternalIdUnused tid veid = do +assertExternalIdUnused :: + Members '[BrigAccess, ScimExternalIdStore, SAMLUserStore] r => + TeamId -> + ST.ValidExternalId -> + Scim.ScimHandler (Sem r) () +assertExternalIdUnused = assertExternalIdInAllowedValues [Nothing] "externalId is already taken" - tid - veid -- | -- Check that the UserRef is not taken any user other than the passed 'UserId' @@ -768,7 +769,7 @@ assertExternalIdUnused tid veid = do -- ASSUMPTION: every scim user has a 'SAML.UserRef', and the `SAML.NameID` in it corresponds -- to a single `externalId`. assertExternalIdNotUsedElsewhere :: Members '[BrigAccess, ScimExternalIdStore, SAMLUserStore] r => TeamId -> ST.ValidExternalId -> UserId -> Scim.ScimHandler (Sem r) () -assertExternalIdNotUsedElsewhere tid veid wireUserId = do +assertExternalIdNotUsedElsewhere tid veid wireUserId = assertExternalIdInAllowedValues [Nothing, Just wireUserId] "externalId already in use by another Wire user" @@ -846,12 +847,12 @@ synthesizeStoredUser usr veid = let writeState :: Maybe (UTCTimeMillis, UTCTimeMillis) -> ManagedBy -> RI.RichInfo -> Scim.StoredUser ST.SparTag -> Sem r () writeState oldAccessTimes oldManagedBy oldRichInfo storedUser = do - when (isNothing oldAccessTimes) $ do + when (isNothing oldAccessTimes) $ ScimUserTimesStore.write storedUser - when (oldManagedBy /= ManagedByScim) $ do + when (oldManagedBy /= ManagedByScim) $ BrigAccess.setManagedBy uid ManagedByScim let newRichInfo = view ST.sueRichInfo . Scim.extra . Scim.value . Scim.thing $ storedUser - when (oldRichInfo /= newRichInfo) $ do + when (oldRichInfo /= newRichInfo) $ BrigAccess.setRichInfo uid newRichInfo (richInfo, accessTimes, baseuri) <- lift readState @@ -938,9 +939,9 @@ getUserById midp stiTeam uid = do assertExternalIdNotUsedElsewhere stiTeam veid uid createValidScimUserSpar stiTeam uid storedUser veid lift $ do - when (veidChanged (accountUser brigUser) veid) $ do + when (veidChanged (accountUser brigUser) veid) $ BrigAccess.setVeid uid veid - when (managedByChanged (accountUser brigUser)) $ do + when (managedByChanged (accountUser brigUser)) $ BrigAccess.setManagedBy uid ManagedByScim pure storedUser _ -> Applicative.empty @@ -1008,7 +1009,7 @@ scimFindUserByEmail mIdpConfig stiTeam email = do getUserById mIdpConfig stiTeam . userId . accountUser $ brigUser where withUref :: SAML.UserRef -> Sem r (Maybe UserId) - withUref uref = do + withUref uref = SAMLUserStore.get uref >>= \case Nothing -> maybe (pure Nothing) withEmailOnly $ Brig.urefToEmail uref Just uid -> pure (Just uid) diff --git a/services/spar/src/Spar/Sem/BindCookieStore/Cassandra.hs b/services/spar/src/Spar/Sem/BindCookieStore/Cassandra.hs deleted file mode 100644 index caae98767c..0000000000 --- a/services/spar/src/Spar/Sem/BindCookieStore/Cassandra.hs +++ /dev/null @@ -1,82 +0,0 @@ -{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} - --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module Spar.Sem.BindCookieStore.Cassandra - ( bindCookieStoreToCassandra, - ) -where - -import Cassandra as Cas -import Control.Lens -import Control.Monad.Except -import Data.Id -import Data.String.Conversions -import Data.Time -import Imports -import Polysemy -import Polysemy.Error -import Polysemy.Input -import qualified SAML2.WebSSO as SAML -import qualified Spar.Data as Data -import Spar.Sem.BindCookieStore -import qualified Web.Cookie as Cky -import Wire.API.Cookie -import Wire.API.User.Saml -import Wire.Sem.Now (Now) -import qualified Wire.Sem.Now as Now - -bindCookieStoreToCassandra :: - forall m r a. - (MonadClient m, Members '[Embed m, Now, Error TTLError, Embed IO, Input Opts] r) => - Sem (BindCookieStore ': r) a -> - Sem r a -bindCookieStoreToCassandra = interpret $ \case - Insert sbc uid ndt -> do - denv <- Data.mkEnv <$> input <*> Now.get - a <- embed @m $ runExceptT $ runReaderT (insertBindCookie sbc uid ndt) denv - case a of - Left err -> throw err - Right () -> pure () - Lookup bc -> embed @m $ lookupBindCookie bc - --- | Associate the value of a 'BindCookie' with its 'UserId'. The 'TTL' of this entry should be the --- same as the one of the 'AuthnRequest' sent with the cookie. -insertBindCookie :: - (HasCallStack, MonadClient m, MonadReader Data.Env m, MonadError TTLError m) => - SetBindCookie -> - UserId -> - NominalDiffTime -> - m () -insertBindCookie cky uid ttlNDT = do - env <- ask - TTL ttlInt32 <- Data.mkTTLAuthnRequestsNDT env ttlNDT - let ckyval = cs . Cky.setCookieValue . SAML.fromSimpleSetCookie . getSimpleSetCookie $ cky - retry x5 . write ins $ params LocalQuorum (ckyval, uid, ttlInt32) - where - ins :: PrepQuery W (ST, UserId, Int32) () - ins = "INSERT INTO bind_cookie (cookie, session_owner) VALUES (?, ?) USING TTL ?" - --- | The counter-part of 'insertBindCookie'. -lookupBindCookie :: (HasCallStack, MonadClient m) => BindCookie -> m (Maybe UserId) -lookupBindCookie (cs . fromBindCookie -> ckyval :: ST) = - runIdentity <$$> do - (retry x1 . query1 sel $ params LocalQuorum (Identity ckyval)) - where - sel :: PrepQuery R (Identity ST) (Identity UserId) - sel = "SELECT session_owner FROM bind_cookie WHERE cookie = ?" diff --git a/services/spar/src/Spar/Sem/BindCookieStore/Mem.hs b/services/spar/src/Spar/Sem/BindCookieStore/Mem.hs deleted file mode 100644 index 69ae9edbdd..0000000000 --- a/services/spar/src/Spar/Sem/BindCookieStore/Mem.hs +++ /dev/null @@ -1,48 +0,0 @@ --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module Spar.Sem.BindCookieStore.Mem - ( bindCookieStoreToMem, - ) -where - -import Data.Id (UserId) -import qualified Data.Map as M -import Data.String.Conversions (cs) -import Imports -import Polysemy -import Polysemy.State -import SAML2.WebSSO -import qualified SAML2.WebSSO.Cookie as SAML -import qualified SAML2.WebSSO.Types as SAML -import Spar.Sem.BindCookieStore -import qualified Web.Cookie as Cky -import Wire.API.Cookie -import Wire.Sem.Now -import qualified Wire.Sem.Now as Now - -bindCookieStoreToMem :: Member Now r => Sem (BindCookieStore ': r) a -> Sem r (Map BindCookie (SAML.Time, UserId), a) -bindCookieStoreToMem = (runState mempty .) $ - reinterpret $ \case - Insert sbc uid ndt -> do - let ckyval = BindCookie . cs . Cky.setCookieValue . SAML.fromSimpleSetCookie . getSimpleSetCookie $ sbc - now <- Now.get - modify $ M.insert ckyval (addTime ndt (Time now), uid) - Lookup bc -> do - gets (M.lookup bc) >>= \case - Just (time, uid) -> boolTTL @SAML.Time Nothing (Just uid) time - Nothing -> pure Nothing diff --git a/services/spar/src/Spar/Sem/IdPConfigStore.hs b/services/spar/src/Spar/Sem/IdPConfigStore.hs index 68e2f29924..630c71d01e 100644 --- a/services/spar/src/Spar/Sem/IdPConfigStore.hs +++ b/services/spar/src/Spar/Sem/IdPConfigStore.hs @@ -30,6 +30,7 @@ module Spar.Sem.IdPConfigStore deleteConfig, setReplacedBy, clearReplacedBy, + deleteIssuer, ) where @@ -70,6 +71,7 @@ data IdPConfigStore m a where -- affects _wiReplacedBy in GetConfig SetReplacedBy :: Replaced -> Replacing -> IdPConfigStore m () ClearReplacedBy :: Replaced -> IdPConfigStore m () + DeleteIssuer :: SAML.Issuer -> IdPConfigStore m () deriving stock instance Show (IdPConfigStore m a) diff --git a/services/spar/src/Spar/Sem/IdPConfigStore/Cassandra.hs b/services/spar/src/Spar/Sem/IdPConfigStore/Cassandra.hs index 15623a7627..65f4819f17 100644 --- a/services/spar/src/Spar/Sem/IdPConfigStore/Cassandra.hs +++ b/services/spar/src/Spar/Sem/IdPConfigStore/Cassandra.hs @@ -56,6 +56,7 @@ idPToCassandra = in deleteIdPConfig idpid issuer team SetReplacedBy r r11 -> setReplacedBy r r11 ClearReplacedBy r -> clearReplacedBy r + DeleteIssuer i -> deleteIssuer i type IdPConfigRow = (SAML.IdPId, SAML.Issuer, URI, SignedCertificate, [SignedCertificate], TeamId, Maybe WireIdPAPIVersion, [SAML.Issuer], Maybe SAML.IdPId) @@ -231,3 +232,9 @@ clearReplacedBy (Replaced old) = do where ins :: PrepQuery W (Identity SAML.IdPId) () ins = "UPDATE idp SET replaced_by = null WHERE idp = ?" + +deleteIssuer :: (HasCallStack, MonadClient m) => SAML.Issuer -> m () +deleteIssuer issuer = retry x5 $ write del (params LocalQuorum (Identity issuer)) + where + del :: PrepQuery W (Identity SAML.Issuer) () + del = "DELETE FROM issuer_idp_v2 WHERE issuer = ?" diff --git a/services/spar/src/Spar/Sem/IdPConfigStore/Mem.hs b/services/spar/src/Spar/Sem/IdPConfigStore/Mem.hs index 9007580131..a2f72884db 100644 --- a/services/spar/src/Spar/Sem/IdPConfigStore/Mem.hs +++ b/services/spar/src/Spar/Sem/IdPConfigStore/Mem.hs @@ -58,16 +58,15 @@ idPToMem = evState . evEff modify' (updateReplacedBy (Just replacing) replaced <$>) ClearReplacedBy (Replaced replaced) -> modify' (updateReplacedBy Nothing replaced <$>) + DeleteIssuer issuer -> modify' (deleteIssuer issuer) storeConfig :: IP.IdP -> TypedState -> TypedState storeConfig iw = M.insert (iw ^. SAML.idpId) iw . M.filter ( \iw' -> - or - [ iw' ^. SAML.idpMetadata . SAML.edIssuer /= iw ^. SAML.idpMetadata . SAML.edIssuer, - iw' ^. SAML.idpExtraInfo . IP.wiTeam /= iw ^. SAML.idpExtraInfo . IP.wiTeam - ] + (iw' ^. SAML.idpMetadata . SAML.edIssuer /= iw ^. SAML.idpMetadata . SAML.edIssuer) + || (iw' ^. SAML.idpExtraInfo . IP.wiTeam /= iw ^. SAML.idpExtraInfo . IP.wiTeam) ) getConfig :: SAML.IdPId -> TypedState -> Maybe IP.IdP @@ -114,3 +113,6 @@ updateReplacedBy mbReplacing replaced idp = & if idp ^. SAML.idpId == replaced then SAML.idpExtraInfo . IP.wiReplacedBy .~ mbReplacing else id + +deleteIssuer :: SAML.Issuer -> TypedState -> TypedState +deleteIssuer = const id diff --git a/services/spar/src/Spar/Sem/IdPConfigStore/Spec.hs b/services/spar/src/Spar/Sem/IdPConfigStore/Spec.hs index 4edc680f99..c022971f0a 100644 --- a/services/spar/src/Spar/Sem/IdPConfigStore/Spec.hs +++ b/services/spar/src/Spar/Sem/IdPConfigStore/Spec.hs @@ -48,16 +48,16 @@ propsForInterpreter :: (forall x. Show x => Maybe (f x -> String)) -> (forall x. Sem r x -> IO (f x)) -> Spec -propsForInterpreter interpreter extract labeler lower = do +propsForInterpreter interpreter extract labeler lower = describe interpreter $ do prop "deleteConfig/deleteConfig" $ prop_deleteDelete Nothing lower prop "deleteConfig/getConfig" $ prop_deleteGet labeler lower - prop "getConfig/storeConfig" $ prop_getStore (Just $ show . (() <$) . extract) lower - prop "getConfig/getConfig" $ prop_getGet (Just $ show . ((() <$) *** (() <$)) . extract) lower + prop "getConfig/storeConfig" $ prop_getStore (Just $ show . void . extract) lower + prop "getConfig/getConfig" $ prop_getGet (Just $ show . (void *** void) . extract) lower prop "setReplacedBy/clearReplacedBy" $ prop_setClear labeler lower - prop "setReplacedBy/getReplacedBy" $ prop_setGet (Just $ show . (fmap (() <$)) . extract) lower - prop "setReplacedBy/setReplacedBy" $ prop_setSet (Just $ show . (fmap (() <$)) . extract) lower - prop "storeConfig/getConfig" $ prop_storeGet (Just $ show . (() <$) . extract) lower + prop "setReplacedBy/getReplacedBy" $ prop_setGet (Just $ show . fmap void . extract) lower + prop "setReplacedBy/setReplacedBy" $ prop_setSet (Just $ show . fmap void . extract) lower + prop "storeConfig/getConfig" $ prop_storeGet (Just $ show . void . extract) lower xit "storeConfig/getIdByIssuerWithoutTeam" $ property $ prop_storeGetByIssuer (Just $ constructorLabel . extract) lower prop "storeConfig/storeConfig (different keys)" $ prop_storeStoreInterleave Nothing lower prop "storeConfig/storeConfig (same keys)" $ prop_storeStore Nothing lower diff --git a/services/spar/src/Spar/Sem/SamlProtocolSettings/Servant.hs b/services/spar/src/Spar/Sem/SamlProtocolSettings/Servant.hs index 64bac45410..c33baf07f2 100644 --- a/services/spar/src/Spar/Sem/SamlProtocolSettings/Servant.hs +++ b/services/spar/src/Spar/Sem/SamlProtocolSettings/Servant.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -Wno-orphans #-} -- This file is part of the Wire Server implementation. @@ -33,6 +34,6 @@ instance SAML.HasConfig ((->) SAML.Config) where getConfig = id sparRouteToServant :: SAML.Config -> Sem (SamlProtocolSettings ': r) a -> Sem r a -sparRouteToServant cfg = interpret $ \x -> case x of +sparRouteToServant cfg = interpret $ \case SpIssuer mitlt -> pure $ sparSPIssuer mitlt cfg ResponseURI mitlt -> pure $ sparResponseURI mitlt cfg diff --git a/services/spar/src/Spar/Sem/ScimExternalIdStore/Spec.hs b/services/spar/src/Spar/Sem/ScimExternalIdStore/Spec.hs index 79157b5e26..d8d9adb7a3 100644 --- a/services/spar/src/Spar/Sem/ScimExternalIdStore/Spec.hs +++ b/services/spar/src/Spar/Sem/ScimExternalIdStore/Spec.hs @@ -38,12 +38,12 @@ propsForInterpreter :: propsForInterpreter interpreter extract lower = do describe interpreter $ do prop "delete/delete" $ prop_deleteDelete Nothing lower - prop "delete/lookup" $ prop_deleteLookup (Just $ show . (() <$) . extract) lower + prop "delete/lookup" $ prop_deleteLookup (Just $ show . void . extract) lower prop "delete/insert" $ prop_deleteInsert Nothing lower prop "lookup/insert" $ prop_lookupInsert Nothing lower prop "insert/delete" $ prop_insertDelete Nothing lower - prop "insert/lookup" $ prop_insertLookup (Just $ show . (() <$) . extract) lower - prop "insert/insert" $ prop_insertInsert (Just $ show . (() <$) . extract) lower + prop "insert/lookup" $ prop_insertLookup (Just $ show . void . extract) lower + prop "insert/insert" $ prop_insertInsert (Just $ show . void . extract) lower -- | All the constraints we need to generalize properties in this module. -- A regular type synonym doesn't work due to dreaded impredicative diff --git a/services/spar/src/Spar/Sem/ScimTokenStore/Cassandra.hs b/services/spar/src/Spar/Sem/ScimTokenStore/Cassandra.hs index e2b7f72792..54b94fe908 100644 --- a/services/spar/src/Spar/Sem/ScimTokenStore/Cassandra.hs +++ b/services/spar/src/Spar/Sem/ScimTokenStore/Cassandra.hs @@ -74,15 +74,15 @@ insertScimToken token ScimTokenInfo {..} = retry x5 . batch $ do insByToken, insByTeam :: PrepQuery W ScimTokenRow () insByToken = [r| - INSERT INTO team_provisioning_by_token - (token_, team, id, created_at, idp, descr) - VALUES (?, ?, ?, ?, ?, ?) + INSERT INTO team_provisioning_by_token + (token_, team, id, created_at, idp, descr) + VALUES (?, ?, ?, ?, ?, ?) |] insByTeam = [r| - INSERT INTO team_provisioning_by_team - (token_, team, id, created_at, idp, descr) - VALUES (?, ?, ?, ?, ?, ?) + INSERT INTO team_provisioning_by_team + (token_, team, id, created_at, idp, descr) + VALUES (?, ?, ?, ?, ?, ?) |] scimTokenLookupKey :: ScimTokenRow -> ScimTokenLookupKey diff --git a/services/spar/src/Spar/Sem/ScimTokenStore/Mem.hs b/services/spar/src/Spar/Sem/ScimTokenStore/Mem.hs index 7793369ab1..255d9a8e2a 100644 --- a/services/spar/src/Spar/Sem/ScimTokenStore/Mem.hs +++ b/services/spar/src/Spar/Sem/ScimTokenStore/Mem.hs @@ -38,4 +38,4 @@ scimTokenStoreToMem = (runState mempty .) $ Lookup st -> gets $ M.lookup st LookupByTeam tid -> gets $ filter ((== tid) . stiTeam) . M.elems Delete tid stid -> modify $ M.filter $ \sti -> not $ stiTeam sti == tid && stiId sti == stid - DeleteByTeam tid -> modify $ M.filter (not . (== tid) . stiTeam) + DeleteByTeam tid -> modify $ M.filter ((/= tid) . stiTeam) diff --git a/services/spar/src/Spar/Sem/VerdictFormatStore/Cassandra.hs b/services/spar/src/Spar/Sem/VerdictFormatStore/Cassandra.hs index 9c1f559fcd..84fde20e40 100644 --- a/services/spar/src/Spar/Sem/VerdictFormatStore/Cassandra.hs +++ b/services/spar/src/Spar/Sem/VerdictFormatStore/Cassandra.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE RecordWildCards #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2022 Wire Swiss GmbH diff --git a/services/spar/test-integration/Test/Spar/APISpec.hs b/services/spar/test-integration/Test/Spar/APISpec.hs index d1d68a8b4e..5f5f111c82 100644 --- a/services/spar/test-integration/Test/Spar/APISpec.hs +++ b/services/spar/test-integration/Test/Spar/APISpec.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wno-unused-do-bind #-} -- This file is part of the Wire Server implementation. -- @@ -23,17 +24,19 @@ module Test.Spar.APISpec where import Bilge +import Brig.Types.Client import Brig.Types.Intra (AccountStatus (Deleted)) import Brig.Types.User import Cassandra hiding (Value) import Control.Lens hiding ((.=)) +import Control.Monad.Catch (MonadThrow) import Control.Monad.Random.Class (getRandomR) import Data.Aeson as Aeson import Data.Aeson.Lens -import qualified Data.ByteString.Builder as LB import Data.ByteString.Conversion import Data.Id import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.Misc import Data.Proxy import Data.String.Conversions import qualified Data.Text as ST @@ -41,6 +44,7 @@ import qualified Data.Text as T import Data.Text.Ascii (decodeBase64, validateBase64) import qualified Data.UUID as UUID hiding (fromByteString, null) import qualified Data.UUID.V4 as UUID (nextRandom) +import qualified Data.Vector as Vec import qualified Data.ZAuth.Token as ZAuth import qualified Galley.Types.Teams as Galley import Imports hiding (head) @@ -79,12 +83,11 @@ import Text.XML.DSig (SignPrivCreds, mkSignCredsWithCert) import qualified URI.ByteString as URI import URI.ByteString.QQ (uri) import Util.Core +import Util.Scim (filterBy, listUsers, registerScimToken) import qualified Util.Scim as ScimT import Util.Types import qualified Web.Cookie as Cky import qualified Web.Scim.Schema.User as Scim -import Wire.API.Cookie -import Wire.API.Routes.Public.Spar import Wire.API.User.IdentityProvider import qualified Wire.API.User.Saml as WireAPI (saml) import Wire.API.User.Scim @@ -95,13 +98,13 @@ spec = do specMetadata specInitiateLogin specFinalizeLogin - specBindingUsers specCRUDIdentityProvider specDeleteCornerCases specScimAndSAML specAux specSsoSettings specSparUserMigration + specReAuthSsoUserWithPassword specMisc :: SpecWith TestEnv specMisc = do @@ -187,15 +190,13 @@ specInitiateLogin = do " idp) <- registerTestIdP resp <- call $ get ((env ^. teSpar) . path (cs $ "/sso/initiate-login/" -/ idp) . expect2xx) liftIO $ do resp `shouldSatisfy` checkRespBody - hasDeleteBindCookieHeader resp `shouldBe` Right () specFinalizeLogin :: SpecWith TestEnv specFinalizeLogin = do @@ -530,211 +531,6 @@ specFinalizeLogin = do mbId2 `shouldSatisfy` isJust mbId1 `shouldBe` mbId2 -specBindingUsers :: SpecWith TestEnv -specBindingUsers = describe "binding existing users to sso identities" $ do - describe "HEAD /sso/initiate-bind/:idp" $ do - context "known IdP, running session with non-sso user" $ do - it "responds with 200" $ do - env <- ask - (owner, _, idPIdToST . (^. idpId) -> idp) <- registerTestIdP - void . call $ - head - ( (env ^. teSpar) - . path (cs $ "/sso-initiate-bind/" -/ idp) - . header "Z-User" (toByteString' owner) - . expect2xx - ) - context "known IdP, running session with sso user" $ do - it "responds with 2xx" $ do - (_, _, idp, (_, privcreds)) <- registerTestIdPWithMeta - uid <- loginSsoUserFirstTime idp privcreds - env <- ask - void . call $ - head - ( (env ^. teSpar) - . header "Z-User" (toByteString' uid) - . path (cs $ "/sso-initiate-bind/" -/ (idPIdToST $ idp ^. idpId)) - . expect2xx - ) - let checkInitiateBind :: HasCallStack => Bool -> TestSpar UserId -> SpecWith TestEnv - checkInitiateBind hasZUser createUser = do - let testmsg = - if hasZUser - then "responds with 200 and a bind cookie" - else "responds with 403 and 'bind-without-auth'" - checkRespBody :: HasCallStack => ResponseLBS -> Bool - checkRespBody (responseBody -> Just (cs -> bdy)) = - all - (`isInfixOf` bdy) - [ "", - "", - " idp) <- registerTestIdP - uid <- createUser - resp <- - call $ - get - ( (env ^. teSpar) - . (if hasZUser then header "Z-User" (toByteString' uid) else id) - . path (cs $ "/sso-initiate-bind/" -/ idp) - ) - liftIO $ - if hasZUser - then do - statusCode resp `shouldBe` 200 - resp `shouldSatisfy` checkRespBody - hasSetBindCookieHeader resp `shouldBe` Right () - else do - statusCode resp `shouldBe` 403 - resp `shouldSatisfy` (not . checkRespBody) - hasSetBindCookieHeader resp `shouldBe` Left "no set-cookie header" - responseJsonEither resp `shouldBe` Right (TestErrorLabel "bind-without-auth") - describe "GET /sso-initiate-bind/:idp" $ do - context "known IdP, running session without authentication" $ do - checkInitiateBind False (fmap fst . call . createRandomPhoneUser =<< asks (^. teBrig)) - context "known IdP, running session with non-sso user" $ do - checkInitiateBind True (fmap fst . call . createRandomPhoneUser =<< asks (^. teBrig)) - context "known IdP, running session with sso user" $ do - checkInitiateBind True (registerTestIdPWithMeta >>= \(_, _, idp, (_, privcreds)) -> loginSsoUserFirstTime idp privcreds) - describe "POST /sso/finalize-login" $ do - let checkGrantingAuthnResp :: HasCallStack => TeamId -> UserId -> SignedAuthnResponse -> ResponseLBS -> TestSpar () - checkGrantingAuthnResp tid uid sparrq sparresp = do - checkGrantingAuthnResp' sparresp - ssoidViaAuthResp <- getSsoidViaAuthResp sparrq - ssoidViaSelf <- getSsoidViaSelf uid - liftIO $ ('s', ssoidViaSelf) `shouldBe` ('s', ssoidViaAuthResp) - Just uidViaSpar <- ssoToUidSpar tid ssoidViaAuthResp - liftIO $ ('u', uidViaSpar) `shouldBe` ('u', uid) - - checkGrantingAuthnResp' :: HasCallStack => ResponseLBS -> TestSpar () - checkGrantingAuthnResp' sparresp = do - liftIO $ do - (cs @_ @String . fromJust . responseBody $ sparresp) - `shouldContain` "wire:sso:success" - hasPersistentCookieHeader sparresp `shouldBe` Right () - - checkDenyingAuthnResp :: HasCallStack => ResponseLBS -> ST -> TestSpar () - checkDenyingAuthnResp sparresp errorlabel = do - liftIO $ do - (cs @_ @String . fromJust . responseBody $ sparresp) - `shouldContain` ("wire:sso:error:" <> cs errorlabel <> "") - hasPersistentCookieHeader sparresp `shouldBe` Left "no set-cookie header" - - initialBind :: HasCallStack => UserId -> IdP -> SignPrivCreds -> TestSpar (NameID, SignedAuthnResponse, ResponseLBS) - initialBind = initialBind' Just - - initialBind' :: - HasCallStack => - (Cky.Cookies -> Maybe Cky.Cookies) -> - UserId -> - IdP -> - SignPrivCreds -> - TestSpar (NameID, SignedAuthnResponse, ResponseLBS) - initialBind' tweakcookies uid idp privcreds = do - subj <- nextSubject - (authnResp, sparAuthnResp) <- reBindSame' tweakcookies uid idp privcreds subj - pure (subj, authnResp, sparAuthnResp) - - reBindSame :: HasCallStack => UserId -> IdP -> SignPrivCreds -> NameID -> TestSpar (SignedAuthnResponse, ResponseLBS) - reBindSame = reBindSame' Just - - reBindSame' :: - HasCallStack => - (Cky.Cookies -> Maybe Cky.Cookies) -> - UserId -> - IdP -> - SignPrivCreds -> - NameID -> - TestSpar (SignedAuthnResponse, ResponseLBS) - reBindSame' tweakcookies uid idp privCreds subj = do - (authnReq, Just (SetBindCookie (SimpleSetCookie bindCky))) <- do - negotiateAuthnRequest' DoInitiateBind idp (header "Z-User" $ toByteString' uid) - let tid = idp ^. idpExtraInfo . wiTeam - spmeta <- getTestSPMetadata tid - authnResp <- runSimpleSP $ mkAuthnResponseWithSubj subj privCreds idp spmeta authnReq True - let cookiehdr = case tweakcookies [(Cky.setCookieName bindCky, Cky.setCookieValue bindCky)] of - Just val -> header "Cookie" . cs . LB.toLazyByteString . Cky.renderCookies $ val - Nothing -> id - sparAuthnResp :: ResponseLBS <- - submitAuthnResponse' cookiehdr tid authnResp - pure (authnResp, sparAuthnResp) - - reBindDifferent :: HasCallStack => UserId -> TestSpar (SignedAuthnResponse, ResponseLBS) - reBindDifferent uid = do - env <- ask - (SampleIdP metadata privcreds _ _) <- makeSampleIdPMetadata - idp <- call $ callIdpCreate (env ^. teWireIdPAPIVersion) (env ^. teSpar) (Just uid) metadata - (_, authnResp, sparAuthnResp) <- initialBind uid idp privcreds - pure (authnResp, sparAuthnResp) - context "initial bind" $ do - it "allowed" $ do - (uid, tid, idp, (_, privcreds)) <- registerTestIdPWithMeta - (_, authnResp, sparAuthnResp) <- initialBind uid idp privcreds - checkGrantingAuthnResp tid uid authnResp sparAuthnResp - context "re-bind to same UserRef" $ do - it "allowed" $ do - (uid, tid, idp, (_, privcreds)) <- registerTestIdPWithMeta - (subj, _, _) <- initialBind uid idp privcreds - (sparrq, sparresp) <- reBindSame uid idp privcreds subj - checkGrantingAuthnResp tid uid sparrq sparresp - context "re-bind to new UserRef from different IdP" $ do - it "allowed" $ do - (uid, tid, idp, (_, privcreds)) <- registerTestIdPWithMeta - _ <- initialBind uid idp privcreds - (sparrq, sparresp) <- reBindDifferent uid - checkGrantingAuthnResp tid uid sparrq sparresp - context "bind to UserRef in use by other wire user" $ do - it "forbidden" $ do - env <- ask - (uid, teamid, idp, (_, privcreds)) <- registerTestIdPWithMeta - (subj, _, _) <- initialBind uid idp privcreds - uid' <- - let perms = Galley.noPermissions - in call $ createTeamMember (env ^. teBrig) (env ^. teGalley) teamid perms - (_, sparresp) <- reBindSame uid' idp privcreds subj - checkDenyingAuthnResp sparresp "subject-id-taken" - context "bind to UserRef from different team" $ do - it "forbidden" $ do - (uid, _, _) <- registerTestIdP - (_, _, idp, (_, privcreds)) <- registerTestIdPWithMeta - (_, _, sparresp) <- initialBind uid idp privcreds - checkDenyingAuthnResp sparresp "bad-team" - describe "cookie corner cases" $ do - -- attempt to bind with different 'Cookie' headers in the request to finalize-login. if the - -- zbind cookie cannot be found, the user is created from scratch, and the old, existing one - -- is "detached". if the zbind cookie is found, the binding is successful. - let check :: HasCallStack => (Cky.Cookies -> Maybe Cky.Cookies) -> Bool -> SpecWith TestEnv - check tweakcookies bindsucceeds = do - it (if bindsucceeds then "binds existing user" else "creates new user") $ do - (uid, tid, idp, (_, privcreds)) <- registerTestIdPWithMeta - (subj :: NameID, sparrq, sparresp) <- initialBind' tweakcookies uid idp privcreds - checkGrantingAuthnResp' sparresp - uid' <- getUserIdViaRef $ UserRef (idp ^. idpMetadata . edIssuer) subj - checkGrantingAuthnResp tid uid' sparrq sparresp - liftIO $ (if bindsucceeds then shouldBe else shouldNotBe) uid' uid - addAtBeginning :: Cky.SetCookie -> Cky.Cookies -> Cky.Cookies - addAtBeginning cky = ((Cky.setCookieName cky, Cky.setCookieValue cky) :) - addAtEnd :: Cky.SetCookie -> Cky.Cookies -> Cky.Cookies - addAtEnd cky = (<> [(Cky.setCookieName cky, Cky.setCookieValue cky)]) - cky1, cky2, cky3 :: Cky.SetCookie - cky1 = Cky.def {Cky.setCookieName = "cky1", Cky.setCookieValue = "val1"} - cky2 = Cky.def {Cky.setCookieName = "cky2", Cky.setCookieValue = "val2"} - cky3 = Cky.def {Cky.setCookieName = "cky3", Cky.setCookieValue = "val3"} - context "with no cookies header in the request" $ do - check (const Nothing) False - context "with empty cookies header in the request" $ do - check (const $ Just mempty) False - context "with no bind cookie and one other cookie in the request" $ do - check (\_ -> Just $ addAtBeginning cky1 mempty) False - context "with bind cookie and one other cookie in the request" $ do - check (\bindcky -> Just $ addAtBeginning cky1 bindcky) True - context "with bind cookie and two other cookies in the request" $ do - check (\bindcky -> Just . addAtEnd cky1 . addAtEnd cky2 . addAtBeginning cky3 $ bindcky) True - testGetPutDelete :: HasCallStack => (SparReq -> Maybe UserId -> IdPId -> IdPMetadataInfo -> Http ResponseLBS) -> SpecWith TestEnv testGetPutDelete whichone = do context "unknown IdP" $ do @@ -908,6 +704,20 @@ specCRUDIdentityProvider = do `shouldRespondWith` ((== 200) . statusCode) callIdpGet (env ^. teSpar) (Just owner) idpid `shouldRespondWith` ((== idpmeta') . view idpMetadata) + it "updates IdP metadata and creates a new IdP with the first metadata" $ do + env <- ask + (owner, _) <- call $ createUserWithTeam (env ^. teBrig) (env ^. teGalley) + -- create new idp + (SampleIdP metadata1 _ _ _) <- makeSampleIdPMetadata + idp1 <- call $ callIdpCreate (env ^. teWireIdPAPIVersion) (env ^. teSpar) (Just owner) metadata1 + -- update the idp metadata + (SampleIdP metadata2 _ _ _) <- makeSampleIdPMetadata + callIdpUpdate' (env ^. teSpar) (Just owner) (idp1 ^. idpId) (IdPMetadataValue (cs $ SAML.encode metadata2) undefined) + `shouldRespondWith` ((== 200) . statusCode) + -- create a new idp with the first metadata (should succeed) + callIdpCreate' (env ^. teWireIdPAPIVersion) (env ^. teSpar) (Just owner) metadata1 + `shouldRespondWith` ((== 201) . statusCode) + context "invalid body" $ do it "rejects" $ do env <- ask @@ -1210,7 +1020,7 @@ specCRUDIdentityProvider = do idp2 ^. idpMetadata . SAML.edIssuer `shouldBe` issuer2 idp2 ^. idpId `shouldNotBe` idp1 ^. idpId idp2 ^. idpExtraInfo . wiOldIssuers `shouldBe` [idpmeta1 ^. edIssuer] - idp1' ^. idpExtraInfo . wiReplacedBy `shouldBe` (Just $ idp2 ^. idpId) + idp1' ^. idpExtraInfo . wiReplacedBy `shouldBe` Just (idp2 ^. idpId) -- erase everything that is supposed to be different between idp1, idp2, and make -- sure the result is equal. let erase :: IdP -> IdP @@ -1285,7 +1095,7 @@ specDeleteCornerCases = describe "delete corner cases" $ do uid <- getUserIdViaRef' uref liftIO $ do uid `shouldSatisfy` isJust - uref `shouldBe` (SAML.UserRef issuer1 userSubject) + uref `shouldBe` SAML.UserRef issuer1 userSubject idp2 <- let idpmeta2 = idpmeta1 & edIssuer .~ issuer2 in call $ callIdpCreateReplace (env ^. teWireIdPAPIVersion) (env ^. teSpar) (Just owner1) idpmeta2 (idp1 ^. SAML.idpId) @@ -1294,7 +1104,7 @@ specDeleteCornerCases = describe "delete corner cases" $ do uid' <- getUserIdViaRef' uref' liftIO $ do uid' `shouldBe` uid - uref' `shouldBe` (SAML.UserRef issuer1 userSubject) + uref' `shouldBe` SAML.UserRef issuer1 userSubject it "deleting the replacing idp2 before it has users does not block registrations on idp1" $ do env <- ask (owner1, _, idp1, (IdPMetadataValue _ idpmeta1, privkey1)) <- registerTestIdPWithMeta @@ -1309,7 +1119,7 @@ specDeleteCornerCases = describe "delete corner cases" $ do uid <- getUserIdViaRef' uref liftIO $ do uid `shouldSatisfy` isJust - uref `shouldBe` (SAML.UserRef issuer1 userSubject) + uref `shouldBe` SAML.UserRef issuer1 userSubject it "create user1 via idp1 (saml); delete user1; create user via newly created idp2 (saml)" $ do pending it "create user1 via saml; delete user1; create via scim (in same team)" $ do @@ -1331,7 +1141,7 @@ specDeleteCornerCases = describe "delete corner cases" $ do let uref = SAML.UserRef tenant subj subj = either (error . show) id $ SAML.mkNameID uname Nothing Nothing Nothing tenant = idp ^. SAML.idpMetadata . SAML.edIssuer - !(Just !uid) <- createViaSaml idp privcreds uref + (Just !uid) <- createViaSaml idp privcreds uref samlUserShouldSatisfy uref isJust deleteViaBrig uid samlUserShouldSatisfy uref isJust -- brig doesn't talk to spar right now when users @@ -1495,10 +1305,9 @@ specSsoSettings = do -- check it is set callGetDefaultSsoCode (env ^. teSpar) `shouldRespondWith` \resp -> - and - [ statusCode resp == 200, - responseJsonEither resp == Right (ssoSettings (Just idpid1)) - ] + (statusCode resp == 200) + && ( responseJsonEither resp == Right (ssoSettings (Just idpid1)) + ) -- update to 2 callSetDefaultSsoCode (env ^. teSpar) idpid2 `shouldRespondWith` \resp -> @@ -1506,10 +1315,9 @@ specSsoSettings = do -- check it is set callGetDefaultSsoCode (env ^. teSpar) `shouldRespondWith` \resp -> - and - [ statusCode resp == 200, - responseJsonEither resp == Right (ssoSettings (Just idpid2)) - ] + (statusCode resp == 200) + && ( responseJsonEither resp == Right (ssoSettings (Just idpid2)) + ) it "allows removing the default SSO code" $ do env <- ask (_userid, _teamid, (^. idpId) -> idpid) <- registerTestIdP @@ -1524,10 +1332,9 @@ specSsoSettings = do -- check it is not set anymore callGetDefaultSsoCode (env ^. teSpar) `shouldRespondWith` \resp -> - and - [ statusCode resp == 200, - responseJsonEither resp == Right (ssoSettings Nothing) - ] + (statusCode resp == 200) + && ( responseJsonEither resp == Right (ssoSettings Nothing) + ) it "removes the default SSO code if the IdP gets removed" $ do env <- ask (userid, _teamid, (^. idpId) -> idpid) <- registerTestIdP @@ -1541,10 +1348,9 @@ specSsoSettings = do -- check it is not set anymore callGetDefaultSsoCode (env ^. teSpar) `shouldRespondWith` \resp -> - and - [ statusCode resp == 200, - responseJsonEither resp == Right (ssoSettings Nothing) - ] + (statusCode resp == 200) + && ( responseJsonEither resp == Right (ssoSettings Nothing) + ) where ssoSettings maybeCode = object @@ -1599,3 +1405,108 @@ specSparUserMigration = do ssoToUidSpar tid ssoid liftIO $ mbUserId `shouldBe` Just memberUid + +specReAuthSsoUserWithPassword :: SpecWith TestEnv +specReAuthSsoUserWithPassword = + describe "Re-auth for SSO users" $ do + it "password user that was upgraded to SCIM has to provide password" $ do + env <- ask + let withoutIdp = False + (uid, cid) <- setup env withoutIdp + -- attempt to delete client again without password should still fail + deleteClient (env ^. teBrig) uid cid Nothing 403 + -- attempt to delete client with correct password should succeed + deleteClient (env ^. teBrig) uid cid (Just (fromPlainTextPassword defPassword)) 200 + it "password user that was upgraded to SAML does not need to provide password" $ do + env <- ask + let withIdp = True + (uid, cid) <- setup env withIdp + -- attempt to delete client again without password should now succeed + deleteClient (env ^. teBrig) uid cid Nothing 200 + where + setup :: TestEnv -> Bool -> TestSpar (UserId, ClientId) + setup env withIdp = do + -- user has been invited via TM and has a password + (owner, tid) <- call (createUserWithTeam (env ^. teBrig) (env ^. teGalley)) + email <- randomEmail + user <- call $ inviteAndRegisterUser (env ^. teBrig) owner tid email + -- user adds a client + cid <- addClientInternal (env ^. teBrig) (userId user) (defNewClient PermanentClientType [prekey] lPrekey) + checkNumClients (env ^. teBrig) (userId user) 1 + -- attempt to delete the client without password fails + deleteClient (env ^. teBrig) (userId user) cid Nothing 403 + -- attempt to delete the client with wrong password fails + deleteClient (env ^. teBrig) (userId user) cid (Just "wrong password") 403 + -- maybe idp is created + maybeIdpId <- + if withIdp + then do + SampleIdP idpmeta _privkey _ _ <- makeSampleIdPMetadata + apiVersion <- view teWireIdPAPIVersion + idp <- call $ callIdpCreate apiVersion (env ^. teSpar) (Just owner) idpmeta + pure $ Just (idp ^. idpId) + else pure Nothing + -- then user gets upgraded to scim with or without SAML + tok <- registerScimToken tid maybeIdpId + _ <- listUsers tok (Just (filterBy "externalId" (fromEmail email))) + -- attempt to delete the client with wrong password still fails + deleteClient (env ^. teBrig) (userId user) cid (Just "wrong password") 403 + pure (userId user, cid) + + checkNumClients :: BrigReq -> UserId -> Int -> TestSpar () + checkNumClients brig u expected = do + r <- + call $ + get $ + brig + . path "clients" + . zUser u + let actual = Vec.length <$> (preview _Array =<< responseJsonMaybe @Value r) + lift $ actual `shouldBe` Just expected + + prekey :: Prekey + prekey = Prekey (PrekeyId 1) "pQABAQECoQBYIOjl7hw0D8YRNqkkBQETCxyr7/ywE/2R5RWcUPM+GJACA6EAoQBYILLf1TIwSB62q69Ojs/X1tzJ+dYHNAw4QbW/7TC5vSZqBPY=" + + lPrekey :: LastPrekey + lPrekey = lastPrekey "pQABARn//wKhAFggnCcZIK1pbtlJf4wRQ44h4w7/sfSgj5oWXMQaUGYAJ/sDoQChAFgglacihnqg/YQJHkuHNFU7QD6Pb3KN4FnubaCF2EVOgRkE9g==" + + addClientInternal :: (HasCallStack, MonadIO m, MonadReader TestEnv m, MonadThrow m) => BrigReq -> UserId -> NewClient -> m ClientId + addClientInternal brig uid new = do + c <- + responseJsonError + =<< call + ( post $ + brig + . paths ["i", "clients", toByteString' uid] + . contentJson + . body (RequestBodyLBS $ encode new) + . expect2xx + ) + pure $ clientId c + + defNewClient :: ClientType -> [Prekey] -> LastPrekey -> NewClient + defNewClient ty pks lpk = + (newClient ty lpk) + { newClientPassword = Just defPassword, + newClientPrekeys = pks, + newClientLabel = Just "Test Device", + newClientModel = Just "Test Model", + newClientVerificationCode = Nothing + } + + deleteClient :: (MonadIO m, MonadReader TestEnv m) => BrigReq -> UserId -> ClientId -> Maybe Text -> Int -> m () + deleteClient brig u c pw expectedStatus = + void $ + call $ + delete $ + brig + . paths ["clients", toByteString' c] + . zUser u + . zConn "conn" + . contentJson + . body payload + . expectStatus ((==) expectedStatus) + where + payload = + RequestBodyLBS . encode . object . maybeToList $ + fmap ("password" .=) pw diff --git a/services/spar/test-integration/Test/Spar/AppSpec.hs b/services/spar/test-integration/Test/Spar/AppSpec.hs index e6bae3d472..9b06e7dc12 100644 --- a/services/spar/test-integration/Test/Spar/AppSpec.hs +++ b/services/spar/test-integration/Test/Spar/AppSpec.hs @@ -87,7 +87,7 @@ spec = describe "accessVerdict" $ do Servant.errHTTPCode outcome `shouldBe` 303 Servant.errReasonPhrase outcome `shouldBe` "forbidden" Servant.errBody outcome `shouldBe` "[\"No Bearer SubjectConfirmation\",\"no AuthnStatement\"]" - uriScheme loc `shouldBe` (URI.Scheme "wire") + uriScheme loc `shouldBe` URI.Scheme "wire" List.lookup "userid" qry `shouldBe` Nothing List.lookup "cookie" qry `shouldBe` Nothing List.lookup "label" qry `shouldBe` Just "forbidden" @@ -99,7 +99,7 @@ spec = describe "accessVerdict" $ do Servant.errHTTPCode outcome `shouldBe` 303 Servant.errReasonPhrase outcome `shouldBe` "success" Servant.errBody outcome `shouldBe` mempty - uriScheme loc `shouldBe` (URI.Scheme "wire") + uriScheme loc `shouldBe` URI.Scheme "wire" List.lookup "label" qry `shouldBe` Nothing List.lookup "userid" qry `shouldBe` (Just . cs . show $ uid) List.lookup "cookie" qry `shouldNotBe` Nothing @@ -171,7 +171,7 @@ requestAccessVerdict idp isGranted mkAuthnReq = do asks (^. teWireIdPAPIVersion) <&> \case User.WireIdPAPIV1 -> Nothing User.WireIdPAPIV2 -> Just (idp ^. SAML.idpExtraInfo . User.wiTeam) - runSpar $ Spar.verdictHandler Nothing mbteam authnresp verdict + runSpar $ Spar.verdictHandler mbteam authnresp verdict let loc :: URI.URI loc = maybe (error "no location") (either error id . SAML.parseURI' . cs) diff --git a/services/spar/test-integration/Test/Spar/DataSpec.hs b/services/spar/test-integration/Test/Spar/DataSpec.hs index 1d0a0503a3..ecd5839492 100644 --- a/services/spar/test-integration/Test/Spar/DataSpec.hs +++ b/services/spar/test-integration/Test/Spar/DataSpec.hs @@ -27,8 +27,6 @@ import Cassandra import Control.Lens import Control.Monad.Except import Data.Kind (Type) -import Data.UUID as UUID -import Data.UUID.V4 as UUID import Imports import Polysemy import SAML2.WebSSO as SAML @@ -36,7 +34,6 @@ import Spar.App as App import Spar.Intra.BrigApp (veidFromUserSSOId) import qualified Spar.Sem.AReqIDStore as AReqIDStore import qualified Spar.Sem.AssIDStore as AssIDStore -import qualified Spar.Sem.BindCookieStore as BindCookieStore import Spar.Sem.IdPConfigStore (GetIdPResult (..), Replaced (..), Replacing (..)) import qualified Spar.Sem.IdPConfigStore as IdPEffect import qualified Spar.Sem.SAMLUserStore as SAMLUserStore @@ -49,7 +46,6 @@ import Util.Scim import Util.Types import Web.Scim.Schema.Common as Scim.Common import Web.Scim.Schema.Meta as Scim.Meta -import Wire.API.Cookie import Wire.API.User.IdentityProvider import Wire.API.User.Saml import Wire.API.User.Scim @@ -146,28 +142,6 @@ spec = do () <- runSpar $ SAMLUserStore.delete uid uref muid <- runSpar (SAMLUserStore.get uref) `aFewTimes` isNothing liftIO $ muid `shouldBe` Nothing - describe "BindCookie" $ do - let mkcky :: TestSpar SetBindCookie - mkcky = fmap SetBindCookie . runSimpleSP . SAML.toggleCookie "/" . Just . (,1) . UUID.toText =<< liftIO UUID.nextRandom - it "insert and get are \"inverses\"" $ do - uid <- nextWireId - cky <- mkcky - () <- runSpar $ BindCookieStore.insert cky uid 1 - muid <- runSpar $ BindCookieStore.lookup (setBindCookieValue cky) - liftIO $ muid `shouldBe` Just uid - context "has timed out" $ do - it "BindCookieStore.lookup returns Nothing" $ do - uid <- nextWireId - cky <- mkcky - () <- runSpar $ BindCookieStore.insert cky uid 1 - liftIO $ threadDelay 2000000 - muid <- runSpar $ BindCookieStore.lookup (setBindCookieValue cky) - liftIO $ muid `shouldBe` Nothing - context "does not exist" $ do - it "BindCookieStore.lookup returns Nothing" $ do - cky <- mkcky - muid <- runSpar $ BindCookieStore.lookup (setBindCookieValue cky) - liftIO $ muid `shouldBe` Nothing describe "Team" $ do testDeleteTeam describe "IdPConfig" $ do @@ -189,14 +163,14 @@ spec = do it "getIdPConfigsByTeam works" $ do skipIdPAPIVersions [WireIdPAPIV1] teamid <- nextWireId - idp <- makeTestIdP <&> idpExtraInfo .~ (WireIdP teamid Nothing [] Nothing) + idp <- makeTestIdP <&> idpExtraInfo .~ WireIdP teamid Nothing [] Nothing () <- runSpar $ IdPEffect.storeConfig idp idps <- runSpar $ IdPEffect.getConfigsByTeam teamid liftIO $ idps `shouldBe` [idp] it "deleteIdPConfig works" $ do teamid <- nextWireId idpApiVersion <- asks (^. teWireIdPAPIVersion) - idp <- makeTestIdP <&> idpExtraInfo .~ (WireIdP teamid (Just idpApiVersion) [] Nothing) + idp <- makeTestIdP <&> idpExtraInfo .~ WireIdP teamid (Just idpApiVersion) [] Nothing () <- runSpar $ IdPEffect.storeConfig idp do midp <- runSpar $ IdPEffect.getConfig (idp ^. idpId) diff --git a/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs b/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs index 7ed60c2888..a19104a642 100644 --- a/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs +++ b/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs @@ -135,7 +135,7 @@ specImportToScimFromSAML = let uref = SAML.UserRef tenant subj subj = emailToSAMLNameID email tenant = idp ^. SAML.idpMetadata . SAML.edIssuer - !(Just !uid) <- createViaSaml idp privCreds uref + (Just !uid) <- createViaSaml idp privCreds uref samlUserShouldSatisfy uref isJust pure (uref, uid) @@ -193,7 +193,7 @@ specImportToScimFromSAML = assertBrigCassandra uid uref (Scim.value . Scim.thing $ storedUserUpdated) (valemail, True) ManagedByScim -- login again - !(Just !uid') <- createViaSaml idp privCreds uref + (Just !uid') <- createViaSaml idp privCreds uref liftIO $ uid' `shouldBe` uid specImportToScimFromInvitation :: SpecWith TestEnv @@ -213,7 +213,7 @@ specImportToScimFromInvitation = email <- randomEmail memberInvited <- call (inviteAndRegisterUser (env ^. teBrig) owner teamid email) let memberIdInvited = userId memberInvited - emailInvited = maybe (error "must have email") id (userEmail memberInvited) + emailInvited = fromMaybe (error "must have email") (userEmail memberInvited) pure (memberIdInvited, emailInvited) addSamlIdP :: HasCallStack => UserId -> TestSpar (SAML.IdPConfig User.WireIdP, SAML.SignPrivCreds) @@ -507,7 +507,7 @@ testCsvData tid owner uid mbeid mbsaml hasissuer = do pure (decodeCSV @CsvExport.TeamExportUser rbody) liftIO $ do - any (== uid) (CsvExport.tExportUserId <$> usersInCsv) `shouldBe` True + elem uid (CsvExport.tExportUserId <$> usersInCsv) `shouldBe` True forM_ usersInCsv $ \export -> when (CsvExport.tExportUserId export == uid) $ do ('e', CsvExport.tExportSCIMExternalId export) `shouldBe` ('e', fromMaybe "" mbeid) @@ -924,7 +924,7 @@ testScimCreateVsUserRef = do let uref = SAML.UserRef tenant subj subj = either (error . show) id $ SAML.mkNameID uname Nothing Nothing Nothing tenant = idp ^. SAML.idpMetadata . SAML.edIssuer - !(Just !uid) <- createViaSaml idp privCreds uref + (Just !uid) <- createViaSaml idp privCreds uref samlUserShouldSatisfy uref isJust deleteViaBrig uid samlUserShouldSatisfy uref isJust -- brig doesn't talk to spar right now when users @@ -1138,7 +1138,7 @@ testFindTeamSettingsInvitedUserMigratedWithEmailInTeamWithSSOViaUserId = do let memberIdInvited = userId memberInvited _ <- getUser tok memberIdInvited - Just brigUserInvited' <- runSpar $ Intra.getBrigUser Intra.NoPendingInvitations (memberIdInvited) + Just brigUserInvited' <- runSpar $ Intra.getBrigUser Intra.NoPendingInvitations memberIdInvited liftIO $ userManagedBy brigUserInvited' `shouldBe` ManagedByScim testFindProvisionedUserNoIdP :: TestSpar () @@ -2116,7 +2116,7 @@ specSCIMManaged = do randomAlphaNum :: MonadIO m => m Text randomAlphaNum = liftIO $ do nrs <- replicateM 21 (randomRIO (97, 122)) -- a-z - return (cs (map chr nrs)) + pure (cs (map chr nrs)) ---------------------------------------------------------------------------- -- Team Search for SAML users diff --git a/services/spar/test-integration/Util/Core.hs b/services/spar/test-integration/Util/Core.hs index 6cf63d76cc..22cf0eae3f 100644 --- a/services/spar/test-integration/Util/Core.hs +++ b/services/spar/test-integration/Util/Core.hs @@ -88,8 +88,6 @@ module Util.Core negotiateAuthnRequest', getCookie, hasPersistentCookieHeader, - hasDeleteBindCookieHeader, - hasSetBindCookieHeader, submitAuthnResponse, submitAuthnResponse', loginSsoUserFirstTime, @@ -151,7 +149,6 @@ import Control.Retry import Crypto.Random.Types (MonadRandom) import Data.Aeson as Aeson hiding (json) import Data.Aeson.Lens as Aeson -import qualified Data.ByteString as SBS import qualified Data.ByteString.Base64.Lazy as EL import Data.ByteString.Conversion import Data.Handle (Handle (Handle)) @@ -198,8 +195,6 @@ import URI.ByteString as URI import Util.Options import Util.Types import qualified Web.Cookie as Web -import Wire.API.Cookie -import Wire.API.Routes.Public.Spar import Wire.API.Team (Icon (..)) import Wire.API.Team.Feature (TeamFeatureStatusValue (..)) import qualified Wire.API.Team.Feature as Public @@ -227,20 +222,20 @@ mkEnvFromOptions = do cliOptsParser :: OPA.Parser (String, String) cliOptsParser = (,) - <$> ( OPA.strOption $ - OPA.long "integration-config" - <> OPA.short 'i' - <> OPA.help "Integration config to load" - <> OPA.showDefault - <> OPA.value defaultIntPath - ) - <*> ( OPA.strOption $ - OPA.long "service-config" - <> OPA.short 's' - <> OPA.help "Spar application config to load" - <> OPA.showDefault - <> OPA.value defaultSparPath - ) + <$> OPA.strOption + ( OPA.long "integration-config" + <> OPA.short 'i' + <> OPA.help "Integration config to load" + <> OPA.showDefault + <> OPA.value defaultIntPath + ) + <*> OPA.strOption + ( OPA.long "service-config" + <> OPA.short 's' + <> OPA.help "Spar application config to load" + <> OPA.showDefault + <> OPA.value defaultSparPath + ) where defaultIntPath = "/etc/wire/integration/integration.yaml" defaultSparPath = "/etc/wire/spar/conf/spar.yaml" @@ -338,7 +333,7 @@ getUserBrig uid = do 200 -> do let user = selfUser $ responseJsonUnsafe resp pure $ - if (userDeleted user) + if userDeleted user then Nothing else Just user 404 -> pure Nothing @@ -372,7 +367,7 @@ createUserWithTeamDisableSSO brg gly = do () <- Control.Exception.assert {- "Team ID in self profile and team table do not match" -} (selfTeam == Just tid) $ pure () - return (uid, tid) + pure (uid, tid) getSSOEnabledInternal :: (HasCallStack, MonadHttp m, MonadIO m) => GalleyReq -> TeamId -> m ResponseLBS getSSOEnabledInternal gly tid = do @@ -412,7 +407,7 @@ inviteAndRegisterUser brig u tid inviteeEmail = do unless (Just tid == userTeam invitee) $ error "Team ID in registration and team table do not match" selfTeam <- userTeam . selfUser <$> getSelfProfile brig (userId invitee) unless (selfTeam == Just tid) $ error "Team ID in self profile and team table do not match" - return invitee + pure invitee where accept' :: User.Email -> User.InvitationCode -> RequestBody accept' email code = acceptWithName (User.Name "Bob") email code @@ -455,7 +450,7 @@ inviteAndRegisterUser brig u tid inviteeEmail = do . queryItem "invitation_id" (toByteString' ref) ) let lbs = fromMaybe "" $ responseBody r - return $ fromByteString . fromMaybe (error "No code?") $ encodeUtf8 <$> (lbs ^? key "code" . _String) + pure $ fromByteString (maybe (error "No code?") encodeUtf8 (lbs ^? key "code" . _String)) -- | NB: this does create an SSO UserRef on brig, but not on spar. this is inconsistent, but the -- inconsistency does not affect the tests we're running with this. to resolve it, we could add an @@ -555,11 +550,9 @@ nextSubject = liftIO $ do nextUserRef :: MonadIO m => m SAML.UserRef nextUserRef = liftIO $ do tenant <- UUID.toText <$> UUID.nextRandom - subject <- nextSubject - pure $ - SAML.UserRef - (SAML.Issuer $ SAML.unsafeParseURI ("http://" <> tenant)) - subject + SAML.UserRef + (SAML.Issuer $ SAML.unsafeParseURI ("http://" <> tenant)) + <$> nextSubject createRandomPhoneUser :: (HasCallStack, MonadCatch m, MonadIO m, MonadHttp m) => BrigReq -> m (UserId, Brig.Phone) createRandomPhoneUser brig_ = do @@ -579,7 +572,7 @@ createRandomPhoneUser brig_ = do get (brig_ . path "/self" . zUser uid) !!! do const 200 === statusCode const (Right (Just phn)) === (fmap Brig.userPhone . responseJsonEither) - return (uid, phn) + pure (uid, phn) getTeams :: (HasCallStack, MonadHttp m, MonadIO m) => UserId -> GalleyReq -> m Galley.TeamList getTeams u gly = do @@ -590,7 +583,7 @@ getTeams u gly = do . zAuthAccess u "conn" . expect2xx ) - return $ responseJsonUnsafe r + pure $ responseJsonUnsafe r getTeamMemberIds :: HasCallStack => UserId -> TeamId -> TestSpar [UserId] getTeamMemberIds usr tid = (^. Galley.userId) <$$> getTeamMembers usr tid @@ -618,7 +611,7 @@ promoteTeamMember usr tid memid = do getSelfProfile :: (HasCallStack, MonadHttp m, MonadIO m) => BrigReq -> UserId -> m Brig.SelfProfile getSelfProfile brg usr = do rsp <- get $ brg . path "/self" . zUser usr - return $ responseJsonUnsafe rsp + pure $ responseJsonUnsafe rsp zAuthAccess :: UserId -> SBS -> Request -> Request zAuthAccess u c = header "Z-Type" "access" . zUser u . zConn c @@ -629,13 +622,13 @@ newTeam = Galley.BindingNewTeam $ Galley.newNewTeam (unsafeRange "teamName") Def randomEmail :: MonadIO m => m Brig.Email randomEmail = do uid <- liftIO nextRandom - return $ Brig.Email ("success+" <> UUID.toText uid) "simulator.amazonses.com" + pure $ Brig.Email ("success+" <> UUID.toText uid) "simulator.amazonses.com" randomPhone :: MonadIO m => m Brig.Phone randomPhone = liftIO $ do nrs <- map show <$> replicateM 14 (randomRIO (0, 9) :: IO Int) let phone = Brig.parsePhone . cs $ "+0" ++ concat nrs - return $ fromMaybe (error "Invalid random phone#") phone + pure $ fromMaybe (error "Invalid random phone#") phone randomUser :: (HasCallStack, MonadCatch m, MonadIO m, MonadHttp m) => BrigReq -> m Brig.User randomUser brig_ = do @@ -649,7 +642,7 @@ createUser :: m Brig.User createUser name brig_ = do r <- postUser name True Nothing Nothing brig_ (lbs ^? Aeson.key "key" . Aeson._String) let acode = Brig.ActivationCode . Ascii.unsafeFromText <$> (lbs ^? Aeson.key "code" . Aeson._String) - return $ (,) <$> akey <*> acode + pure $ (,) <$> akey <*> acode activate :: (HasCallStack, MonadIO m, MonadHttp m) => @@ -758,7 +751,7 @@ makeTestIdP = do SampleIdP md _ _ _ <- makeSampleIdPMetadata IdPConfig <$> (IdPId <$> liftIO UUID.nextRandom) - <*> (pure md) + <*> pure md <*> nextWireIdP apiversion getTestSPMetadata :: (HasCallStack, MonadReader TestEnv m, MonadIO m) => TeamId -> m SPMetadata @@ -823,9 +816,6 @@ getCookie proxy rsp = do then Right $ SimpleSetCookie web else Left $ "bad cookie name. (found, expected) == " <> show (Web.setCookieName web, SAML.cookieName proxy) -getSetBindCookie :: ResponseLBS -> Either String SetBindCookie -getSetBindCookie = fmap SetBindCookie . getCookie (Proxy @"zbind") - -- | In 'setResponseCookie' we set an expiration date iff cookie is persistent. So here we test for -- expiration date. Easier than parsing and inspecting the cookie value. hasPersistentCookieHeader :: ResponseLBS -> Either String () @@ -835,31 +825,6 @@ hasPersistentCookieHeader rsp = do Left $ "expiration date should NOT empty: " <> show cky --- | A bind cookie is always sent, but if we do not want to send one, it looks like this: --- "wire.com=; Path=/sso/finalize-login; Expires=Thu, 01-Jan-1970 00:00:00 GMT; Max-Age=-1; Secure" -hasDeleteBindCookieHeader :: HasCallStack => ResponseLBS -> Either String () -hasDeleteBindCookieHeader rsp = isDeleteBindCookie =<< getSetBindCookie rsp - -isDeleteBindCookie :: HasCallStack => SetBindCookie -> Either String () -isDeleteBindCookie (SetBindCookie (SimpleSetCookie cky)) = - if (SAML.Time <$> Web.setCookieExpires cky) == Just (SAML.unsafeReadTime "1970-01-01T00:00:00Z") - then Right () - else Left $ "expiration should be empty: " <> show cky - -hasSetBindCookieHeader :: HasCallStack => ResponseLBS -> Either String () -hasSetBindCookieHeader rsp = isSetBindCookie =<< getSetBindCookie rsp - -isSetBindCookie :: HasCallStack => SetBindCookie -> Either String () -isSetBindCookie (SetBindCookie (SimpleSetCookie cky)) = do - unless (Web.setCookieName cky == "zbind") $ do - Left $ "expected zbind cookie: " <> show cky - unless (maybe False ("/sso/finalize-login" `SBS.isPrefixOf`) $ Web.setCookiePath cky) $ do - Left $ "expected path prefix /sso/finalize-login: " <> show cky - unless (Web.setCookieSecure cky) $ do - Left $ "cookie must be secure: " <> show cky - unless (Web.setCookieSameSite cky == Just Web.sameSiteStrict) $ do - Left $ "cookie must be same-site: " <> show cky - tryLogin :: HasCallStack => SignPrivCreds -> IdP -> NameID -> TestSpar SAML.UserRef tryLogin privkey idp userSubject = do env <- ask @@ -892,37 +857,25 @@ negotiateAuthnRequest :: (HasCallStack, MonadIO m, MonadReader TestEnv m) => IdP -> m SAML.AuthnRequest -negotiateAuthnRequest idp = - negotiateAuthnRequest' DoInitiateLogin idp id >>= \case - (req, cky) -> case maybe (Left "missing") isDeleteBindCookie cky of - Right () -> pure req - Left msg -> error $ "unexpected bind cookie: " <> show (cky, msg) - -doInitiatePath :: DoInitiate -> [ST] -doInitiatePath DoInitiateLogin = ["sso", "initiate-login"] -doInitiatePath DoInitiateBind = ["sso-initiate-bind"] +negotiateAuthnRequest idp = negotiateAuthnRequest' idp id negotiateAuthnRequest' :: (HasCallStack, MonadIO m, MonadReader TestEnv m) => - DoInitiate -> IdP -> (Request -> Request) -> - m (SAML.AuthnRequest, Maybe SetBindCookie) -negotiateAuthnRequest' (doInitiatePath -> doInit) idp modreq = do + m SAML.AuthnRequest +negotiateAuthnRequest' idp modreq = do env <- ask resp :: ResponseLBS <- call $ get ( modreq . (env ^. teSpar) - . paths (cs <$> (doInit <> [idPIdToST $ idp ^. SAML.idpId])) + . paths (cs <$> ["sso", "initiate-login", idPIdToST $ idp ^. SAML.idpId]) . expect2xx ) (_, authnreq) <- either error pure . parseAuthnReqResp $ cs <$> responseBody resp - let wireCookie = - SetBindCookie . SAML.SimpleSetCookie . Web.parseSetCookie - <$> lookup "Set-Cookie" (responseHeaders resp) - pure (authnreq, wireCookie) + pure authnreq submitAuthnResponse :: (HasCallStack, MonadIO m, MonadReader TestEnv m) => @@ -977,7 +930,7 @@ loginCreatedSsoUser nameid idp privCreds = do authnResp <- runSimpleSP $ mkAuthnResponseWithSubj nameid privCreds idp spmeta authnReq True sparAuthnResp <- submitAuthnResponse tid authnResp - let wireCookie = maybe (error (show sparAuthnResp)) id . lookup "Set-Cookie" $ responseHeaders sparAuthnResp + let wireCookie = fromMaybe (error (show sparAuthnResp)) . lookup "Set-Cookie" $ responseHeaders sparAuthnResp accessResp :: ResponseLBS <- call $ post ((env ^. teBrig) . path "/access" . header "Cookie" wireCookie . expect2xx) @@ -1140,16 +1093,15 @@ callIdpCreateReplace' apiversion sparreq_ muid metadata idpid = do . maybe id zUser muid . path "/identity-providers/" . Bilge.query - ( [ ( "api_version", - case apiversion of - WireIdPAPIV1 -> if explicitQueryParam then Just "v1" else Nothing - WireIdPAPIV2 -> Just "v2" - ), - ( "replaces", - Just . cs . idPIdToST $ idpid - ) - ] - ) + [ ( "api_version", + case apiversion of + WireIdPAPIV1 -> if explicitQueryParam then Just "v1" else Nothing + WireIdPAPIV2 -> Just "v2" + ), + ( "replaces", + Just . cs . idPIdToST $ idpid + ) + ] . body (RequestBodyLBS . cs $ SAML.encode metadata) . header "Content-Type" "application/xml" diff --git a/services/spar/test-integration/Util/Email.hs b/services/spar/test-integration/Util/Email.hs index f3ebef1b10..6f503cb5e0 100644 --- a/services/spar/test-integration/Util/Email.hs +++ b/services/spar/test-integration/Util/Email.hs @@ -153,7 +153,7 @@ getActivationCode brig ep = do let lbs = fromMaybe "" $ responseBody r let akey = ActivationKey . Ascii.unsafeFromText <$> (lbs ^? key "key" . _String) let acode = ActivationCode . Ascii.unsafeFromText <$> (lbs ^? key "code" . _String) - return $ (,) <$> akey <*> acode + pure $ (,) <$> akey <*> acode setSamlEmailValidation :: HasCallStack => TeamId -> Feature.TeamFeatureStatusValue -> TestSpar () setSamlEmailValidation tid status = do diff --git a/services/spar/test-integration/Util/Invitation.hs b/services/spar/test-integration/Util/Invitation.hs index bbd69b67bb..5d1a4f88d3 100644 --- a/services/spar/test-integration/Util/Invitation.hs +++ b/services/spar/test-integration/Util/Invitation.hs @@ -66,7 +66,7 @@ getInvitationCode brig t ref = do . queryItem "invitation_id" (toByteString' ref) ) let lbs = fromMaybe "" $ responseBody r - return $ fromByteString . fromMaybe (error "No code?") $ encodeUtf8 <$> (lbs ^? key "code" . _String) + pure $ fromByteString (maybe (error "No code?") encodeUtf8 (lbs ^? key "code" . _String)) registerInvitation :: HasCallStack => Email -> Name -> InvitationCode -> Bool -> TestSpar () registerInvitation email name inviteeCode shouldSucceed = do diff --git a/services/spar/test-integration/Util/Scim.hs b/services/spar/test-integration/Util/Scim.hs index b74a9406ac..4ac23e3b22 100644 --- a/services/spar/test-integration/Util/Scim.hs +++ b/services/spar/test-integration/Util/Scim.hs @@ -249,7 +249,7 @@ listUsers :: HasCallStack => ScimToken -> Maybe Scim.Filter -> - TestSpar [(Scim.StoredUser SparTag)] + TestSpar [Scim.StoredUser SparTag] listUsers tok mbFilter = do env <- ask r <- diff --git a/services/spar/test/Test/Spar/APISpec.hs b/services/spar/test/Test/Spar/APISpec.hs index 807878f5d5..814eb2e681 100644 --- a/services/spar/test/Test/Spar/APISpec.hs +++ b/services/spar/test/Test/Spar/APISpec.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2022 Wire Swiss GmbH diff --git a/services/spar/test/Test/Spar/DataSpec.hs b/services/spar/test/Test/Spar/DataSpec.hs index 45b73dc67c..32ece91eab 100644 --- a/services/spar/test/Test/Spar/DataSpec.hs +++ b/services/spar/test/Test/Spar/DataSpec.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2022 Wire Swiss GmbH @@ -36,13 +34,13 @@ spec = do describe "ttlToNominalDiffTime" $ do it "" $ do addTime (ttlToNominalDiffTime $ TTL 3) (Time $ parsetm "1924-07-14T08:30:00Z") - `shouldBe` (Time $ parsetm "1924-07-14T08:30:03Z") + `shouldBe` Time (parsetm "1924-07-14T08:30:03Z") check :: HasCallStack => Int -> Env -> String -> Either TTLError (TTL "authresp") -> Spec check testnumber env (parsetm -> endOfLife) expectttl = it (show testnumber) $ mkTTLAssertions env endOfLife `shouldBe` expectttl -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/Intra/BrigSpec.hs b/services/spar/test/Test/Spar/Intra/BrigSpec.hs index ee7c29934b..940d1de564 100644 --- a/services/spar/test/Test/Spar/Intra/BrigSpec.hs +++ b/services/spar/test/Test/Spar/Intra/BrigSpec.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -Wno-orphans #-} -- This file is part of the Wire Server implementation. diff --git a/services/spar/test/Test/Spar/ScimSpec.hs b/services/spar/test/Test/Spar/ScimSpec.hs index 8dddea10dd..f2d6ecdcfe 100644 --- a/services/spar/test/Test/Spar/ScimSpec.hs +++ b/services/spar/test/Test/Spar/ScimSpec.hs @@ -137,7 +137,7 @@ spec = describe "toScimStoredUser'" $ do }|] let (Aeson.Success (PatchOp [operation])) = Aeson.parse (parseJSON @(PatchOp SparTag)) operationJSON applyOperation (ScimUserExtra mempty) operation - `shouldBe` (Right (ScimUserExtra (RichInfo (mkRichInfoAssocList [RichField "newAttr" "newValue"])))) + `shouldBe` Right (ScimUserExtra (RichInfo (mkRichInfoAssocList [RichField "newAttr" "newValue"]))) it "can replace in rich info map" $ do let operationJSON = [aesonQQ|{ @@ -150,7 +150,7 @@ spec = describe "toScimStoredUser'" $ do }|] let (Aeson.Success (PatchOp [operation])) = Aeson.parse (parseJSON @(PatchOp SparTag)) operationJSON applyOperation (ScimUserExtra (RichInfo (mkRichInfoAssocList [RichField "oldAttr" "oldValue"]))) operation - `shouldBe` (Right (ScimUserExtra (RichInfo (mkRichInfoAssocList [RichField "oldAttr" "newValue"])))) + `shouldBe` Right (ScimUserExtra (RichInfo (mkRichInfoAssocList [RichField "oldAttr" "newValue"]))) it "treats rich info map case insensitively" $ do let operationJSON = [aesonQQ|{ @@ -163,7 +163,7 @@ spec = describe "toScimStoredUser'" $ do }|] let (Aeson.Success (PatchOp [operation])) = Aeson.parse (parseJSON @(PatchOp SparTag)) operationJSON applyOperation (ScimUserExtra (RichInfo (mkRichInfoAssocList [RichField "oldAttr" "oldValue"]))) operation - `shouldBe` (Right (ScimUserExtra (RichInfo (mkRichInfoAssocList [RichField "oldAttr" "newValue"])))) + `shouldBe` Right (ScimUserExtra (RichInfo (mkRichInfoAssocList [RichField "oldAttr" "newValue"]))) it "can remove from rich info map" $ do let operationJSON = [aesonQQ|{ @@ -175,7 +175,7 @@ spec = describe "toScimStoredUser'" $ do }|] let (Aeson.Success (PatchOp [operation])) = Aeson.parse (parseJSON @(PatchOp SparTag)) operationJSON applyOperation (ScimUserExtra (RichInfo (mkRichInfoAssocList [RichField "oldAttr" "oldValue"]))) operation - `shouldBe` (Right (ScimUserExtra mempty)) + `shouldBe` Right (ScimUserExtra mempty) it "adds new fields to rich info assoc list at the end" $ do let operationJSON = [aesonQQ|{ @@ -188,7 +188,7 @@ spec = describe "toScimStoredUser'" $ do }|] let (Aeson.Success (PatchOp [operation])) = Aeson.parse (parseJSON @(PatchOp SparTag)) operationJSON applyOperation (ScimUserExtra (RichInfo (mkRichInfoAssocList [RichField "oldAttr" "oldValue"]))) operation - `shouldBe` (Right (ScimUserExtra (RichInfo (mkRichInfoAssocList [RichField "oldAttr" "oldValue", RichField "newAttr" "newValue"])))) + `shouldBe` Right (ScimUserExtra (RichInfo (mkRichInfoAssocList [RichField "oldAttr" "oldValue", RichField "newAttr" "newValue"]))) it "can replace in rich info assoc list while maintaining order" $ do let operationJSON = [aesonQQ|{ @@ -211,7 +211,7 @@ spec = describe "toScimStoredUser'" $ do RichField "thirdAttr" "thirdVal" ] applyOperation (ScimUserExtra (RichInfo (mkRichInfoAssocList origAssocList))) operation - `shouldBe` (Right (ScimUserExtra (RichInfo (mkRichInfoAssocList expectedAssocList)))) + `shouldBe` Right (ScimUserExtra (RichInfo (mkRichInfoAssocList expectedAssocList))) it "can remove from rich info assoc list" $ do let operationJSON = [aesonQQ|{ @@ -223,7 +223,7 @@ spec = describe "toScimStoredUser'" $ do }|] let (Aeson.Success (PatchOp [operation])) = Aeson.parse (parseJSON @(PatchOp SparTag)) operationJSON applyOperation (ScimUserExtra (RichInfo (mkRichInfoAssocList [RichField "oldAttr" "oldValue"]))) operation - `shouldBe` (Right (ScimUserExtra mempty)) + `shouldBe` Right (ScimUserExtra mempty) it "throws error if asked to patch an recognized schema" $ do let schema = Just (CustomSchema "wrong-schema") path = Just (NormalPath (AttrPath schema "oldAttr" Nothing)) @@ -252,7 +252,7 @@ spec = describe "toScimStoredUser'" $ do RichField "thirdAttr" "thirdVal" ] applyOperation (ScimUserExtra (RichInfo (mkRichInfoAssocList origAssocList))) operation - `shouldBe` (Right (ScimUserExtra (RichInfo (mkRichInfoAssocList expectedAssocList)))) + `shouldBe` Right (ScimUserExtra (RichInfo (mkRichInfoAssocList expectedAssocList))) describe "normalization" $ do let usr :: User SparTag diff --git a/services/spar/test/Test/Spar/Sem/IdPConfigStoreSpec.hs b/services/spar/test/Test/Spar/Sem/IdPConfigStoreSpec.hs index 961f27773f..af387bd5fe 100644 --- a/services/spar/test/Test/Spar/Sem/IdPConfigStoreSpec.hs +++ b/services/spar/test/Test/Spar/Sem/IdPConfigStoreSpec.hs @@ -1,6 +1,4 @@ -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} diff --git a/stack.yaml b/stack.yaml index 974fdc6db4..5ebff33258 100644 --- a/stack.yaml +++ b/stack.yaml @@ -258,6 +258,7 @@ extra-deps: - proto-lens-runtime-0.7.0.1 - proto-lens-setup-0.4.0.5 - tracing-0.0.7.2 +- zlib-0.6.3.0 ############################################################ # Development tools diff --git a/stack.yaml.lock b/stack.yaml.lock index 3bcc5f92c0..985811c000 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -868,6 +868,13 @@ packages: sha256: b3059324bf8fea08874dd4f5518105f3edd6e469104242e652698f488a5227d5 original: hackage: tracing-0.0.7.2 +- completed: + hackage: zlib-0.6.3.0@sha256:8214a9d37580f17f8b675109578a5dbe6853559eef156e34dc2233f1123ace33,5216 + pantry-tree: + size: 2622 + sha256: 87b7fd16379d679eb01d9fae78b4db97356d301fce4a040ba9e690d16eeb98b2 + original: + hackage: zlib-0.6.3.0 - completed: hackage: ormolu-0.1.4.1@sha256:ed404eac6e4eb64da1ca5fb749e0f99907431a9633e6ba34e44d260e7d7728ba,6499 pantry-tree: diff --git a/tools/stern/.hlint.yaml b/tools/stern/.hlint.yaml new file mode 120000 index 0000000000..f6977905d3 --- /dev/null +++ b/tools/stern/.hlint.yaml @@ -0,0 +1 @@ +../../.hlint.yaml \ No newline at end of file diff --git a/tools/stern/src/Stern/API.hs b/tools/stern/src/Stern/API.hs index 1252be7bad..0b2d23e3f9 100644 --- a/tools/stern/src/Stern/API.hs +++ b/tools/stern/src/Stern/API.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeOperators #-} @@ -77,7 +76,7 @@ start o = do s <- Server.newSettings (server e) runSettings s (pipeline e) where - server e = Server.defaultServer (unpack $ (stern o) ^. epHost) ((stern o) ^. epPort) (e ^. applog) (e ^. metrics) + server e = Server.defaultServer (unpack $ stern o ^. epHost) (stern o ^. epPort) (e ^. applog) (e ^. metrics) pipeline e = GZip.gzip GZip.def $ serve e serve e r k = runHandler e r (Server.route (Server.compile sitemap) r k) k @@ -90,8 +89,8 @@ routes :: Routes Doc.ApiBuilder Handler () routes = do -- Begin Internal - get "/i/status" (continue $ const $ return empty) true - head "/i/status" (continue $ const $ return empty) true + get "/i/status" (continue $ const $ pure empty) true + head "/i/status" (continue $ const $ pure empty) true -- End Internal @@ -387,7 +386,7 @@ routes = do description "Team ID" Doc.parameter Doc.Path "feature" Doc.typeTeamFeatureNameNoConfig $ description "Feature name" - Doc.parameter Doc.Query "status" Public.typeTeamFeatureStatusValue $ do + Doc.parameter Doc.Query "status" Public.typeTeamFeatureStatusValue $ Doc.description "team feature status (enabled or disabled)" Doc.response 200 "Team feature flag status" Doc.end @@ -395,7 +394,7 @@ routes = do -- These endpoints should be part of team settings. Until then, we access them from here -- for authorized personnel to enable/disable this on the team's behalf - get "/teams/:tid/search-visibility" (continue (liftM json . Intra.getSearchVisibility)) $ + get "/teams/:tid/search-visibility" (continue (fmap json . Intra.getSearchVisibility)) $ capture "tid" document "GET" "getSearchVisibility" $ do summary "Shows the current TeamSearchVisibility value for the given team" @@ -480,7 +479,7 @@ routes = do document "GET" "getConsentLog" $ do summary "Fetch the consent log given an email address of a non-user" notes "Relevant only internally at Wire" - Doc.parameter Doc.Query "email" Doc.string' $ do + Doc.parameter Doc.Query "email" Doc.string' $ Doc.description "An email address" Doc.response 200 "Consent Log" Doc.end Doc.response 403 "Access denied! There is a user with this email address" Doc.end @@ -490,7 +489,7 @@ routes = do document "GET" "getUserMetaInfo" $ do summary "Fetch a user's meta info given a user id: TEMPORARY!" notes "Relevant only internally at Wire" - Doc.parameter Doc.Query "id" Doc.bytes' $ do + Doc.parameter Doc.Query "id" Doc.bytes' $ Doc.description "A user's ID" Doc.response 200 "Meta Info" Doc.end @@ -513,22 +512,22 @@ type JSON = Media "application" "json" suspendUser :: UserId -> Handler Response suspendUser uid = do Intra.putUserStatus Suspended uid - return empty + pure empty unsuspendUser :: UserId -> Handler Response -unsuspendUser uid = Intra.putUserStatus Active uid >> return empty +unsuspendUser uid = Intra.putUserStatus Active uid >> pure empty usersByEmail :: Email -> Handler Response -usersByEmail = liftM json . Intra.getUserProfilesByIdentity . Left +usersByEmail = fmap json . Intra.getUserProfilesByIdentity . Left usersByPhone :: Phone -> Handler Response -usersByPhone = liftM json . Intra.getUserProfilesByIdentity . Right +usersByPhone = fmap json . Intra.getUserProfilesByIdentity . Right usersByIds :: List UserId -> Handler Response -usersByIds = liftM json . Intra.getUserProfiles . Left . fromList +usersByIds = fmap json . Intra.getUserProfiles . Left . fromList usersByHandles :: List Handle -> Handler Response -usersByHandles = liftM json . Intra.getUserProfiles . Right . fromList +usersByHandles = fmap json . Intra.getUserProfiles . Right . fromList ejpdInfoByHandles :: (List Handle ::: Bool) -> Handler Response ejpdInfoByHandles (handles ::: includeContacts) = json <$> Intra.getEjpdInfo (fromList handles) includeContacts @@ -536,29 +535,29 @@ ejpdInfoByHandles (handles ::: includeContacts) = json <$> Intra.getEjpdInfo (fr userConnections :: UserId -> Handler Response userConnections uid = do conns <- Intra.getUserConnections uid - return . json $ groupByStatus conns + pure . json $ groupByStatus conns usersConnections :: List UserId -> Handler Response -usersConnections = liftM json . Intra.getUsersConnections +usersConnections = fmap json . Intra.getUsersConnections searchOnBehalf :: UserId ::: T.Text ::: Range 1 100 Int32 -> Handler Response searchOnBehalf (uid ::: q ::: s) = - liftM json $ Intra.getContacts uid q (fromRange s) + json <$> Intra.getContacts uid q (fromRange s) revokeIdentity :: Either Email Phone -> Handler Response -revokeIdentity emailOrPhone = Intra.revokeIdentity emailOrPhone >> return empty +revokeIdentity emailOrPhone = Intra.revokeIdentity emailOrPhone >> pure empty changeEmail :: JSON ::: UserId ::: Bool ::: JsonRequest EmailUpdate -> Handler Response changeEmail (_ ::: uid ::: validate ::: req) = do upd <- parseBody req !>> mkError status400 "client-error" Intra.changeEmail uid upd validate - return empty + pure empty changePhone :: JSON ::: UserId ::: JsonRequest PhoneUpdate -> Handler Response changePhone (_ ::: uid ::: req) = do upd <- parseBody req !>> mkError status400 "client-error" Intra.changePhone uid upd - return empty + pure empty deleteUser :: UserId ::: Either Email Phone -> Handler Response deleteUser (uid ::: emailOrPhone) = do @@ -569,9 +568,9 @@ deleteUser (uid ::: emailOrPhone) = do then do info $ userMsg uid . msg (val "Deleting account") void $ Intra.deleteAccount uid - return empty + pure empty else throwE $ mkError status400 "match-error" "email or phone did not match UserId" - _ -> return $ setStatus status404 empty + _ -> pure $ setStatus status404 empty where checkUUID u = userId u == uid @@ -590,7 +589,7 @@ deleteTeam (givenTid ::: False ::: Just email) = do unless (length (tiMembers tInfo) == 1) $ throwE wrongMemberCount void $ Intra.deleteBindingTeam givenTid - return $ setStatus status202 empty + pure $ setStatus status202 empty where handleNoUser = ifNothing (mkError status404 "no-user" "No such user with that email") handleNoTeam = ifNothing (mkError status404 "no-binding-team" "No such binding team") @@ -599,7 +598,7 @@ deleteTeam (givenTid ::: False ::: Just email) = do deleteTeam (tid ::: True ::: _) = do void $ Intra.getTeamData tid -- throws 404 if team does not exist void $ Intra.deleteBindingTeamForce tid - return $ setStatus status202 empty + pure $ setStatus status202 empty isUserKeyBlacklisted :: Either Email Phone -> Handler Response isUserKeyBlacklisted emailOrPhone = do @@ -609,7 +608,7 @@ isUserKeyBlacklisted emailOrPhone = do else response status404 "The given user key is NOT blacklisted" where response st reason = - return + pure . setStatus st . json $ object ["status" .= (reason :: Text)] @@ -617,18 +616,18 @@ isUserKeyBlacklisted emailOrPhone = do addBlacklist :: Either Email Phone -> Handler Response addBlacklist emailOrPhone = do Intra.setBlacklistStatus True emailOrPhone - return empty + pure empty deleteFromBlacklist :: Either Email Phone -> Handler Response deleteFromBlacklist emailOrPhone = do Intra.setBlacklistStatus False emailOrPhone - return empty + pure empty getTeamInfo :: TeamId -> Handler Response -getTeamInfo = liftM json . Intra.getTeamInfo +getTeamInfo = fmap json . Intra.getTeamInfo getTeamAdminInfo :: TeamId -> Handler Response -getTeamAdminInfo = liftM (json . toAdminInfo) . Intra.getTeamInfo +getTeamAdminInfo = fmap (json . toAdminInfo) . Intra.getTeamInfo getTeamFeatureFlagH :: forall (a :: Public.TeamFeatureName). @@ -669,13 +668,13 @@ setTeamFeatureNoConfigFlagH (tid ::: featureName ::: statusValue) = setSearchVisibility :: JSON ::: TeamId ::: JsonRequest Team.TeamSearchVisibility -> Handler Response setSearchVisibility (_ ::: tid ::: req) = do status :: Team.TeamSearchVisibility <- parseBody req !>> mkError status400 "client-error" - liftM json $ Intra.setSearchVisibility tid status + json <$> Intra.setSearchVisibility tid status getTeamBillingInfo :: TeamId -> Handler Response getTeamBillingInfo tid = do ti <- Intra.getTeamBillingInfo tid case ti of - Just t -> return $ json t + Just t -> pure $ json t Nothing -> throwE (mkError status404 "no-team" "No team or no billing info for team") updateTeamBillingInfo :: JSON ::: TeamId ::: JsonRequest TeamBillingInfoUpdate -> Handler Response @@ -684,20 +683,20 @@ updateTeamBillingInfo (_ ::: tid ::: req) = do current <- Intra.getTeamBillingInfo tid >>= handleNoTeam let changes = parse update current Intra.setTeamBillingInfo tid changes - liftM json $ Intra.getTeamBillingInfo tid + json <$> Intra.getTeamBillingInfo tid where handleNoTeam = ifNothing (mkError status404 "no-team" "No team or no billing info for team") parse :: TeamBillingInfoUpdate -> TeamBillingInfo -> TeamBillingInfo parse TeamBillingInfoUpdate {..} tbi = tbi - { tbiFirstname = fromMaybe (tbiFirstname tbi) (fromRange <$> tbiuFirstname), - tbiLastname = fromMaybe (tbiLastname tbi) (fromRange <$> tbiuLastname), - tbiStreet = fromMaybe (tbiStreet tbi) (fromRange <$> tbiuStreet), - tbiZip = fromMaybe (tbiZip tbi) (fromRange <$> tbiuZip), - tbiCity = fromMaybe (tbiCity tbi) (fromRange <$> tbiuCity), - tbiCountry = fromMaybe (tbiCountry tbi) (fromRange <$> tbiuCountry), - tbiCompany = (fromRange <$> tbiuCompany) <|> tbiCompany tbi, - tbiState = (fromRange <$> tbiuState) <|> tbiState tbi + { tbiFirstname = maybe (tbiFirstname tbi) fromRange tbiuFirstname, + tbiLastname = maybe (tbiLastname tbi) fromRange tbiuLastname, + tbiStreet = maybe (tbiStreet tbi) fromRange tbiuStreet, + tbiZip = maybe (tbiZip tbi) fromRange tbiuZip, + tbiCity = maybe (tbiCity tbi) fromRange tbiuCity, + tbiCountry = maybe (tbiCountry tbi) fromRange tbiuCountry, + tbiCompany = fromRange <$> tbiuCompany <|> tbiCompany tbi, + tbiState = fromRange <$> tbiuState <|> tbiState tbi } setTeamBillingInfo :: JSON ::: TeamId ::: JsonRequest TeamBillingInfo -> Handler Response @@ -711,9 +710,9 @@ setTeamBillingInfo (_ ::: tid ::: req) = do getTeamInfoByMemberEmail :: Email -> Handler Response getTeamInfoByMemberEmail e = do - acc <- (listToMaybe <$> Intra.getUserProfilesByIdentity (Left e)) >>= handleUser + acc <- Intra.getUserProfilesByIdentity (Left e) >>= handleUser . listToMaybe tid <- (Intra.getUserBindingTeam . userId . accountUser $ acc) >>= handleTeam - liftM json $ Intra.getTeamInfo tid + json <$> Intra.getTeamInfo tid where handleUser = ifNothing (mkError status404 "no-user" "No such user with that email") handleTeam = ifNothing (mkError status404 "no-binding-team" "No such binding team") @@ -721,17 +720,17 @@ getTeamInfoByMemberEmail e = do getTeamInvoice :: TeamId ::: InvoiceId ::: JSON -> Handler Response getTeamInvoice (tid ::: iid ::: _) = do url <- Intra.getInvoiceUrl tid iid - return $ plain (fromStrict url) + pure $ plain (fromStrict url) getConsentLog :: Email -> Handler Response getConsentLog e = do - acc <- (listToMaybe <$> Intra.getUserProfilesByIdentity (Left e)) + acc <- listToMaybe <$> Intra.getUserProfilesByIdentity (Left e) when (isJust acc) $ throwE $ mkError status403 "user-exists" "Trying to access consent log of existing user!" consentLog <- Intra.getEmailConsentLog e marketo <- Intra.getMarketoResult e - return . json $ + pure . json $ object [ "consent_log" .= consentLog, "marketo" .= marketo @@ -740,7 +739,7 @@ getConsentLog e = do -- TODO: This will be removed as soon as this is ported to another tool getUserData :: UserId -> Handler Response getUserData uid = do - account <- (listToMaybe <$> Intra.getUserProfiles (Left [uid])) >>= noSuchUser + account <- Intra.getUserProfiles (Left [uid]) >>= noSuchUser . listToMaybe conns <- Intra.getUserConnections uid convs <- Intra.getUserConversations uid clts <- Intra.getUserClients uid @@ -751,8 +750,8 @@ getUserData uid = do properties <- Intra.getUserProperties uid -- Get all info from Marketo too let em = userEmail $ accountUser account - marketo <- maybe (return noEmail) Intra.getMarketoResult em - return . json $ + marketo <- maybe (pure noEmail) Intra.getMarketoResult em + pure . json $ object [ "account" .= account, "cookies" .= cookies, @@ -786,7 +785,7 @@ groupByStatus conns = byStatus s = length . filter ((==) s . ucStatus) ifNothing :: Error -> Maybe a -> Handler a -ifNothing e = maybe (throwE e) return +ifNothing e = maybe (throwE e) pure noSuchUser :: Maybe a -> Handler a noSuchUser = ifNothing (mkError status404 "no-user" "No such user") diff --git a/tools/stern/src/Stern/App.hs b/tools/stern/src/Stern/App.hs index 1907faf80f..17bc07c726 100644 --- a/tools/stern/src/Stern/App.hs +++ b/tools/stern/src/Stern/App.hs @@ -71,11 +71,11 @@ 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 - <$> pure def - <*> Bilge.newManager (Bilge.defaultManagerSettings {Bilge.managerResponseTimeout = responseTimeoutMicro 10000000}) + Env (mkRequest $ O.brig o) (mkRequest $ O.galley o) (mkRequest $ O.gundeck o) (mkRequest $ O.ibis o) (mkRequest $ O.galeb o) l mt def + <$> newManager where mkRequest s = Bilge.host (encodeUtf8 (s ^. epHost)) . Bilge.port (s ^. epPort) $ Bilge.empty + newManager = Bilge.newManager (Bilge.defaultManagerSettings {Bilge.managerResponseTimeout = responseTimeoutMicro 10000000}) -- Monads newtype AppT m a = AppT (ReaderT Env m a) @@ -131,12 +131,12 @@ runHandler e r h k = do i <- reqId (lookupRequestId r) let e' = set requestId (Bilge.RequestId i) e a <- runAppT e' (runExceptT h) - either (onError (view applog e) r k) return a + either (onError (view applog e) r k) pure a where - reqId (Just i) = return i + reqId (Just i) = pure i reqId Nothing = do uuid <- UUID.nextRandom - return $ toByteString' $ "stern-" ++ toString uuid + pure $ toByteString' $ "stern-" ++ toString uuid onError :: Logger -> Request -> Continue IO -> Error -> IO ResponseReceived onError g r k e = do diff --git a/tools/stern/src/Stern/Intra.hs b/tools/stern/src/Stern/Intra.hs index 3b3df24fca..2c719c228f 100644 --- a/tools/stern/src/Stern/Intra.hs +++ b/tools/stern/src/Stern/Intra.hs @@ -155,7 +155,7 @@ getUserConnections uid = do let batch = clConnections userConnectionList if (not . null) batch && clHasMore userConnectionList then fetchAll (batch ++ xs) (Just . qUnqualified . ucTo $ last batch) - else return (batch ++ xs) + else pure (batch ++ xs) fetchBatch :: Maybe UserId -> Handler UserConnectionList fetchBatch start = do b <- view brig @@ -196,7 +196,7 @@ getUserProfiles :: Either [UserId] [Handle] -> Handler [UserAccount] getUserProfiles uidsOrHandles = do info $ msg "Getting user accounts" b <- view brig - return . concat =<< mapM (doRequest b) (prepareQS uidsOrHandles) + concat <$> mapM (doRequest b) (prepareQS uidsOrHandles) where doRequest :: Request -> (Request -> Request) -> Handler [UserAccount] doRequest b qry = do @@ -211,7 +211,7 @@ getUserProfiles uidsOrHandles = do . expect2xx ) parseResponse (mkError status502 "bad-upstream") r - prepareQS :: Either [UserId] [Handle] -> [(Request -> Request)] + 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] @@ -240,7 +240,7 @@ getEjpdInfo handles includeContacts = do info $ msg "Getting ejpd info on users by handle" b <- view brig let bdy :: Value - bdy = object ["ejpd_request" .= ((cs @_ @Text . toByteString') <$> handles)] + bdy = object ["ejpd_request" .= (cs @_ @Text . toByteString' <$> handles)] r <- catchRpcErrors $ rpc' @@ -301,7 +301,7 @@ deleteAccount uid = do setStatusBindingTeam :: TeamId -> Team.TeamStatus -> Handler () setStatusBindingTeam tid status = do - info $ msg ("Setting team status to " <> (cs $ encode status)) + info $ msg ("Setting team status to " <> cs (encode status)) g <- view galley void . catchRpcErrors $ rpc' @@ -380,7 +380,7 @@ getTeamInfo :: TeamId -> Handler TeamInfo getTeamInfo tid = do d <- getTeamData tid m <- getTeamMembers tid - return $ TeamInfo d (map TeamMemberInfo (m ^. teamMembers)) + pure $ TeamInfo d (map TeamMemberInfo (m ^. teamMembers)) getUserBindingTeam :: UserId -> Handler (Maybe TeamId) getUserBindingTeam u = do @@ -398,7 +398,7 @@ getUserBindingTeam u = do . expect2xx ) teams <- parseResponse (mkError status502 "bad-upstream") r - return $ + pure $ listToMaybe $ fmap (view teamId) $ filter ((== Binding) . view teamBinding) $ @@ -418,7 +418,7 @@ getInvoiceUrl tid iid = do . noRedirect . expectStatus (== 307) ) - return $ getHeader' "Location" r + pure $ getHeader' "Location" r getTeamBillingInfo :: TeamId -> Handler (Maybe TeamBillingInfo) getTeamBillingInfo tid = do @@ -434,7 +434,7 @@ getTeamBillingInfo tid = do ) case Bilge.statusCode r of 200 -> Just <$> parseResponse (mkError status502 "bad-upstream") r - 404 -> return Nothing + 404 -> pure Nothing _ -> throwE (mkError status502 "bad-upstream" "bad response") setTeamBillingInfo :: TeamId -> TeamBillingInfo -> Handler () @@ -466,8 +466,8 @@ isBlacklisted emailOrPhone = do . userKeyToParam emailOrPhone ) case Bilge.statusCode r of - 200 -> return True - 404 -> return False + 200 -> pure True + 404 -> pure False _ -> throwE (mkError status502 "bad-upstream" "bad response") setBlacklistStatus :: Bool -> Either Email Phone -> Handler () @@ -570,7 +570,7 @@ getSearchVisibility :: TeamId -> Handler TeamSearchVisibilityView getSearchVisibility tid = do info $ msg "Getting TeamSearchVisibilityView value" gly <- view galley - (>>= fromResponseBody) . catchRpcErrors $ + fromResponseBody <=< catchRpcErrors $ rpc' "galley" gly @@ -708,7 +708,7 @@ 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 - 404 -> return noEmail + 404 -> pure noEmail _ -> throwE (mkError status502 "bad-upstream" "") where noEmail = MarketoResult $ KeyMap.singleton "results" emptyArray @@ -752,9 +752,9 @@ getUserConversations uid = do fetchAll xs start = do userConversationList <- fetchBatch start let batch = convList userConversationList - if (not . null) batch && (convHasMore userConversationList) + if (not . null) batch && convHasMore userConversationList then fetchAll (batch ++ xs) (Just . qUnqualified . cnvQualifiedId $ last batch) - else return (batch ++ xs) + else pure (batch ++ xs) fetchBatch :: Maybe ConvId -> Handler (ConversationList Conversation) fetchBatch start = do b <- view galley @@ -808,7 +808,7 @@ getUserProperties uid = do keys <- parseResponse (mkError status502 "bad-upstream") r :: Handler [PropertyKey] UserProperties <$> fetchProperty b keys mempty where - fetchProperty _ [] acc = return acc + fetchProperty _ [] acc = pure acc fetchProperty b (x : xs) acc = do r <- catchRpcErrors $ @@ -832,9 +832,9 @@ getUserNotifications uid = do fetchAll xs start = do userNotificationList <- fetchBatch start let batch = view queuedNotifications userNotificationList - if (not . null) batch && (view queuedHasMore userNotificationList) - then fetchAll (batch ++ xs) (Just . (view queuedNotificationId) $ last batch) - else return (batch ++ xs) + if (not . null) batch && view queuedHasMore userNotificationList + then fetchAll (batch ++ xs) (Just . view queuedNotificationId $ last batch) + else pure (batch ++ xs) fetchBatch :: Maybe NotificationId -> Handler QueuedNotificationList fetchBatch start = do b <- view gundeck diff --git a/tools/stern/src/Stern/Options.hs b/tools/stern/src/Stern/Options.hs index 103d381a2c..f47f2bf518 100644 --- a/tools/stern/src/Stern/Options.hs +++ b/tools/stern/src/Stern/Options.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -- This file is part of the Wire Server implementation. -- diff --git a/tools/stern/src/Stern/Types.hs b/tools/stern/src/Stern/Types.hs index 063c4f63aa..9af0409b2b 100644 --- a/tools/stern/src/Stern/Types.hs +++ b/tools/stern/src/Stern/Types.hs @@ -76,7 +76,7 @@ isOwner :: TeamMember -> Bool isOwner m = hasPermission m SetBilling isAdmin :: TeamMember -> Bool -isAdmin m = (hasPermission m AddTeamMember) && not (hasPermission m SetBilling) +isAdmin m = hasPermission m AddTeamMember && not (hasPermission m SetBilling) instance ToJSON TeamInfo where toJSON (TeamInfo d m) =