diff --git a/CHANGELOG.md b/CHANGELOG.md index 2ca4a7fb4f5..e681a5bcddf 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,82 @@ -# [2026-03-24] (Chart Release 5.29.0) +# [2026-04-20] (Chart Release 5.30.0) + +## Release notes + +* Since 5.29 was broken and you should have skipped it, you are about to upgrade from 5.28 to 5.30 in one step. This has been tested and should work. Please consult the release notes from both 5.29 and 5.30 for changes w.r.t. 5.28. + +* `background-worker` now reuses `galley`'s configmap and secrets for cassandra, postgres and federation domain settings. This removes redundant settings and keeps the two services aligned. No operator action is strictly required; however, we advise removing the `background-worker` value overrides for galley's cassandra, postgres, and federation domain settings, as they are duplicated and no longer needed: + + - background-worker.config.cassandraGalley + - background-worker.config.postgresql + - background-worker.secrets.pgPassword + - background-worker.config.federationDomain (#5180) + +* Operators upgrading from the previous wire-server chart release, where the service charts were consolidated into the umbrella chart, must now set `tags.proxy` explicitly again. + + If your currently installed values no longer contain a `proxy` tag because of that consolidation, add one before upgrading to this release and set it to the intended state: + - `tags.proxy: true` to deploy the `proxy` chart + - `tags.proxy: false` to keep the `proxy` chart disabled (#5161) + +* The Restund helm chart and code stops being supported and shipped. If you have not already, please migrate to coturn which continues to be supported. (#5162) + + +## Features + + +* Send team.member-join to all apps in team. (#5187) + + +## Bug fixes and other updates + + +* Remove the Server response header value for entire API. (#5179) + +* Integration tests for user events when user type is app. Replace redundant app-created event with team.member-join. (#5139) + +* (Un-)suspend apps if en-/disabled in the team. (#5177) + +* Apps from outside own team do not appear in contact search. (#5173) + +* Fix: apps cannot form connections accross teams. Integration test for cross-team conversations working with apps as expected. (#5171) + +* Prevent password reset for SAML users (#5191) + +* Remove apps from conversations when apps are disabled in conversation. (#5176) + +* Fix: allow removal of bots from conversation after switching it to MLS. (#5186) + +* Hotfix: handle NULL in brig-cassandra:user.user_type. (#5193) + +* Fix bug where the mls-users tool would crash for users with null `supported_protocols` (#5190) + + +## Documentation + + +* Make schema-profunctor schema names derived and avoid name clashes between scopes. (#5151) + + +## Internal changes + + +* Propagate error from brig on stern API call `GET i/domain-registration/:domain` (#5179) + +* The status code for rate limit responses from nginz and cannon is now configurable and set to 420 per default (#5154) + +* Moved code from galley to ClientSubsystem (#5154, #5147, #5157, #5156, #5165, #5168) + +* The defaults in k8ssandra-test-cluster should now work for both a fresh cassandra 4.1 pod as well as an upgrade of an existing previous k8ssandra-test-cluster deployment. We assume k8ssandra-operator helm chart version 1.20.2. (#5091) + +* Use sbomnix to generate SBOMs for Nix-built Docker images and devShells. Adjust Helm chart values for inlined wire-server chart. (#5167) + +* Remove tom-bombadil SBOM creation targets from `Makefile`. There's a better approach to create SBOMs in place (in `Makefile` and CI). (#5181) + + +# ~~[2026-03-24] (Chart Release 5.29.0)~~ + + +## This release is broken. Please upgrade from 5.28 directly to 5.30! + ## Release notes diff --git a/Makefile b/Makefile index 49407d77299..e366edbb91e 100644 --- a/Makefile +++ b/Makefile @@ -7,7 +7,7 @@ DOCKER_TAG ?= $(USER) # default helm chart version must be 0.0.42 for local development (because 42 is the answer to the universe and everything) HELM_SEMVER ?= 0.0.42 # The list of helm charts needed on internal kubernetes testing environments -CHARTS_INTEGRATION := wire-server databases-ephemeral rabbitmq fake-aws ingress-nginx-controller nginx-ingress-services fluent-bit kibana restund k8ssandra-test-cluster wire-server-enterprise +CHARTS_INTEGRATION := wire-server databases-ephemeral rabbitmq fake-aws ingress-nginx-controller nginx-ingress-services fluent-bit kibana k8ssandra-test-cluster wire-server-enterprise # The list of helm charts to publish on S3 # FUTUREWORK: after we "inline local subcharts", # (e.g. move charts/brig to charts/wire-server/brig) @@ -17,7 +17,7 @@ CHARTS_RELEASE := wire-server redis-ephemeral rabbitmq rabbitmq-external databas fake-aws fake-aws-s3 fake-aws-sqs aws-ingress fluent-bit kibana backoffice \ calling-test demo-smtp elasticsearch-curator elasticsearch-external \ elasticsearch-ephemeral minio-external cassandra-external \ -ingress-nginx-controller nginx-ingress-services reaper restund \ +ingress-nginx-controller nginx-ingress-services reaper \ k8ssandra-test-cluster ldap-scim-bridge wire-server-enterprise KIND_CLUSTER_NAME := wire-server HELM_PARALLELISM ?= 1 # 1 for sequential tests; 6 for all-parallel tests @@ -699,22 +699,9 @@ diff-live-manifest: clean-charts charts-integration DIFF_OUTPUT_FILE="$(DIFF_OUTPUT_FILE)" ./hack/bin/diff-wire-server-manifests.sh "$(LIVE_MANIFEST_FILE)" /tmp/wire-server.yaml render-ci-manifest: clean-charts charts-integration - VALUES_FILE="$${VALUES_FILE:-$$(mktemp).yaml}"; \ - ./hack/bin/helm-render-ci-values.sh \ - ./hack/bin/render-manifest.sh "$$VALUES_FILE" - -sbom.json: - nix -Lv build '.#wireServer.bomDependencies' && \ - nix run 'github:wireapp/tom-bombadil#create-sbom' -- --root-package-name "wire-server" - -# Ask the security team for the `DEPENDENCY_TRACK_API_KEY` (if you need it) -.PHONY: upload-bombon -upload-bombon: sbom.json - nix run 'github:wireapp/tom-bombadil#upload-bom' -- \ - --project-name "wire-server" \ - --project-version $(HELM_SEMVER) \ - --auto-create \ - --bom-file ./sbom.json + VALUES_FILE="$${VALUES_FILE:-$$(mktemp).yaml}"; export VALUES_FILE; \ + ./hack/bin/helm-render-ci-values.sh && \ + ./hack/bin/render-manifest.sh "$$VALUES_FILE" # SBOM creation and uploading (Helm charts, Helmfile, docker-compose) # @@ -729,9 +716,9 @@ upload-bombon: sbom.json # Targets should be independently executable and creating a Nix env in a Nix # env doesn't play well. -# Generate all SBOMs (Helm + Docker Compose + Helmfile) +# Generate all SBOMs (Helm + Docker Compose + Helmfile + Nix Docker Images + Nix DevShell) .PHONY: sboms -sboms: sboms-helm sboms-docker-compose sboms-helmfile +sboms: sboms-helm sboms-docker-compose sboms-helmfile sboms-nix-docker-images sboms-nix-devshell # Generate SBOMs for Helm charts .PHONY: sboms-helm @@ -756,6 +743,26 @@ sboms-helmfile: .local/charts fi ./hack/bin/create-helmfile-sboms.sh tmp/sboms/helmfile $(HELM_SEMVER) +# Generate SBOMs for Nix-built Docker images using sbomnix +# This generates SBOMs from the Nix store paths of executables that go into Docker images +.PHONY: sboms-nix-docker-images +sboms-nix-docker-images: + @if [ "$(HELM_SEMVER)" = "0.0.42" ]; then \ + echo "Environment variable HELM_SEMVER not set to non-default value. Re-run with HELM_SEMVER="; \ + exit 1; \ + fi + ./hack/bin/create-nix-docker-image-sboms.sh tmp/sboms/nix-docker-images $(HELM_SEMVER) imagesUnoptimizedNoDocs + +# Generate SBOMs for Nix devShells using sbomnix +# This generates SBOMs from the Nix store paths of packages in the development environments +.PHONY: sboms-nix-devshell +sboms-nix-devshell: + @if [ "$(HELM_SEMVER)" = "0.0.42" ]; then \ + echo "Environment variable HELM_SEMVER not set to non-default value. Re-run with HELM_SEMVER="; \ + exit 1; \ + fi + ./hack/bin/create-nix-devshell-sbom.sh tmp/sboms/nix-devshell $(HELM_SEMVER) + # Validate all SBOM files using cyclonedx .PHONY: validate-sboms validate-sboms: diff --git a/README.md b/README.md index ffd0519e620..34d6b7c62c6 100644 --- a/README.md +++ b/README.md @@ -30,7 +30,6 @@ This repository contains the following source code: - **cannon**: WebSocket Push Notifications - **cargohold**: Asset (image, file, ...) Storage - **proxy**: 3rd Party API Integration - - **restund**: STUN/TURN server for use in Audio/Video calls - **spar**: Single-Sign-On (SSO) - **tools** diff --git a/cabal.project b/cabal.project index f35b3b95050..1cf1aa8ecbc 100644 --- a/cabal.project +++ b/cabal.project @@ -4,7 +4,6 @@ index-state: 2023-10-03T15:17:00Z packages: integration , libs/bilge/ - , libs/brig-types/ , libs/cargohold-types/ , libs/cassandra-util/ , libs/extended/ @@ -57,7 +56,6 @@ packages: , tools/db/repair-brig-clients-table/ , tools/db/service-backfill/ , tools/rabbitmq-consumer - , tools/rex/ , tools/stern/ , tools/mlsstats/ , tools/test-stats/ diff --git a/charts/k8ssandra-test-cluster/templates/check-cluster-job.yaml b/charts/k8ssandra-test-cluster/templates/check-cluster-job.yaml index 99739c53a3f..3c26ce37845 100644 --- a/charts/k8ssandra-test-cluster/templates/check-cluster-job.yaml +++ b/charts/k8ssandra-test-cluster/templates/check-cluster-job.yaml @@ -6,6 +6,10 @@ kind: Job metadata: name: check-cluster-job namespace: {{ .Release.Namespace }} + annotations: + "helm.sh/hook": post-install,post-upgrade + "helm.sh/hook-delete-policy": before-hook-creation,hook-succeeded + "helm.sh/hook-weight": "10" spec: template: spec: diff --git a/charts/k8ssandra-test-cluster/templates/k8ssandra-cluster.yaml b/charts/k8ssandra-test-cluster/templates/k8ssandra-cluster.yaml index 0d85eaac04b..6b7bddb97fc 100644 --- a/charts/k8ssandra-test-cluster/templates/k8ssandra-cluster.yaml +++ b/charts/k8ssandra-test-cluster/templates/k8ssandra-cluster.yaml @@ -7,6 +7,7 @@ spec: auth: false cassandra: serverVersion: "4.1.10" + serverImage: "docker.io/k8ssandra/cass-management-api:4.1.10-ubi" telemetry: prometheus: enabled: {{ .Values.prometheus.enabled }} @@ -30,6 +31,9 @@ spec: client_encryption_options: enabled: {{ .Values.client_encryption_options.enabled }} optional: {{ .Values.client_encryption_options.optional }} + server_encryption_options: + internode_encryption: none + datacenters: - metadata: name: datacenter-1 diff --git a/charts/k8ssandra-test-cluster/values.yaml b/charts/k8ssandra-test-cluster/values.yaml index 239dba3c21d..54a82b1f949 100644 --- a/charts/k8ssandra-test-cluster/values.yaml +++ b/charts/k8ssandra-test-cluster/values.yaml @@ -16,7 +16,7 @@ storageSize: 10G # https://cassandra.apache.org/doc/stable/cassandra/configuration/cass_yaml_file.html#client_encryption_options client_encryption_options: enabled: false - optional: true + optional: false # The password could be secured better. However, this chart is meant to be # used as test setup. And, protecting a self-signed certificate isn't very # useful. diff --git a/charts/nginx-ingress-services/templates/ingress.yaml b/charts/nginx-ingress-services/templates/ingress.yaml index acca141ae0c..7ae2f42dff9 100644 --- a/charts/nginx-ingress-services/templates/ingress.yaml +++ b/charts/nginx-ingress-services/templates/ingress.yaml @@ -4,7 +4,7 @@ metadata: name: {{ include "nginx-ingress-services.getIngressName" . | quote }} {{- if .Values.config.renderCSPInIngress }} annotations: - {{- if not (contains .Values.config.ingressClass "nginx") }} + {{- if not (hasPrefix "nginx" .Values.config.ingressClass) }} {{ fail "In ingress CSP header setting only works with a 'nginx' controller. (Rename it to 'nginx-*' if it is one.)" }} {{- end }} {{/* We need to add CSP headers here for webapp, team-settings and diff --git a/charts/proxy/.helmignore b/charts/proxy/.helmignore new file mode 100644 index 00000000000..f0c13194444 --- /dev/null +++ b/charts/proxy/.helmignore @@ -0,0 +1,21 @@ +# Patterns to ignore when building packages. +# This supports shell glob matching, relative path matching, and +# negation (prefixed with !). Only one pattern per line. +.DS_Store +# Common VCS dirs +.git/ +.gitignore +.bzr/ +.bzrignore +.hg/ +.hgignore +.svn/ +# Common backup files +*.swp +*.bak +*.tmp +*~ +# Various IDEs +.project +.idea/ +*.tmproj diff --git a/charts/proxy/Chart.yaml b/charts/proxy/Chart.yaml new file mode 100644 index 00000000000..04cb2a0b64c --- /dev/null +++ b/charts/proxy/Chart.yaml @@ -0,0 +1,4 @@ +apiVersion: v1 +description: Proxy (part of Wire Server) - 3rd party proxy service +name: proxy +version: 0.0.42 diff --git a/charts/proxy/templates/_helpers.tpl b/charts/proxy/templates/_helpers.tpl new file mode 100644 index 00000000000..af93ab9a720 --- /dev/null +++ b/charts/proxy/templates/_helpers.tpl @@ -0,0 +1,8 @@ +{{/* Allow KubeVersion to be overridden. */}} +{{- define "kubeVersion" -}} + {{- default .Capabilities.KubeVersion.Version .Values.kubeVersionOverride -}} +{{- end -}} + +{{- define "includeSecurityContext" -}} + {{- (semverCompare ">= 1.24-0" (include "kubeVersion" .)) -}} +{{- end -}} diff --git a/charts/proxy/templates/configmap.yaml b/charts/proxy/templates/configmap.yaml new file mode 100644 index 00000000000..1f07e080586 --- /dev/null +++ b/charts/proxy/templates/configmap.yaml @@ -0,0 +1,16 @@ +apiVersion: v1 +kind: ConfigMap +metadata: + name: "proxy" +data: + proxy.yaml: | + logFormat: {{ .Values.config.logFormat }} + logLevel: {{ .Values.config.logLevel }} + logNetStrings: {{ .Values.config.logNetStrings }} + disabledAPIVersions: {{ toJson .Values.config.disabledAPIVersions }} + proxy: + host: 0.0.0.0 + port: {{ .Values.service.internalPort }} + httpPoolSize: 1000 + maxConns: 5000 + secretsConfig: /etc/wire/proxy/secrets/proxy.config diff --git a/charts/wire-server/templates/proxy/deployment.yaml b/charts/proxy/templates/deployment.yaml similarity index 76% rename from charts/wire-server/templates/proxy/deployment.yaml rename to charts/proxy/templates/deployment.yaml index 430cd356af7..86e84b18178 100644 --- a/charts/wire-server/templates/proxy/deployment.yaml +++ b/charts/proxy/templates/deployment.yaml @@ -8,12 +8,12 @@ metadata: release: {{ .Release.Name }} heritage: {{ .Release.Service }} spec: - replicas: {{ .Values.proxy.replicaCount }} + replicas: {{ .Values.replicaCount }} strategy: type: RollingUpdate rollingUpdate: maxUnavailable: 0 - maxSurge: {{ .Values.proxy.replicaCount }} + maxSurge: {{ .Values.replicaCount }} selector: matchLabels: app: proxy @@ -24,8 +24,8 @@ spec: release: {{ .Release.Name }} annotations: # An annotation of the configmap checksum ensures changes to the configmap cause a redeployment upon `helm upgrade` - checksum/configmap: {{ include (print .Template.BasePath "/proxy/configmap.yaml") . | sha256sum }} - checksum/secret: {{ include (print .Template.BasePath "/proxy/secret.yaml") . | sha256sum }} + checksum/configmap: {{ include (print .Template.BasePath "/configmap.yaml") . | sha256sum }} + checksum/secret: {{ include (print .Template.BasePath "/secret.yaml") . | sha256sum }} spec: topologySpreadConstraints: - maxSkew: 1 @@ -43,11 +43,11 @@ spec: secretName: "proxy" containers: - name: proxy - image: "{{ .Values.proxy.image.repository }}:{{ .Values.proxy.image.tag }}" - imagePullPolicy: {{ default "" .Values.proxy.imagePullPolicy | quote }} + image: "{{ .Values.image.repository }}:{{ .Values.image.tag }}" + imagePullPolicy: {{ default "" .Values.imagePullPolicy | quote }} {{- if eq (include "includeSecurityContext" .) "true" }} securityContext: - {{- toYaml .Values.proxy.podSecurityContext | nindent 12 }} + {{- toYaml .Values.podSecurityContext | nindent 12 }} {{- end }} volumeMounts: - name: "proxy-secrets" @@ -55,7 +55,7 @@ spec: - name: "proxy-config" mountPath: "/etc/wire/proxy/conf" env: - {{- with .Values.proxy.config.proxy }} + {{- with .Values.config.proxy }} {{- if .httpProxy }} - name: http_proxy value: {{ .httpProxy | quote }} @@ -74,18 +74,18 @@ spec: - name: NO_PROXY value: {{ join "," .noProxyList | quote }} {{- end }} - {{- end }} + {{- end }} ports: - - containerPort: {{ .Values.proxy.service.internalPort }} + - containerPort: {{ .Values.service.internalPort }} livenessProbe: httpGet: scheme: HTTP path: /i/status - port: {{ .Values.proxy.service.internalPort }} + port: {{ .Values.service.internalPort }} readinessProbe: httpGet: scheme: HTTP path: /i/status - port: {{ .Values.proxy.service.internalPort }} + port: {{ .Values.service.internalPort }} resources: -{{ toYaml .Values.proxy.resources | indent 12 }} +{{ toYaml .Values.resources | indent 12 }} diff --git a/charts/wire-server/templates/proxy/poddisruptionbudget.yaml b/charts/proxy/templates/poddisruptionbudget.yaml similarity index 72% rename from charts/wire-server/templates/proxy/poddisruptionbudget.yaml rename to charts/proxy/templates/poddisruptionbudget.yaml index 614bb54b077..c828d0368dc 100644 --- a/charts/wire-server/templates/proxy/poddisruptionbudget.yaml +++ b/charts/proxy/templates/poddisruptionbudget.yaml @@ -1,4 +1,4 @@ -{{- if gt (int .Values.proxy.replicaCount) 1 }} +{{- if gt (int .Values.replicaCount) 1 }} apiVersion: policy/v1 kind: PodDisruptionBudget metadata: @@ -9,7 +9,7 @@ metadata: release: {{ .Release.Name }} heritage: {{ .Release.Service }} spec: - maxUnavailable: {{ sub (int .Values.proxy.replicaCount) 1 }} + maxUnavailable: {{ sub (int .Values.replicaCount) 1 }} selector: matchLabels: app: proxy diff --git a/charts/wire-server/templates/proxy/secret.yaml b/charts/proxy/templates/secret.yaml similarity index 75% rename from charts/wire-server/templates/proxy/secret.yaml rename to charts/proxy/templates/secret.yaml index defd1a01640..de452b7fca7 100644 --- a/charts/wire-server/templates/proxy/secret.yaml +++ b/charts/proxy/templates/secret.yaml @@ -9,4 +9,4 @@ metadata: heritage: "{{ .Release.Service }}" type: Opaque data: - proxy.config: {{ .Values.proxy.secrets.proxy_config | b64enc | quote }} + proxy.config: {{ .Values.secrets.proxy_config | b64enc | quote }} diff --git a/charts/wire-server/templates/proxy/service.yaml b/charts/proxy/templates/service.yaml similarity index 82% rename from charts/wire-server/templates/proxy/service.yaml rename to charts/proxy/templates/service.yaml index 4a4760460cd..478ad3d6a37 100644 --- a/charts/wire-server/templates/proxy/service.yaml +++ b/charts/proxy/templates/service.yaml @@ -17,8 +17,8 @@ spec: type: ClusterIP ports: - name: http - port: {{ .Values.proxy.service.externalPort }} - targetPort: {{ .Values.proxy.service.internalPort }} + port: {{ .Values.service.externalPort }} + targetPort: {{ .Values.service.internalPort }} selector: app: proxy release: {{ .Release.Name }} diff --git a/charts/wire-server/templates/proxy/servicemonitor.yaml b/charts/proxy/templates/servicemonitor.yaml similarity index 87% rename from charts/wire-server/templates/proxy/servicemonitor.yaml rename to charts/proxy/templates/servicemonitor.yaml index eedad5d1a4b..88120fe7cdb 100644 --- a/charts/wire-server/templates/proxy/servicemonitor.yaml +++ b/charts/proxy/templates/servicemonitor.yaml @@ -1,4 +1,4 @@ -{{- if .Values.proxy.metrics.serviceMonitor.enabled }} +{{- if .Values.metrics.serviceMonitor.enabled }} apiVersion: monitoring.coreos.com/v1 kind: ServiceMonitor metadata: diff --git a/charts/proxy/values.yaml b/charts/proxy/values.yaml new file mode 100644 index 00000000000..3173289cc8d --- /dev/null +++ b/charts/proxy/values.yaml @@ -0,0 +1,33 @@ +replicaCount: 3 +image: + repository: quay.io/wire/proxy + tag: do-not-use +service: + externalPort: 8080 + internalPort: 8080 +metrics: + serviceMonitor: + enabled: false +resources: + requests: + memory: "25Mi" + cpu: "50m" + limits: + memory: "50Mi" +config: + logLevel: Info + logFormat: StructuredJSON + logNetStrings: false + proxy: {} + # Disable one or more API versions. Please make sure the configuration value is the same in all these charts: + # brig, cannon, cargohold, galley, gundeck, proxy, spar. + disabledAPIVersions: [ development ] + +podSecurityContext: + allowPrivilegeEscalation: false + capabilities: + drop: + - ALL + runAsNonRoot: true + seccompProfile: + type: RuntimeDefault diff --git a/charts/restund/Chart.yaml b/charts/restund/Chart.yaml deleted file mode 100644 index 87cf4ae6f96..00000000000 --- a/charts/restund/Chart.yaml +++ /dev/null @@ -1,14 +0,0 @@ -apiVersion: v2 -name: restund -description: Restund - a modular STUN/TURN server -type: application - -# This is the chart version. This version number should be incremented each time you make changes -# to the chart and its templates, including the app version. -# Versions are expected to follow Semantic Versioning (https://semver.org/) -version: 0.1.0 - -# This is the version number of the application being deployed. This version number should be -# incremented each time you make changes to the application. Versions are not expected to -# follow Semantic Versioning. They should reflect the version the application is using. -appVersion: v0.6.0-rc.1 diff --git a/charts/restund/README.md b/charts/restund/README.md deleted file mode 100644 index 8af0d2d3446..00000000000 --- a/charts/restund/README.md +++ /dev/null @@ -1,14 +0,0 @@ -This chart deploys [Restund](https://docs.wire.com/understand/restund.html), a -STUN and TURN server. - -You need to supply the zrestSecret at key `secrets.zrestSecret`. Make sure this -matches `secrets.turn.secret` of the brig chart. - -Restund pods are deployed with `hostNetwork: true`, because restund needs to -listen on a wide range of udp ports. See `values.yaml` for additional tcp ports -that need to be exposed on the hosting node. - -The Restund server might also expose the internal network to which the hosting -node is connected to. It is therefore recommended to run restund on a separate -network (cluster) than the rest of wire's services. See -[details](https://docs.wire.com/understand/restund.html#network). diff --git a/charts/restund/templates/_helpers.tpl b/charts/restund/templates/_helpers.tpl deleted file mode 100644 index af75bb10977..00000000000 --- a/charts/restund/templates/_helpers.tpl +++ /dev/null @@ -1,51 +0,0 @@ -{{- define "restund.name" -}} -{{- default .Chart.Name .Values.nameOverride | trunc 63 | trimSuffix "-" }} -{{- end }} - -{{/* -Create chart name and version as used by the chart label. -*/}} -{{- define "restund.chart" -}} -{{- printf "%s-%s" .Chart.Name .Chart.Version | replace "+" "_" | trunc 63 | trimSuffix "-" }} -{{- end }} - -{{/* -Common labels -*/}} -{{- define "restund.labels" -}} -helm.sh/chart: {{ include "restund.chart" . }} -{{ include "restund.selectorLabels" . }} -{{- if .Chart.AppVersion }} -app.kubernetes.io/version: {{ .Values.image.tag | default .Chart.AppVersion | quote }} -{{- end }} -app.kubernetes.io/managed-by: {{ .Release.Service }} -{{- end }} - -{{/* -Create a default fully qualified app name. -We truncate at 63 chars because some Kubernetes name fields are limited to this (by the DNS naming spec). -If release name contains chart name it will be used as a full name. -*/}} -{{- define "restund.fullname" -}} -{{- if .Values.fullnameOverride }} -{{- .Values.fullnameOverride | trunc 63 | trimSuffix "-" }} -{{- else }} -{{- $name := default .Chart.Name .Values.nameOverride }} -{{- if contains $name .Release.Name }} -{{- .Release.Name | trunc 63 | trimSuffix "-" }} -{{- else }} -{{- printf "%s-%s" .Release.Name $name | trunc 63 | trimSuffix "-" }} -{{- end }} -{{- end }} -{{- end }} - -{{- define "restund.selectorLabels" -}} -app.kubernetes.io/name: {{ include "restund.name" . }} -app.kubernetes.io/instance: {{ .Release.Name }} -{{- end }} - -{{- define "restund.federateCAName" -}} -{{- $nameParts := list (include "restund.fullname" .) -}} -{{- $nameParts = append $nameParts "federate-ca-name" -}} -{{- join "-" $nameParts -}} -{{- end }} diff --git a/charts/restund/templates/ca-configmap.yaml b/charts/restund/templates/ca-configmap.yaml deleted file mode 100644 index 0e0dd8d5bed..00000000000 --- a/charts/restund/templates/ca-configmap.yaml +++ /dev/null @@ -1,9 +0,0 @@ -{{- if .Values.federate.dtls.enabled }} -apiVersion: v1 -kind: ConfigMap -metadata: - name: {{ include "restund.federateCAName" . }} -data: - CA: - {{ .Values.federate.dtls.ca | quote }} -{{- end }} diff --git a/charts/restund/templates/configmap-restund-conf-template.yaml b/charts/restund/templates/configmap-restund-conf-template.yaml deleted file mode 100644 index d65fbfc6930..00000000000 --- a/charts/restund/templates/configmap-restund-conf-template.yaml +++ /dev/null @@ -1,62 +0,0 @@ -apiVersion: v1 -kind: ConfigMap -metadata: - name: {{ include "restund.fullname" . }} - labels: - {{- include "restund.selectorLabels" . | nindent 4 }} - -data: - restund.conf.template: | - ## core - daemon no - debug no - realm dummy.io - syncinterval 600 - udp_listen ${RESTUND_HOST}:{{ .Values.restundUDPListenPort }} - udp_sockbuf_size 524288 - tcp_listen ${RESTUND_HOST}:{{ .Values.restundTCPListenPort }} - # tls_listen - - ## modules - module_path /usr/local/lib/restund/modules - module stat.so - module drain.so - module binding.so - module auth.so - module turn.so - module zrest.so - module status.so - - ## auth - auth_nonce_expiry 3600 - - ## turn - turn_max_allocations 64000 - turn_max_lifetime 3600 - turn_relay_addr ${RESTUND_HOST} - # # turn_public_addr is an IP which must be reachable for UDP traffic from other restund servers (and from this server itself). If unset, defaults to 'turn_relay_addr' - # turn_public_addr - - # syslog - syslog_facility 24 - - ## status - status_http_addr ${POD_IP} - status_http_port {{ .Values.restundHTTPStatusPort }} - # status_udp_addr - # status_udp_port - - # zrest - zrest_listen ${POD_IP} - zrest_secret ${ZREST_SECRET} - -{{- if .Values.federate.enabled }} - # federate - federate_listen ${RESTUND_HOST} - federate_port {{ .Values.federate.port }} - federate_type dtls -{{- if .Values.federate.dtls.enabled }} - federate_certfile /home/restund/federate-cert+key.pem - federate_cafile /home/restund/federate-ca-certs.pem -{{- end }} -{{- end }} diff --git a/charts/restund/templates/secret-or-certificate.yaml b/charts/restund/templates/secret-or-certificate.yaml deleted file mode 100644 index 4e2914013dc..00000000000 --- a/charts/restund/templates/secret-or-certificate.yaml +++ /dev/null @@ -1,41 +0,0 @@ -{{- if .Values.federate.dtls.enabled -}} - -{{- if .Values.federate.dtls.tls.issuerRef -}} -{{- if or .Values.federate.dtls.tls.key .Values.federate.dtls.tls.crt }} -{{- fail "issuerRef and {crt,key} are mutually exclusive" -}} -{{- end -}} -apiVersion: cert-manager.io/v1 -kind: Certificate -metadata: - name: "{{ include "restund.fullname" . }}" - labels: - {{- include "restund.labels" . | nindent 4 }} - {{- if .Values.federate.dtls.tls.certificate.labels }} - {{- toYaml .Values.federate.dtls.tls.certificate.labels | nindent 4}} - {{- end }} -spec: - dnsNames: - {{- toYaml .Values.federate.dtls.tls.certificate.dnsNames | nindent 4 }} - secretName: restund-certificate - issuerRef: - {{- toYaml .Values.federate.dtls.tls.issuerRef | nindent 4 }} - privateKey: - rotationPolicy: Always - algorithm: ECDSA - size: 384 -{{- else if and .Values.federate.dtls.tls.key .Values.federate.dtls.tls.crt }} -apiVersion: v1 -kind: Secret -metadata: - name: restund-certificate - labels: - {{- include "restund.labels" . | nindent 4 }} -type: Opaque -data: - tls.key: {{ .Values.federate.dtls.tls.key | b64enc }} - tls.crt: {{ .Values.federate.dtls.tls.crt | b64enc }} -{{- else -}} -{{- fail "must specify tls.key and tls.crt , or tls.issuerRef" -}} -{{- end -}} - -{{- end -}} diff --git a/charts/restund/templates/secret.yaml b/charts/restund/templates/secret.yaml deleted file mode 100644 index f5652f9dacc..00000000000 --- a/charts/restund/templates/secret.yaml +++ /dev/null @@ -1,11 +0,0 @@ -apiVersion: v1 -kind: Secret -metadata: - name: restund - labels: - chart: {{ .Chart.Name }}-{{ .Chart.Version | replace "+" "_" }} - release: "{{ .Release.Name }}" - heritage: "{{ .Release.Service }}" -type: Opaque -data: - zrest_secret.txt: {{ .Values.secrets.zrestSecret | b64enc | quote }} diff --git a/charts/restund/templates/service-account.yaml b/charts/restund/templates/service-account.yaml deleted file mode 100644 index 1708744dd63..00000000000 --- a/charts/restund/templates/service-account.yaml +++ /dev/null @@ -1,33 +0,0 @@ ---- -apiVersion: v1 -kind: ServiceAccount -metadata: - name: {{ include "restund.fullname" . }} - labels: - {{- include "restund.labels" . | nindent 4 }} ---- -apiVersion: rbac.authorization.k8s.io/v1 -kind: ClusterRole -metadata: - name: {{ include "restund.fullname" . }} - labels: - {{- include "restund.labels" . | nindent 4 }} -rules: - - apiGroups: [""] - resources: [nodes] - verbs: [get] ---- -apiVersion: rbac.authorization.k8s.io/v1 -kind: ClusterRoleBinding -metadata: - name: {{ include "restund.fullname" . }} - labels: - {{- include "restund.labels" . | nindent 4 }} -roleRef: - kind: ClusterRole - apiGroup: rbac.authorization.k8s.io - name: {{ include "restund.fullname" . }} -subjects: - - kind: ServiceAccount - name: {{ include "restund.fullname" . }} - namespace: {{ .Release.Namespace }} diff --git a/charts/restund/templates/service.yaml b/charts/restund/templates/service.yaml deleted file mode 100644 index d5f0a7b9409..00000000000 --- a/charts/restund/templates/service.yaml +++ /dev/null @@ -1,20 +0,0 @@ ---- -apiVersion: v1 -kind: Service -metadata: - name: {{ include "restund.fullname" . }} - labels: - {{- include "restund.labels" . | nindent 4 }} -spec: - # Needs to be headless - # See: https://kubernetes.io/docs/concepts/workloads/controllers/statefulset/ - clusterIP: None - ports: - - name: restund-tcp - port: 3478 - targetPort: restund-tcp - - name: sft-config - port: 8000 - targetPort: sft-config - selector: - {{- include "restund.selectorLabels" . | nindent 4 }} diff --git a/charts/restund/templates/statefulset.yaml b/charts/restund/templates/statefulset.yaml deleted file mode 100644 index 8ae1b05f76a..00000000000 --- a/charts/restund/templates/statefulset.yaml +++ /dev/null @@ -1,163 +0,0 @@ -apiVersion: apps/v1 -kind: StatefulSet -metadata: - name: {{ include "restund.fullname" . }} - labels: - {{- include "restund.labels" . | nindent 4 }} - -spec: - replicas: {{ .Values.replicaCount }} - - # Allows restund to start up and shut down in parallel when scaling up and down. - # However this does not affect upgrades. - podManagementPolicy: Parallel - - serviceName: {{ include "restund.fullname" . }} - selector: - matchLabels: - {{- include "restund.selectorLabels" . | nindent 6 }} - template: - metadata: - {{- with .Values.podAnnotations }} - annotations: - {{- toYaml . | nindent 8 }} - {{- end }} - - labels: - {{- include "restund.selectorLabels" . | nindent 8 }} - spec: - topologySpreadConstraints: - - maxSkew: 1 - topologyKey: "kubernetes.io/hostname" - whenUnsatisfiable: ScheduleAnyway - labelSelector: - matchLabels: - {{- include "restund.selectorLabels" . | nindent 6 }} - securityContext: - {{- toYaml .Values.podSecurityContext | nindent 8 }} - hostNetwork: true - serviceAccountName: {{ include "restund.fullname" . }} - volumes: - - name: external-ip - emptyDir: {} - - name: restund-config-template - configMap: - name: {{ include "restund.fullname" . }} - - name: secrets - secret: - secretName: restund -{{- if .Values.federate.dtls.enabled }} - - name: restund-certificate - secret: - secretName: restund-certificate - - name: ca-certs - configMap: - name: {{ include "restund.federateCAName" . }} -{{- end }} - initContainers: - - name: get-external-ip - image: {{ .Values.kubectlImage.registry }}/{{ .Values.kubectlImage.repository }}:{{ .Values.kubectlImage.tag }} - volumeMounts: - - name: external-ip - mountPath: /external-ip - env: - - name: NODE_NAME - valueFrom: - fieldRef: - fieldPath: spec.nodeName - command: - - /bin/sh - - -c - - | - set -e - - # In the cloud, this setting is available to indicate the true IP address - addr=$(kubectl get node $NODE_NAME -ojsonpath='{.status.addresses[?(@.type=="ExternalIP")].address}') - - # On on-prem we allow people to set "wire.com/external-ip" to override this - if [ -z "$addr" ]; then - addr=$(kubectl get node $NODE_NAME -ojsonpath='{.metadata.annotations.wire\.com/external-ip}') - fi - echo -n "$addr" | tee /dev/stderr > /external-ip/ip - containers: - - name: {{ .Chart.Name }} - {{- if .Values.image.digest }} - image: "{{ .Values.image.repository }}@{{ .Values.image.digest }}" - {{- else }} - image: "{{ .Values.image.repository }}:{{ .Values.image.tag | default .Chart.AppVersion }}" - {{- end }} - imagePullPolicy: {{ .Values.image.pullPolicy }} - env: - - name: POD_IP - valueFrom: - fieldRef: - fieldPath: status.podIP - - name: POD_NAME - valueFrom: - fieldRef: - fieldPath: metadata.name - volumeMounts: - - name: external-ip - mountPath: /external-ip - - name: restund-config-template - mountPath: /restund-template/restund.conf.template - subPath: restund.conf.template - - name: secrets - mountPath: /secrets/ - readOnly: true -{{- if .Values.federate.dtls.enabled }} - - name: ca-certs - mountPath: /ca-certs - - name: restund-certificate - mountPath: restund-certificate -{{- end }} - command: - - /bin/sh - - -c - - | - set -e - EXTERNAL_IP=$(cat /external-ip/ip) - export RESTUND_HOST="$EXTERNAL_IP" - export ZREST_SECRET="$(cat /secrets/zrest_secret.txt)" -{{- if .Values.federate.dtls.enabled }} - cat /restund-certificate/tls.crt /restund-certificate/tls.key > /home/restund/federate-cert+key.pem - cp /ca-certs/CA /home/restund/federate-ca-certs.pem -{{- end }} - envsubst '$RESTUND_HOST $POD_IP $ZREST_SECRET' < /restund-template/restund.conf.template > /home/restund/restund.conf - exec /usr/local/sbin/restund -n -f /home/restund/restund.conf - - ports: - - name: restund-tcp - containerPort: 3478 - protocol: TCP - - name: sft-config - containerPort: 8000 - protocol: TCP - - name: status-http - containerPort: {{ .Values.restundHTTPStatusPort }} - protocol: TCP - - livenessProbe: - httpGet: - path: / - port: status-http - - readinessProbe: - httpGet: - path: / - port: status-http - - resources: - {{- toYaml .Values.resources | nindent 12 }} - {{- with .Values.nodeSelector }} - nodeSelector: - {{- toYaml . | nindent 8 }} - {{- end }} - {{- with .Values.affinity }} - affinity: - {{- toYaml . | nindent 8 }} - {{- end }} - {{- with .Values.tolerations }} - tolerations: - {{- toYaml . | nindent 8 }} - {{- end }} diff --git a/charts/restund/values.yaml b/charts/restund/values.yaml deleted file mode 100644 index e45c63670c2..00000000000 --- a/charts/restund/values.yaml +++ /dev/null @@ -1,74 +0,0 @@ -# The amount of Restund instances to run. NOTE: Only one Restund can run per node due -# to `hostNetwork`. If this number is higher than the amount of nodes that can -# be used for scheduling (Also see `nodeSelector`) pods will remain in a -# pending state untill you add more capacity. -replicaCount: 1 - -image: - repository: quay.io/wire/restund - pullPolicy: Always - # overwrite the tag here, otherwise `appVersion` of the chart will be used - tag: "" - -kubectlImage: - # Use a kubectl image that includes a shell (sh/bash). Distroless images will fail to exec the script. - registry: docker.io - repository: bitnamilegacy/kubectl - tag: 1.32.4 - -# If you have multiple deployments of Restund running in one cluster, it is -# important that they run on disjoint sets of nodes, you can use nodeSelector to enforce this -nodeSelector: {} - -podSecurityContext: - fsGroup: 31337 - -securityContext: - # Pick a high number that is unlikely to conflict with the host - # https://kubesec.io/basics/containers-securitycontext-runasuser/ - runAsUser: 31337 - -restundUDPListenPort: 3478 -restundTCPListenPort: 3478 -restundUDPStatusPort: 33000 -restundHTTPStatusPort: 8080 -restundMetricsListenPort: 8443 - -federate: - enabled: false - port: 9191 - - dtls: - enabled: true - - tls: - # Example: - # - # tls: - # key: "-----BEGIN EC PRIVATE KEY----- ..." # (ascii blob) private key - # crt: "-----BEGIN CERTIFICATE----- ..." # (ascii blob) certificate - # - # OR (mutually exclusive) - # - # tls: - # issuerRef: - # name: letsencrypt-http01 - # - # # We can reference ClusterIssuers by changing the kind here. - # # The default value is Issuer (i.e. a locally namespaced Issuer) - # # kind: Issuer - # kind: Issuer - # - # # This is optional since cert-manager will default to this value however - # # if you are using an external issuer, change this to that issuer group. - # group: cert-manager.io - # - # # optional labels to attach to the cert-manager Certificate - # certificate: - # labels: .. - # - # host: # public hostname for which the certificate is created for. - # - ca: # list of trusted CA certificates (concatenated list of PEMs) - # example: - # ca: "-----BEGIN CERTIFICATE-----" diff --git a/charts/wire-server/requirements.yaml b/charts/wire-server/requirements.yaml index 9b130743d70..fc10d8fa195 100644 --- a/charts/wire-server/requirements.yaml +++ b/charts/wire-server/requirements.yaml @@ -22,6 +22,13 @@ dependencies: - backoffice - haskellServices - services +- name: proxy + version: "0.0.42" + repository: "file://../proxy" + tags: + - proxy + - haskellServices + - services - name: nginz version: "0.0.42" repository: "file://../nginz" diff --git a/charts/wire-server/templates/_helpers.tpl b/charts/wire-server/templates/_helpers.tpl index 0cd6d5ede53..5edb0251456 100644 --- a/charts/wire-server/templates/_helpers.tpl +++ b/charts/wire-server/templates/_helpers.tpl @@ -39,14 +39,6 @@ {{- end -}} {{- end -}} -{{- define "galleyTlsSecretRef" -}} -{{- if and .cassandraGalley .cassandraGalley.tlsCaSecretRef -}} -{{ .cassandraGalley.tlsCaSecretRef | toYaml }} -{{- else }} -{{- dict "name" "background-worker-cassandra-galley" "key" "ca.pem" | toYaml -}} -{{- end -}} -{{- end -}} - {{/* BRIG */}} {{- define "brig.tlsSecretRef" -}} {{- if .cassandra.tlsCaSecretRef -}} diff --git a/charts/wire-server/templates/background-worker/cassandra-secret.yaml b/charts/wire-server/templates/background-worker/cassandra-secret.yaml index 8db998467ed..9066de03d37 100644 --- a/charts/wire-server/templates/background-worker/cassandra-secret.yaml +++ b/charts/wire-server/templates/background-worker/cassandra-secret.yaml @@ -29,18 +29,3 @@ type: Opaque data: ca.pem: {{ $backgroundWorker.config.cassandraBrig.tlsCa | b64enc | quote }} {{- end }} -{{- if and $backgroundWorker.config.cassandraGalley (not (empty $backgroundWorker.config.cassandraGalley.tlsCa)) }} ---- -apiVersion: v1 -kind: Secret -metadata: - name: background-worker-cassandra-galley - labels: - app: background-worker - chart: {{ .Chart.Name }}-{{ .Chart.Version | replace "+" "_" }} - release: "{{ .Release.Name }}" - heritage: "{{ .Release.Service }}" -type: Opaque -data: - ca.pem: {{ $backgroundWorker.config.cassandraGalley.tlsCa | b64enc | quote }} -{{- end }} diff --git a/charts/wire-server/templates/background-worker/configmap.yaml b/charts/wire-server/templates/background-worker/configmap.yaml index 49c0c3d38d7..7c8ef9aee43 100644 --- a/charts/wire-server/templates/background-worker/configmap.yaml +++ b/charts/wire-server/templates/background-worker/configmap.yaml @@ -36,6 +36,8 @@ data: host: {{ .spar.host }} port: {{ .spar.port }} + postgresqlPool: {{ toYaml .postgresqlPool | nindent 6 }} + cassandra: endpoint: host: {{ .cassandra.host }} @@ -62,28 +64,6 @@ data: {{- end }} {{- end }} - {{- if .cassandraGalley }} - cassandraGalley: - endpoint: - host: {{ .cassandraGalley.host }} - port: 9042 - keyspace: galley - {{- if hasKey .cassandraGalley "filterNodesByDatacentre" }} - filterNodesByDatacentre: {{ .cassandraGalley.filterNodesByDatacentre }} - {{- end }} - {{- if eq (include "useCassandraTLS" .cassandraGalley) "true" }} - tlsCa: /etc/wire/background-worker/cassandra-galley/{{- (include "galleyTlsSecretRef" . | fromYaml).key }} - {{- end }} - {{- end }} - - postgresql: {{ toYaml .postgresql | nindent 6 }} - postgresqlPool: {{ toYaml .postgresqlPool | nindent 6 }} - {{- if hasKey $backgroundWorker.secrets "pgPassword" }} - postgresqlPassword: /etc/wire/background-worker/secrets/pgPassword - {{- end }} - - federationDomain: {{ $backgroundWorker.config.federationDomain }} - {{- with .rabbitmq }} rabbitmq: host: {{ .host }} @@ -95,8 +75,8 @@ data: {{- end }} enableTls: {{ .enableTls }} insecureSkipVerifyTls: {{ .insecureSkipVerifyTls }} - {{- if .tlsCaSecretRef }} - caCert: /etc/wire/background-worker/rabbitmq-ca/{{ .tlsCaSecretRef.key }} + {{- if $.Values.galley.config.rabbitmq.tlsCaSecretRef }} + caCert: /etc/wire/galley/rabbitmq-ca/{{ $.Values.galley.config.rabbitmq.tlsCaSecretRef.key }} {{- end }} {{- end }} diff --git a/charts/wire-server/templates/background-worker/deployment.yaml b/charts/wire-server/templates/background-worker/deployment.yaml index 31ee47b1e55..e2f6ef5250e 100644 --- a/charts/wire-server/templates/background-worker/deployment.yaml +++ b/charts/wire-server/templates/background-worker/deployment.yaml @@ -26,8 +26,10 @@ spec: annotations: # An annotation of the configmap checksum ensures changes to the configmap cause a redeployment upon `helm upgrade` checksum/configmap: {{ include (print .Template.BasePath "/background-worker/configmap.yaml") . | sha256sum }} + checksum/galley-configmap: {{ include (print .Template.BasePath "/galley/configmap.yaml") . | sha256sum }} checksum/secret: {{ include (print .Template.BasePath "/background-worker/secret.yaml") . | sha256sum }} checksum/cassandra-secret: {{ include (print .Template.BasePath "/background-worker/cassandra-secret.yaml") . | sha256sum }} + checksum/galley-secret: {{ include (print .Template.BasePath "/galley/secret.yaml") . | sha256sum }} fluentbit.io/parser: json spec: serviceAccount: null @@ -37,9 +39,15 @@ spec: - name: "background-worker-config" configMap: name: "background-worker" + - name: "galley-config" + configMap: + name: "galley" - name: "background-worker-secrets" secret: secretName: "background-worker" + - name: "galley-secrets" + secret: + secretName: "galley" {{- if eq (include "useCassandraTLS" $backgroundWorker.config.cassandra) "true" }} - name: "background-worker-cassandra-gundeck" secret: @@ -50,15 +58,15 @@ spec: secret: secretName: {{ (include "brigTlsSecretRef" $backgroundWorker.config | fromYaml).name }} {{- end }} - {{- if eq (include "useCassandraTLS" $backgroundWorker.config.cassandraGalley) "true" }} - - name: "background-worker-cassandra-galley" + {{- if eq (include "useCassandraTLS" .Values.galley.config.cassandra) "true" }} + - name: "galley-cassandra" secret: - secretName: {{ (include "galleyTlsSecretRef" $backgroundWorker.config | fromYaml).name }} + secretName: {{ (include "galley.tlsSecretRef" .Values.galley.config | fromYaml).name }} {{- end }} - {{- if $backgroundWorker.config.rabbitmq.tlsCaSecretRef }} - - name: "rabbitmq-ca" + {{- if .Values.galley.config.rabbitmq.tlsCaSecretRef }} + - name: "galley-rabbitmq-ca" secret: - secretName: {{ $backgroundWorker.config.rabbitmq.tlsCaSecretRef.name }} + secretName: {{ .Values.galley.config.rabbitmq.tlsCaSecretRef.name }} {{- end }} {{- if .Values.additionalVolumes }} {{ toYaml .Values.additionalVolumes | nindent 8 }} @@ -74,8 +82,12 @@ spec: volumeMounts: - name: "background-worker-secrets" mountPath: "/etc/wire/background-worker/secrets" + - name: "galley-secrets" + mountPath: "/etc/wire/galley/secrets" - name: "background-worker-config" mountPath: "/etc/wire/background-worker/conf" + - name: "galley-config" + mountPath: "/etc/wire/galley/conf" {{- if eq (include "useCassandraTLS" $backgroundWorker.config.cassandra) "true" }} - name: "background-worker-cassandra-gundeck" mountPath: "/etc/wire/background-worker/cassandra-gundeck" @@ -84,13 +96,13 @@ spec: - name: "background-worker-cassandra-brig" mountPath: "/etc/wire/background-worker/cassandra-brig" {{- end }} - {{- if eq (include "useCassandraTLS" $backgroundWorker.config.cassandraGalley) "true" }} - - name: "background-worker-cassandra-galley" - mountPath: "/etc/wire/background-worker/cassandra-galley" + {{- if eq (include "useCassandraTLS" .Values.galley.config.cassandra) "true" }} + - name: "galley-cassandra" + mountPath: "/etc/wire/galley/cassandra" {{- end }} - {{- if $backgroundWorker.config.rabbitmq.tlsCaSecretRef }} - - name: "rabbitmq-ca" - mountPath: "/etc/wire/background-worker/rabbitmq-ca/" + {{- if .Values.galley.config.rabbitmq.tlsCaSecretRef }} + - name: "galley-rabbitmq-ca" + mountPath: "/etc/wire/galley/rabbitmq-ca/" {{- end }} {{- if .Values.additionalVolumeMounts }} {{ toYaml .Values.additionalVolumeMounts | nindent 10 }} diff --git a/charts/wire-server/templates/background-worker/secret.yaml b/charts/wire-server/templates/background-worker/secret.yaml index 4fc5271160b..1efb48f2cfa 100644 --- a/charts/wire-server/templates/background-worker/secret.yaml +++ b/charts/wire-server/templates/background-worker/secret.yaml @@ -16,7 +16,4 @@ data: {{- with $backgroundWorker.secrets }} rabbitmqUsername: {{ .rabbitmq.username | b64enc | quote }} rabbitmqPassword: {{ .rabbitmq.password | b64enc | quote }} - {{- if .pgPassword }} - pgPassword: {{ .pgPassword | b64enc | quote }} - {{- end }} {{- end }} diff --git a/charts/wire-server/templates/proxy/configmap.yaml b/charts/wire-server/templates/proxy/configmap.yaml deleted file mode 100644 index 4ee4424b35e..00000000000 --- a/charts/wire-server/templates/proxy/configmap.yaml +++ /dev/null @@ -1,16 +0,0 @@ -apiVersion: v1 -kind: ConfigMap -metadata: - name: "proxy" -data: - proxy.yaml: | - logFormat: {{ .Values.proxy.config.logFormat }} - logLevel: {{ .Values.proxy.config.logLevel }} - logNetStrings: {{ .Values.proxy.config.logNetStrings }} - disabledAPIVersions: {{ toJson .Values.proxy.config.disabledAPIVersions }} - proxy: - host: 0.0.0.0 - port: {{ .Values.proxy.service.internalPort }} - httpPoolSize: 1000 - maxConns: 5000 - secretsConfig: /etc/wire/proxy/secrets/proxy.config diff --git a/charts/wire-server/values.yaml b/charts/wire-server/values.yaml index 5b6f0c99b0e..77dd4b6953d 100644 --- a/charts/wire-server/values.yaml +++ b/charts/wire-server/values.yaml @@ -11,6 +11,7 @@ tags: backoffice: false mlsstats: false integration: false + proxy: false galley: replicaCount: 3 @@ -663,43 +664,6 @@ cannon: # effect: "NoSchedule" tolerations: [] -proxy: - replicaCount: 3 - image: - repository: quay.io/wire/proxy - tag: do-not-use - service: - externalPort: 8080 - internalPort: 8080 - imagePullPolicy: "" - metrics: - serviceMonitor: - enabled: false - resources: - requests: - memory: "25Mi" - cpu: "50m" - limits: - memory: "50Mi" - config: - logLevel: Info - logFormat: StructuredJSON - logNetStrings: false - proxy: {} - # Disable one ore more API versions. Please make sure the configuration value is the same in all these charts: - # brig, cannon, cargohold, galley, gundeck, proxy, spar. - disabledAPIVersions: [development] - - podSecurityContext: - allowPrivilegeEscalation: false - capabilities: - drop: - - ALL - runAsNonRoot: true - seccompProfile: - type: RuntimeDefault - secrets: {} - gundeck: replicaCount: 3 image: @@ -968,34 +932,13 @@ background-worker: adminPort: 15672 enableTls: false insecureSkipVerifyTls: false - # tlsCaSecretRef: - # name: - # key: + # Cassandra clusters used by background-worker cassandra: host: aws-cassandra - cassandraGalley: - host: aws-cassandra cassandraBrig: host: aws-cassandra - # Postgres connection settings - # - # Values are described in https://www.postgresql.org/docs/17/libpq-connect.html#LIBPQ-PARAMKEYWORDS - # To set the password via a brig secret see `secrets.pgPassword`. - # - # `additionalVolumeMounts` and `additionalVolumes` can be used to mount - # additional files (e.g. certificates) into the brig container. This way - # does not work for password files (parameter `passfile`), because - # libpq-connect requires access rights (mask 0600) for them that we cannot - # provide for random uids. - # - # Below is an example configuration we're using for our CI tests. - postgresql: - host: postgresql # DNS name without protocol - port: "5432" - user: wire-server - dbname: wire-server postgresqlPool: size: 5 acquisitionTimeout: 10s @@ -1042,7 +985,6 @@ background-worker: secrets: {} - # pgPassword: podSecurityContext: allowPrivilegeEscalation: false diff --git a/docs/src/how-to/install/sft.md b/docs/src/how-to/install/sft.md index 1432d76da68..a2d18cb7a23 100644 --- a/docs/src/how-to/install/sft.md +++ b/docs/src/how-to/install/sft.md @@ -82,10 +82,10 @@ For more advanced setups please refer to the [technical documentation](https://g The SFT allocates media addresses in the UDP [default port range](../../understand/notes/port-ranges.md#port-ranges). Ingress and egress traffic should be allowed for this range. Furthermore the SFT needs to be -able to reach the [Restund server](../../understand/restund.md#understand-restund), as it uses STUN and TURN in cases the client +able to reach the Coturn (or previously [Restund server](../../understand/restund.md#understand-restund)), as it uses STUN and TURN in cases the client can not directly connect to the SFT. In practise this means the SFT should allow ingress and egress traffic on the UDP [default port range](../../understand/notes/port-ranges.md#port-ranges) from and -to both, clients and [Restund servers](../../understand/restund.md#understand-restund). +to both, clients and Coturn (or previously [Restund servers](../../understand/restund.md#understand-restund)). *For more information on this port range, how to read and change it, and how to configure your firewall, please see* [this note](../../understand/notes/port-ranges.md#port-ranges). diff --git a/docs/src/how-to/install/troubleshooting.md b/docs/src/how-to/install/troubleshooting.md index aacf3e9cbab..ecb0ffb636a 100644 --- a/docs/src/how-to/install/troubleshooting.md +++ b/docs/src/how-to/install/troubleshooting.md @@ -433,8 +433,8 @@ From your own computer (not from the Wire backend), test that you can reach all * `nginz-https.` * `nginz-ssl.` * `sftd.` -* `restund01.` -* `restund02.` +* `turn01.` +* `turn02.` * `federator.` Some domains (such as the federator) might not apply to your setup. Refer to the domains you configured during installation, and act accordingly. diff --git a/flake.lock b/flake.lock index 0d4742fa79f..cc0609b71f2 100644 --- a/flake.lock +++ b/flake.lock @@ -68,6 +68,55 @@ "type": "github" } }, + "flake-compat": { + "flake": false, + "locked": { + "lastModified": 1746162366, + "narHash": "sha256-5SSSZ/oQkwfcAz/o/6TlejlVGqeK08wyREBQ5qFFPhM=", + "owner": "nix-community", + "repo": "flake-compat", + "rev": "0f158086a2ecdbb138cd0429410e44994f1b7e4b", + "type": "github" + }, + "original": { + "owner": "nix-community", + "repo": "flake-compat", + "type": "github" + } + }, + "flake-parts": { + "inputs": { + "nixpkgs-lib": "nixpkgs-lib" + }, + "locked": { + "lastModified": 1756770412, + "narHash": "sha256-+uWLQZccFHwqpGqr2Yt5VsW/PbeJVTn9Dk6SHWhNRPw=", + "owner": "hercules-ci", + "repo": "flake-parts", + "rev": "4524271976b625a4a605beefd893f270620fd751", + "type": "github" + }, + "original": { + "owner": "hercules-ci", + "repo": "flake-parts", + "type": "github" + } + }, + "flake-root": { + "locked": { + "lastModified": 1723604017, + "narHash": "sha256-rBtQ8gg+Dn4Sx/s+pvjdq3CB2wQNzx9XGFq/JVGCB6k=", + "owner": "srid", + "repo": "flake-root", + "rev": "b759a56851e10cb13f6b8e5698af7b59c44be26e", + "type": "github" + }, + "original": { + "owner": "srid", + "repo": "flake-root", + "type": "github" + } + }, "flake-utils": { "inputs": { "systems": "systems" @@ -86,6 +135,54 @@ "type": "github" } }, + "git-hooks-nix": { + "inputs": { + "flake-compat": [ + "sbomnix", + "flake-compat" + ], + "gitignore": "gitignore", + "nixpkgs": [ + "sbomnix", + "nixpkgs" + ] + }, + "locked": { + "lastModified": 1757239681, + "narHash": "sha256-E9spYi9lxm2f1zWQLQ7xQt8Xs2nWgr1T4QM7ZjLFphM=", + "owner": "cachix", + "repo": "git-hooks.nix", + "rev": "ab82ab08d6bf74085bd328de2a8722c12d97bd9d", + "type": "github" + }, + "original": { + "owner": "cachix", + "repo": "git-hooks.nix", + "type": "github" + } + }, + "gitignore": { + "inputs": { + "nixpkgs": [ + "sbomnix", + "git-hooks-nix", + "nixpkgs" + ] + }, + "locked": { + "lastModified": 1709087332, + "narHash": "sha256-HG2cCnktfHsKV0s4XW83gU3F57gaTljL9KNSuG6bnQs=", + "owner": "hercules-ci", + "repo": "gitignore.nix", + "rev": "637db329424fd7e46cf4185293b9cc8c88c95394", + "type": "github" + }, + "original": { + "owner": "hercules-ci", + "repo": "gitignore.nix", + "type": "github" + } + }, "hedis": { "flake": false, "locked": { @@ -153,6 +250,21 @@ "type": "github" } }, + "nixpkgs-lib": { + "locked": { + "lastModified": 1754788789, + "narHash": "sha256-x2rJ+Ovzq0sCMpgfgGaaqgBSwY+LST+WbZ6TytnT9Rk=", + "owner": "nix-community", + "repo": "nixpkgs.lib", + "rev": "a73b9c743612e4244d865a2fdee11865283c04e6", + "type": "github" + }, + "original": { + "owner": "nix-community", + "repo": "nixpkgs.lib", + "type": "github" + } + }, "nixpkgs-unstable": { "locked": { "lastModified": 1772963539, @@ -216,6 +328,7 @@ "nixpkgs-unstable": "nixpkgs-unstable", "nixpkgs_24_11": "nixpkgs_24_11", "postie": "postie", + "sbomnix": "sbomnix", "servant-openapi3": "servant-openapi3", "tasty": "tasty", "tasty-ant-xml": "tasty-ant-xml", @@ -225,6 +338,32 @@ "wai-predicates": "wai-predicates" } }, + "sbomnix": { + "inputs": { + "flake-compat": "flake-compat", + "flake-parts": "flake-parts", + "flake-root": "flake-root", + "git-hooks-nix": "git-hooks-nix", + "nixpkgs": [ + "nixpkgs" + ], + "treefmt-nix": "treefmt-nix" + }, + "locked": { + "lastModified": 1760339225, + "narHash": "sha256-pYZax5cxBHa+jcxTsQKEVHhXMtmvLGD1ISUyli2ZreU=", + "owner": "tiiuae", + "repo": "sbomnix", + "rev": "fe2a608c000127092b3d27c9cfd65c26f325bb28", + "type": "github" + }, + "original": { + "owner": "tiiuae", + "ref": "v1.7.4", + "repo": "sbomnix", + "type": "github" + } + }, "servant-openapi3": { "flake": false, "locked": { @@ -348,6 +487,27 @@ "type": "github" } }, + "treefmt-nix": { + "inputs": { + "nixpkgs": [ + "sbomnix", + "nixpkgs" + ] + }, + "locked": { + "lastModified": 1756662192, + "narHash": "sha256-F1oFfV51AE259I85av+MAia221XwMHCOtZCMcZLK2Jk=", + "owner": "numtide", + "repo": "treefmt-nix", + "rev": "1aabc6c05ccbcbf4a635fb7a90400e44282f61c4", + "type": "github" + }, + "original": { + "owner": "numtide", + "repo": "treefmt-nix", + "type": "github" + } + }, "wai-predicates": { "flake": false, "locked": { diff --git a/flake.nix b/flake.nix index 0819c0d85dc..1b65360f4a1 100644 --- a/flake.nix +++ b/flake.nix @@ -12,6 +12,10 @@ inputs.nixpkgs.follows = "nixpkgs"; inputs.flake-utils.follows = "flake-utils"; }; + sbomnix = { + url = "github:tiiuae/sbomnix/v1.7.4"; + inputs.nixpkgs.follows = "nixpkgs"; + }; bloodhound = { url = "github:wireapp/bloodhound?ref=wire-fork"; @@ -83,7 +87,7 @@ }; }; - outputs = inputs@{ nixpkgs, nixpkgs_24_11, nixpkgs-unstable, flake-utils, tom-bombadil, ... }: + outputs = inputs@{ nixpkgs, nixpkgs_24_11, nixpkgs-unstable, flake-utils, tom-bombadil, sbomnix, ... }: flake-utils.lib.eachDefaultSystem (system: let pkgs = import nixpkgs { @@ -134,6 +138,7 @@ pkgs_unstable.syft pkgs.kubernetes-helm pkgs.helmfile + sbomnix.packages.${system}.default ] ++ pkgs.lib.optionals pkgs.stdenv.isLinux [ # Linux-only container tools pkgs.skopeo diff --git a/hack/bin/create-helm-sboms.sh b/hack/bin/create-helm-sboms.sh index c113d78e038..c9493b07826 100755 --- a/hack/bin/create-helm-sboms.sh +++ b/hack/bin/create-helm-sboms.sh @@ -33,10 +33,36 @@ extract_images_from_chart() { fi # Template the chart and extract image references - # We use a dummy release name and set a global placeholder to be more lenient + # For wire-server and wire-server-enterprise, provide minimal values to pass required checks # (we don't want to check the Helm chart, only extract its images) local output - output=$(helm template test-release "$chart_path" --set-string 'global.placeholder=placeholder' 2>/dev/null) || true + if [[ "$chart_name" == "wire-server" ]]; then + local tmpval + tmpval=$(mktemp --suffix=.yaml) + cat > "$tmpval" <<'EOF' +nginz: {secrets: {zAuth: {publicKeys: placeholder}, basicAuth: placeholder}} +brig: + secrets: {zAuth: {privateKeys: placeholder, publicKeys: placeholder}, turn: {secret: placeholder}, rabbitmq: {username: placeholder, password: placeholder}} + config: + aws: {sesQueue: placeholder} + externalUrls: {nginz: 'https://placeholder'} +cargohold: {secrets: {placeholder: placeholder}} +background-worker: {secrets: {rabbitmq: {username: placeholder, password: placeholder}}} +proxy: {secrets: {proxy_config: placeholder}} +cannon: {secrets: {rabbitmq: {username: placeholder, password: placeholder}}} +gundeck: {secrets: {rabbitmq: {username: placeholder, password: placeholder}}} +cassandra-migrations: {cassandra: {host: placeholder}} +elasticsearch-index: {elasticsearch: {host: placeholder}, cassandra: {host: placeholder}} +spar: {config: {appUri: 'https://placeholder', ssoUri: 'https://placeholder', contacts: [placeholder]}} +galley: {config: {settings: {conversationCodeURI: 'https://placeholder'}}, secrets: {rabbitmq: {username: placeholder, password: placeholder}}} +EOF + output=$(helm template test-release "$chart_path" -f "$tmpval") + rm -f "$tmpval" + elif [[ "$chart_name" == "wire-server-enterprise" ]]; then + output=$(helm template test-release "$chart_path" --set 'secrets.placeholder=placeholder') + else + output=$(helm template test-release "$chart_path") + fi # Extract image values from the output using yq (jq wrapper) # Recursively find all .image fields in objects and output unique values diff --git a/hack/bin/create-nix-devshell-sbom.sh b/hack/bin/create-nix-devshell-sbom.sh new file mode 100755 index 00000000000..0750caf5c23 --- /dev/null +++ b/hack/bin/create-nix-devshell-sbom.sh @@ -0,0 +1,152 @@ +#!/usr/bin/env bash + +set -euo pipefail + +# Find git repository root to ensure paths work regardless of where script is executed +GIT_ROOT="$(git rev-parse --show-toplevel)" + +OUTPUT_DIR_BASE="${1:-.}" +VERSION="${2:-}" + +if [[ -z "$VERSION" ]]; then + echo "Usage: $0 " + echo " output-dir-base: Base directory to write SBOM files" + echo " Will create subdirectories: runtime/ and buildtime/" + echo " version: Version to use for SBOMs (e.g., 5.28.22)" + exit 1 +fi + +# Create separate directories for runtime and buildtime SBOMs +OUTPUT_DIR_RUNTIME="$OUTPUT_DIR_BASE/runtime" +OUTPUT_DIR_BUILDTIME="$OUTPUT_DIR_BASE/buildtime" +mkdir -p "$OUTPUT_DIR_RUNTIME" "$OUTPUT_DIR_BUILDTIME" + +# Get current git commit hash for linking to source +GIT_COMMIT=$(git rev-parse HEAD) + +# Get system architecture for the flake reference +SYSTEM=$(nix eval --impure --raw --expr 'builtins.currentSystem') + +# Track errors during processing +error_count=0 + +# Function to generate SBOM with metadata and convert it +# Parameters: flake_ref, output_file, component_name, purl, sbom_type +# sbom_type must be either "runtime" or "buildtime" +# Uses global variables: VERSION, GIT_COMMIT +generate_sbom() { + local flake_ref="$1" + local output_file="$2" + local component_name="$3" + local purl="$4" + local sbom_type="$5" + + # Validate sbom_type parameter + if [[ "$sbom_type" != "runtime" && "$sbom_type" != "buildtime" ]]; then + echo " ERROR: Invalid sbom_type '$sbom_type'. Must be 'runtime' or 'buildtime'" >&2 + return 1 + fi + + echo " Generating $sbom_type SBOM..." + + # Build sbomnix command with buildtime flag if needed + local sbomnix_cmd="sbomnix \"$flake_ref\" --verbose 1" + [[ "$sbom_type" == "buildtime" ]] && sbomnix_cmd="$sbomnix_cmd --buildtime" + sbomnix_cmd="$sbomnix_cmd --cdx=\"$output_file\"" + + if ! eval "$sbomnix_cmd" 2>&1; then + echo " ERROR: sbomnix ($sbom_type) failed" >&2 + return 1 + fi + + # Add metadata and convert to v1.6 + if [[ -f "$output_file" ]]; then + local temp_file="${output_file}.tmp" + local source_url="https://github.com/wireapp/wire-server/tree/${GIT_COMMIT}" + + # Remove invalid CPEs (those with empty version fields) and add our metadata + jq --arg component_name "$component_name" \ + --arg purl "$purl" \ + --arg source_url "$source_url" \ + --arg version "$VERSION" \ + '# Remove CPE from metadata.component if it has empty version (::) + if .metadata.component.cpe and (.metadata.component.cpe | contains("::")) then + .metadata.component |= del(.cpe) + else . end | + # Add our metadata + .metadata.component.name = $component_name | + .metadata.component.version = $version | + .metadata.component.purl = $purl | + .metadata.component.externalReferences += [ + {"type": "vcs", "url": $source_url, "comment": "Source repository"} + ]' \ + "$output_file" > "$temp_file" + mv "$temp_file" "$output_file" + + # Convert to CycloneDX 1.6 + if cyclonedx convert --input-file "$output_file" --output-file "$temp_file" --output-format json --output-version v1_6; then + mv "$temp_file" "$output_file" + echo " ✓ $sbom_type SBOM created: $output_file" + return 0 + else + echo " ERROR: CycloneDX conversion failed for $sbom_type SBOM" >&2 + return 1 + fi + fi + + return 1 +} + +echo "Generating SBOMs for Nix devShells..." +echo "Version: $VERSION" +echo "System: $SYSTEM" +echo "Output directory (runtime): $OUTPUT_DIR_RUNTIME" +echo "Output directory (buildtime): $OUTPUT_DIR_BUILDTIME" +echo "" + +# Get list of devShell names from the devShells attrset +echo "Discovering devShells..." +mapfile -t devshell_names < <(nix --extra-experimental-features 'nix-command flakes' eval "$GIT_ROOT#devShells.${SYSTEM}" --apply 'shells: builtins.concatStringsSep "\n" (builtins.attrNames shells)' --raw 2>&1 | grep -v warning) + +echo "Found ${#devshell_names[@]} devShells to process" +echo "" + +# Process each devShell +for devshell_name in "${devshell_names[@]}"; do + # Skip empty lines + [[ -z "$devshell_name" ]] && continue + + echo "Processing devShell: $devshell_name" + + # Create flake reference for the devShell + flake_ref="$GIT_ROOT#devShells.${SYSTEM}.${devshell_name}" + echo " Flake reference: $flake_ref" + + # Create component metadata + component_name="wire-server-devshell-${devshell_name}" + purl="pkg:nix/wire-server/${devshell_name}@${VERSION}" + + # Generate runtime-only SBOM + runtime_output_file="$OUTPUT_DIR_RUNTIME/sbom-nix-devshell-${devshell_name}.${VERSION}.cyclonedx.json" + if ! generate_sbom "$flake_ref" "$runtime_output_file" "$component_name" "$purl" "runtime"; then + ((error_count++)) + fi + + # Generate buildtime SBOM (includes build dependencies) + buildtime_output_file="$OUTPUT_DIR_BUILDTIME/sbom-nix-devshell-${devshell_name}.${VERSION}.cyclonedx.json" + if ! generate_sbom "$flake_ref" "$buildtime_output_file" "$component_name" "$purl" "buildtime"; then + ((error_count++)) + fi + + echo "" +done + +echo "SBOM generation complete." +echo "Runtime SBOMs: $OUTPUT_DIR_RUNTIME" +echo "Buildtime SBOMs: $OUTPUT_DIR_BUILDTIME" +echo "Total devShells processed: ${#devshell_names[@]}" + +if [[ $error_count -gt 0 ]]; then + echo "WARNING: $error_count error(s) occurred during SBOM generation" >&2 + exit 1 +fi diff --git a/hack/bin/create-nix-docker-image-sboms.sh b/hack/bin/create-nix-docker-image-sboms.sh new file mode 100755 index 00000000000..1c65218e170 --- /dev/null +++ b/hack/bin/create-nix-docker-image-sboms.sh @@ -0,0 +1,156 @@ +#!/usr/bin/env bash + +set -euo pipefail + +# Find git repository root to ensure paths work regardless of where script is executed +GIT_ROOT="$(git rev-parse --show-toplevel)" + +OUTPUT_DIR_BASE="${1:-.}" +VERSION="${2:-}" +IMAGES_ATTR="${3:-imagesNoDocs}" + +if [[ -z "$VERSION" ]]; then + echo "Usage: $0 [images-attr]" + echo " output-dir-base: Base directory to write SBOM files" + echo " Will create subdirectories: runtime/ and buildtime/" + echo " version: Version to use for SBOMs (e.g., 5.28.22)" + echo " images-attr: Nix attribute for images (default: imagesNoDocs)" + echo "" + echo "Available image attributes:" + echo " - imagesNoDocs (production images, optimized)" + echo " - imagesUnoptimizedNoDocs (dev images, faster builds)" + echo " - images (full images with docs)" + exit 1 +fi + +# Create separate directories for runtime and buildtime SBOMs +OUTPUT_DIR_RUNTIME="$OUTPUT_DIR_BASE/runtime" +OUTPUT_DIR_BUILDTIME="$OUTPUT_DIR_BASE/buildtime" +mkdir -p "$OUTPUT_DIR_RUNTIME" "$OUTPUT_DIR_BUILDTIME" + +# Get current git commit hash for linking to source +GIT_COMMIT=$(git rev-parse HEAD) + +# Track errors during processing +error_count=0 + +# Function to generate SBOM with metadata and conversion +# Parameters: flake_ref, output_file, docker_image, oci_purl, sbom_type +# sbom_type must be either "runtime" or "buildtime" +# Uses global variables: VERSION, GIT_COMMIT +generate_sbom() { + local flake_ref="$1" + local output_file="$2" + local docker_image="$3" + local oci_purl="$4" + local sbom_type="$5" + + # Validate sbom_type parameter + if [[ "$sbom_type" != "runtime" && "$sbom_type" != "buildtime" ]]; then + echo " ERROR: Invalid sbom_type '$sbom_type'. Must be 'runtime' or 'buildtime'" >&2 + return 1 + fi + + echo " Generating $sbom_type SBOM..." + + # Build sbomnix command with buildtime flag if needed + local sbomnix_cmd="sbomnix \"$flake_ref\" --verbose 1" + [[ "$sbom_type" == "buildtime" ]] && sbomnix_cmd="$sbomnix_cmd --buildtime" + sbomnix_cmd="$sbomnix_cmd --cdx=\"$output_file\"" + + if ! eval "$sbomnix_cmd" 2>&1; then + echo " ERROR: sbomnix ($sbom_type) failed" >&2 + return 1 + fi + + # Add metadata and convert to v1.6 + if [[ -f "$output_file" ]]; then + local temp_file="${output_file}.tmp" + local source_url="https://github.com/wireapp/wire-server/tree/${GIT_COMMIT}" + + # Remove invalid CPEs (those with empty version fields) and add our metadata + jq --arg docker_image "$docker_image" \ + --arg oci_purl "$oci_purl" \ + --arg source_url "$source_url" \ + --arg version "$VERSION" \ + '# Remove CPE from metadata.component if it has empty version (::) + if .metadata.component.cpe and (.metadata.component.cpe | contains("::")) then + .metadata.component |= del(.cpe) + else . end | + # Add our metadata + .metadata.component.version = $version | + .metadata.component.purl = $oci_purl | + .metadata.component.externalReferences += [ + {"type": "distribution", "url": ("docker://" + $docker_image), "comment": "Docker image"}, + {"type": "vcs", "url": $source_url, "comment": "Source repository"} + ]' \ + "$output_file" > "$temp_file" + mv "$temp_file" "$output_file" + + # Convert to CycloneDX 1.6 + if cyclonedx convert --input-file "$output_file" --output-file "$temp_file" --output-format json --output-version v1_6; then + mv "$temp_file" "$output_file" + echo " ✓ $sbom_type SBOM created: $output_file" + return 0 + else + echo " ERROR: CycloneDX conversion failed for $sbom_type SBOM" >&2 + return 1 + fi + fi + + return 1 +} + +echo "Generating SBOMs for Nix-built Docker images..." +echo "Images attribute: $IMAGES_ATTR" +echo "Version: $VERSION" +echo "Output directory (runtime): $OUTPUT_DIR_RUNTIME" +echo "Output directory (buildtime): $OUTPUT_DIR_BUILDTIME" +echo "" + +# Get list of image names from the imagesNoDocs attrset (excluding 'all') +echo "Discovering images from $IMAGES_ATTR..." +mapfile -t image_names < <(nix --extra-experimental-features 'nix-command flakes' eval "$GIT_ROOT#wireServer.${IMAGES_ATTR}" --apply 'images: builtins.concatStringsSep "\n" (builtins.filter (name: name != "all") (builtins.attrNames images))' --raw 2>&1 | grep -v warning) + +echo "Found ${#image_names[@]} images to process" +echo "" + +# Process each image +for image_name in "${image_names[@]}"; do + # Skip empty lines + [[ -z "$image_name" ]] && continue + + echo "Processing image: $image_name" + + # Create flake reference for the image + flake_ref="$GIT_ROOT#wireServer.${IMAGES_ATTR}.${image_name}" + echo " Flake reference: $flake_ref" + + # Create docker image reference and metadata + docker_image="quay.io/wire/${image_name}:${VERSION}" + oci_purl="pkg:oci/wire-${image_name}@${VERSION}?repository_url=quay.io/wire" + + # Generate runtime-only SBOM + runtime_output_file="$OUTPUT_DIR_RUNTIME/sbom-nix-docker-${image_name}.${VERSION}.cyclonedx.json" + if ! generate_sbom "$flake_ref" "$runtime_output_file" "$docker_image" "$oci_purl" "runtime"; then + ((error_count++)) + fi + + # Generate buildtime SBOM (includes build dependencies) + buildtime_output_file="$OUTPUT_DIR_BUILDTIME/sbom-nix-docker-${image_name}.${VERSION}.cyclonedx.json" + if ! generate_sbom "$flake_ref" "$buildtime_output_file" "$docker_image" "$oci_purl" "buildtime"; then + ((error_count++)) + fi + + echo "" +done + +echo "SBOM generation complete." +echo "Runtime SBOMs: $OUTPUT_DIR_RUNTIME" +echo "Buildtime SBOMs: $OUTPUT_DIR_BUILDTIME" +echo "Total images processed: ${#image_names[@]}" + +if [[ $error_count -gt 0 ]]; then + echo "WARNING: $error_count error(s) occurred during SBOM generation" >&2 + exit 1 +fi diff --git a/hack/bin/generate-clients.sh b/hack/bin/generate-clients.sh new file mode 100755 index 00000000000..0cfef722690 --- /dev/null +++ b/hack/bin/generate-clients.sh @@ -0,0 +1,53 @@ +#!/usr/bin/env bash +set -euo pipefail + +# Simple OpenAPI client generator using openapi-generator +# Usage: ./generate-clients.sh + +SWAGGER_URL="${1:-https://staging-nginz-https.zinfra.io/v16/api/swagger.json}" +OUTPUT_DIR="$(pwd)/generated" + +echo "==> Generating clients from: $SWAGGER_URL" +echo "==> Output directory: $OUTPUT_DIR" + +# Clean up previous runs +rm -rf "$OUTPUT_DIR" +mkdir -p "$OUTPUT_DIR" + +# Download the spec +echo "==> Downloading OpenAPI spec..." +curl -s "$SWAGGER_URL" > "$OUTPUT_DIR/swagger.json" + +# Check if docker is available +if ! command -v docker &> /dev/null; then + echo "Error: docker is not installed. Please install docker to use openapi-generator." + echo "Alternative: install openapi-generator-cli via npm: npm install -g @openapitools/openapi-generator-cli" + exit 1 +fi + +# Generate TypeScript client +echo "" +echo "==> Generating TypeScript client..." +docker run --rm \ + -v "$OUTPUT_DIR:/local" \ + openapitools/openapi-generator-cli:latest generate \ + -i /local/swagger.json \ + -g typescript-axios \ + -o /local/typescript \ + --additional-properties=supportsES6=true,npmName=wire-api-client,npmVersion=1.0.0 + +# Generate Kotlin client +echo "" +echo "==> Generating Kotlin client..." +docker run --rm \ + -v "$OUTPUT_DIR:/local" \ + openapitools/openapi-generator-cli:latest generate \ + -i /local/swagger.json \ + -g kotlin \ + -o /local/kotlin \ + --additional-properties=packageName=com.wire.api.client,serializationLibrary=gson + +echo "" +echo "==> Done! Generated clients:" +echo " TypeScript: $OUTPUT_DIR/typescript" +echo " Kotlin: $OUTPUT_DIR/kotlin" diff --git a/hack/bin/set-wire-server-image-version.sh b/hack/bin/set-wire-server-image-version.sh index 8530336d574..98ecf4f30af 100755 --- a/hack/bin/set-wire-server-image-version.sh +++ b/hack/bin/set-wire-server-image-version.sh @@ -6,7 +6,7 @@ target_version=${1?$USAGE} TOP_LEVEL="$( cd "$( dirname "${BASH_SOURCE[0]}" )/../.." && pwd )" CHARTS_DIR="$TOP_LEVEL/.local/charts" -charts=(cassandra-migrations elasticsearch-index federator backoffice integration wire-server-enterprise) +charts=(proxy cassandra-migrations elasticsearch-index federator backoffice integration wire-server-enterprise) for chart in "${charts[@]}"; do values_file="$CHARTS_DIR/$chart/values.yaml" @@ -18,5 +18,5 @@ done # special case nginz sed -i "s/^ tag: .*/ tag: $target_version/g" "$CHARTS_DIR/nginz/values.yaml" -# Brig, Galley, Cargohold, BackgroundWorker, Cannon, Proxy, Gundeck, and Spar are inlined into the umbrella chart. +# Brig, Galley, Cargohold, BackgroundWorker, Cannon, Gundeck, and Spar are inlined into the umbrella chart. sed -i "s/^ tag: .*/ tag: $target_version/g" "$CHARTS_DIR/wire-server/values.yaml" diff --git a/hack/bin/upload-all-sboms.sh b/hack/bin/upload-all-sboms.sh index 524b8fb190c..74e56273153 100755 --- a/hack/bin/upload-all-sboms.sh +++ b/hack/bin/upload-all-sboms.sh @@ -28,21 +28,85 @@ SBOMS_DIR="$GIT_ROOT/tmp/sboms" SCRIPT_DIR="$(dirname "$0")" -echo "Uploading Helm SBOMs..." -find "$SBOMS_DIR/helm" -name '*.json' -type f -not -path '*/.oci-cache/*' 2>/dev/null | while read -r sbom; do - chart_purl=$(jq -r '.metadata.component.externalReferences[] | select(.comment == "Helm chart") | .url' "$sbom") - chart_name=$(echo "$chart_purl" | sed 's|pkg:helm/||' | cut -d'@' -f1) - "$SCRIPT_DIR/upload-sbom.sh" "$sbom" "Helm charts" "$PROJECT_NAME" "$VERSION" "$chart_name" || exit 1 -done - -echo "Uploading Helmfile SBOMs..." -find "$SBOMS_DIR/helmfile" -name '*.json' -type f -not -path '*/.oci-cache/*' 2>/dev/null | while read -r sbom; do - "$SCRIPT_DIR/upload-sbom.sh" "$sbom" helmfile "$PROJECT_NAME" "$VERSION" || exit 1 -done - -echo "Uploading Docker Compose SBOMs..." -find "$SBOMS_DIR/docker-compose" -name '*.json' -type f -not -path '*/.oci-cache/*' 2>/dev/null | while read -r sbom; do - "$SCRIPT_DIR/upload-sbom.sh" "$sbom" docker-compose "$PROJECT_NAME" "$VERSION" || exit 1 -done +if [[ -d "$SBOMS_DIR/helm" ]]; then + echo "Uploading Helm SBOMs..." + find "$SBOMS_DIR/helm" -name '*.json' -type f -not -path '*/.oci-cache/*' 2>/dev/null | while read -r sbom; do + chart_purl=$(jq -r '.metadata.component.externalReferences[] | select(.comment == "Helm chart") | .url' "$sbom") + chart_name=$(echo "$chart_purl" | sed 's|pkg:helm/||' | cut -d'@' -f1) + "$SCRIPT_DIR/upload-sbom.sh" "$sbom" "Helm charts" "$PROJECT_NAME" "$VERSION" "$chart_name" || exit 1 + done +else + echo "Skipping Helm SBOMs (directory not found)" +fi + +if [[ -d "$SBOMS_DIR/helmfile" ]]; then + echo "Uploading Helmfile SBOMs..." + find "$SBOMS_DIR/helmfile" -name '*.json' -type f -not -path '*/.oci-cache/*' 2>/dev/null | while read -r sbom; do + "$SCRIPT_DIR/upload-sbom.sh" "$sbom" helmfile "$PROJECT_NAME" "$VERSION" || exit 1 + done +else + echo "Skipping Helmfile SBOMs (directory not found)" +fi + +if [[ -d "$SBOMS_DIR/docker-compose" ]]; then + echo "Uploading Docker Compose SBOMs..." + find "$SBOMS_DIR/docker-compose" -name '*.json' -type f -not -path '*/.oci-cache/*' 2>/dev/null | while read -r sbom; do + "$SCRIPT_DIR/upload-sbom.sh" "$sbom" docker-compose "$PROJECT_NAME" "$VERSION" || exit 1 + done +else + echo "Skipping Docker Compose SBOMs (directory not found)" +fi + +if [[ -d "$SBOMS_DIR/nix-docker-images/runtime" ]]; then + echo "Uploading Nix Docker Images SBOMs (runtime dependencies)..." + find "$SBOMS_DIR/nix-docker-images/runtime" -name '*.json' -type f 2>/dev/null | while read -r sbom; do + # Extract image name from filename: sbom-nix-docker-{name}.{version}.cyclonedx.json + image_name=$(basename "$sbom" | sed 's/sbom-nix-docker-//' | sed 's/\.[0-9].*//' | sed 's/\.cyclonedx\.json$//') + # Add [runtime] to make project name unique + project_prefix="$image_name [runtime]" + "$SCRIPT_DIR/upload-sbom.sh" "$sbom" "nix-docker-runtime" "$PROJECT_NAME" "$VERSION" "$project_prefix" || exit 1 + done +else + echo "Skipping Nix Docker Images SBOMs (runtime) (directory not found)" +fi + +if [[ -d "$SBOMS_DIR/nix-docker-images/buildtime" ]]; then + echo "Uploading Nix Docker Images SBOMs (buildtime dependencies)..." + find "$SBOMS_DIR/nix-docker-images/buildtime" -name '*.json' -type f 2>/dev/null | while read -r sbom; do + # Extract image name from filename: sbom-nix-docker-{name}.{version}.cyclonedx.json + image_name=$(basename "$sbom" | sed 's/sbom-nix-docker-//' | sed 's/\.[0-9].*//' | sed 's/\.cyclonedx\.json$//') + # Add [buildtime] to make project name unique + project_prefix="$image_name [buildtime]" + "$SCRIPT_DIR/upload-sbom.sh" "$sbom" "nix-docker-buildtime" "$PROJECT_NAME" "$VERSION" "$project_prefix" || exit 1 + done +else + echo "Skipping Nix Docker Images SBOMs (buildtime) (directory not found)" +fi + +if [[ -d "$SBOMS_DIR/nix-devshell/runtime" ]]; then + echo "Uploading Nix devShell SBOMs (runtime dependencies)..." + find "$SBOMS_DIR/nix-devshell/runtime" -name '*.json' -type f 2>/dev/null | while read -r sbom; do + # Extract devShell name from filename: sbom-nix-devshell-{name}.{version}.cyclonedx.json + devshell_name=$(basename "$sbom" | sed 's/sbom-nix-devshell-//' | sed 's/\.[0-9].*//' | sed 's/\.cyclonedx\.json$//') + # Add [runtime] to make project name unique + project_prefix="devshell-$devshell_name [runtime]" + "$SCRIPT_DIR/upload-sbom.sh" "$sbom" "nix-devshell-runtime" "$PROJECT_NAME" "$VERSION" "$project_prefix" || exit 1 + done +else + echo "Skipping Nix devShell SBOMs (runtime) (directory not found)" +fi + +if [[ -d "$SBOMS_DIR/nix-devshell/buildtime" ]]; then + echo "Uploading Nix devShell SBOMs (buildtime dependencies)..." + find "$SBOMS_DIR/nix-devshell/buildtime" -name '*.json' -type f 2>/dev/null | while read -r sbom; do + # Extract devShell name from filename: sbom-nix-devshell-{name}.{version}.cyclonedx.json + devshell_name=$(basename "$sbom" | sed 's/sbom-nix-devshell-//' | sed 's/\.[0-9].*//' | sed 's/\.cyclonedx\.json$//') + # Add [buildtime] to make project name unique + project_prefix="devshell-$devshell_name [buildtime]" + "$SCRIPT_DIR/upload-sbom.sh" "$sbom" "nix-devshell-buildtime" "$PROJECT_NAME" "$VERSION" "$project_prefix" || exit 1 + done +else + echo "Skipping Nix devShell SBOMs (buildtime) (directory not found)" +fi echo "✓ All SBOMs uploaded successfully" diff --git a/hack/helm_vars/wire-server/values.yaml.gotmpl b/hack/helm_vars/wire-server/values.yaml.gotmpl index 5255592075c..fe0a19d0682 100644 --- a/hack/helm_vars/wire-server/values.yaml.gotmpl +++ b/hack/helm_vars/wire-server/values.yaml.gotmpl @@ -5,6 +5,7 @@ tags: legalhold: false sftd: false integration: true + proxy: true consumableNotifications: false @@ -652,14 +653,6 @@ background-worker: name: "cassandra-jks-keystore" key: "ca.crt" {{- end }} - cassandraGalley: - host: {{ .Values.cassandraHost }} - replicaCount: 1 - {{- if .Values.useK8ssandraSSL.enabled }} - tlsCaSecretRef: - name: "cassandra-jks-keystore" - key: "ca.crt" - {{- end }} cassandraBrig: host: {{ .Values.cassandraHost }} replicaCount: 1 @@ -668,8 +661,6 @@ background-worker: name: "cassandra-jks-keystore" key: "ca.crt" {{- end }} - # See helmfile for the real value - federationDomain: integration.example.com postgresMigration: conversation: {{ .Values.conversationStore }} conversationCodes: {{ .Values.conversationCodesStore }} @@ -683,7 +674,6 @@ background-worker: name: "rabbitmq-certificate" key: "ca.crt" secrets: - pgPassword: "posty-the-gres" rabbitmq: username: {{ .Values.rabbitmqUsername }} password: {{ .Values.rabbitmqPassword }} diff --git a/hack/helmfile.yaml.gotmpl b/hack/helmfile.yaml.gotmpl index c64cc8bbf46..fbd83410307 100644 --- a/hack/helmfile.yaml.gotmpl +++ b/hack/helmfile.yaml.gotmpl @@ -324,8 +324,6 @@ releases: value: {{ .Values.federationDomain1 }} - name: galley.config.settings.federationDomain value: {{ .Values.federationDomain1 }} - - name: backgroundWorker.config.federationDomain - value: {{ .Values.federationDomain1 }} - name: cargohold.config.settings.federationDomain value: {{ .Values.federationDomain1 }} - name: brig.config.wireServerEnterprise.enabled @@ -346,8 +344,6 @@ releases: value: {{ .Values.federationDomain2 }} - name: galley.config.settings.federationDomain value: {{ .Values.federationDomain2 }} - - name: backgroundWorker.config.federationDomain - value: {{ .Values.federationDomain2 }} - name: cargohold.config.settings.federationDomain value: {{ .Values.federationDomain2 }} needs: diff --git a/integration/test/API/Brig.hs b/integration/test/API/Brig.hs index cecb6fbef73..d5cc1d33bf9 100644 --- a/integration/test/API/Brig.hs +++ b/integration/test/API/Brig.hs @@ -1227,11 +1227,11 @@ data NewApp = NewApp instance Default NewApp where def = NewApp - { name = "", + { name = "default name", assets = Nothing, accentId = Nothing, category = "other", - description = "" + description = "default description" } createApp :: (MakesValue creator) => creator -> String -> NewApp -> App Response diff --git a/integration/test/Test/AccessUpdate.hs b/integration/test/Test/AccessUpdate.hs index e8103451e40..19488fdee62 100644 --- a/integration/test/Test/AccessUpdate.hs +++ b/integration/test/Test/AccessUpdate.hs @@ -29,7 +29,7 @@ import Testlib.Prelude import Testlib.ResourcePool -- These two commented out tests exist to test the Setup.hs code. --- Both of these tests should not appear in the output. +-- Neither of these tests should appear in the output. -- testBar :: HasCallStack => App () -- testBar = pure () @@ -89,6 +89,7 @@ testAccessUpdateGuestRemoved proto = do bindResponse (getConversation alice conv) $ \res -> do res.status `shouldMatchInt` 200 + (length <$> (res.json %. "members.others" & asList)) `shouldMatchInt` 1 res.json %. "members.others.0.qualified_id" `shouldMatch` objQidObject bob -- @END diff --git a/integration/test/Test/Apps.hs b/integration/test/Test/Apps.hs index a82af79adc6..72eaa5e637f 100644 --- a/integration/test/Test/Apps.hs +++ b/integration/test/Test/Apps.hs @@ -23,37 +23,60 @@ import API.Brig import qualified API.BrigInternal as BrigI import API.Common import API.Galley +import Control.Lens hiding ((.=)) import Data.Aeson.QQ.Simple +import MLS.Util +import Notifications import SetupHelpers import Testlib.Prelude -testCreateApp :: (HasCallStack) => App () -testCreateApp = do - -- FUTUREWORK: what about federation? - domain <- make OwnDomain - (owner, tid, [regularMember]) <- createTeam domain 2 - let new = +testCreateGetApp :: (HasCallStack) => Domain -> App () +testCreateGetApp sameOrOtherDomain = do + domainA <- make OwnDomain + domainB <- make sameOrOtherDomain + + (owner, tid, [regularMember]) <- createTeam domainA 2 + let new :: NewApp = def { name = "chappie", description = "some description of this app", category = "ai" - } :: - NewApp + } -- Regular team member can't create apps bindResponse (createApp regularMember tid new) $ \resp -> do resp.status `shouldMatchInt` 403 resp.json %. "label" `shouldMatch` "app-no-permission" + -- Get the last team notification ID before creating the app + lastTeamNotif <- bindResponse (getTeamNotifications regularMember Nothing) $ \resp -> do + resp.status `shouldMatchInt` 200 + resp.json %. "notifications.-1.id" & asString + -- Owner can create an app - (appId, cookie) <- bindResponse (createApp owner tid new) $ \resp -> do + (appId, cookie) <- withWebSockets [owner, regularMember] \[wsOwner, wsRegularMember] -> do + bindResponse (createApp owner tid new) $ \resp -> do + resp.status `shouldMatchInt` 200 + appId <- resp.json %. "user.id" & asString + cookie <- resp.json %. "cookie" & asString + _ <- do + let predicate payload = do + typ <- payload %. "payload.0.type" & asString + pure $ typ == "team.member-join" + void $ awaitMatch predicate wsOwner + void $ assertNoEvent 5 wsRegularMember + pure (appId, cookie) + + -- Verify that the team.member-join event is in the team notifications queue + bindResponse (getTeamNotifications regularMember (Just lastTeamNotif)) $ \resp -> do resp.status `shouldMatchInt` 200 - appId <- resp.json %. "user.id" & asString - cookie <- resp.json %. "cookie" & asString - pure (appId, cookie) + -- First notification is `lastTeamNotif`, we can ignore that one. + resp.json %. "notifications.1.payload.0.type" `shouldMatch` "team.member-join" + resp.json %. "notifications.1.payload.0.team" `shouldMatch` tid + resp.json %. "notifications.1.payload.0.data.user" `shouldMatch` appId -- App user should have type "app" - let appIdObject = object ["domain" .= domain, "id" .= appId] + let appIdObject = object ["domain" .= domainA, "id" .= appId] bindResponse (getUser owner appIdObject) $ \resp -> do resp.status `shouldMatchInt` 200 resp.json %. "type" `shouldMatch` "app" @@ -78,7 +101,7 @@ testCreateApp = do resp.status `shouldMatchInt` 200 resp.json %. "type" `shouldMatch` "regular" - void $ bindResponse (renewToken domain cookie) $ \resp -> do + void $ bindResponse (renewToken domainA cookie) $ \resp -> do resp.status `shouldMatchInt` 200 resp.json %. "user" `shouldMatch` appId resp.json %. "token_type" `shouldMatch` "Bearer" @@ -92,54 +115,25 @@ testCreateApp = do (resp.json %. "app.category") `shouldMatch` "ai" -- A teamless user can't get the app - outsideUser <- randomUser domain def + outsideUser <- randomUser domainB (def {BrigI.team = False}) bindResponse (getApp outsideUser tid appId) $ \resp -> do - -- this may change soon, see - -- https://wearezeta.atlassian.net/browse/WPB-23995, - -- https://wearezeta.atlassian.net/browse/WPB-23840 - resp.status `shouldMatchInt` 200 + resp.status `shouldMatchInt` 404 - (owner2, tid2, [regularMember2]) <- createTeam domain 2 - bindResponse (getApp owner2 tid appId) $ \resp -> resp.status `shouldMatchInt` 200 - bindResponse (getApp owner2 tid2 appId) $ \resp -> resp.status `shouldMatchInt` 200 - bindResponse (getApp regularMember2 tid appId) $ \resp -> resp.status `shouldMatchInt` 200 + (owner2, tid2, [regularMember2]) <- createTeam domainB 2 + bindResponse (getApp owner2 tid appId) $ \resp -> resp.status `shouldMatchInt` 404 + bindResponse (getApp owner2 tid2 appId) $ \resp -> resp.status `shouldMatchInt` 404 + bindResponse (getApp regularMember2 tid appId) $ \resp -> resp.status `shouldMatchInt` 404 + + -- Get app on remote apps gives 404 not found. + void $ getApp owner2 tid appId `bindResponse` \resp -> do + resp.status `shouldMatchInt` 404 + resp.json %. "label" `shouldMatch` "not-found" -- Category can be any text; sanitization must happen by clients. void $ bindResponse (createApp owner tid new {category = "notinenum"}) $ \resp -> do resp.status `shouldMatchInt` 200 deleteTeamMember tid owner (resp.json %. "user") >>= assertSuccess - let foundUserType :: (HasCallStack) => Value -> String -> [String] -> App () - foundUserType searcher exactMatchTerm aTypes = - searchContacts searcher exactMatchTerm OwnDomain `bindResponse` \resp -> do - resp.status `shouldMatchInt` 200 - foundDocs :: [Value] <- resp.json %. "documents" >>= asList - docsInTeam :: [Value] <- do - -- make sure that matches from previous test runs don't get in the way. - -- related: https://wearezeta.atlassian.net/browse/WPB-23995 - catMaybes - <$> forM - foundDocs - ( \doc -> do - tidActual <- doc %. "team" & asString - pure $ if tidActual == tid then Just doc else Nothing - ) - - (%. "type") `mapM` docsInTeam `shouldMatch` aTypes - - -- App's user is findable from /search/contacts - BrigI.refreshIndex domain - foundUserType owner new.name ["app"] - foundUserType regularMember new.name ["app"] - - -- App's user is *not* findable from other team. - BrigI.refreshIndex domain - foundUserType owner2 new.name [] - - -- Regular members still have the type "regular" - memberName <- regularMember %. "name" & asString - foundUserType owner memberName ["regular"] - testRefreshAppCookie :: (HasCallStack) => App () testRefreshAppCookie = do (alice, tid, [bob]) <- createTeam OwnDomain 2 @@ -189,7 +183,7 @@ testRefreshAppCookie = do testDeleteAppFromTeam :: (HasCallStack) => App () testDeleteAppFromTeam = do domain <- make OwnDomain - (owner, tid, _) <- createTeam domain 1 + (owner, tid, [regularMember]) <- createTeam domain 2 let new = def {name = "chappie"} :: NewApp appId <- bindResponse (createApp owner tid new) $ \resp -> do resp.status `shouldMatchInt` 200 @@ -197,8 +191,14 @@ testDeleteAppFromTeam = do let appIdObject = object ["domain" .= domain, "id" .= appId] - bindResponse (deleteTeamMember tid owner appIdObject) $ \resp -> do - resp.status `shouldMatchInt` 202 + withWebSockets [owner, regularMember] \[wsOwner, wsRegularMember] -> do + bindResponse (deleteTeamMember tid owner appIdObject) $ \resp -> do + resp.status `shouldMatchInt` 202 + let predicate payload = do + typ <- payload %. "payload.0.type" & asString + pure $ typ == "team.member-leave" + void $ awaitMatch predicate wsOwner + void $ awaitMatch predicate wsRegularMember eventually $ do -- Check StoredApp is gone @@ -218,7 +218,7 @@ testDeleteAppFromTeam = do testPutApp :: (HasCallStack) => App () testPutApp = do domain <- make OwnDomain - (owner, tid, _) <- createTeam domain 1 + (owner, tid, [regularMember]) <- createTeam domain 2 let new = def {name = "choppie"} :: NewApp appId <- bindResponse (createApp owner tid new) $ \resp -> do resp.status `shouldMatchInt` 200 @@ -240,9 +240,11 @@ testPutApp = do "description": "This is the best app ever." }|] - bindResponse (putAppMetadata tid owner appId (Object appMetadata)) $ \resp -> do - resp.status `shouldMatchInt` 200 - + withWebSockets [owner, regularMember] \[wsOwner, wsRegularMember] -> do + bindResponse (putAppMetadata tid owner appId (Object appMetadata)) $ \resp -> do + resp.status `shouldMatchInt` 200 + void $ assertNoEvent 5 wsOwner + void $ assertNoEvent 5 wsRegularMember bindResponse (getApp owner tid appId) $ \resp -> do resp.status `shouldMatchInt` 200 resp.json @@ -257,6 +259,10 @@ testPutApp = do bindResponse (putAppMetadata tid owner badAppId (Object appMetadata)) $ \resp -> do resp.status `shouldMatchInt` 404 +-- | FUTUREWORK: 'Test.Apps.testFindApp', +-- 'Test.Apps.testRetrieveUsersIncludingApps', +-- 'Test.Search.checkUserSearch' have some overlap, or at least could +-- be re-ordered for clarity. testRetrieveUsersIncludingApps :: (HasCallStack) => App () testRetrieveUsersIncludingApps = do let userShape = @@ -299,6 +305,21 @@ testRetrieveUsersIncludingApps = do ("team", SString), ("type", SString) ] + listResultShape = + SObject + [ ("accent_id", SNumber), + ("assets", SArray SAny), + ("app", SAny), + ("id", SString), + ("legalhold_status", SString), + ("name", SString), + ("picture", SArray SAny), + ("qualified_id", SObject [("domain", SString), ("id", SString)]), + ("searchable", SBool), + ("supported_protocols", SArray SString), + ("team", SString), + ("type", SString) + ] domain <- make OwnDomain (owner, tid, [regular]) <- createTeam domain 2 @@ -348,22 +369,7 @@ testRetrieveUsersIncludingApps = do -- [`POST /list-users`](https://staging-nginz-https.zinfra.io/v15/api/swagger-ui/#/default/list-users-by-ids-or-handles) (route id: "list-users-by-ids-or-handles") listUsers owner [appCreated %. "user"] `bindResponse` \resp -> do resp.status `shouldMatchInt` 200 - resp.json - %. "found.0" - `shouldMatchShapeLenient` SObject - [ ("accent_id", SNumber), - ("assets", SArray SAny), - ("id", SString), - ("legalhold_status", SString), - ("name", SString), - ("picture", SArray SAny), - ("qualified_id", SObject [("domain", SString), ("id", SString)]), - ("searchable", SBool), - ("supported_protocols", SArray SString), - ("team", SString), - ("type", SString) - -- TODO: [("user", ...), ("app", ...)] ? - ] + resp.json %. "found.0" `shouldMatchShapeLenient` listResultShape -- [`GET /search/contacts`](https://staging-nginz-https.zinfra.io/v15/api/swagger-ui/#/default/search-contacts) (route id: "search-contacts") putSelf owner (def {name = Just "name-A1"}) >>= assertSuccess @@ -376,3 +382,182 @@ testRetrieveUsersIncludingApps = do hits :: [Value] <- resp.json %. "documents" & asList length hits `shouldMatchInt` 2 -- owner doesn't find itself (`shouldMatchShapeLenient` searchResultShape) `mapM_` hits + +testCrossTeamAppConversation :: (HasCallStack) => Domain -> App () +testCrossTeamAppConversation sameOrOtherDomain = do + domainA <- make OwnDomain + domainB <- make sameOrOtherDomain + (ownerA, tidA, [m1]) <- createTeam domainA 2 + (ownerB, tidB, [m2]) <- createTeam domainB 2 + + -- Create app A1 (member of team A) + let newAppA1 = def {name = "app-a1"} :: NewApp + appA1 <- bindResponse (createApp ownerA tidA newAppA1) $ \resp -> do + resp.status `shouldMatchInt` 200 + resp.json %. "user" + + -- Create app A2 (member of team B) + let newAppA2 = def {name = "app-a2"} :: NewApp + appA2 <- bindResponse (createApp ownerB tidB newAppA2) $ \resp -> do + resp.status `shouldMatchInt` 200 + resp.json %. "user" + + -- Create MLS clients for M1 and A1 (both on domainA) + [m1c, appA1c] <- traverse (createMLSClient def) [m1, appA1] + traverse_ (uploadNewKeyPackage def) [m1c, appA1c] + + -- M1 tries to connect to app A2 from team B => should fail + -- Apps cannot create connections accross teams + bindResponse (postConnection m1 appA2) $ \resp -> do + resp.status `shouldMatchInt` 400 + resp.json %. "label" `shouldMatch` "invalid-user" + + -- M1 creates an MLS team conversation + convId <- createNewGroupWith def m1c defMLS {team = Just tidA} + + -- M1 adds A1 to the conversation + void $ createAddCommit m1c convId [appA1] >>= sendAndConsumeCommitBundle + + -- M1 connects to M2 from team B (cross-team/cross-domain) + postConnection m1 m2 >>= assertSuccess + putConnection m2 m1 "accepted" >>= assertSuccess + + -- Create MLS client for M2 (on domainB) and add to conversation + m2c <- createMLSClient def m2 + void $ uploadNewKeyPackage def m2c + void $ createAddCommit m1c convId [m2] >>= sendAndConsumeCommitBundle + + -- Create app A3 (on domainA, team A) + let newAppA3 = def {name = "app-a3"} :: NewApp + appA3 <- bindResponse (createApp ownerA tidA newAppA3) $ \resp -> do + resp.status `shouldMatchInt` 200 + resp.json %. "user" + + -- Create MLS client for A3 and add to conversation + appA3c <- createMLSClient def appA3 + void $ uploadNewKeyPackage def appA3c + void $ createAddCommit m1c convId [appA3] >>= sendAndConsumeCommitBundle + + void $ createApplicationMessage convId m1c "hello from M1" >>= sendAndConsumeMessage + void $ createApplicationMessage convId appA1c "hello from A1" >>= sendAndConsumeMessage + void $ createApplicationMessage convId appA3c "hello from A3" >>= sendAndConsumeMessage + void $ createApplicationMessage convId m2c "hello from M2" >>= sendAndConsumeMessage + +-- | FUTUREWORK: 'Test.Apps.testFindApp', +-- 'Test.Apps.testRetrieveUsersIncludingApps', +-- 'Test.Search.checkUserSearch' have some overlap, or at least could +-- be re-ordered for clarity. +testFindApp :: (HasCallStack) => Domain -> App () +testFindApp sameOrOtherDomain = do + domainA <- make OwnDomain + domainB <- make sameOrOtherDomain + + (ownerA1, tidA1, [regularMemberA1]) <- createTeam domainA 2 + let newAppA1 :: NewApp = def {name = "app A1", description = ""} + (appA1Id) <- bindResponse (createApp ownerA1 tidA1 newAppA1) $ \resp -> do + resp.status `shouldMatchInt` 200 + resp.json %. "user.id" & asString + BrigI.refreshIndex domainA + + (ownerA2, _, [regularMemberA2]) <- createTeam domainA 2 + (ownerB1, _, [regularMemberB1]) <- createTeam domainB 2 + + let foundUserType :: (HasCallStack) => SearchContactsCfg -> [String] -> App () + foundUserType cfg uids = + searchContactsWith cfg `bindResponse` \resp -> do + resp.status `shouldMatchInt` 200 + foundDocs :: [Value] <- resp.json %. "documents" >>= asList + ((%. "id") `mapM` foundDocs) `shouldMatch` uids + + searchTerm <- asString newAppA1.name + domain <- asString domainA + + -- App is findable from /search/contacts inside the own team. + forM_ [ownerA1, regularMemberA1] + $ \user -> do + foundUserType SearchContactsCfg {types = Nothing, ..} [appA1Id] + foundUserType SearchContactsCfg {types = Just [], ..} [appA1Id] + foundUserType SearchContactsCfg {types = Just ["app"], ..} [appA1Id] + foundUserType SearchContactsCfg {types = Just ["app", "regular"], ..} [appA1Id] + foundUserType SearchContactsCfg {types = Just ["regular"], ..} [] + + -- App user is *not* findable from other team. + forM_ [ownerA2, regularMemberA2, ownerB1, regularMemberB1] + $ \user -> do + foundUserType SearchContactsCfg {types = Nothing, ..} [] + foundUserType SearchContactsCfg {types = Just [], ..} [] + foundUserType SearchContactsCfg {types = Just ["app"], ..} [] + foundUserType SearchContactsCfg {types = Just ["app", "regular"], ..} [] + foundUserType SearchContactsCfg {types = Just ["regular"], ..} [] + +testRemoveServicesAccessRole :: (HasCallStack) => App () +testRemoveServicesAccessRole = do + domain <- make OwnDomain + + -- Create team A with owner, member, and app + (ownerA, tidA, [memberA]) <- createTeam domain 2 + let newApp = def {name = "test-app"} :: NewApp + app <- bindResponse (createApp ownerA tidA newApp) $ \resp -> do + resp.status `shouldMatchInt` 200 + resp.json %. "user" + + -- Create MLS clients + [memberAClient, appClient] <- traverse (createMLSClient def) [memberA, app] + traverse_ (uploadNewKeyPackage def) [memberAClient, appClient] + + -- Create an MLS team conversation and add app + conv <- postConversation memberA defMLS {team = Just tidA, protocol = "mls"} >>= getJSON 201 + convId <- objConvId conv + createGroup def memberAClient convId + void $ createAddCommit memberAClient convId [app] >>= sendAndConsumeCommitBundle + + -- Verify all members are in the conversation + bindResponse (getConversation memberA conv) $ \resp -> do + resp.status `shouldMatchInt` 200 + members <- resp.json %. "members.others" >>= asList + memberIds <- mapM (\m -> m %. "qualified_id.id" >>= asString) members + appId <- app %. "qualified_id.id" & asString + memberIds `shouldContain` [appId] + + -- Remove "services" from access roles -> app should be removed + -- First verify we can get the conversation with the creator + bindResponse (getConversation memberA conv) $ \resp -> do + resp.status `shouldMatchInt` 200 + resp.json %. "protocol" `shouldMatch` "mls" + + let noServices = + [ "access" .= ["invite", "link"], + "access_role" .= (["team_member", "non_team_member"] :: [String]) + ] + -- Use the conversation creator for the update + bindResponse (updateAccess memberA conv noServices) $ \resp -> do + resp.status `shouldMatchInt` 200 + eventually $ do + bindResponse (getConversation memberA conv) $ \resp -> do + resp.status `shouldMatchInt` 200 + members <- resp.json %. "members.others" >>= asList + memberIds <- mapM (\m -> m %. "qualified_id.id" >>= asString) members + appId <- app %. "qualified_id.id" & asString + memberIds `shouldNotContain` [appId] + +testAppReceivesMemberJoinNotification :: (HasCallStack) => App () +testAppReceivesMemberJoinNotification = do + (owner, tid, []) <- createTeam OwnDomain 1 + + -- Create an app in the team + app <- bindResponse (createApp owner tid def) $ \resp -> do + resp.status `shouldMatchInt` 200 + resp.json %. "user" + + -- With websockets open for both owner and app, add a new regular member. + -- Both should receive the team.member-join notification. + withWebSockets [owner, app] $ \[wsOwner, wsApp] -> do + newMember <- addUserToTeam owner + + memberJoinOwner <- awaitMatch isTeamMemberJoinNotif wsOwner + memberJoinOwner %. "payload.0.team" `shouldMatch` tid + memberJoinOwner %. "payload.0.data.user" `shouldMatch` objId newMember + + memberJoinApp <- awaitMatch isTeamMemberJoinNotif wsApp + memberJoinApp %. "payload.0.team" `shouldMatch` tid + memberJoinApp %. "payload.0.data.user" `shouldMatch` objId newMember diff --git a/integration/test/Test/FeatureFlags/Apps.hs b/integration/test/Test/FeatureFlags/Apps.hs index 06f82ea02b3..b96543d142d 100644 --- a/integration/test/Test/FeatureFlags/Apps.hs +++ b/integration/test/Test/FeatureFlags/Apps.hs @@ -17,6 +17,8 @@ module Test.FeatureFlags.Apps where +import API.Brig (NewApp (..), createApp) +import qualified API.BrigInternal as BrigI import qualified API.GalleyInternal as Internal import SetupHelpers import Test.FeatureFlags.Util @@ -40,3 +42,51 @@ testAppsInternal = do testPatchApps :: (HasCallStack) => App () testPatchApps = checkPatch OwnDomain "apps" disabled + +-- | Disabling the apps feature for a team suspends all app users in that team. +-- Re-enabling it restores them to active. Regular team members are unaffected. +testAppsSuspendOnDisable :: (HasCallStack) => App () +testAppsSuspendOnDisable = do + (owner, tid, [regularMember]) <- createTeam OwnDomain 2 + Internal.setTeamFeatureLockStatus owner tid "apps" "unlocked" + + -- Create an app user in the team + app <- + let newApp = + NewApp + { name = "poll-app", + assets = Nothing, + accentId = Nothing, + category = "other", + description = "also other" + } + in bindResponse (createApp owner tid newApp) $ \resp -> do + resp.status `shouldMatchInt` 200 + resp.json %. "user" + + -- Verify initial account statuses are active + BrigI.getAccountStatus app `bindResponse` \resp -> do + resp.status `shouldMatchInt` 200 + resp.json %. "status" `shouldMatch` "active" + BrigI.getAccountStatus regularMember `bindResponse` \resp -> do + resp.status `shouldMatchInt` 200 + resp.json %. "status" `shouldMatch` "active" + + -- Disable the apps feature: app users should be suspended + setFeature InternalAPI owner tid "apps" disabled >>= assertSuccess + + BrigI.getAccountStatus app `bindResponse` \resp -> do + resp.status `shouldMatchInt` 200 + resp.json %. "status" `shouldMatch` "suspended" + + -- Regular member must NOT be suspended + BrigI.getAccountStatus regularMember `bindResponse` \resp -> do + resp.status `shouldMatchInt` 200 + resp.json %. "status" `shouldMatch` "active" + + -- Re-enable the apps feature: app users should be active again + setFeature InternalAPI owner tid "apps" enabled >>= assertSuccess + + BrigI.getAccountStatus app `bindResponse` \resp -> do + resp.status `shouldMatchInt` 200 + resp.json %. "status" `shouldMatch` "active" diff --git a/integration/test/Test/MLS/Services.hs b/integration/test/Test/MLS/Services.hs index 8eb2d5fcbb4..c4e697c2335 100644 --- a/integration/test/Test/MLS/Services.hs +++ b/integration/test/Test/MLS/Services.hs @@ -110,3 +110,70 @@ testWhitelistUpdatePermissions = do postServiceWhitelist admin tid np >>= \resp -> do resp.status `shouldMatchInt` 409 (resp.json %. "label") `shouldMatch` Just "mls-services-not-allowed" + +-- | Removing a service from an MLS team should succeed even though adding is blocked. +testRemoveServiceFromMLSTeam :: (HasCallStack) => App () +testRemoveServiceFromMLSTeam = do + -- Create a team (default protocol is proteus) + (owner, tid, []) <- createTeam OwnDomain 1 + + -- Create a service + provider <- make <$> setupProvider owner def + providerId <- provider %. "id" & asString + service <- make <$> newService OwnDomain providerId def + serviceId <- service %. "id" & asString + + -- Whitelist the service while the team is still on proteus + do + np <- + make + $ object + [ "id" .= serviceId, + "provider" .= providerId, + "whitelisted" .= True + ] + postServiceWhitelist owner tid np >>= assertStatus 200 + + -- Upgrade the team to MLS + mlsConfig <- + make + $ object + [ "config" + .= object + [ "allowedCipherSuites" .= [1 :: Int], + "defaultCipherSuite" .= (1 :: Int), + "defaultProtocol" .= "mls", + "protocolToggleUsers" .= ([] :: [String]), + "supportedProtocols" .= ["mls", "proteus"] + ], + "status" .= "enabled", + "ttl" .= "unlimited" + ] + patchTeamFeatureConfig OwnDomain tid "mls" mlsConfig >>= assertStatus 200 + + -- Adding a NEW service on an MLS team should be blocked + do + -- Service is already whitelisted, so we need a fresh service to test the add path + service2 <- make <$> newService OwnDomain providerId def + serviceId2 <- service2 %. "id" & asString + np2 <- + make + $ object + [ "id" .= serviceId2, + "provider" .= providerId, + "whitelisted" .= True + ] + postServiceWhitelist owner tid np2 >>= \resp -> do + resp.status `shouldMatchInt` 409 + (resp.json %. "label") `shouldMatch` Just "mls-services-not-allowed" + + -- Removing the already-whitelisted service from the MLS team should succeed + do + np <- + make + $ object + [ "id" .= serviceId, + "provider" .= providerId, + "whitelisted" .= False + ] + postServiceWhitelist owner tid np >>= assertStatus 200 diff --git a/integration/test/Test/Search.hs b/integration/test/Test/Search.hs index b91fd0523d6..fc822aedef7 100644 --- a/integration/test/Test/Search.hs +++ b/integration/test/Test/Search.hs @@ -153,20 +153,19 @@ testFederatedUserSearchWithType = checkUserSearch d1 d1 -- target dynamic domain locally checkUserSearch d1 d2 -- target one dynamic domain from another +-- | FUTUREWORK: 'Test.Apps.testFindApp', +-- 'Test.Apps.testRetrieveUsersIncludingApps', +-- 'Test.Search.checkUserSearch' have some overlap, or at least could +-- be re-ordered for clarity. checkUserSearch :: (HasCallStack) => String -> String -> App () checkUserSearch d1 d2 = do (remoteSearcher, _, []) <- createTeam d1 1 (owner, tid, [mem]) <- createTeam d2 2 assertSuccess =<< GalleyI.setTeamFeatureStatus d2 tid "searchVisibilityInbound" "enabled" - -- create app with name "chappie" on d2 - let newApp :: BrigP.NewApp - newApp = def {BrigP.name = "chappie"} - in BrigP.createApp owner tid newApp >>= assertSuccess - - -- set name of d2 member to "chappie-also", so we can search for both with one prefix. + -- set name of d2 member to "chappie" so it can be found by that search term. let nameUpd :: BrigP.PutSelf - nameUpd = def {BrigP.name = Just "chappie-also"} + nameUpd = def {BrigP.name = Just "chappie"} in BrigP.putSelf mem nameUpd >>= assertSuccess let filterByType :: (HasCallStack) => Value -> String -> Maybe [String] -> [String] -> App () @@ -181,11 +180,7 @@ checkUserSearch d1 d2 = do BrigI.refreshIndex d2 forM_ [owner, remoteSearcher] $ \searcher -> do - filterByType searcher "chappie" Nothing ["chappie", "chappie-also"] - filterByType searcher "chappie" (Just []) ["chappie", "chappie-also"] - filterByType searcher "chappie" (Just ["regular"]) ["chappie-also"] - filterByType searcher "chappie" (Just ["app"]) ["chappie"] - filterByType searcher "chappie" (Just ["regular", "app"]) ["chappie", "chappie-also"] + filterByType searcher "chappie" Nothing ["chappie"] federatedUserSearch :: (HasCallStack) => String -> String -> FedUserSearchTestCase -> App () federatedUserSearch d1 d2 test = do diff --git a/integration/test/Test/Spar.hs b/integration/test/Test/Spar.hs index 27e622fb8b3..d136b122e86 100644 --- a/integration/test/Test/Spar.hs +++ b/integration/test/Test/Spar.hs @@ -23,6 +23,7 @@ import API.Brig as Brig import API.BrigInternal as BrigInternal import API.Common (defPassword, randomDomain, randomEmail, randomExternalId, randomHandle) import API.GalleyInternal (setTeamFeatureStatus) +import qualified API.Nginz as Nginz import API.Spar import API.SparInternal import Control.Lens (to, (^.)) @@ -1400,3 +1401,26 @@ testAllowUpdatesBySCIMWhenE2EIdEnabled (TaggedBool ssoEnabled) = do pure su -- @END + +testNoPasswordResetForSAMLUser :: (HasCallStack) => App () +testNoPasswordResetForSAMLUser = do + (owner, tid, _) <- createTeam OwnDomain 1 + void $ setTeamFeatureStatus owner tid "sso" "enabled" + void $ setTeamFeatureStatus owner tid "validateSAMLemails" "enabled" + (idp, _) <- registerTestIdPWithMetaWithPrivateCreds owner + idpId <- asString $ idp.json %. "id" + tok <- createScimToken owner def {idp = Just idpId} >>= getJSON 200 >>= (%. "token") >>= asString + scimUser <- randomScimUser + email <- scimUser %. "emails" >>= asList >>= assertOne >>= (%. "value") >>= asString + _uid <- createScimUser OwnDomain tok scimUser >>= getJSON 201 >>= (%. "id") >>= asString + activateEmail OwnDomain email + -- login with password should fail + Nginz.login OwnDomain email defPassword `bindResponse` \resp -> do + resp.status `shouldMatchInt` 403 + -- password reset returns 201 always to not leak any account information + passwordReset OwnDomain email `bindResponse` \resp -> do + resp.status `shouldMatchInt` 201 + -- however no password reset code and key should be generated + getPasswordResetCode OwnDomain email `bindResponse` \resp -> do + resp.status `shouldMatchInt` 400 + resp.json %. "label" `shouldMatch` "invalid-key" diff --git a/integration/test/Testlib/ModService.hs b/integration/test/Testlib/ModService.hs index 3939c17164f..a28f3505365 100644 --- a/integration/test/Testlib/ModService.hs +++ b/integration/test/Testlib/ModService.hs @@ -46,6 +46,8 @@ import Data.Function import Data.Functor import Data.IORef import qualified Data.List as List +import Data.Map (Map) +import qualified Data.Map as Map import Data.Maybe import Data.Monoid import Data.String @@ -62,6 +64,7 @@ import System.Directory (copyFile, createDirectoryIfMissing, doesDirectoryExist, import System.Exit import System.FilePath import System.IO +import System.IO.Error (isDoesNotExistError) import System.IO.Temp (createTempDirectory, writeTempFile) import qualified System.Linux.Proc as LinuxProc import System.Posix (keyboardSignal, killProcess, signalProcess) @@ -317,7 +320,9 @@ startBackend :: Codensity App () startBackend resource overrides = do lift $ waitForPortsToBeFree resource - traverseConcurrentlyCodensity (withProcess resource overrides) allServices + initRuntimeFiles <- lift $ initBackendRuntimeFiles resource overrides + artifacts <- hoistCodensity $ Codensity $ E.bracket initRuntimeFiles cleanupBackendRuntimeFiles + traverseConcurrentlyCodensity (withProcess artifacts resource) allServices lift $ ensureBackendReachable resource.berDomain waitForPortsToBeFree :: (HasCallStack) => BackendResource -> App () @@ -437,26 +442,12 @@ processColors = ("nginx", colored purpleish) ] -data ServiceInstance = ServiceInstance - { handle :: ProcessHandle, - config :: FilePath +data BackendRuntimeFiles = BackendRuntimeFiles + { serviceConfigs :: Map Service FilePath, + tempPaths :: [FilePath], + nginzWorkingDir :: FilePath } -timeout :: Int -> IO a -> IO (Maybe a) -timeout usecs action = either (const Nothing) Just <$> race (threadDelay usecs) action - -cleanupService :: (HasCallStack) => ServiceInstance -> IO () -cleanupService inst = do - mPid <- getPid inst.handle - for_ mPid (signalProcess keyboardSignal) - timeout 50000 (waitForProcess inst.handle) >>= \case - Just _ -> pure () - Nothing -> do - for_ mPid (signalProcess killProcess) - void $ waitForProcess inst.handle - whenM (doesFileExist inst.config) $ removeFile inst.config - whenM (doesDirectoryExist inst.config) $ removeDirectoryRecursive inst.config - -- | Wait for a service to come up. waitUntilServiceIsUp :: (HasCallStack) => Maybe ProcessDebug -> String -> Service -> App () waitUntilServiceIsUp mDebug domain srv = @@ -483,46 +474,113 @@ readAndUpdateConfig overrides resource service = >>= updateServiceMapInConfig resource service >>= lookupConfigOverride overrides service -withProcess :: (HasCallStack) => BackendResource -> ServiceOverrides -> Service -> Codensity App () -withProcess resource overrides service = do - let domain = berDomain resource - sm <- lift $ getServiceMap domain +data ProcessInstance = ProcessInstance {handle :: ProcessHandle, pid :: Pid} + +withProcess :: (HasCallStack) => BackendRuntimeFiles -> BackendResource -> Service -> Codensity App () +withProcess artifacts resource service = do env <- lift ask - let execName = configName service - let (cwd, exe) = case env.servicesCwdBase of + let domain = berDomain resource + execName = configName service + (cwd, exe) = case env.servicesCwdBase of Nothing -> (Nothing, execName) Just dir -> (Just (dir execName), "../../dist" execName) - startNginzLocalIO <- lift $ appToIO $ startNginzLocal resource - stdOut <- liftIO $ newIORef [] stdErr <- liftIO $ newIORef [] phRef <- liftIO $ newIORef Nothing - getConfig <- lift $ readAndUpdateConfig overrides resource service let prefix = "[" <> execName <> "@" <> domain <> maybe "" (":" <>) env.currentTestName <> "] " - let initProcess = case (service, cwd) of - (Nginz, Nothing) -> startNginzK8s domain sm - (Nginz, Just _) -> startNginzLocalIO + initProcess = case (service, cwd) of + (Nginz, _) -> + startNginz domain (lookupServiceConfig Nginz artifacts) artifacts.nginzWorkingDir + (BackgroundWorker, _) -> do + let backgroundWorkerConf = lookupServiceConfig BackgroundWorker artifacts + galleyConf = lookupServiceConfig Galley artifacts + params = ["-c", backgroundWorkerConf, "--galley-config-file", galleyConf] + createServiceInstance params _ -> do - config <- getConfig - tempFile <- writeTempFile "/tmp" (execName <> "-" <> domain <> "-" <> ".yaml") (cs $ Yaml.encode config) - (_, Just stdoutHdl, Just stderrHdl, ph) <- createProcess (proc exe ["-c", tempFile]) {cwd = cwd, std_out = CreatePipe, std_err = CreatePipe} - let colorize = fromMaybe id (lookup execName processColors) - void $ forkIO $ logToConsoleDebug (Just stdOut) colorize prefix stdoutHdl - void $ forkIO $ logToConsoleDebug (Just stdErr) colorize prefix stderrHdl - liftIO $ writeIORef phRef (Just ph) - pure $ ServiceInstance ph tempFile + let conf = lookupServiceConfig service artifacts + params = ["-c", conf] + createServiceInstance params + where + createServiceInstance params = do + (_, Just stdoutHdl, Just stderrHdl, ph) <- createProcess (proc exe params) {cwd = cwd, std_out = CreatePipe, std_err = CreatePipe} + let colorize = fromMaybe id (lookup execName processColors) + void $ forkIO $ logToConsoleDebug (Just stdOut) colorize prefix stdoutHdl + void $ forkIO $ logToConsoleDebug (Just stdErr) colorize prefix stderrHdl + writeIORef phRef (Just ph) + mkProcessInstance service ph void $ hoistCodensity $ Codensity $ - E.bracket initProcess cleanupService + E.bracket initProcess kill lift $ addFailureContext ("Waiting for service: " <> prefix) $ do waitUntilServiceIsUp (Just $ ProcessDebug {phRef = phRef, stdOut = stdOut, stdErr = stdErr}) domain service + where + kill :: (HasCallStack) => ProcessInstance -> IO () + kill p = do + processExists <- ignoreMissingProcess (signalProcess keyboardSignal p.pid) + if processExists + then + timeout 50000 (waitForProcess p.handle) >>= \case + Just _ -> pure () + Nothing -> forceKillAndWait + else waitForProcessWithTimeout + where + forceKillAndWait = do + void $ ignoreMissingProcess (signalProcess killProcess p.pid) + waitForProcessWithTimeout + + waitForProcessWithTimeout = + timeout 50000 (waitForProcess p.handle) >>= \case + Just _ -> pure () + Nothing -> E.throw (AssertionFailure callStack Nothing Nothing "Timed out waiting for service process to terminate during cleanup") + + ignoreMissingProcess :: IO () -> IO Bool + ignoreMissingProcess action = + E.catch + (action $> True) + ( \e -> + if isDoesNotExistError e + then pure False + else E.throwIO e + ) + + timeout usecs action = either (const Nothing) Just <$> race (threadDelay usecs) action + +initBackendRuntimeFiles :: BackendResource -> ServiceOverrides -> App (IO BackendRuntimeFiles) +initBackendRuntimeFiles resource overrides = appToIO do + serviceConfigs <- prepareConfigFiles $ filter (/= Nginz) allServices + (nginzConf, nginzTempDir, nginzWorkingDir) <- prepareNginzRuntimeFiles resource + pure $ + BackendRuntimeFiles + { serviceConfigs = Map.insert Nginz nginzConf serviceConfigs, + tempPaths = nginzTempDir : Map.elems serviceConfigs, + nginzWorkingDir = nginzWorkingDir + } + where + prepareConfigFiles services = Map.fromList <$> traverse getAndWrite services + + getAndWrite :: Service -> App (Service, FilePath) + getAndWrite service = do + getConfig <- readAndUpdateConfig overrides resource service + config <- liftIO getConfig + tempFile <- liftIO $ writeTempFile "/tmp" (configName service <> "-" <> resource.berDomain <> "-" <> ".yaml") (cs $ Yaml.encode config) + pure (service, tempFile) + +cleanupBackendRuntimeFiles :: BackendRuntimeFiles -> IO () +cleanupBackendRuntimeFiles artifacts = for_ artifacts.tempPaths \path -> do + whenM (doesFileExist path) $ removeFile path + whenM (doesDirectoryExist path) $ removeDirectoryRecursive path + +lookupServiceConfig :: Service -> BackendRuntimeFiles -> FilePath +lookupServiceConfig service artifacts = + fromMaybe (error $ "missing backend artifact for service " <> show service) $ + Map.lookup service artifacts.serviceConfigs logToConsole :: (String -> String) -> String -> Handle -> IO () logToConsole = logToConsoleDebug Nothing @@ -581,11 +639,19 @@ retryRequestUntilDebug mProcessDebug reqAction err = do addFailureContext msg $ assertFailure msg -startNginzK8s :: String -> ServiceMap -> IO ServiceInstance -startNginzK8s domain sm = do - tmpDir <- liftIO $ createTempDirectory "/tmp" ("nginz" <> "-" <> domain) - liftIO $ - copyDirectoryRecursively "/etc/wire/nginz/" tmpDir +prepareNginzRuntimeFiles :: BackendResource -> App (FilePath, FilePath, FilePath) +prepareNginzRuntimeFiles resource = do + let domain = berDomain resource + sm <- getServiceMap domain + mBaseDir <- asks (.servicesCwdBase) + case mBaseDir of + Nothing -> liftIO $ prepareNginzK8sRuntimeFiles domain sm + Just basedir -> liftIO $ prepareNginzLocalRuntimeFiles resource sm basedir + +prepareNginzK8sRuntimeFiles :: String -> ServiceMap -> IO (FilePath, FilePath, FilePath) +prepareNginzK8sRuntimeFiles domain sm = do + tmpDir <- createTempDirectory "/tmp" ("nginz" <> "-" <> domain) + copyDirectoryRecursively "/etc/wire/nginz/" tmpDir let nginxConfFile = tmpDir "conf" "nginx.conf" conf <- Text.readFile nginxConfFile @@ -599,35 +665,29 @@ startNginzK8s domain sm = do Text.writeFile nginxConfFile $ replaceUpstreamsInConfig conf' sm - ph <- startNginz domain nginxConfFile "/" - pure $ ServiceInstance ph tmpDir + pure (nginxConfFile, tmpDir, "/") -startNginzLocal :: BackendResource -> App ServiceInstance -startNginzLocal resource = do +prepareNginzLocalRuntimeFiles :: BackendResource -> ServiceMap -> FilePath -> IO (FilePath, FilePath, FilePath) +prepareNginzLocalRuntimeFiles resource sm basedir = do let domain = berDomain resource - sm <- getServiceMap domain -- Create a whole temporary directory and copy all nginx's config files. -- This is necessary because nginx assumes local imports are relative to -- the location of the main configuration file. - tmpDir <- liftIO $ createTempDirectory "/tmp" ("nginz" <> "-" <> domain) - mBaseDir <- asks (.servicesCwdBase) - basedir <- maybe (failApp "service cwd base not found") pure mBaseDir + tmpDir <- createTempDirectory "/tmp" ("nginz" <> "-" <> domain) -- copy all config files into the tmp dir - liftIO $ do - let from = basedir "nginz" "integration-test" - copyDirectoryRecursively (from "conf" "nginz") (tmpDir "conf" "nginz") - copyDirectoryRecursively (from "resources") (tmpDir "resources") + let from = basedir "nginz" "integration-test" + copyDirectoryRecursively (from "conf" "nginz") (tmpDir "conf" "nginz") + copyDirectoryRecursively (from "resources") (tmpDir "resources") -- hide access log let nginxConfFile = tmpDir "conf" "nginz" "nginx.conf" - liftIO $ do - conf <- Text.readFile nginxConfFile - Text.writeFile nginxConfFile $ - ( conf - & Text.replace "access_log /dev/stdout" "access_log /dev/null" - ) + conf <- Text.readFile nginxConfFile + Text.writeFile nginxConfFile $ + ( conf + & Text.replace "access_log /dev/stdout" "access_log /dev/null" + ) -- override port configuration let nginzPort = sm.nginz.port @@ -642,30 +702,23 @@ startNginzLocal resource = do |] integrationConfFile = tmpDir "conf" "nginz" "integration.conf" - liftIO $ do - whenM (doesFileExist integrationConfFile) $ removeFile integrationConfFile - writeFile integrationConfFile portConfig + whenM (doesFileExist integrationConfFile) $ removeFile integrationConfFile + writeFile integrationConfFile portConfig -- override upstreams let upstreamsCfg = tmpDir "conf" "nginz" "upstreams" - liftIO $ do - whenM (doesFileExist upstreamsCfg) $ - removeFile upstreamsCfg - writeFile upstreamsCfg (makeUpstreamsCfgs sm) + whenM (doesFileExist upstreamsCfg) $ + removeFile upstreamsCfg + writeFile upstreamsCfg (makeUpstreamsCfgs sm) -- override pid configuration let pidConfigFile = tmpDir "conf" "nginz" "pid.conf" let pid = tmpDir "conf" "nginz" "nginz.pid" - liftIO $ do - whenM (doesFileExist $ pidConfigFile) $ removeFile pidConfigFile - writeFile pidConfigFile (cs $ "pid " <> pid <> ";") + whenM (doesFileExist $ pidConfigFile) $ removeFile pidConfigFile + writeFile pidConfigFile (cs $ "pid " <> pid <> ";") - -- start service - ph <- liftIO $ startNginz domain nginxConfFile tmpDir - - -- return handle and nginx tmp dir path - pure $ ServiceInstance ph tmpDir + pure (nginxConfFile, tmpDir, tmpDir) makeUpstreamsCfgs :: ServiceMap -> String makeUpstreamsCfgs sm = @@ -744,7 +797,14 @@ replaceUpstreamsInConfig nginxConf sm = } |] -startNginz :: String -> FilePath -> FilePath -> IO ProcessHandle +mkProcessInstance :: Service -> ProcessHandle -> IO ProcessInstance +mkProcessInstance service ph = do + mPid <- getPid ph + case mPid of + Just pid -> pure $ ProcessInstance ph pid + Nothing -> E.throw (AssertionFailure callStack Nothing Nothing (configName service <> " started without a pid")) + +startNginz :: String -> FilePath -> FilePath -> IO ProcessInstance startNginz domain conf workingDir = do (_, Just stdoutHdl, Just stderrHdl, ph) <- createProcess @@ -759,5 +819,4 @@ startNginz domain conf workingDir = do void $ forkIO $ logToConsole colorize prefix stdoutHdl void $ forkIO $ logToConsole colorize prefix stderrHdl - - pure ph + mkProcessInstance Nginz ph diff --git a/libs/brig-types/.ormolu b/libs/brig-types/.ormolu deleted file mode 120000 index 157b212d7cd..00000000000 --- a/libs/brig-types/.ormolu +++ /dev/null @@ -1 +0,0 @@ -../../.ormolu \ No newline at end of file diff --git a/libs/brig-types/LICENSE b/libs/brig-types/LICENSE deleted file mode 100644 index dba13ed2ddf..00000000000 --- a/libs/brig-types/LICENSE +++ /dev/null @@ -1,661 +0,0 @@ - GNU AFFERO GENERAL PUBLIC LICENSE - Version 3, 19 November 2007 - - Copyright (C) 2007 Free Software Foundation, Inc. - Everyone is permitted to copy and distribute verbatim copies - of this license document, but changing it is not allowed. - - Preamble - - The GNU Affero General Public License is a free, copyleft license for -software and other kinds of works, specifically designed to ensure -cooperation with the community in the case of network server software. - - The licenses for most software and other practical works are designed -to take away your freedom to share and change the works. By contrast, -our General Public Licenses are intended to guarantee your freedom to -share and change all versions of a program--to make sure it remains free -software for all its users. - - When we speak of free software, we are referring to freedom, not -price. Our General Public Licenses are designed to make sure that you -have the freedom to distribute copies of free software (and charge for -them if you wish), that you receive source code or can get it if you -want it, that you can change the software or use pieces of it in new -free programs, and that you know you can do these things. - - Developers that use our General Public Licenses protect your rights -with two steps: (1) assert copyright on the software, and (2) offer -you this License which gives you legal permission to copy, distribute -and/or modify the software. - - A secondary benefit of defending all users' freedom is that -improvements made in alternate versions of the program, if they -receive widespread use, become available for other developers to -incorporate. Many developers of free software are heartened and -encouraged by the resulting cooperation. However, in the case of -software used on network servers, this result may fail to come about. -The GNU General Public License permits making a modified version and -letting the public access it on a server without ever releasing its -source code to the public. - - The GNU Affero General Public License is designed specifically to -ensure that, in such cases, the modified source code becomes available -to the community. It requires the operator of a network server to -provide the source code of the modified version running there to the -users of that server. Therefore, public use of a modified version, on -a publicly accessible server, gives the public access to the source -code of the modified version. - - An older license, called the Affero General Public License and -published by Affero, was designed to accomplish similar goals. This is -a different license, not a version of the Affero GPL, but Affero has -released a new version of the Affero GPL which permits relicensing under -this license. - - The precise terms and conditions for copying, distribution and -modification follow. - - TERMS AND CONDITIONS - - 0. Definitions. - - "This License" refers to version 3 of the GNU Affero General Public License. - - "Copyright" also means copyright-like laws that apply to other kinds of -works, such as semiconductor masks. - - "The Program" refers to any copyrightable work licensed under this -License. Each licensee is addressed as "you". "Licensees" and -"recipients" may be individuals or organizations. - - To "modify" a work means to copy from or adapt all or part of the work -in a fashion requiring copyright permission, other than the making of an -exact copy. The resulting work is called a "modified version" of the -earlier work or a work "based on" the earlier work. - - A "covered work" means either the unmodified Program or a work based -on the Program. - - To "propagate" a work means to do anything with it that, without -permission, would make you directly or secondarily liable for -infringement under applicable copyright law, except executing it on a -computer or modifying a private copy. Propagation includes copying, -distribution (with or without modification), making available to the -public, and in some countries other activities as well. - - To "convey" a work means any kind of propagation that enables other -parties to make or receive copies. Mere interaction with a user through -a computer network, with no transfer of a copy, is not conveying. - - An interactive user interface displays "Appropriate Legal Notices" -to the extent that it includes a convenient and prominently visible -feature that (1) displays an appropriate copyright notice, and (2) -tells the user that there is no warranty for the work (except to the -extent that warranties are provided), that licensees may convey the -work under this License, and how to view a copy of this License. If -the interface presents a list of user commands or options, such as a -menu, a prominent item in the list meets this criterion. - - 1. Source Code. - - The "source code" for a work means the preferred form of the work -for making modifications to it. "Object code" means any non-source -form of a work. - - A "Standard Interface" means an interface that either is an official -standard defined by a recognized standards body, or, in the case of -interfaces specified for a particular programming language, one that -is widely used among developers working in that language. - - The "System Libraries" of an executable work include anything, other -than the work as a whole, that (a) is included in the normal form of -packaging a Major Component, but which is not part of that Major -Component, and (b) serves only to enable use of the work with that -Major Component, or to implement a Standard Interface for which an -implementation is available to the public in source code form. A -"Major Component", in this context, means a major essential component -(kernel, window system, and so on) of the specific operating system -(if any) on which the executable work runs, or a compiler used to -produce the work, or an object code interpreter used to run it. - - The "Corresponding Source" for a work in object code form means all -the source code needed to generate, install, and (for an executable -work) run the object code and to modify the work, including scripts to -control those activities. However, it does not include the work's -System Libraries, or general-purpose tools or generally available free -programs which are used unmodified in performing those activities but -which are not part of the work. For example, Corresponding Source -includes interface definition files associated with source files for -the work, and the source code for shared libraries and dynamically -linked subprograms that the work is specifically designed to require, -such as by intimate data communication or control flow between those -subprograms and other parts of the work. - - The Corresponding Source need not include anything that users -can regenerate automatically from other parts of the Corresponding -Source. - - The Corresponding Source for a work in source code form is that -same work. - - 2. Basic Permissions. - - All rights granted under this License are granted for the term of -copyright on the Program, and are irrevocable provided the stated -conditions are met. This License explicitly affirms your unlimited -permission to run the unmodified Program. The output from running a -covered work is covered by this License only if the output, given its -content, constitutes a covered work. This License acknowledges your -rights of fair use or other equivalent, as provided by copyright law. - - You may make, run and propagate covered works that you do not -convey, without conditions so long as your license otherwise remains -in force. You may convey covered works to others for the sole purpose -of having them make modifications exclusively for you, or provide you -with facilities for running those works, provided that you comply with -the terms of this License in conveying all material for which you do -not control copyright. Those thus making or running the covered works -for you must do so exclusively on your behalf, under your direction -and control, on terms that prohibit them from making any copies of -your copyrighted material outside their relationship with you. - - Conveying under any other circumstances is permitted solely under -the conditions stated below. Sublicensing is not allowed; section 10 -makes it unnecessary. - - 3. Protecting Users' Legal Rights From Anti-Circumvention Law. - - No covered work shall be deemed part of an effective technological -measure under any applicable law fulfilling obligations under article -11 of the WIPO copyright treaty adopted on 20 December 1996, or -similar laws prohibiting or restricting circumvention of such -measures. - - When you convey a covered work, you waive any legal power to forbid -circumvention of technological measures to the extent such circumvention -is effected by exercising rights under this License with respect to -the covered work, and you disclaim any intention to limit operation or -modification of the work as a means of enforcing, against the work's -users, your or third parties' legal rights to forbid circumvention of -technological measures. - - 4. Conveying Verbatim Copies. - - You may convey verbatim copies of the Program's source code as you -receive it, in any medium, provided that you conspicuously and -appropriately publish on each copy an appropriate copyright notice; -keep intact all notices stating that this License and any -non-permissive terms added in accord with section 7 apply to the code; -keep intact all notices of the absence of any warranty; and give all -recipients a copy of this License along with the Program. - - You may charge any price or no price for each copy that you convey, -and you may offer support or warranty protection for a fee. - - 5. Conveying Modified Source Versions. - - You may convey a work based on the Program, or the modifications to -produce it from the Program, in the form of source code under the -terms of section 4, provided that you also meet all of these conditions: - - a) The work must carry prominent notices stating that you modified - it, and giving a relevant date. - - b) The work must carry prominent notices stating that it is - released under this License and any conditions added under section - 7. This requirement modifies the requirement in section 4 to - "keep intact all notices". - - c) You must license the entire work, as a whole, under this - License to anyone who comes into possession of a copy. This - License will therefore apply, along with any applicable section 7 - additional terms, to the whole of the work, and all its parts, - regardless of how they are packaged. This License gives no - permission to license the work in any other way, but it does not - invalidate such permission if you have separately received it. - - d) If the work has interactive user interfaces, each must display - Appropriate Legal Notices; however, if the Program has interactive - interfaces that do not display Appropriate Legal Notices, your - work need not make them do so. - - A compilation of a covered work with other separate and independent -works, which are not by their nature extensions of the covered work, -and which are not combined with it such as to form a larger program, -in or on a volume of a storage or distribution medium, is called an -"aggregate" if the compilation and its resulting copyright are not -used to limit the access or legal rights of the compilation's users -beyond what the individual works permit. Inclusion of a covered work -in an aggregate does not cause this License to apply to the other -parts of the aggregate. - - 6. Conveying Non-Source Forms. - - You may convey a covered work in object code form under the terms -of sections 4 and 5, provided that you also convey the -machine-readable Corresponding Source under the terms of this License, -in one of these ways: - - a) Convey the object code in, or embodied in, a physical product - (including a physical distribution medium), accompanied by the - Corresponding Source fixed on a durable physical medium - customarily used for software interchange. - - b) Convey the object code in, or embodied in, a physical product - (including a physical distribution medium), accompanied by a - written offer, valid for at least three years and valid for as - long as you offer spare parts or customer support for that product - model, to give anyone who possesses the object code either (1) a - copy of the Corresponding Source for all the software in the - product that is covered by this License, on a durable physical - medium customarily used for software interchange, for a price no - more than your reasonable cost of physically performing this - conveying of source, or (2) access to copy the - Corresponding Source from a network server at no charge. - - c) Convey individual copies of the object code with a copy of the - written offer to provide the Corresponding Source. This - alternative is allowed only occasionally and noncommercially, and - only if you received the object code with such an offer, in accord - with subsection 6b. - - d) Convey the object code by offering access from a designated - place (gratis or for a charge), and offer equivalent access to the - Corresponding Source in the same way through the same place at no - further charge. You need not require recipients to copy the - Corresponding Source along with the object code. If the place to - copy the object code is a network server, the Corresponding Source - may be on a different server (operated by you or a third party) - that supports equivalent copying facilities, provided you maintain - clear directions next to the object code saying where to find the - Corresponding Source. Regardless of what server hosts the - Corresponding Source, you remain obligated to ensure that it is - available for as long as needed to satisfy these requirements. - - e) Convey the object code using peer-to-peer transmission, provided - you inform other peers where the object code and Corresponding - Source of the work are being offered to the general public at no - charge under subsection 6d. - - A separable portion of the object code, whose source code is excluded -from the Corresponding Source as a System Library, need not be -included in conveying the object code work. - - A "User Product" is either (1) a "consumer product", which means any -tangible personal property which is normally used for personal, family, -or household purposes, or (2) anything designed or sold for incorporation -into a dwelling. In determining whether a product is a consumer product, -doubtful cases shall be resolved in favor of coverage. For a particular -product received by a particular user, "normally used" refers to a -typical or common use of that class of product, regardless of the status -of the particular user or of the way in which the particular user -actually uses, or expects or is expected to use, the product. A product -is a consumer product regardless of whether the product has substantial -commercial, industrial or non-consumer uses, unless such uses represent -the only significant mode of use of the product. - - "Installation Information" for a User Product means any methods, -procedures, authorization keys, or other information required to install -and execute modified versions of a covered work in that User Product from -a modified version of its Corresponding Source. The information must -suffice to ensure that the continued functioning of the modified object -code is in no case prevented or interfered with solely because -modification has been made. - - If you convey an object code work under this section in, or with, or -specifically for use in, a User Product, and the conveying occurs as -part of a transaction in which the right of possession and use of the -User Product is transferred to the recipient in perpetuity or for a -fixed term (regardless of how the transaction is characterized), the -Corresponding Source conveyed under this section must be accompanied -by the Installation Information. But this requirement does not apply -if neither you nor any third party retains the ability to install -modified object code on the User Product (for example, the work has -been installed in ROM). - - The requirement to provide Installation Information does not include a -requirement to continue to provide support service, warranty, or updates -for a work that has been modified or installed by the recipient, or for -the User Product in which it has been modified or installed. Access to a -network may be denied when the modification itself materially and -adversely affects the operation of the network or violates the rules and -protocols for communication across the network. - - Corresponding Source conveyed, and Installation Information provided, -in accord with this section must be in a format that is publicly -documented (and with an implementation available to the public in -source code form), and must require no special password or key for -unpacking, reading or copying. - - 7. Additional Terms. - - "Additional permissions" are terms that supplement the terms of this -License by making exceptions from one or more of its conditions. -Additional permissions that are applicable to the entire Program shall -be treated as though they were included in this License, to the extent -that they are valid under applicable law. If additional permissions -apply only to part of the Program, that part may be used separately -under those permissions, but the entire Program remains governed by -this License without regard to the additional permissions. - - When you convey a copy of a covered work, you may at your option -remove any additional permissions from that copy, or from any part of -it. (Additional permissions may be written to require their own -removal in certain cases when you modify the work.) You may place -additional permissions on material, added by you to a covered work, -for which you have or can give appropriate copyright permission. - - Notwithstanding any other provision of this License, for material you -add to a covered work, you may (if authorized by the copyright holders of -that material) supplement the terms of this License with terms: - - a) Disclaiming warranty or limiting liability differently from the - terms of sections 15 and 16 of this License; or - - b) Requiring preservation of specified reasonable legal notices or - author attributions in that material or in the Appropriate Legal - Notices displayed by works containing it; or - - c) Prohibiting misrepresentation of the origin of that material, or - requiring that modified versions of such material be marked in - reasonable ways as different from the original version; or - - d) Limiting the use for publicity purposes of names of licensors or - authors of the material; or - - e) Declining to grant rights under trademark law for use of some - trade names, trademarks, or service marks; or - - f) Requiring indemnification of licensors and authors of that - material by anyone who conveys the material (or modified versions of - it) with contractual assumptions of liability to the recipient, for - any liability that these contractual assumptions directly impose on - those licensors and authors. - - All other non-permissive additional terms are considered "further -restrictions" within the meaning of section 10. If the Program as you -received it, or any part of it, contains a notice stating that it is -governed by this License along with a term that is a further -restriction, you may remove that term. If a license document contains -a further restriction but permits relicensing or conveying under this -License, you may add to a covered work material governed by the terms -of that license document, provided that the further restriction does -not survive such relicensing or conveying. - - If you add terms to a covered work in accord with this section, you -must place, in the relevant source files, a statement of the -additional terms that apply to those files, or a notice indicating -where to find the applicable terms. - - Additional terms, permissive or non-permissive, may be stated in the -form of a separately written license, or stated as exceptions; -the above requirements apply either way. - - 8. Termination. - - You may not propagate or modify a covered work except as expressly -provided under this License. Any attempt otherwise to propagate or -modify it is void, and will automatically terminate your rights under -this License (including any patent licenses granted under the third -paragraph of section 11). - - However, if you cease all violation of this License, then your -license from a particular copyright holder is reinstated (a) -provisionally, unless and until the copyright holder explicitly and -finally terminates your license, and (b) permanently, if the copyright -holder fails to notify you of the violation by some reasonable means -prior to 60 days after the cessation. - - Moreover, your license from a particular copyright holder is -reinstated permanently if the copyright holder notifies you of the -violation by some reasonable means, this is the first time you have -received notice of violation of this License (for any work) from that -copyright holder, and you cure the violation prior to 30 days after -your receipt of the notice. - - Termination of your rights under this section does not terminate the -licenses of parties who have received copies or rights from you under -this License. If your rights have been terminated and not permanently -reinstated, you do not qualify to receive new licenses for the same -material under section 10. - - 9. Acceptance Not Required for Having Copies. - - You are not required to accept this License in order to receive or -run a copy of the Program. Ancillary propagation of a covered work -occurring solely as a consequence of using peer-to-peer transmission -to receive a copy likewise does not require acceptance. However, -nothing other than this License grants you permission to propagate or -modify any covered work. These actions infringe copyright if you do -not accept this License. Therefore, by modifying or propagating a -covered work, you indicate your acceptance of this License to do so. - - 10. Automatic Licensing of Downstream Recipients. - - Each time you convey a covered work, the recipient automatically -receives a license from the original licensors, to run, modify and -propagate that work, subject to this License. You are not responsible -for enforcing compliance by third parties with this License. - - An "entity transaction" is a transaction transferring control of an -organization, or substantially all assets of one, or subdividing an -organization, or merging organizations. If propagation of a covered -work results from an entity transaction, each party to that -transaction who receives a copy of the work also receives whatever -licenses to the work the party's predecessor in interest had or could -give under the previous paragraph, plus a right to possession of the -Corresponding Source of the work from the predecessor in interest, if -the predecessor has it or can get it with reasonable efforts. - - You may not impose any further restrictions on the exercise of the -rights granted or affirmed under this License. For example, you may -not impose a license fee, royalty, or other charge for exercise of -rights granted under this License, and you may not initiate litigation -(including a cross-claim or counterclaim in a lawsuit) alleging that -any patent claim is infringed by making, using, selling, offering for -sale, or importing the Program or any portion of it. - - 11. Patents. - - A "contributor" is a copyright holder who authorizes use under this -License of the Program or a work on which the Program is based. The -work thus licensed is called the contributor's "contributor version". - - A contributor's "essential patent claims" are all patent claims -owned or controlled by the contributor, whether already acquired or -hereafter acquired, that would be infringed by some manner, permitted -by this License, of making, using, or selling its contributor version, -but do not include claims that would be infringed only as a -consequence of further modification of the contributor version. For -purposes of this definition, "control" includes the right to grant -patent sublicenses in a manner consistent with the requirements of -this License. - - Each contributor grants you a non-exclusive, worldwide, royalty-free -patent license under the contributor's essential patent claims, to -make, use, sell, offer for sale, import and otherwise run, modify and -propagate the contents of its contributor version. - - In the following three paragraphs, a "patent license" is any express -agreement or commitment, however denominated, not to enforce a patent -(such as an express permission to practice a patent or covenant not to -sue for patent infringement). To "grant" such a patent license to a -party means to make such an agreement or commitment not to enforce a -patent against the party. - - If you convey a covered work, knowingly relying on a patent license, -and the Corresponding Source of the work is not available for anyone -to copy, free of charge and under the terms of this License, through a -publicly available network server or other readily accessible means, -then you must either (1) cause the Corresponding Source to be so -available, or (2) arrange to deprive yourself of the benefit of the -patent license for this particular work, or (3) arrange, in a manner -consistent with the requirements of this License, to extend the patent -license to downstream recipients. "Knowingly relying" means you have -actual knowledge that, but for the patent license, your conveying the -covered work in a country, or your recipient's use of the covered work -in a country, would infringe one or more identifiable patents in that -country that you have reason to believe are valid. - - If, pursuant to or in connection with a single transaction or -arrangement, you convey, or propagate by procuring conveyance of, a -covered work, and grant a patent license to some of the parties -receiving the covered work authorizing them to use, propagate, modify -or convey a specific copy of the covered work, then the patent license -you grant is automatically extended to all recipients of the covered -work and works based on it. - - A patent license is "discriminatory" if it does not include within -the scope of its coverage, prohibits the exercise of, or is -conditioned on the non-exercise of one or more of the rights that are -specifically granted under this License. You may not convey a covered -work if you are a party to an arrangement with a third party that is -in the business of distributing software, under which you make payment -to the third party based on the extent of your activity of conveying -the work, and under which the third party grants, to any of the -parties who would receive the covered work from you, a discriminatory -patent license (a) in connection with copies of the covered work -conveyed by you (or copies made from those copies), or (b) primarily -for and in connection with specific products or compilations that -contain the covered work, unless you entered into that arrangement, -or that patent license was granted, prior to 28 March 2007. - - Nothing in this License shall be construed as excluding or limiting -any implied license or other defenses to infringement that may -otherwise be available to you under applicable patent law. - - 12. No Surrender of Others' Freedom. - - If conditions are imposed on you (whether by court order, agreement or -otherwise) that contradict the conditions of this License, they do not -excuse you from the conditions of this License. If you cannot convey a -covered work so as to satisfy simultaneously your obligations under this -License and any other pertinent obligations, then as a consequence you may -not convey it at all. For example, if you agree to terms that obligate you -to collect a royalty for further conveying from those to whom you convey -the Program, the only way you could satisfy both those terms and this -License would be to refrain entirely from conveying the Program. - - 13. Remote Network Interaction; Use with the GNU General Public License. - - Notwithstanding any other provision of this License, if you modify the -Program, your modified version must prominently offer all users -interacting with it remotely through a computer network (if your version -supports such interaction) an opportunity to receive the Corresponding -Source of your version by providing access to the Corresponding Source -from a network server at no charge, through some standard or customary -means of facilitating copying of software. This Corresponding Source -shall include the Corresponding Source for any work covered by version 3 -of the GNU General Public License that is incorporated pursuant to the -following paragraph. - - Notwithstanding any other provision of this License, you have -permission to link or combine any covered work with a work licensed -under version 3 of the GNU General Public License into a single -combined work, and to convey the resulting work. The terms of this -License will continue to apply to the part which is the covered work, -but the work with which it is combined will remain governed by version -3 of the GNU General Public License. - - 14. Revised Versions of this License. - - The Free Software Foundation may publish revised and/or new versions of -the GNU Affero General Public License from time to time. Such new versions -will be similar in spirit to the present version, but may differ in detail to -address new problems or concerns. - - Each version is given a distinguishing version number. If the -Program specifies that a certain numbered version of the GNU Affero General -Public License "or any later version" applies to it, you have the -option of following the terms and conditions either of that numbered -version or of any later version published by the Free Software -Foundation. If the Program does not specify a version number of the -GNU Affero General Public License, you may choose any version ever published -by the Free Software Foundation. - - If the Program specifies that a proxy can decide which future -versions of the GNU Affero General Public License can be used, that proxy's -public statement of acceptance of a version permanently authorizes you -to choose that version for the Program. - - Later license versions may give you additional or different -permissions. However, no additional obligations are imposed on any -author or copyright holder as a result of your choosing to follow a -later version. - - 15. Disclaimer of Warranty. - - THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY -APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT -HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY -OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, -THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM -IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF -ALL NECESSARY SERVICING, REPAIR OR CORRECTION. - - 16. Limitation of Liability. - - IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING -WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS -THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY -GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE -USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF -DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD -PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), -EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF -SUCH DAMAGES. - - 17. Interpretation of Sections 15 and 16. - - If the disclaimer of warranty and limitation of liability provided -above cannot be given local legal effect according to their terms, -reviewing courts shall apply local law that most closely approximates -an absolute waiver of all civil liability in connection with the -Program, unless a warranty or assumption of liability accompanies a -copy of the Program in return for a fee. - - END OF TERMS AND CONDITIONS - - How to Apply These Terms to Your New Programs - - If you develop a new program, and you want it to be of the greatest -possible use to the public, the best way to achieve this is to make it -free software which everyone can redistribute and change under these terms. - - To do so, attach the following notices to the program. It is safest -to attach them to the start of each source file to most effectively -state the exclusion of warranty; and each file should have at least -the "copyright" line and a pointer to where the full notice is found. - - - Copyright (C) - - This program is free software: you can redistribute it and/or modify - it under the terms of the GNU Affero General Public License as published by - the Free Software Foundation, either version 3 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU Affero General Public License for more details. - - You should have received a copy of the GNU Affero General Public License - along with this program. If not, see . - -Also add information on how to contact you by electronic and paper mail. - - If your software can interact with users remotely through a computer -network, you should also make sure that it provides a way for users to -get its source. For example, if your program is a web application, its -interface could display a "Source" link that leads users to an archive -of the code. There are many ways you could offer source, and different -solutions will be better for different programs; see section 13 for the -specific requirements. - - You should also get your employer (if you work as a programmer) or school, -if any, to sign a "copyright disclaimer" for the program, if necessary. -For more information on this, and how to apply and follow the GNU AGPL, see -. diff --git a/libs/brig-types/brig-types.cabal b/libs/brig-types/brig-types.cabal deleted file mode 100644 index 2ce9b7dc42f..00000000000 --- a/libs/brig-types/brig-types.cabal +++ /dev/null @@ -1,154 +0,0 @@ -cabal-version: 1.12 -name: brig-types -version: 1.35.0 -synopsis: User Service -category: Network -author: Wire Swiss GmbH -maintainer: Wire Swiss GmbH -copyright: (c) 2017 Wire Swiss GmbH -license: AGPL-3 -license-file: LICENSE -build-type: Simple - -library - exposed-modules: - Brig.Types.Activation - Brig.Types.Connection - Brig.Types.Intra - Brig.Types.Provider.Tag - Brig.Types.Team - Brig.Types.Team.LegalHold - Brig.Types.Test.Arbitrary - Brig.Types.User - - other-modules: Paths_brig_types - hs-source-dirs: src - default-extensions: - AllowAmbiguousTypes - BangPatterns - ConstraintKinds - DataKinds - DefaultSignatures - DeriveFunctor - DeriveGeneric - DeriveLift - DeriveTraversable - DerivingStrategies - DerivingVia - DuplicateRecordFields - EmptyCase - FlexibleContexts - FlexibleInstances - FunctionalDependencies - GADTs - InstanceSigs - KindSignatures - LambdaCase - MultiParamTypeClasses - MultiWayIf - NamedFieldPuns - NoImplicitPrelude - OverloadedRecordDot - OverloadedStrings - PackageImports - PatternSynonyms - PolyKinds - QuasiQuotes - RankNTypes - ScopedTypeVariables - StandaloneDeriving - TupleSections - TypeApplications - TypeFamilies - TypeFamilyDependencies - TypeOperators - UndecidableInstances - ViewPatterns - - ghc-options: - -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates - -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path - -funbox-strict-fields -Wredundant-constraints -Wunused-packages - - build-depends: - base >=4 && <5 - , cassandra-util - , containers >=0.5 - , imports - , QuickCheck >=2.9 - , types-common >=0.16 - , wire-api - - default-language: GHC2021 - -test-suite brig-types-tests - type: exitcode-stdio-1.0 - main-is: Main.hs - other-modules: - Paths_brig_types - Test.Brig.Roundtrip - Test.Brig.Types.Common - Test.Brig.Types.Team - Test.Brig.Types.User - - hs-source-dirs: test/unit - default-extensions: - AllowAmbiguousTypes - BangPatterns - ConstraintKinds - DataKinds - DefaultSignatures - DeriveFunctor - DeriveGeneric - DeriveLift - DeriveTraversable - DerivingStrategies - DerivingVia - DuplicateRecordFields - EmptyCase - FlexibleContexts - FlexibleInstances - FunctionalDependencies - GADTs - InstanceSigs - KindSignatures - LambdaCase - MultiParamTypeClasses - MultiWayIf - NamedFieldPuns - NoImplicitPrelude - OverloadedRecordDot - OverloadedStrings - PackageImports - PatternSynonyms - PolyKinds - QuasiQuotes - RankNTypes - ScopedTypeVariables - StandaloneDeriving - TupleSections - TypeApplications - TypeFamilies - TypeFamilyDependencies - TypeOperators - UndecidableInstances - ViewPatterns - - ghc-options: - -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates - -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path - -threaded -with-rtsopts=-N -Wredundant-constraints - -Wunused-packages - - build-depends: - aeson >=2.0.1.0 - , base >=4 && <5 - , brig-types - , imports - , openapi3 - , QuickCheck >=2.9 - , tasty - , tasty-quickcheck - , wire-api - - default-language: GHC2021 diff --git a/libs/brig-types/default.nix b/libs/brig-types/default.nix deleted file mode 100644 index 4611943535f..00000000000 --- a/libs/brig-types/default.nix +++ /dev/null @@ -1,45 +0,0 @@ -# WARNING: GENERATED FILE, DO NOT EDIT. -# This file is generated by running hack/bin/generate-local-nix-packages.sh and -# must be regenerated whenever local packages are added or removed, or -# dependencies are added or removed. -{ mkDerivation -, aeson -, base -, cassandra-util -, containers -, gitignoreSource -, imports -, lib -, openapi3 -, QuickCheck -, tasty -, tasty-quickcheck -, types-common -, wire-api -}: -mkDerivation { - pname = "brig-types"; - version = "1.35.0"; - src = gitignoreSource ./.; - libraryHaskellDepends = [ - base - cassandra-util - containers - imports - QuickCheck - types-common - wire-api - ]; - testHaskellDepends = [ - aeson - base - imports - openapi3 - QuickCheck - tasty - tasty-quickcheck - wire-api - ]; - description = "User Service"; - license = lib.licenses.agpl3Only; -} diff --git a/libs/brig-types/src/Brig/Types/Activation.hs b/libs/brig-types/src/Brig/Types/Activation.hs deleted file mode 100644 index 14d0ca030a3..00000000000 --- a/libs/brig-types/src/Brig/Types/Activation.hs +++ /dev/null @@ -1,26 +0,0 @@ --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module Brig.Types.Activation - ( ActivationPair, - ) -where - -import Wire.API.User.Activation - --- | A pair of 'ActivationKey' and 'ActivationCode' as required for activation. -type ActivationPair = (ActivationKey, ActivationCode) diff --git a/libs/brig-types/src/Brig/Types/Connection.hs b/libs/brig-types/src/Brig/Types/Connection.hs deleted file mode 100644 index 83345069204..00000000000 --- a/libs/brig-types/src/Brig/Types/Connection.hs +++ /dev/null @@ -1,27 +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 . - --- | > docs/reference/user/connection.md {#RefConnection} --- --- Types for connections between users. -module Brig.Types.Connection - ( UserIds (..), - UpdateConnectionsInternal (..), - ) -where - -import Wire.API.User diff --git a/libs/brig-types/src/Brig/Types/Intra.hs b/libs/brig-types/src/Brig/Types/Intra.hs deleted file mode 100644 index 6b0a81ca597..00000000000 --- a/libs/brig-types/src/Brig/Types/Intra.hs +++ /dev/null @@ -1,25 +0,0 @@ --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module Brig.Types.Intra - ( User (..), - NewUserScimInvitation (..), - UserSet (..), - ) -where - -import Wire.API.User diff --git a/libs/brig-types/src/Brig/Types/Team.hs b/libs/brig-types/src/Brig/Types/Team.hs deleted file mode 100644 index 06ddae0800e..00000000000 --- a/libs/brig-types/src/Brig/Types/Team.hs +++ /dev/null @@ -1,20 +0,0 @@ --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module Brig.Types.Team (module M) where - -import Wire.API.Team.Size as M diff --git a/libs/brig-types/src/Brig/Types/Team/LegalHold.hs b/libs/brig-types/src/Brig/Types/Team/LegalHold.hs deleted file mode 100644 index fd3c1601727..00000000000 --- a/libs/brig-types/src/Brig/Types/Team/LegalHold.hs +++ /dev/null @@ -1,26 +0,0 @@ --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module Brig.Types.Team.LegalHold - ( LegalHoldService (..), - legalHoldService, - viewLegalHoldService, - LegalHoldClientRequest (..), - ) -where - -import Wire.API.Team.LegalHold.Internal diff --git a/libs/brig-types/src/Brig/Types/Test/Arbitrary.hs b/libs/brig-types/src/Brig/Types/Test/Arbitrary.hs deleted file mode 100644 index fd00582837d..00000000000 --- a/libs/brig-types/src/Brig/Types/Test/Arbitrary.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module Brig.Types.Test.Arbitrary - ( module Wire.Arbitrary, - ) -where - -import Brig.Types.Team.LegalHold -import Imports -import Test.QuickCheck -import Wire.Arbitrary - -instance Arbitrary LegalHoldClientRequest where - arbitrary = - LegalHoldClientRequest - <$> arbitrary - <*> arbitrary - -instance Arbitrary LegalHoldService where - arbitrary = LegalHoldService <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary diff --git a/libs/brig-types/src/Brig/Types/User.hs b/libs/brig-types/src/Brig/Types/User.hs deleted file mode 100644 index 75dfe18f59a..00000000000 --- a/libs/brig-types/src/Brig/Types/User.hs +++ /dev/null @@ -1,25 +0,0 @@ --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module Brig.Types.User - ( ManagedByUpdate (..), - RichInfoUpdate (..), - PasswordResetPair, - ) -where - -import Wire.API.User diff --git a/libs/brig-types/src/Brig/Types/User/Auth.hs b/libs/brig-types/src/Brig/Types/User/Auth.hs deleted file mode 100644 index 378f49f53bd..00000000000 --- a/libs/brig-types/src/Brig/Types/User/Auth.hs +++ /dev/null @@ -1,66 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module Brig.Types.User.Auth - ( SsoLogin (..), - LegalHoldLogin (..), - ) -where - -import Data.Aeson -import Data.Id (UserId) -import Data.Misc (PlainTextPassword6) -import Imports -import Wire.API.User.Auth - --- | A special kind of login that is only used for an internal endpoint. -data SsoLogin - = SsoLogin !UserId !(Maybe CookieLabel) - --- | A special kind of login that is only used for an internal endpoint. --- This kind of login returns restricted 'LegalHoldUserToken's instead of regular --- tokens. -data LegalHoldLogin - = LegalHoldLogin !UserId !(Maybe PlainTextPassword6) !(Maybe CookieLabel) - -instance FromJSON SsoLogin where - parseJSON = withObject "SsoLogin" $ \o -> - SsoLogin <$> o .: "user" <*> o .:? "label" - -instance ToJSON SsoLogin where - toJSON (SsoLogin uid label) = - object ["user" .= uid, "label" .= label] - -instance FromJSON LegalHoldLogin where - parseJSON = withObject "LegalHoldLogin" $ \o -> - LegalHoldLogin - <$> o - .: "user" - <*> o - .:? "password" - <*> o - .:? "label" - -instance ToJSON LegalHoldLogin where - toJSON (LegalHoldLogin uid password label) = - object - [ "user" .= uid, - "password" .= password, - "label" .= label - ] diff --git a/libs/brig-types/test/unit/Main.hs b/libs/brig-types/test/unit/Main.hs deleted file mode 100644 index a3c1b63c0bd..00000000000 --- a/libs/brig-types/test/unit/Main.hs +++ /dev/null @@ -1,37 +0,0 @@ --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module Main - ( main, - ) -where - -import Imports -import Test.Brig.Types.Common qualified -import Test.Brig.Types.Team qualified -import Test.Brig.Types.User qualified -import Test.Tasty - -main :: IO () -main = - defaultMain $ - testGroup - "Tests" - [ Test.Brig.Types.Common.tests, - Test.Brig.Types.Team.tests, - Test.Brig.Types.User.tests - ] diff --git a/libs/brig-types/test/unit/Test/Brig/Roundtrip.hs b/libs/brig-types/test/unit/Test/Brig/Roundtrip.hs deleted file mode 100644 index d7f91ce70c7..00000000000 --- a/libs/brig-types/test/unit/Test/Brig/Roundtrip.hs +++ /dev/null @@ -1,57 +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.Brig.Roundtrip where - -import Data.Aeson (FromJSON, ToJSON, parseJSON, toJSON) -import Data.Aeson.Types (parseEither) -import Data.OpenApi (ToSchema, validatePrettyToJSON) -import Imports -import Test.Tasty (TestTree) -import Test.Tasty.QuickCheck (Arbitrary, counterexample, testProperty, (.&&.), (===)) -import Type.Reflection (typeRep) - --- FUTUREWORK: make this an alias for 'testRoundTripWithSwagger' (or just remove the latter). -testRoundTrip :: - forall a. - (Arbitrary a, Typeable a, ToJSON a, FromJSON a, Eq a, Show a) => - TestTree -testRoundTrip = testProperty msg trip - where - msg = show (typeRep @a) - trip (v :: a) = - counterexample (show $ toJSON v) $ - Right v === (parseEither parseJSON . toJSON) v - -testRoundTripWithSwagger :: - forall a. - (Arbitrary a, ToJSON a, FromJSON a, ToSchema a, Eq a, Show a) => - TestTree -testRoundTripWithSwagger = testProperty msg (trip .&&. scm) - where - msg = show (typeRep @a) - - trip (v :: a) = - counterexample (show $ toJSON v) $ - Right v === (parseEither parseJSON . toJSON) v - - scm (v :: a) = - counterexample - ( fromMaybe "Schema validation failed, but there were no errors. This looks like a bug in swagger2!" $ - validatePrettyToJSON v - ) - $ isNothing (validatePrettyToJSON v) diff --git a/libs/brig-types/test/unit/Test/Brig/Types/Common.hs b/libs/brig-types/test/unit/Test/Brig/Types/Common.hs deleted file mode 100644 index 92cdd9b7864..00000000000 --- a/libs/brig-types/test/unit/Test/Brig/Types/Common.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} - --- 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 . - --- | This is where currently all the json roundtrip tests happen for brig-types and --- galley-types. -module Test.Brig.Types.Common where - -import Brig.Types.Team.LegalHold -import Brig.Types.Test.Arbitrary () -import Test.Brig.Roundtrip (testRoundTrip) -import Test.Tasty - --- NB: validateEveryToJSON from servant-swagger doesn't render these tests unnecessary! - -tests :: TestTree -tests = - testGroup - "Common (types vs. aeson)" - [ testRoundTrip @LegalHoldService, - testRoundTrip @LegalHoldClientRequest - ] diff --git a/libs/brig-types/test/unit/Test/Brig/Types/Team.hs b/libs/brig-types/test/unit/Test/Brig/Types/Team.hs deleted file mode 100644 index b95b4c72542..00000000000 --- a/libs/brig-types/test/unit/Test/Brig/Types/Team.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# OPTIONS_GHC -Wno-orphans #-} - --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module Test.Brig.Types.Team where - -import Brig.Types.Team -import Imports -import Test.Brig.Roundtrip (testRoundTrip) -import Test.Tasty -import Test.Tasty.QuickCheck (Arbitrary, arbitrary, arbitrarySizedNatural) - -tests :: TestTree -tests = testGroup "Team" $ [testRoundTrip @TeamSize] - -instance Arbitrary TeamSize where - arbitrary = TeamSize <$> arbitrarySizedNatural diff --git a/libs/brig-types/test/unit/Test/Brig/Types/User.hs b/libs/brig-types/test/unit/Test/Brig/Types/User.hs deleted file mode 100644 index 79a848fcef8..00000000000 --- a/libs/brig-types/test/unit/Test/Brig/Types/User.hs +++ /dev/null @@ -1,53 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -Wno-orphans #-} - --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module Test.Brig.Types.User where - -import Brig.Types.Connection (UpdateConnectionsInternal (..)) -import Brig.Types.Intra -import Brig.Types.User (ManagedByUpdate (..), RichInfoUpdate (..)) -import Imports -import Test.Brig.Roundtrip (testRoundTrip, testRoundTripWithSwagger) -import Test.QuickCheck (Arbitrary (arbitrary)) -import Test.Tasty -import Wire.API.Routes.Internal.Brig.EJPD (EJPDRequestBody (..), EJPDResponseBody (..)) -import Wire.API.User.Auth.ReAuth - -tests :: TestTree -tests = testGroup "User (types vs. aeson)" $ roundtripTests - -roundtripTests :: [TestTree] -roundtripTests = - [ testRoundTrip @ManagedByUpdate, - testRoundTrip @ReAuthUser, - testRoundTrip @RichInfoUpdate, - testRoundTrip @NewUserScimInvitation, - testRoundTripWithSwagger @EJPDRequestBody, - testRoundTripWithSwagger @EJPDResponseBody, - testRoundTrip @UpdateConnectionsInternal - ] - -instance Arbitrary ReAuthUser where - arbitrary = ReAuthUser <$> arbitrary <*> arbitrary <*> arbitrary diff --git a/libs/saml2-web-sso/src/SAML2/WebSSO/Config.hs b/libs/saml2-web-sso/src/SAML2/WebSSO/Config.hs index a1a3d92a212..2e8c3ed8d1e 100644 --- a/libs/saml2-web-sso/src/SAML2/WebSSO/Config.hs +++ b/libs/saml2-web-sso/src/SAML2/WebSSO/Config.hs @@ -88,7 +88,7 @@ data ConfigRaw = ConfigRaw instance ToSchema ConfigRaw where schema = - object "ConfigRaw" $ + object $ ConfigRaw <$> (_cfgRawLogLevel .= field "logLevel" schema) <*> (_cfgRawSPHost .= field "spHost" schema) @@ -100,7 +100,7 @@ instance ToSchema ConfigRaw where instance ToSchema MultiIngressDomainConfig where schema = - object "MultiIngressDomainConfig" $ + object $ MultiIngressDomainConfig <$> (_cfgSPAppURI .= field "spAppUri" schema) <*> (_cfgSPSsoURI .= field "spSsoUri" schema) diff --git a/libs/saml2-web-sso/src/SAML2/WebSSO/Orphans.hs b/libs/saml2-web-sso/src/SAML2/WebSSO/Orphans.hs index 6364fe97797..0606a642319 100644 --- a/libs/saml2-web-sso/src/SAML2/WebSSO/Orphans.hs +++ b/libs/saml2-web-sso/src/SAML2/WebSSO/Orphans.hs @@ -66,7 +66,7 @@ instance ToSchema URI where $ (parseURI strictURIParserOptions . Text.encodeUtf8) uriText instance ToSchema Level where - schema = assert exhaustive $ enum @Text "Level" $ mconcat $ el <$> [minBound ..] + schema = assert exhaustive $ enum @Text $ mconcat $ el <$> [minBound ..] where el l = element (Text.pack (show l)) l diff --git a/libs/saml2-web-sso/src/SAML2/WebSSO/Types.hs b/libs/saml2-web-sso/src/SAML2/WebSSO/Types.hs index 93039ca76d7..8041b9bc70e 100644 --- a/libs/saml2-web-sso/src/SAML2/WebSSO/Types.hs +++ b/libs/saml2-web-sso/src/SAML2/WebSSO/Types.hs @@ -166,6 +166,7 @@ import Data.Aeson import Data.Aeson.TH import Data.Bifunctor (first) import Data.CaseInsensitive qualified as CI +import Data.Data (Typeable) import Data.List qualified as L import Data.List.NonEmpty (NonEmpty ((:|))) import Data.List.NonEmpty qualified as NL @@ -271,7 +272,7 @@ data ContactPerson = ContactPerson -- (We may want to replace old template-haskell'ed ToJSON and FromJSON instances in hsaml2, but how?) instance Schema.ToSchema ContactPerson where schema = - Schema.object "ContactPerson" $ + Schema.object $ ContactPerson <$> (_cntType Schema..= Schema.field "type" Schema.schema) <*> (_cntCompany Schema..= Schema.maybe_ (Schema.optField "company" Schema.schema)) @@ -291,7 +292,7 @@ data ContactType -- (We may want to replace old template-haskell'ed ToJSON and FromJSON instances in hsaml2, but how?) instance Schema.ToSchema ContactType where schema = - Schema.enum @ST.Text "ContactType" $ + Schema.enum @ST.Text $ mconcat [ Schema.element "ContactTechnical" ContactTechnical, Schema.element "ContactSupport" ContactSupport, @@ -312,7 +313,7 @@ data IdPMetadata = IdPMetadata instance Schema.ToSchema IdPMetadata where schema = - Schema.object "IdPMetadata" $ + Schema.object $ IdPMetadata <$> (_edIssuer Schema..= Schema.field "issuer" Schema.schema) <*> (_edRequestURI Schema..= Schema.field "requestURI" Schema.schema) @@ -346,9 +347,9 @@ data IdPConfig extra = IdPConfig deriving (Eq, Show, Generic) deriving (FromJSON, ToJSON, S.ToSchema) via (Schema.Schema (IdPConfig extra)) -instance (Schema.ToSchema extra) => Schema.ToSchema (IdPConfig extra) where +instance (Typeable (IdPConfig extra), Schema.ToSchema extra) => Schema.ToSchema (IdPConfig extra) where schema = - Schema.object "IdPConfig" $ + Schema.object $ IdPConfig <$> (_idpId Schema..= Schema.field "id" Schema.schema) <*> (_idpMetadata Schema..= Schema.field "metadata" Schema.schema) diff --git a/libs/schema-profunctor/default.nix b/libs/schema-profunctor/default.nix index bede1bdeae6..6c435f9ba59 100644 --- a/libs/schema-profunctor/default.nix +++ b/libs/schema-profunctor/default.nix @@ -6,10 +6,13 @@ , aeson , aeson-qq , base +, base64-bytestring , bifunctors +, bytestring , comonad , containers , gitignoreSource +, hashable , imports , insert-ordered-containers , lens @@ -29,9 +32,12 @@ mkDerivation { libraryHaskellDepends = [ aeson base + base64-bytestring bifunctors + bytestring comonad containers + hashable imports lens openapi3 diff --git a/libs/schema-profunctor/schema-profunctor.cabal b/libs/schema-profunctor/schema-profunctor.cabal index 45f2696a11b..f7f29931427 100644 --- a/libs/schema-profunctor/schema-profunctor.cabal +++ b/libs/schema-profunctor/schema-profunctor.cabal @@ -62,11 +62,14 @@ library -Wredundant-constraints -Wunused-packages build-depends: - aeson >=2.0.1.0 - , base >=4 && <5 + aeson >=2.0.1.0 + , base >=4 && <5 + , base64-bytestring , bifunctors + , bytestring , comonad , containers + , hashable , imports , lens , openapi3 @@ -83,6 +86,7 @@ test-suite schemas-tests other-modules: Paths_schema_profunctor Test.Data.Schema + Test.Data.Schema.Names hs-source-dirs: test/unit default-extensions: diff --git a/libs/schema-profunctor/src/Data/Schema.hs b/libs/schema-profunctor/src/Data/Schema.hs index 3cb88657d5b..ef62358f138 100644 --- a/libs/schema-profunctor/src/Data/Schema.hs +++ b/libs/schema-profunctor/src/Data/Schema.hs @@ -50,8 +50,13 @@ module Data.Schema declareSwaggerSchema, getName, object, + namedObject, objectWithDocModifier, + namedObjectWithDocModifier, objectOver, + namedObjectOver, + mkSchemaName, + mkSchemaNameWith, jsonObject, jsonValue, field, @@ -67,6 +72,7 @@ module Data.Schema map_, mapWithKeys, enum, + namedEnum, maybe_, maybeWithDefault, bind, @@ -97,6 +103,10 @@ import Control.Monad.Trans.Cont import Data.Aeson.Key qualified as Key import Data.Aeson.Types qualified as A import Data.Bifunctor.Joker +import Data.ByteString.Base64 qualified as Base64 +import Data.ByteString.Builder (integerDec, toLazyByteString) +import Data.ByteString.Lazy qualified as LBS +import Data.Hashable (hash) import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty qualified as NonEmpty import Data.Map qualified as Map @@ -104,13 +114,16 @@ import Data.Monoid hiding (Product) import Data.OpenApi qualified as S import Data.OpenApi.Declare qualified as S import Data.Profunctor (Star (..)) -import Data.Proxy (Proxy (..)) import Data.Set qualified as Set import Data.Text qualified as T +import Data.Text.Encoding qualified as T import Data.Text.Lazy qualified as TL +import Data.Typeable (Proxy (..), typeRep) import Data.Vector qualified as V import Imports hiding (Product) import Numeric.Natural +import Type.Reflection (SomeTypeRep (..), tyConModule, tyConName) +import Type.Reflection qualified as TR type Declare = S.Declare (S.Definitions S.Schema) @@ -401,38 +414,146 @@ tag f = rmap runIdentity . f . rmap Identity -- -- This can be used to convert a combination of schemas obtained using -- 'field' into a single schema for a JSON object. +-- Uses the Typeable instance to automatically generate the schema name. object :: + forall doc doc' a b. + (Typeable a, HasObject doc doc') => + SchemaP doc A.Object [A.Pair] a b -> + SchemaP doc' A.Value A.Value a b +object = namedObject (mkSchemaName @a) + +-- | Version of 'object' that takes an explicit name. +namedObject :: (HasObject doc doc') => Text -> SchemaP doc A.Object [A.Pair] a b -> SchemaP doc' A.Value A.Value a b -object = objectOver id +namedObject name = namedObjectOver id name -- | A version of 'object' for more general input values. +-- Uses the Typeable instance to automatically generate the schema name. -- -- Just like 'fieldOver', but for 'object'. objectOver :: + forall doc doc' v' a b v. + (Typeable a, HasObject doc doc') => + Lens v v' A.Value A.Object -> + SchemaP doc v' [A.Pair] a b -> + SchemaP doc' v A.Value a b +objectOver l = namedObjectOver l (mkSchemaName @a) + +-- | Version of 'objectOver' that takes an explicit name. +namedObjectOver :: (HasObject doc doc') => Lens v v' A.Value A.Object -> Text -> SchemaP doc v' [A.Pair] a b -> SchemaP doc' v A.Value a b -objectOver l name sch = SchemaP (SchemaDoc s) (SchemaIn r) (SchemaOut w) +namedObjectOver l name sch = SchemaP (SchemaDoc s) (SchemaIn r) (SchemaOut w) where parseObject val = ContT $ \k -> A.withObject (T.unpack name) k val r v = runContT (l parseObject v) (schemaIn sch) w x = A.object <$> schemaOut sch x s = mkObject name (schemaDoc sch) +-- | Object and enum schema names by default are the fully qualified +-- name of the haskell type, including type parameters. If that's not +-- unique, we should probably change those type names. This will avoid +-- collisions in the hash table keeping track of all the schema references +-- in the openapi3 package. +-- +-- See test suite for examples. +mkSchemaName :: forall a. (Typeable a) => Text +mkSchemaName = T.pack $ sanitizeSchemaName $ mkSchemaNameInternal @a + +mkSchemaNameWith :: forall a. (Typeable a) => Text -> Text +mkSchemaNameWith extra = T.pack $ sanitizeSchemaName $ T.unpack extra <> " " <> (mkSchemaNameInternal @a) + +-- | Vacuum's yaml parser chokes on '/' in schema names. Let's +-- indulge it, and use a conservative positive filter. +sanitizeSchemaName :: String -> String +sanitizeSchemaName = + rmLeadingUnderscore + . rmTrailingUnderscore + . nubUnderscores + . mconcat + . map + ( \c -> + if c `elem` (['a' .. 'z'] ++ ['A' .. 'Z'] ++ ['0' .. '9'] ++ "._-" :: [Char]) + then [c] + else "_" + ) + where + rmLeadingUnderscore ('_' : n) = n + rmLeadingUnderscore n = n + + rmTrailingUnderscore "_" = "" + rmTrailingUnderscore (c : n) = c : rmTrailingUnderscore n + rmTrailingUnderscore [] = "" + + nubUnderscores ('_' : n@('_' : _)) = nubUnderscores n + nubUnderscores (c : n) = c : nubUnderscores n + nubUnderscores [] = "" + +-- Schema names must be unique in order to avoid name clashes in some +-- hash table in openapi3. +-- +-- Complete representations of the types for which we define schemas +-- can get very long, and vacuum appears to have some length limit on +-- schema names somewhere between 300 and 3000 (it's a bit vague about +-- the details). So we use a human-readable, but not necessarily +-- unique name plus a hash of the complete string representation. + +-- Since even the `typeRep` itself (without all the disambiguiating +-- work), it doesn't do as a human-readable part (might still break +-- vacuum's length limit, plus isn't always all that human-readable). +-- So we nub it if it is longer than 50 characters (might be better +-- than cutting off in keeping the interesting bits). +mkSchemaNameInternal :: forall a. (Typeable a) => String +mkSchemaNameInternal = shortTypeRepString ++ "_" <> uniqueId + where + shortTypeRepString :: String + shortTypeRepString = if length s > 50 then nub s else s + where + s = show $ typeRep (Proxy @a) + + uniqueId = + let hashValue = hash $ uniqueTypeRepString (TR.typeRep @a) + hashBytes = LBS.toStrict $ toLazyByteString $ integerDec $ toInteger hashValue + encoded = Base64.encode hashBytes + in take 12 $ T.unpack $ T.decodeUtf8 encoded + + uniqueTypeRepString :: forall t. TR.TypeRep t -> String + uniqueTypeRepString tr = + case TR.splitApps tr of + (tyCon, []) -> + -- Simple type with no arguments + tyConModule tyCon <> "." <> tyConName tyCon + (tyCon, args) -> + -- Type constructor applied to arguments + let conName = tyConModule tyCon <> "." <> tyConName tyCon + argNames = map (\(SomeTypeRep arg) -> uniqueTypeRepString arg) args + in conName <> " " <> unwords argNames + -- | Like 'object', but apply an arbitrary function to the -- documentation of the resulting object. +-- Uses the Typeable instance to automatically generate the schema name. objectWithDocModifier :: + forall doc doc' a. + (Typeable a, HasObject doc doc') => + (doc' -> doc') -> + ObjectSchema doc a -> + ValueSchema doc' a +objectWithDocModifier = namedObjectWithDocModifier (mkSchemaName @a) + +-- | Version of 'objectWithDocModifier' that takes an explicit name. +namedObjectWithDocModifier :: (HasObject doc doc') => Text -> (doc' -> doc') -> ObjectSchema doc a -> ValueSchema doc' a -objectWithDocModifier name modify sch = over doc modify (object name sch) +namedObjectWithDocModifier name modify sch = over doc modify (namedObject name sch) -- | Turn a named schema into an unnamed one. -- @@ -557,13 +678,23 @@ element label value = SchemaP (SchemaDoc d) (SchemaIn i) (SchemaOut o) -- -- This is used to convert a combination of schemas obtained using -- 'element' into a single schema for a JSON string. +-- | A schema for an enumeration. +-- Uses the Typeable instance to automatically generate the schema name. enum :: + forall v doc a b. + (Typeable b, With v, HasEnum v doc) => + SchemaP [A.Value] v (Alt Maybe v) a b -> + SchemaP doc A.Value A.Value a b +enum = namedEnum (mkSchemaName @b) + +-- | Version of 'enum' that takes an explicit name. +namedEnum :: forall v doc a b. (With v, HasEnum v doc) => Text -> SchemaP [A.Value] v (Alt Maybe v) a b -> SchemaP doc A.Value A.Value a b -enum name sch = SchemaP (SchemaDoc d) (SchemaIn i) (SchemaOut o) +namedEnum name sch = SchemaP (SchemaDoc d) (SchemaIn i) (SchemaOut o) where d = mkEnum @v name (schemaDoc sch) i x = @@ -653,7 +784,7 @@ parsedTextWithDoc desc name parser = appendDescr (text name) `withParser` (eithe -- | A schema for an arbitrary JSON object. jsonObject :: ValueSchema SwaggerDoc A.Object jsonObject = - unnamed . object "Object" $ + unnamed . object $ mkSchema (pure (mempty & S.type_ ?~ S.OpenApiObject)) pure (pure . (^.. ifolded . withIndex)) -- | A schema for an arbitrary JSON value. diff --git a/libs/schema-profunctor/test/unit/Test/Data/Schema.hs b/libs/schema-profunctor/test/unit/Test/Data/Schema.hs index 9164e4af3c1..53ee964d6d3 100644 --- a/libs/schema-profunctor/test/unit/Test/Data/Schema.hs +++ b/libs/schema-profunctor/test/unit/Test/Data/Schema.hs @@ -33,6 +33,7 @@ import Data.Proxy import Data.Schema hiding (getName) import Data.Text qualified as Text import Imports +import Test.Data.Schema.Names import Test.Tasty import Test.Tasty.HUnit @@ -69,7 +70,8 @@ tests = testRmClientWrong, testRmClient, testEnumType, - testNullable + testNullable, + testSchemaNames ] testFooToJSON :: TestTree @@ -112,7 +114,7 @@ testFooSchema = (s ^. S.required) assertEqual "Schema for \"a\" should be referenced" - (Just (S.Ref (S.Reference "A"))) + (Just (S.Ref (S.Reference "A_LTU1Nzc2NDkw"))) (s ^. S.properties . at "a") case s ^. S.properties . at "str" of Nothing -> assertFailure "\"str\" field should be present" @@ -337,7 +339,7 @@ testEnumType :: TestTree testEnumType = testCase "Enum Swagger schema has the correct type" $ do let e1 :: ValueSchema NamedSwaggerDoc Text - e1 = enum @Text "TextEnum" (element "hello" "hello") + e1 = enum @Text (element "hello" "hello") (_, s1) = S.runDeclare (declareSwaggerSchema e1) mempty assertEqual "Text enum has Swagger type \"string\"" @@ -345,7 +347,7 @@ testEnumType = (Just S.OpenApiString) let e2 :: ValueSchema NamedSwaggerDoc Integer - e2 = enum @Integer "IntEnum" (element (3 :: Integer) (3 :: Integer)) + e2 = enum @Integer (element (3 :: Integer) (3 :: Integer)) (_, s2) = S.runDeclare (declareSwaggerSchema e2) mempty assertEqual "Integer enum has Swagger type \"integer\"" @@ -376,7 +378,7 @@ data A = A {thing :: Text, other :: Int} instance ToSchema A where schema = - object "A" $ + object $ A <$> thing .= field "thing" schema <*> other .= field "other" schema @@ -385,7 +387,7 @@ newtype B = B {bThing :: Int} deriving (Eq, Show) instance ToSchema B where - schema = object "B" $ B <$> bThing .= field "b_thing" schema + schema = object $ B <$> bThing .= field "b_thing" schema data Foo = Foo {fooA :: A, fooB :: B, fooStr :: Text} deriving stock (Eq, Show) @@ -410,7 +412,7 @@ exampleFooInvalidJSON = instance ToSchema Foo where schema = (doc . description ?~ "A Foo object") - . object "Foo" + . object $ Foo <$> fooA .= field "a" schema <* (thing . fooA) .= optional (field "a_thing" (unnamed schema)) @@ -455,7 +457,7 @@ data Access = Public | Private | Link | Code instance ToSchema Access where schema = - enum @Text "Access" $ + enum @Text $ element "public" Public <> element "private" Private <> element "link" Link @@ -473,7 +475,7 @@ data User = User instance ToSchema User where schema = - object "User" $ + object $ User <$> userName .= field "name" schema <*> userHandle .= maybe_ (optField "handle" schema) @@ -517,16 +519,16 @@ _Obj2 = prism' Obj2 $ \case _ -> Nothing instance ToSchema Tag where - schema = enum @Text "Tag" (element "tag1" Tag1 <> element "tag2" Tag2) + schema = enum @Text (element "tag1" Tag1 <> element "tag2" Tag2) instance ToSchema TaggedObject where schema = - object "TaggedObject" $ + object $ uncurry TO <$> (toTag &&& toObj) .= bind (fst .= field "tag" schema) - (snd .= fieldOver _1 "obj" (objectOver _1 "UntaggedObject" untaggedSchema)) + (snd .= fieldOver _1 "obj" (objectOver _1 untaggedSchema)) where untaggedSchema = dispatch $ \case Tag1 -> tag _Obj1 (field "tag1_data" schema) @@ -554,14 +556,14 @@ newtype NonEmptyTest = NonEmptyTest {nl :: NonEmpty Text} deriving (ToJSON, FromJSON, S.ToSchema) via Schema NonEmptyTest instance ToSchema NonEmptyTest where - schema = object "NonEmptyTest" $ NonEmptyTest <$> nl .= field "nl" (nonEmptyArray schema) + schema = object $ NonEmptyTest <$> nl .= field "nl" (nonEmptyArray schema) -- references newtype Named = Named {getName :: Text} instance ToSchema Named where - schema = Named <$> getName .= object "Named" (field "name" (text "Name")) + schema = Named <$> getName .= object (field "name" (text "Name")) instance S.ToSchema Named where declareNamedSchema = schemaToSwagger @@ -584,13 +586,13 @@ passwordSchema = schema `withParser` validate -- this is "wrong", because it succeeds even if password validation fails rmClientSchema :: ValueSchema NamedSwaggerDoc RmClient rmClientSchema = - object "RmClient" $ + object $ RmClient <$> rmPassword .= optional (field "password" (maybeWithDefault Null passwordSchema)) instance ToSchema RmClient where schema = - object "RmClient" $ + object $ RmClient <$> rmPassword .= maybe_ (optField "password" passwordSchema) @@ -616,12 +618,12 @@ data DetailTag = NameTag | AgeTag tagSchema :: ValueSchema NamedSwaggerDoc DetailTag tagSchema = - enum @Text "Detail Tag" $ + enum @Text $ mconcat [element "name" NameTag, element "age" AgeTag] detailSchema :: ValueSchema NamedSwaggerDoc Detail detailSchema = - object "Detail" $ + object $ fromTagged <$> toTagged .= bind @@ -641,7 +643,7 @@ detailSchema = userSchemaWithDefaultName' :: ValueSchema NamedSwaggerDoc User userSchemaWithDefaultName' = - object "User" $ + object $ User <$> (getOptText . userName) .= maybe_ (fromMaybe "" <$> optField "name" schema) <*> userHandle .= maybe_ (optField "handle" schema) @@ -653,7 +655,7 @@ userSchemaWithDefaultName' = userSchemaWithDefaultName :: ValueSchema NamedSwaggerDoc User userSchemaWithDefaultName = - object "User" $ + object $ User <$> userName .= (field "name" schema <|> pure "") <*> userHandle .= maybe_ (optField "handle" schema) diff --git a/libs/schema-profunctor/test/unit/Test/Data/Schema/Names.hs b/libs/schema-profunctor/test/unit/Test/Data/Schema/Names.hs new file mode 100644 index 00000000000..7ae7da2157e --- /dev/null +++ b/libs/schema-profunctor/test/unit/Test/Data/Schema/Names.hs @@ -0,0 +1,106 @@ +-- 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.Data.Schema.Names where + +import Data.Schema hiding (getName) +import Imports +import Test.Tasty +import Test.Tasty.HUnit + +newtype UserId = UserId Text + deriving (Eq, Show) + +newtype Qualified a = Qualified a + deriving (Eq, Show) + +testSchemaNames :: TestTree +testSchemaNames = + testGroup + "mkSchemaName" + [ testSimpleType, + testSimpleTypeFromStdLib, + testParameterizedTypeOne, + testParameterizedTypeTwo, + testNestedParameterizedType, + testTupleType, + testListType + ] + +testSimpleType :: TestTree +testSimpleType = + testCase "Simple type from current module" $ + assertEqual + mempty + "UserId_Mzg3ODM1MzE3" + (mkSchemaName @UserId) + +testSimpleTypeFromStdLib :: TestTree +testSimpleTypeFromStdLib = + testCase "Simple type from standard library" $ + assertEqual + mempty + "Int_Mjg5NjU2NjEw" + (mkSchemaName @Int) + +testParameterizedTypeOne :: TestTree +testParameterizedTypeOne = + testCase "Parameterized type with one parameter" $ do + assertEqual + mempty + "Maybe_Int_LTg4NDMwMDQ1" + (mkSchemaName @(Maybe Int)) + assertEqual + mempty + "Qualified_UserId_NjA2MzcwNjQ2" + (mkSchemaName @(Qualified UserId)) + +testParameterizedTypeTwo :: TestTree +testParameterizedTypeTwo = + testCase "Parameterized type with two parameters" $ + assertEqual + mempty + "Either_Int_UserId_OTAzNzE0MzA4" + (mkSchemaName @(Either Int UserId)) + +testNestedParameterizedType :: TestTree +testNestedParameterizedType = + testCase "Nested parameterized types" $ do + assertEqual + mempty + "Maybe_Qualified_UserId_NjE1MjgxNDQz" + (mkSchemaName @(Maybe (Qualified UserId))) + assertEqual + mempty + "Qualified_Maybe_Int_LTU0NDY2MjU1" + (mkSchemaName @(Qualified (Maybe Int))) + +testTupleType :: TestTree +testTupleType = + testCase "Tuple types" $ + assertEqual + mempty + "Int_UserId_LTgwNjYzNzA2" + (mkSchemaName @(Int, UserId)) + +testListType :: TestTree +testListType = + testCase "List type" $ + assertEqual + mempty + "UserId_LTc0Mjg2NTY2" + (mkSchemaName @[UserId]) diff --git a/libs/types-common/src/Data/Code.hs b/libs/types-common/src/Data/Code.hs index 6bba1c5f087..c5b55a701b7 100644 --- a/libs/types-common/src/Data/Code.hs +++ b/libs/types-common/src/Data/Code.hs @@ -125,7 +125,7 @@ data KeyValuePair = KeyValuePair instance ToSchema KeyValuePair where schema = - object "KeyValuePair" $ + object $ KeyValuePair <$> key .= field "key" schema <*> code .= field "code" schema diff --git a/libs/types-common/src/Data/HavePendingInvitations.hs b/libs/types-common/src/Data/HavePendingInvitations.hs index d04a020b7f2..8c38f3de986 100644 --- a/libs/types-common/src/Data/HavePendingInvitations.hs +++ b/libs/types-common/src/Data/HavePendingInvitations.hs @@ -31,7 +31,7 @@ data HavePendingInvitations deriving (FromJSON, ToJSON, S.ToSchema) via Schema HavePendingInvitations instance ToSchema HavePendingInvitations where - schema = enum @Bool "HavePendingInvitations" $ mconcat [element True WithPendingInvitations, element False NoPendingInvitations] + schema = enum @Bool $ mconcat [element True WithPendingInvitations, element False NoPendingInvitations] fromBool :: Bool -> HavePendingInvitations fromBool True = WithPendingInvitations diff --git a/libs/types-common/src/Data/Id.hs b/libs/types-common/src/Data/Id.hs index ba6e6c21d2c..87b51358ae7 100644 --- a/libs/types-common/src/Data/Id.hs +++ b/libs/types-common/src/Data/Id.hs @@ -484,8 +484,8 @@ newtype IdObject a = IdObject {fromIdObject :: a} deriving (Eq, Show, Generic) deriving (ToJSON, FromJSON, S.ToSchema) via Schema (IdObject a) -instance (ToSchema a) => ToSchema (IdObject a) where +instance (Typeable a, ToSchema a) => ToSchema (IdObject a) where schema = idObjectSchema (IdObject <$> fromIdObject .= schema) -idObjectSchema :: ValueSchemaP NamedSwaggerDoc a b -> ValueSchemaP NamedSwaggerDoc a b -idObjectSchema sch = object "Id" (field "id" sch) +idObjectSchema :: (Typeable a) => ValueSchemaP NamedSwaggerDoc a b -> ValueSchemaP NamedSwaggerDoc a b +idObjectSchema sch = object (field "id" sch) diff --git a/libs/types-common/src/Data/LegalHold.hs b/libs/types-common/src/Data/LegalHold.hs index 247684fee78..f7666513ae1 100644 --- a/libs/types-common/src/Data/LegalHold.hs +++ b/libs/types-common/src/Data/LegalHold.hs @@ -40,7 +40,7 @@ data UserLegalHoldStatus instance ToSchema UserLegalHoldStatus where schema = (S.schema . description ?~ desc) $ - enum @Text "UserLegalHoldStatus" $ + enum @Text $ element "enabled" UserLegalHoldEnabled <> element "pending" UserLegalHoldPending <> element "disabled" UserLegalHoldDisabled diff --git a/libs/types-common/src/Data/Qualified.hs b/libs/types-common/src/Data/Qualified.hs index fc59fd841cc..4c3da13f926 100644 --- a/libs/types-common/src/Data/Qualified.hs +++ b/libs/types-common/src/Data/Qualified.hs @@ -189,14 +189,13 @@ deprecatedSchema new = . (deprecated ?~ True) qualifiedSchema :: - (HasSchemaRef doc) => + (Typeable a, HasSchemaRef doc) => Text -> Text -> ValueSchema doc a -> ValueSchema NamedSwaggerDoc (Qualified a) -qualifiedSchema name fieldName sch = - object ("Qualified_" <> name) $ - qualifiedObjectSchema fieldName sch +qualifiedSchema _name fieldName sch = + object $ qualifiedObjectSchema fieldName sch qualifiedObjectSchema :: (HasSchemaRef d) => @@ -208,16 +207,16 @@ qualifiedObjectSchema fieldName sch = <$> qDomain .= field "domain" schema <*> qUnqualified .= field fieldName sch -instance (KnownIdTag t) => ToSchema (Qualified (Id t)) where +instance (Typeable t, KnownIdTag t) => ToSchema (Qualified (Id t)) where schema = qualifiedSchema (idTagName (idTagValue @t) <> "Id") "id" schema instance ToSchema (Qualified Handle) where schema = qualifiedSchema "Handle" "handle" schema -instance (KnownIdTag t) => ToJSON (Qualified (Id t)) where +instance (Typeable t, KnownIdTag t) => ToJSON (Qualified (Id t)) where toJSON = schemaToJSON -instance (KnownIdTag t) => FromJSON (Qualified (Id t)) where +instance (Typeable t, KnownIdTag t) => FromJSON (Qualified (Id t)) where parseJSON = schemaParseJSON instance (Typeable t, KnownIdTag t) => S.ToSchema (Qualified (Id t)) where diff --git a/libs/types-common/src/Util/Options.hs b/libs/types-common/src/Util/Options.hs index 9fa6117aede..93a7239fe37 100644 --- a/libs/types-common/src/Util/Options.hs +++ b/libs/types-common/src/Util/Options.hs @@ -118,20 +118,9 @@ getOptions desc mp defaultPath = do (header desc <> fullDesc) exists <- doesFileExist path case (exists, mOpts) of - -- config file exists, take options from there - (True, _) -> do - decodeFileEither path >>= \case - Left e -> - fail $ - show e - <> " while attempting to decode " - <> path - Right o -> pure o - -- config doesn't exist, take options from command line + (True, _) -> decodeConfigFileUnsafe path (False, Just opts) -> pure opts - -- no config, no parser, just fail - (False, Nothing) -> - fail $ "Config file at " <> path <> " does not exist." + (False, Nothing) -> fail $ "Config file at " <> path <> " does not exist." where optsOrConfigFile :: Parser (FilePath, Maybe a) optsOrConfigFile = @@ -145,6 +134,23 @@ getOptions desc mp defaultPath = do ) <*> sequenceA mp +decodeConfigFile :: (FromJSON a) => FilePath -> IO a +decodeConfigFile path = do + exists <- doesFileExist path + if exists + then decodeConfigFileUnsafe path + else fail $ "Config file at " <> path <> " does not exist." + +decodeConfigFileUnsafe :: (FromJSON a) => FilePath -> IO a +decodeConfigFileUnsafe path = do + decodeFileEither path >>= \case + Left e -> + fail $ + show e + <> " while attempting to decode " + <> path + Right o -> pure o + parseAWSEndpoint :: ReadM AWSEndpoint parseAWSEndpoint = readerAsk >>= maybe (error "Could not parse AWS endpoint") pure . fromByteString . fromString diff --git a/libs/wai-utilities/src/Network/Wai/Utilities/JSONResponse.hs b/libs/wai-utilities/src/Network/Wai/Utilities/JSONResponse.hs index c7238eaf9b0..318f5206804 100644 --- a/libs/wai-utilities/src/Network/Wai/Utilities/JSONResponse.hs +++ b/libs/wai-utilities/src/Network/Wai/Utilities/JSONResponse.hs @@ -50,7 +50,7 @@ data JSONResponse = JSONResponse instance ToSchema JSONResponse where schema = - object "JSONResponse" $ + object $ JSONResponse <$> status .= field "status" (toEnum <$> (fromEnum .= schema)) <*> value .= field "value" jsonValue diff --git a/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs b/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs index b07b18fc863..f6b4fc02c35 100644 --- a/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs +++ b/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs @@ -97,6 +97,7 @@ newSettings :: Server -> Settings newSettings (Server h p l t) = setHost (fromString h) . setPort (fromIntegral p) + . setServerName "" . setBeforeMainLoop logStart . setOnOpen (const $ connStart >> pure True) . setOnClose (const connEnd) diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API.hs b/libs/wire-api-federation/src/Wire/API/Federation/API.hs index 73dbbeded3b..704d8a3a0a0 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/API.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/API.hs @@ -128,7 +128,7 @@ fedClientIn :: fedClientIn = clientIn (Proxy @api) (Proxy @m) sendBundle :: - (KnownComponent c) => + (Typeable c, KnownComponent c) => PayloadBundle c -> FedQueueClient c () sendBundle bundle = do @@ -147,7 +147,8 @@ sendBundle bundle = do fedQueueClient :: forall {k} (tag :: k) c. - ( HasNotificationEndpoint tag, + ( Typeable c, + HasNotificationEndpoint tag, HasVersionRange tag, HasFedPath tag, KnownComponent (NotificationComponent k), diff --git a/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs b/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs index 2e780eab99f..ac1e0e03cd9 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs @@ -65,7 +65,7 @@ data BackendNotification = BackendNotification instance ToSchema BackendNotification where schema = - object "BackendNotification" $ + object $ BackendNotification <$> ownDomain .= field "ownDomain" schema <*> targetComponent .= field "targetComponent" schema @@ -110,9 +110,9 @@ newtype PayloadBundle (c :: Component) = PayloadBundle deriving (A.ToJSON, A.FromJSON) via (Schema (PayloadBundle c)) deriving newtype (Semigroup) -instance ToSchema (PayloadBundle c) where +instance (Typeable c) => ToSchema (PayloadBundle c) where schema = - object "PayloadBundle" $ + object $ PayloadBundle <$> notifications .= field "notifications" (nonEmptyArray schema) diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Version.hs b/libs/wire-api-federation/src/Wire/API/Federation/Version.hs index 4c141c20fe9..5e2f016901a 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/Version.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/Version.hs @@ -79,7 +79,7 @@ intToVersion intV = find (\v -> versionInt v == intV) [minBound ..] instance ToSchema Version where schema = - enum @Integer "Version" . mconcat $ + enum @Integer . mconcat $ [ element 0 V0, element 1 V1, element 2 V2, @@ -96,7 +96,7 @@ data VersionInfo = VersionInfo instance ToSchema VersionInfo where schema = - objectWithDocModifier "VersionInfo" (S.schema . S.example ?~ toJSON example) $ + objectWithDocModifier (S.schema . S.example ?~ toJSON example) $ VersionInfo -- if the supported_versions field does not exist, assume an old backend -- that only supports V0 @@ -147,7 +147,7 @@ deriving instance Ord VersionRange instance ToSchema VersionRange where schema = - object "VersionRange" $ + object $ VersionRange <$> _fromVersion .= field "from" schema <*> (versionFromUpperBound . _toVersionExcl) diff --git a/libs/wire-api/src/Wire/API/Asset.hs b/libs/wire-api/src/Wire/API/Asset.hs index ac51bde02f9..d54acd2a80d 100644 --- a/libs/wire-api/src/Wire/API/Asset.hs +++ b/libs/wire-api/src/Wire/API/Asset.hs @@ -127,7 +127,7 @@ mkAsset k = Asset k Nothing Nothing instance ToSchema Asset where schema = - object "Asset" $ + object $ Asset <$> _assetKey .= ( Qualified @@ -231,7 +231,7 @@ newtype NewAssetToken = NewAssetToken instance ToSchema NewAssetToken where schema = - object "NewAssetToken" $ + object $ NewAssetToken <$> newAssetToken .= field "token" schema -------------------------------------------------------------------------------- @@ -308,7 +308,7 @@ defAssetSettings = AssetSettings False Nothing Nothing Nothing Nothing instance ToSchema AssetSettings where schema = - object "AssetSettings" $ + object $ AssetSettings <$> _setAssetPublic .= (fromMaybe False <$> optField "public" schema) <*> _setAssetRetention .= maybe_ (optField "retention" schema) @@ -389,7 +389,7 @@ retentionToTextRep AssetExpiring = "expiring" instance ToSchema AssetRetention where schema = - enum @Text "AssetRetention" $ + enum @Text $ foldMap (\value -> element (retentionToTextRep value) value) [minBound .. maxBound] diff --git a/libs/wire-api/src/Wire/API/BackgroundJobs.hs b/libs/wire-api/src/Wire/API/BackgroundJobs.hs index f0432d2f535..78f179ed955 100644 --- a/libs/wire-api/src/Wire/API/BackgroundJobs.hs +++ b/libs/wire-api/src/Wire/API/BackgroundJobs.hs @@ -51,7 +51,7 @@ data JobPayloadTag instance ToSchema JobPayloadTag where schema = - enum @Text "JobPayloadTag" $ + enum @Text $ mconcat [ element "sync-user-group-and-channel" JobSyncUserGroupAndChannelTag, element "sync-user-group" JobSyncUserGroupTag @@ -78,7 +78,7 @@ data SyncUserGroupAndChannel = SyncUserGroupAndChannel instance ToSchema SyncUserGroupAndChannel where schema = - object "SyncUserGroupAndChannel" $ + object $ SyncUserGroupAndChannel <$> (.teamId) .= field "team_id" schema <*> (.userGroupId) .= field "user_group_id" schema @@ -96,7 +96,7 @@ data SyncUserGroup = SyncUserGroup instance ToSchema SyncUserGroup where schema = - object "SyncUserGroup" $ + object $ SyncUserGroup <$> (.teamId) .= field "team_id" schema <*> (.userGroupId) .= field "user_group_id" schema @@ -118,7 +118,7 @@ jobPayloadObjectSchema = JobSyncUserGroupTag -> tag _JobSyncUserGroup (field "payload" schema) instance ToSchema JobPayload where - schema = object "JobPayload" jobPayloadObjectSchema + schema = object jobPayloadObjectSchema deriving via (Schema JobPayload) instance Aeson.FromJSON JobPayload @@ -138,7 +138,7 @@ data Job = Job instance ToSchema Job where schema = - object "Job" $ + object $ Job <$> jobId .= field "id" schema <*> requestId .= field "requestId" schema diff --git a/libs/wire-api/src/Wire/API/Bot.hs b/libs/wire-api/src/Wire/API/Bot.hs index 6c82112f721..c2d4b576310 100644 --- a/libs/wire-api/src/Wire/API/Bot.hs +++ b/libs/wire-api/src/Wire/API/Bot.hs @@ -54,7 +54,7 @@ addBot = AddBot instance ToSchema AddBot where schema = - object "AddBot" $ + object $ AddBot <$> _addBotService .= field "service" schema <*> _addBotConv .= field "conversation" schema @@ -74,7 +74,7 @@ removeBot = RemoveBot instance ToSchema RemoveBot where schema = - object "RemoveBot" $ + object $ RemoveBot <$> _rmBotConv .= field "conversation" schema <*> _rmBotId .= field "bot" schema diff --git a/libs/wire-api/src/Wire/API/Bot/Service.hs b/libs/wire-api/src/Wire/API/Bot/Service.hs index 05554f34da6..cfb4623a1e6 100644 --- a/libs/wire-api/src/Wire/API/Bot/Service.hs +++ b/libs/wire-api/src/Wire/API/Bot/Service.hs @@ -53,7 +53,7 @@ newService ref url tok fps = Service ref url tok fps True instance ToSchema Service where schema = - object "BotService" $ + object $ Service <$> _serviceRef .= field "ref" schema <*> _serviceUrl .= field "base_url" schema diff --git a/libs/wire-api/src/Wire/API/Call/Config.hs b/libs/wire-api/src/Wire/API/Call/Config.hs index e0fafcf1f6f..b58f82a5a33 100644 --- a/libs/wire-api/src/Wire/API/Call/Config.hs +++ b/libs/wire-api/src/Wire/API/Call/Config.hs @@ -138,7 +138,7 @@ rtcConfiguration = RTCConfiguration instance ToSchema RTCConfiguration where schema = - objectWithDocModifier "RTCConfiguration" (description ?~ "A subset of the WebRTC 'RTCConfiguration' dictionary") $ + objectWithDocModifier (description ?~ "A subset of the WebRTC 'RTCConfiguration' dictionary") $ RTCConfiguration <$> _rtcConfIceServers .= fieldWithDocModifier "ice_servers" (description ?~ "Array of 'RTCIceServer' objects") (nonEmptyArray schema) @@ -163,7 +163,7 @@ newtype SFTServer = SFTServer instance ToSchema SFTServer where schema = - objectWithDocModifier "SftServer" (description ?~ "Inspired by WebRTC 'RTCIceServer' object, contains details of SFT servers") $ + objectWithDocModifier (description ?~ "Inspired by WebRTC 'RTCIceServer' object, contains details of SFT servers") $ SFTServer <$> (pure . _sftURL) .= fieldWithDocModifier "urls" (description ?~ "Array containing exactly one SFT server address of the form 'https://:'") (withParser (array schema) p) @@ -189,7 +189,7 @@ data AuthSFTServer = AuthSFTServer instance ToSchema AuthSFTServer where schema = - objectWithDocModifier "SftServer" (description ?~ "Inspired by WebRTC 'RTCIceServer' object, contains details of SFT servers") $ + objectWithDocModifier (description ?~ "Inspired by WebRTC 'RTCIceServer' object, contains details of SFT servers") $ AuthSFTServer <$> (pure . _authURL) .= fieldWithDocModifier "urls" (description ?~ "Array containing exactly one SFT server address of the form 'https://:'") (withParser (array schema) p) @@ -228,7 +228,7 @@ rtcIceServer = RTCIceServer instance ToSchema RTCIceServer where schema = - objectWithDocModifier "RTCIceServer" (description ?~ "A subset of the WebRTC 'RTCIceServer' object") $ + objectWithDocModifier (description ?~ "A subset of the WebRTC 'RTCIceServer' object") $ RTCIceServer <$> _iceURLs .= fieldWithDocModifier "urls" (description ?~ "Array of TURN server addresses of the form 'turn::'") (nonEmptyArray schema) @@ -323,7 +323,7 @@ instance BC.FromByteString Scheme where instance ToSchema Scheme where schema = - enum @Text "Scheme" $ + enum @Text $ mconcat [ element "turn" SchemeTurn, element "turns" SchemeTurns @@ -343,7 +343,7 @@ data TurnHostTag = TurnHostIpTag | TurnHostNameTag tagSchema :: ValueSchema NamedSwaggerDoc TurnHostTag tagSchema = - enum @Text "TurnHostTag" $ + enum @Text $ mconcat [ element "TurnHostIp" TurnHostIpTag, element "TurnHostName" TurnHostNameTag @@ -351,7 +351,7 @@ tagSchema = turnHostSchema :: ValueSchema NamedSwaggerDoc TurnHost turnHostSchema = - object "TurnHost" $ + object $ fromTagged <$> toTagged .= bind @@ -431,7 +431,7 @@ instance BC.FromByteString Transport where instance ToSchema Transport where schema = - enum @Text "Transport" $ + enum @Text $ mconcat [ element "udp" TransportUDP, element "tcp" TransportTCP diff --git a/libs/wire-api/src/Wire/API/Component.hs b/libs/wire-api/src/Wire/API/Component.hs index 607a1fc6619..079bdef2c81 100644 --- a/libs/wire-api/src/Wire/API/Component.hs +++ b/libs/wire-api/src/Wire/API/Component.hs @@ -58,7 +58,7 @@ data Component instance ToSchema Component where schema = - enum @Text "Component" $ + enum @Text $ mconcat [ element "brig" Brig, element "galley" Galley, diff --git a/libs/wire-api/src/Wire/API/Connection.hs b/libs/wire-api/src/Wire/API/Connection.hs index d7843692c5e..0eba6606ea5 100644 --- a/libs/wire-api/src/Wire/API/Connection.hs +++ b/libs/wire-api/src/Wire/API/Connection.hs @@ -86,7 +86,7 @@ data UserConnectionList = UserConnectionList instance ToSchema UserConnectionList where schema = - object "UserConnectionList" $ + object $ UserConnectionList <$> clConnections .= field "connections" (array schema) <*> clHasMore .= fieldWithDocModifier "has_more" (description ?~ "Indicator that the server has more connections than returned.") schema @@ -113,7 +113,7 @@ data UserConnection = UserConnection instance ToSchema UserConnection where schema = - object "UserConnection" $ + object $ UserConnection <$> ucFrom .= field "from" schema <*> ucTo .= field "qualified_to" schema @@ -197,7 +197,7 @@ relationDropHistory = \case instance ToSchema Relation where schema = - enum @Text "Relation" $ + enum @Text $ mconcat [ element "accepted" Accepted, element "blocked" Blocked, @@ -282,7 +282,7 @@ data ConnectionRequest = ConnectionRequest instance ToSchema ConnectionRequest where schema = - object "ConnectionRequest" $ + object $ ConnectionRequest <$> crUser .= fieldWithDocModifier "user" (description ?~ "user ID of the user to request a connection with") schema <*> crName .= fieldWithDocModifier "name" (description ?~ "Name of the (pending) conversation being initiated (1 - 256) characters)") schema @@ -297,6 +297,6 @@ newtype ConnectionUpdate = ConnectionUpdate instance ToSchema ConnectionUpdate where schema = - object "ConnectionUpdate" $ + object $ ConnectionUpdate <$> cuStatus .= fieldWithDocModifier "status" (description ?~ "New relation status") schema diff --git a/libs/wire-api/src/Wire/API/Conversation.hs b/libs/wire-api/src/Wire/API/Conversation.hs index 915fafd535e..ac954d93d98 100644 --- a/libs/wire-api/src/Wire/API/Conversation.hs +++ b/libs/wire-api/src/Wire/API/Conversation.hs @@ -244,14 +244,13 @@ conversationMetadataObjectSchema sch = <*> cnvmHistory .= (fromMaybe def <$> optField "history" schema) instance ToSchema ConversationMetadata where - schema = object "ConversationMetadata" (conversationMetadataObjectSchema accessRolesSchema) + schema = object (conversationMetadataObjectSchema accessRolesSchema) instance ToSchema (Versioned 'V2 ConversationMetadata) where schema = Versioned <$> unVersioned .= object - "ConversationMetadata" (conversationMetadataObjectSchema accessRolesSchemaV2) instance HasCellsState ConversationMetadata where @@ -323,8 +322,8 @@ conversationSchema :: Maybe Version -> ValueSchema NamedSwaggerDoc OwnConversation conversationSchema v = - objectWithDocModifier - ("OwnConversation" <> foldMap (Text.toUpper . versionText) v) + versionedObjectWithDocModifier + v (DS.description ?~ "A conversation object as returned from the server") (ownConversationObjectSchema v) @@ -355,7 +354,6 @@ data Conversation = Conversation instance ToSchema Conversation where schema = objectWithDocModifier - "Conversation" (DS.description ?~ "A conversation object as returned from the server") $ conversationObjectSchema @@ -373,13 +371,12 @@ data MLSOne2OneConversation a = MLSOne2OneConversation } deriving (ToJSON, FromJSON, S.ToSchema) via (Schema (MLSOne2OneConversation a)) -instance (ToSchema a) => ToSchema (MLSOne2OneConversation a) where +instance (Typeable a, ToSchema a) => ToSchema (MLSOne2OneConversation a) where schema = - let aName = maybe "" ("_" <>) $ getName (schemaDoc (schema @a)) - in object ("MLSOne2OneConversation" <> aName) $ - MLSOne2OneConversation - <$> (.conversation) .= field "conversation" schema - <*> publicKeys .= field "public_keys" schema + object $ + MLSOne2OneConversation + <$> (.conversation) .= field "conversation" schema + <*> publicKeys .= field "public_keys" schema -- | The public-facing conversation type extended with information on which -- remote users could not be added when creating the conversation. @@ -402,7 +399,6 @@ instance (SingI v) => ToSchema (Versioned v CreateGroupOwnConversation) where createGroupConversationSchema :: Maybe Version -> ValueSchema NamedSwaggerDoc CreateGroupOwnConversation createGroupConversationSchema v = objectWithDocModifier - "CreateGroupOwnConversation" (DS.description ?~ "A created group-conversation object extended with a list of failed-to-add users") $ CreateGroupOwnConversation <$> cgcConversation .= ownConversationObjectSchema v @@ -427,7 +423,6 @@ data CreateGroupConversation = CreateGroupConversation instance ToSchema CreateGroupConversation where schema = objectWithDocModifier - "CreateGroupConversation" (DS.description ?~ "A created group-conversation object extended with a list of failed-to-add users") $ CreateGroupConversation <$> (.conversation) .= conversationObjectSchema @@ -449,7 +444,6 @@ data ConversationCoverView = ConversationCoverView instance ToSchema ConversationCoverView where schema = objectWithDocModifier - "ConversationCoverView" (DS.description ?~ "Limited view of Conversation.") $ ConversationCoverView <$> cnvCoverConvId .= field "id" schema @@ -473,7 +467,7 @@ instance ConversationListItem ConvId where instance ConversationListItem OwnConversation where convListItemName _ = "conversations" -instance (ConversationListItem a, ToSchema a) => ToSchema (ConversationList a) where +instance (Typeable a, ConversationListItem a, ToSchema a) => ToSchema (ConversationList a) where schema = conversationListSchema schema instance ToSchema (Versioned 'V2 (ConversationList OwnConversation)) where @@ -484,12 +478,11 @@ instance ToSchema (Versioned 'V2 (ConversationList OwnConversation)) where conversationListSchema :: forall a. - (ConversationListItem a) => + (Typeable a, ConversationListItem a) => ValueSchema NamedSwaggerDoc a -> ValueSchema NamedSwaggerDoc (ConversationList a) conversationListSchema sch = objectWithDocModifier - "ConversationList" (DS.description ?~ "Object holding a list of " <> convListItemName (Proxy @a)) $ ConversationList <$> convList .= field "conversations" (array sch) @@ -528,7 +521,6 @@ newtype ListConversations = ListConversations instance ToSchema ListConversations where schema = objectWithDocModifier - "ListConversations" (DS.description ?~ "A request to list some of a user's conversations, including remote ones. Maximum 1000 qualified conversation IDs") $ ListConversations <$> (fromRange . lcQualifiedIds) .= field "qualified_ids" (rangedSchema (array schema)) @@ -547,8 +539,8 @@ conversationsResponseSchema :: conversationsResponseSchema v = let notFoundDoc = DS.description ?~ "These conversations either don't exist or are deleted." failedDoc = DS.description ?~ "The server failed to fetch these conversations, most likely due to network issues while contacting a remote server" - in objectWithDocModifier - ("ConversationsResponse" <> foldMap (Text.toUpper . versionText) v) + in versionedObjectWithDocModifier + v (DS.description ?~ "Response object for getting metadata of a list of conversations") $ ConversationsResponse <$> crFound .= field "found" (array (conversationSchema v)) @@ -581,7 +573,7 @@ data Access instance ToSchema Access where schema = (S.schema . DS.description ?~ "How users can join conversations") $ - enum @Text "Access" $ + enum @Text $ mconcat [ element "private" PrivateAccess, element "invite" InviteAccess, @@ -726,7 +718,7 @@ toAccessRoleLegacy accessRoles = do instance ToSchema AccessRole where schema = (S.schema . DS.description ?~ desc) $ - enum @Text "AccessRole" $ + enum @Text $ mconcat [ element "team_member" TeamMemberAccessRole, element "non_team_member" NonTeamMemberAccessRole, @@ -747,7 +739,7 @@ instance ToSchema AccessRoleLegacy where schema = (S.schema . S.deprecated ?~ True) $ (S.schema . DS.description ?~ desc) $ - enum @Text "AccessRoleLegacy" $ + enum @Text $ mconcat [ element "private" PrivateAccessRole, element "team" TeamAccessRole, @@ -781,7 +773,7 @@ data ConvType instance ToSchema ConvType where schema = - enum @Integer "ConvType" $ + enum @Integer $ mconcat [ element 0 RegularConv, element 1 SelfConv, @@ -852,7 +844,7 @@ data GroupConvType = GroupConversation | Channel | MeetingConversation instance ToSchema GroupConvType where schema = - enum @Text "GroupConvType" $ + enum @Text $ mconcat [ element "group_conversation" GroupConversation, element "channel" Channel, @@ -910,8 +902,8 @@ newConvSchema :: ObjectSchema SwaggerDoc (Maybe (Set AccessRole)) -> ValueSchema NamedSwaggerDoc NewConv newConvSchema v sch = - objectWithDocModifier - ("NewConv" <> foldMap (Text.toUpper . versionText) v) + versionedObjectWithDocModifier + v (DS.description ?~ "JSON object to create a new conversation. When using 'qualified_users' (preferred), you can omit 'users'") $ NewConv <$> newConvUsers @@ -1008,7 +1000,6 @@ managedDesc = instance ToSchema ConvTeamInfo where schema = objectWithDocModifier - "ConvTeamInfo" (DS.description ?~ "Team information") $ ConvTeamInfo <$> cnvTeamId .= field "teamid" schema @@ -1036,7 +1027,6 @@ data NewOne2OneConv = NewOne2OneConv instance ToSchema NewOne2OneConv where schema = objectWithDocModifier - "NewOne2OneConv" (DS.description ?~ "JSON object to create a new 1:1 conversation. When using 'qualified_users' (preferred), you can omit 'users'") $ NewOne2OneConv <$> (.users) @@ -1085,7 +1075,7 @@ data Invite = Invite -- Deprecated, use InviteQualified (and maybe rename?) instance ToSchema Invite where schema = - object "Invite" $ + object $ Invite <$> (.invUsers) .= field "users" (nonEmptyArray schema) @@ -1103,7 +1093,7 @@ data InviteQualified = InviteQualified instance ToSchema InviteQualified where schema = - object "InviteQualified" $ + object $ InviteQualified <$> (.users) .= field "qualified_users" (nonEmptyArray schema) <*> roleName .= (fromMaybe roleNameWireAdmin <$> optField "conversation_role" schema) @@ -1118,7 +1108,7 @@ data InviteQualifiedInternal = InviteQualifiedInternal instance ToSchema InviteQualifiedInternal where schema = - object "InviteQualifiedInternal" $ + object $ InviteQualifiedInternal <$> (.actor) .= field "actor" schema <*> (.invite) .= field "invite" schema @@ -1135,7 +1125,7 @@ newtype ConversationRename = ConversationRename instance ToSchema ConversationRename where schema = - object "ConversationRename" $ + object $ ConversationRename <$> cupName .= fieldWithDocModifier @@ -1155,7 +1145,7 @@ data ConversationAccessData = ConversationAccessData conversationAccessDataSchema :: Maybe Version -> ValueSchema NamedSwaggerDoc ConversationAccessData conversationAccessDataSchema v = - object ("ConversationAccessData" <> foldMap (Text.toUpper . versionText) v) $ + versionedObject v $ ConversationAccessData <$> cupAccess .= field "access" (set schema) <*> cupAccessRoles .= accessRolesVersionedSchema v @@ -1175,7 +1165,7 @@ data ConversationReceiptModeUpdate = ConversationReceiptModeUpdate instance ToSchema ConversationReceiptModeUpdate where schema = - objectWithDocModifier "ConversationReceiptModeUpdate" (DS.description ?~ desc) $ + objectWithDocModifier (DS.description ?~ desc) $ ConversationReceiptModeUpdate <$> cruReceiptMode .= field "receipt_mode" (unnamed schema) where @@ -1195,7 +1185,6 @@ data ConversationMessageTimerUpdate = ConversationMessageTimerUpdate instance ToSchema ConversationMessageTimerUpdate where schema = objectWithDocModifier - "ConversationMessageTimerUpdate" (DS.description ?~ "Contains conversation properties to update") $ ConversationMessageTimerUpdate <$> cupMessageTimer .= optField "message_timer" (maybeWithDefault A.Null schema) @@ -1210,7 +1199,7 @@ instance Default JoinType where instance ToSchema JoinType where schema = - enum @Text "JoinType" $ + enum @Text $ mconcat [ element "external_add" ExternalAdd, element "internal_add" InternalAdd @@ -1228,7 +1217,6 @@ data ConversationJoin = ConversationJoin instance ToSchema ConversationJoin where schema = objectWithDocModifier - "ConversationJoin" (DS.description ?~ "The action of some users joining a conversation") $ ConversationJoin <$> (.users) .= field "users" (nonEmptyArray schema) @@ -1246,7 +1234,6 @@ data ConversationMemberUpdate = ConversationMemberUpdate instance ToSchema ConversationMemberUpdate where schema = objectWithDocModifier - "ConversationMemberUpdate" (DS.description ?~ "The action of promoting/demoting a member of a conversation") $ ConversationMemberUpdate <$> cmuTarget .= field "target" schema @@ -1263,7 +1250,6 @@ data ConversationRemoveMembers = ConversationRemoveMembers instance ToSchema ConversationRemoveMembers where schema = objectWithDocModifier - "ConversationRemoveMembers" (DS.description ?~ "The action of removing members from a conversation") $ ConversationRemoveMembers <$> crmTargets .= field "targets" (nonEmptyArray schema) @@ -1290,7 +1276,7 @@ instance Default AddPermission where instance ToSchema AddPermission where schema = - enum @Text "AddPermission" $ + enum @Text $ mconcat [ element "admins" Admins, element "everyone" Everyone @@ -1318,7 +1304,6 @@ newtype AddPermissionUpdate = AddPermissionUpdate instance ToSchema AddPermissionUpdate where schema = objectWithDocModifier - "AddPermissionUpdate" (DS.description ?~ "The action of changing the permission to add members to a channel") $ AddPermissionUpdate <$> addPermission .= field "add_permission" schema @@ -1336,7 +1321,6 @@ instance Default ExtraConversationData where instance ToSchema ExtraConversationData where schema = objectWithDocModifier - "ExtraConversationData" (DS.description ?~ "Extra conversation data, used for group conversations") $ ExtraConversationData <$> newGroupId .= optField "group_id" (maybeWithDefault A.Null schema) @@ -1350,7 +1334,7 @@ data ConversationHistoryUpdate = ConversationHistoryUpdate instance ToSchema ConversationHistoryUpdate where schema = - object "ConversationHistoryUpdate" $ + object $ ConversationHistoryUpdate <$> (.history) .= field "history" schema diff --git a/libs/wire-api/src/Wire/API/Conversation/Action.hs b/libs/wire-api/src/Wire/API/Conversation/Action.hs index 415bbeede91..0d480912b93 100644 --- a/libs/wire-api/src/Wire/API/Conversation/Action.hs +++ b/libs/wire-api/src/Wire/API/Conversation/Action.hs @@ -150,14 +150,12 @@ conversationActionSchema :: forall tag. Sing tag -> ValueSchema NamedSwaggerDoc conversationActionSchema SConversationJoinTag = schema @ConversationJoin conversationActionSchema SConversationLeaveTag = objectWithDocModifier - "ConversationLeave" (S.description ?~ "The action of some users leaving a conversation on their own") $ pure () conversationActionSchema SConversationRemoveMembersTag = schema conversationActionSchema SConversationMemberUpdateTag = schema @ConversationMemberUpdate conversationActionSchema SConversationDeleteTag = objectWithDocModifier - "ConversationDelete" (S.description ?~ "The action of deleting a conversation") (pure ()) conversationActionSchema SConversationRenameTag = schema diff --git a/libs/wire-api/src/Wire/API/Conversation/Action/Tag.hs b/libs/wire-api/src/Wire/API/Conversation/Action/Tag.hs index 47488f460af..90aa92757e7 100644 --- a/libs/wire-api/src/Wire/API/Conversation/Action/Tag.hs +++ b/libs/wire-api/src/Wire/API/Conversation/Action/Tag.hs @@ -67,7 +67,7 @@ instance Arbitrary ConversationActionTag where instance ToSchema ConversationActionTag where schema = - enum @Text "ConversationActionTag" $ + enum @Text $ mconcat [ element "ConversationJoinTag" ConversationJoinTag, element "ConversationLeaveTag" ConversationLeaveTag, diff --git a/libs/wire-api/src/Wire/API/Conversation/Bot.hs b/libs/wire-api/src/Wire/API/Conversation/Bot.hs index a6878f3835d..84d9f6ee7dc 100644 --- a/libs/wire-api/src/Wire/API/Conversation/Bot.hs +++ b/libs/wire-api/src/Wire/API/Conversation/Bot.hs @@ -52,7 +52,7 @@ data AddBot = AddBot instance ToSchema AddBot where schema = - object "AddBot" $ + object $ AddBot <$> addBotProvider .= field "provider" schema <*> addBotService .= field "service" schema @@ -72,7 +72,7 @@ data AddBotResponse = AddBotResponse instance ToSchema AddBotResponse where schema = - object "AddBotResponse" $ + object $ AddBotResponse <$> rsAddBotId .= field "id" schema <*> rsAddBotClient .= field "client" schema @@ -95,7 +95,7 @@ newtype RemoveBotResponse = RemoveBotResponse instance ToSchema RemoveBotResponse where schema = - object "RemoveBotResponse" $ + object $ RemoveBotResponse <$> rsRemoveBotEvent .= field "event" schema @@ -111,6 +111,6 @@ newtype UpdateBotPrekeys = UpdateBotPrekeys instance ToSchema UpdateBotPrekeys where schema = - object "UpdateBotPrekeys" $ + object $ UpdateBotPrekeys <$> updateBotPrekeyList .= field "prekeys" (array schema) diff --git a/libs/wire-api/src/Wire/API/Conversation/CellsState.hs b/libs/wire-api/src/Wire/API/Conversation/CellsState.hs index b6084cb440d..fe327c06e12 100644 --- a/libs/wire-api/src/Wire/API/Conversation/CellsState.hs +++ b/libs/wire-api/src/Wire/API/Conversation/CellsState.hs @@ -43,7 +43,7 @@ instance Default CellsState where instance ToSchema CellsState where schema = - enum @Text "CellsState" $ + enum @Text $ mconcat [ element "disabled" CellsDisabled, element "pending" CellsPending, diff --git a/libs/wire-api/src/Wire/API/Conversation/Code.hs b/libs/wire-api/src/Wire/API/Conversation/Code.hs index c80b588c535..579562f3b28 100644 --- a/libs/wire-api/src/Wire/API/Conversation/Code.hs +++ b/libs/wire-api/src/Wire/API/Conversation/Code.hs @@ -57,7 +57,6 @@ instance ToSchema CreateConversationCodeRequest where schema :: ValueSchema NamedSwaggerDoc CreateConversationCodeRequest schema = objectWithDocModifier - "CreateConversationCodeRequest" (description ?~ "Request body for creating a conversation code") $ CreateConversationCodeRequest <$> (.password) .= maybe_ (optFieldWithDocModifier "password" desc schema) @@ -75,7 +74,6 @@ data JoinConversationByCode = JoinConversationByCode instance ToSchema JoinConversationByCode where schema = objectWithDocModifier - "JoinConversationByCode" (description ?~ "Request body for joining a conversation by code") $ JoinConversationByCode <$> (.code) .= conversationCodeObjectSchema @@ -106,7 +104,6 @@ conversationCodeObjectSchema = instance ToSchema ConversationCode where schema = objectWithDocModifier - "ConversationCode" (description ?~ "Contains conversation properties to update") conversationCodeObjectSchema @@ -122,7 +119,6 @@ data ConversationCodeInfo = ConversationCodeInfo instance ToSchema ConversationCodeInfo where schema = objectWithDocModifier - "ConversationCodeInfo" (description ?~ "Contains conversation properties to update") $ ConversationCodeInfo <$> (.code) .= conversationCodeObjectSchema diff --git a/libs/wire-api/src/Wire/API/Conversation/Config.hs b/libs/wire-api/src/Wire/API/Conversation/Config.hs index 6565fbd1d1e..b9617cc3175 100644 --- a/libs/wire-api/src/Wire/API/Conversation/Config.hs +++ b/libs/wire-api/src/Wire/API/Conversation/Config.hs @@ -40,7 +40,7 @@ data ConversationSubsystemConfig = ConversationSubsystemConfig instance ToSchema ConversationSubsystemConfig where schema = - object "ConversationSubsystemConfig" $ + object $ ConversationSubsystemConfig <$> (.mlsKeys) .= maybe_ (optField "mls_keys" schema) <*> (.federationProtocols) .= maybe_ (optField "federation_protocols" (array schema)) diff --git a/libs/wire-api/src/Wire/API/Conversation/Member.hs b/libs/wire-api/src/Wire/API/Conversation/Member.hs index e496b1708e0..7ed8bcce16b 100644 --- a/libs/wire-api/src/Wire/API/Conversation/Member.hs +++ b/libs/wire-api/src/Wire/API/Conversation/Member.hs @@ -64,7 +64,7 @@ data OwnConvMembers = OwnConvMembers instance ToSchema OwnConvMembers where schema = - objectWithDocModifier "OwnConvMembers" (description ?~ "Users of a conversation") $ + objectWithDocModifier (description ?~ "Users of a conversation") $ OwnConvMembers <$> cmSelf .= fieldWithDocModifier @@ -90,7 +90,7 @@ data ConvMembers = ConvMembers instance ToSchema ConvMembers where schema = - objectWithDocModifier "ConvMembers" (description ?~ "Users of a conversation") $ + objectWithDocModifier (description ?~ "Users of a conversation") $ ConvMembers <$> self .= maybe_ (optFieldWithDocModifier "self" selfDesc schema) <*> others .= fieldWithDocModifier "others" othersDesc (array schema) @@ -132,7 +132,7 @@ defMember uid = instance ToSchema Member where schema = - object "Member" $ + object $ Member <$> memId .= field "qualified_id" schema <* (qUnqualified . memId) @@ -177,7 +177,7 @@ data OtherMember = OtherMember instance ToSchema OtherMember where schema = - object "OtherMember" $ + object $ OtherMember <$> omQualifiedId .= field "qualified_id" schema <* (qUnqualified . omQualifiedId) .= optional (field "id" schema) @@ -212,7 +212,7 @@ memberUpdate = MemberUpdate Nothing Nothing Nothing Nothing Nothing Nothing instance ToSchema MemberUpdate where schema = (`withParser` (either fail pure . validateMemberUpdate)) - . object "MemberUpdate" + . object $ MemberUpdate <$> mupOtrMuteStatus .= maybe_ (optField "otr_muted_status" schema) <*> mupOtrMuteRef .= maybe_ (optField "otr_muted_ref" schema) @@ -255,7 +255,6 @@ instance ToSchema OtherMemberUpdate where schema = (`withParser` (either fail pure . validateOtherMemberUpdate)) . objectWithDocModifier - "OtherMemberUpdate" (description ?~ "Update user properties of other members relative to a conversation") $ OtherMemberUpdate <$> omuConvRoleName .= maybe_ (optField "conversation_role" schema) diff --git a/libs/wire-api/src/Wire/API/Conversation/Pagination.hs b/libs/wire-api/src/Wire/API/Conversation/Pagination.hs index 034f508b501..faa674c2765 100644 --- a/libs/wire-api/src/Wire/API/Conversation/Pagination.hs +++ b/libs/wire-api/src/Wire/API/Conversation/Pagination.hs @@ -33,7 +33,7 @@ newtype ConversationPage = ConversationPage {page :: [ConversationSearchResult]} instance ToSchema ConversationPage where schema = - objectWithDocModifier "ConversationPage" addPageDocs $ + objectWithDocModifier addPageDocs $ ConversationPage <$> page .= field "page" (array schema) instance Arbitrary ConversationPage where @@ -52,7 +52,7 @@ data ConversationSearchResult = ConversationSearchResult instance ToSchema ConversationSearchResult where schema = - object "ConversationSearchResult" $ + object $ ConversationSearchResult <$> (.convId) .= field "id" schema <*> (.name) .= maybe_ (optField "name" schema) diff --git a/libs/wire-api/src/Wire/API/Conversation/Protocol.hs b/libs/wire-api/src/Wire/API/Conversation/Protocol.hs index e41ad2f7207..fa46c8e9181 100644 --- a/libs/wire-api/src/Wire/API/Conversation/Protocol.hs +++ b/libs/wire-api/src/Wire/API/Conversation/Protocol.hs @@ -174,10 +174,10 @@ optionalActiveMLSConversationDataSchema _ = mk epoch ts cs = ActiveMLSConversationData epoch <$> ts <*> cs instance ToSchema ConversationMLSData where - schema = object "ConversationMLSData" (mlsDataSchema Nothing) + schema = object (mlsDataSchema Nothing) instance ToSchema (Versioned 'V5 ConversationMLSData) where - schema = Versioned <$> object "ConversationMLSDataV5" (unVersioned .= mlsDataSchema (Just V5)) + schema = Versioned <$> object (unVersioned .= mlsDataSchema (Just V5)) -- TODO: Fix API compatibility data ActiveMLSConversationData = ActiveMLSConversationData @@ -193,7 +193,7 @@ data ActiveMLSConversationData = ActiveMLSConversationData deriving (ToJSON, FromJSON) via Schema ActiveMLSConversationData instance ToSchema ActiveMLSConversationData where - schema = object "ActiveMLSConversationData" activeMLSConversationDataSchema + schema = object activeMLSConversationDataSchema activeMLSConversationDataSchema :: ObjectSchema SwaggerDoc ActiveMLSConversationData activeMLSConversationDataSchema = @@ -231,7 +231,7 @@ protocolTag (ProtocolMixed _) = ProtocolMixedTag instance ToSchema ProtocolTag where schema = - enum @Text "Protocol" $ + enum @Text $ mconcat [ element "proteus" ProtocolProteusTag, element "mls" ProtocolMLSTag, @@ -254,10 +254,10 @@ protocolSchema v = (snd .= dispatch (protocolDataSchema v)) instance ToSchema Protocol where - schema = object "Protocol" (protocolSchema Nothing) + schema = object (protocolSchema Nothing) instance ToSchema (Versioned 'V5 Protocol) where - schema = object "Protocol" (Versioned <$> unVersioned .= protocolSchema (Just V5)) + schema = object (Versioned <$> unVersioned .= protocolSchema (Just V5)) deriving via (Schema Protocol) instance FromJSON Protocol @@ -275,7 +275,7 @@ newtype ProtocolUpdate = ProtocolUpdate {unProtocolUpdate :: ProtocolTag} deriving (Arbitrary) via GenericUniform ProtocolUpdate instance ToSchema ProtocolUpdate where - schema = object "ProtocolUpdate" (ProtocolUpdate <$> unProtocolUpdate .= protocolTagSchema) + schema = object (ProtocolUpdate <$> unProtocolUpdate .= protocolTagSchema) deriving via (Schema ProtocolUpdate) instance FromJSON ProtocolUpdate diff --git a/libs/wire-api/src/Wire/API/Conversation/Typing.hs b/libs/wire-api/src/Wire/API/Conversation/Typing.hs index 076dbde5e47..82e5e93ac25 100644 --- a/libs/wire-api/src/Wire/API/Conversation/Typing.hs +++ b/libs/wire-api/src/Wire/API/Conversation/Typing.hs @@ -35,11 +35,11 @@ data TypingStatus instance ToSchema TypingStatus where schema = - object "TypingData" $ + object $ field "status" typingStatusSchema typingStatusSchema :: ValueSchema NamedSwaggerDoc TypingStatus typingStatusSchema = - enum @Text "TypingStatus" $ + enum @Text $ element "started" StartedTyping <> element "stopped" StoppedTyping diff --git a/libs/wire-api/src/Wire/API/CustomBackend.hs b/libs/wire-api/src/Wire/API/CustomBackend.hs index f7c12e0140d..42c7a0997e3 100644 --- a/libs/wire-api/src/Wire/API/CustomBackend.hs +++ b/libs/wire-api/src/Wire/API/CustomBackend.hs @@ -40,7 +40,7 @@ data CustomBackend = CustomBackend instance ToSchema CustomBackend where schema = - objectWithDocModifier "CustomBackend" (description ?~ "Description of a custom backend") $ + objectWithDocModifier (description ?~ "Description of a custom backend") $ CustomBackend <$> backendConfigJsonUrl .= fieldWithDocModifier "config_json_url" (description ?~ "the location of the custom backend's config.json file") schema <*> backendWebappWelcomeUrl .= fieldWithDocModifier "webapp_welcome_url" (description ?~ "the location of the custom webapp") schema diff --git a/libs/wire-api/src/Wire/API/EnterpriseLogin.hs b/libs/wire-api/src/Wire/API/EnterpriseLogin.hs index 78e78da4a95..19aecc414bc 100644 --- a/libs/wire-api/src/Wire/API/EnterpriseLogin.hs +++ b/libs/wire-api/src/Wire/API/EnterpriseLogin.hs @@ -87,7 +87,7 @@ domainRedirectTag PreAuthorized = PreAuthorizedTag instance ToSchema DomainRedirectTag where schema = - enum @Text "DomainRedirect Tag" $ + enum @Text $ mconcat [ element "none" NoneTag, element "locked" LockedTag, @@ -146,7 +146,7 @@ domainRedirectSchema v = backendConfigObjectSchema :: ValueSchema NamedSwaggerDoc (HttpsUrl, Maybe HttpsUrl) backendConfigObjectSchema = - object "BackendConfig" $ + object $ (,) <$> fst .= field "config_url" schema <*> snd .= maybe_ (optField "webapp_url" schema) @@ -155,7 +155,7 @@ samlIdPIdObjectSchema :: ObjectSchema SwaggerDoc SAML.IdPId samlIdPIdObjectSchema = SAML.IdPId <$> SAML.fromIdPId .= field "sso_code" uuidSchema instance ToSchema DomainRedirect where - schema = object "DomainRedirect " (domainRedirectSchema V10) + schema = object (domainRedirectSchema V10) deriving via (Schema DomainRedirect) instance FromJSON DomainRedirect @@ -184,7 +184,7 @@ data TeamInviteTag instance ToSchema TeamInviteTag where schema = - enum @Text "TeamInvite Tag" $ + enum @Text $ mconcat [ element "allowed" AllowedTag, element "not-allowed" NotAllowedTag, @@ -214,7 +214,7 @@ teamInviteObjectSchema = TeamTag -> tag _Team (field "team" schema) instance ToSchema TeamInvite where - schema = object "TeamInvite" teamInviteObjectSchema + schema = object teamInviteObjectSchema deriving via (Schema TeamInvite) instance FromJSON TeamInvite @@ -255,7 +255,7 @@ instance Arbitrary DomainRegistrationUpdate where instance ToSchema DomainRegistrationUpdate where schema = - object "DomainRegistrationUpdate" $ + object $ DomainRegistrationUpdate <$> (.domainRedirect) .= domainRedirectSchema V10 <*> (.teamInvite) .= teamInviteObjectSchema @@ -273,9 +273,9 @@ data DomainRegistrationResponse (v :: Version) = DomainRegistrationResponse mkDomainRegistrationResponse :: DomainRegistration -> DomainRegistrationResponse v mkDomainRegistrationResponse DomainRegistration {..} = DomainRegistrationResponse {..} -instance (SingI v) => ToSchema (DomainRegistrationResponse v) where +instance (Typeable v, SingI v) => ToSchema (DomainRegistrationResponse v) where schema = - object "DomainRegistrationResponse" $ + object $ DomainRegistrationResponse <$> (.domain) .= field "domain" schema <*> (.authorizedTeam) .= maybe_ (optField "authorized_team" schema) diff --git a/libs/wire-api/src/Wire/API/Error.hs b/libs/wire-api/src/Wire/API/Error.hs index a1899f9f6ca..76aa9c0517c 100644 --- a/libs/wire-api/src/Wire/API/Error.hs +++ b/libs/wire-api/src/Wire/API/Error.hs @@ -144,7 +144,7 @@ dynError = dynError' $ seSing @e staticErrorSchema :: SStaticError e -> ValueSchema NamedSwaggerDoc (SStaticError e) staticErrorSchema e@(SStaticError c l m) = - objectWithDocModifier "Error" addExample $ + objectWithDocModifier addExample $ SStaticError <$> (c <$ (const code .= field "code" codeSchema)) <*> (l <$ (const label .= field "label" labelSchema)) @@ -157,9 +157,9 @@ staticErrorSchema e@(SStaticError c l m) = addExample = S.schema . S.example ?~ A.toJSON e labelSchema :: ValueSchema SwaggerDoc Text - labelSchema = unnamed $ enum @Text "Label" (element label label) + labelSchema = unnamed $ enum @Text (element label label) codeSchema :: ValueSchema SwaggerDoc Natural - codeSchema = unnamed $ enum @Natural "Status" (element code code) + codeSchema = unnamed $ enum @Natural (element code code) instance (KnownError e) => ToSchema (SStaticError e) where schema = staticErrorSchema seSing diff --git a/libs/wire-api/src/Wire/API/Error/Galley.hs b/libs/wire-api/src/Wire/API/Error/Galley.hs index 0ce4976f735..7c57f12f1ab 100644 --- a/libs/wire-api/src/Wire/API/Error/Galley.hs +++ b/libs/wire-api/src/Wire/API/Error/Galley.hs @@ -531,7 +531,7 @@ nonFederatingBackendsFromList domains = instance ToSchema NonFederatingBackends where schema = - object "NonFederatingBackends" $ + object $ withParser (nonFederatingBackendsToList .= field "non_federating_backends" (array schema)) nonFederatingBackendsFromList @@ -575,7 +575,7 @@ unreachableBackendsStatus = HTTP.mkStatus 533 "Unreachable backends" instance ToSchema UnreachableBackends where schema = - object "UnreachableBackends" $ + object $ UnreachableBackends <$> (.backends) .= field "unreachable_backends" (array schema) @@ -651,14 +651,14 @@ instance APIError GroupInfoDiagnostics where indexedClientSchema :: ValueSchema NamedSwaggerDoc (Int, ClientIdentity) indexedClientSchema = - object "IndexedClient" $ + object $ (,) <$> fst .= field "index" schema <*> snd .= field "client" schema instance ToSchema GroupInfoDiagnostics where schema = - object "GroupInfoDiagnostics" $ + object $ GroupInfoDiagnostics <$> (.commit) .= field "commit" base64Schema <*> (.groupInfo) .= field "group_info" base64Schema @@ -717,7 +717,7 @@ mlsOutOfSyncErrorObjectSchema = <$> (.missingUsers) .= field "missing_users" (array schema) instance ToSchema MLSOutOfSyncError where - schema = object "MLSOutOfSyncError" mlsOutOfSyncErrorObjectSchema + schema = object mlsOutOfSyncErrorObjectSchema instance IsSwaggerError MLSOutOfSyncError where addToOpenApi = diff --git a/libs/wire-api/src/Wire/API/Event/Conversation.hs b/libs/wire-api/src/Wire/API/Event/Conversation.hs index af2b35abf20..64195a8c8bf 100644 --- a/libs/wire-api/src/Wire/API/Event/Conversation.hs +++ b/libs/wire-api/src/Wire/API/Event/Conversation.hs @@ -119,7 +119,7 @@ data EventVia = EventViaUserAction | EventViaSCIM instance ToSchema EventVia where schema = - enum @Text "EventVia" $ + enum @Text $ mconcat [ element "scim" EventViaSCIM, element "user" EventViaUserAction @@ -197,7 +197,7 @@ data EventType instance ToSchema EventType where schema = - enum @Text "EventType" $ + enum @Text $ mconcat [ element "conversation.member-join" MemberJoin, element "conversation.member-leave" MemberLeave, @@ -326,7 +326,7 @@ data MembersJoin = MembersJoin instance ToSchema MembersJoin where schema = - object "MembersJoin" $ + object $ MembersJoin <$> mMembers .= field "users" (array schema) <* (fmap smId . mMembers) @@ -353,7 +353,7 @@ smId = qUnqualified . smQualifiedId instance ToSchema SimpleMember where schema = - object "SimpleMember" $ + object $ SimpleMember <$> smQualifiedId .= field "qualified_id" schema <* smId .= optional (field "id" schema) @@ -374,7 +374,7 @@ data Connect = Connect deriving (FromJSON, ToJSON, S.ToSchema) via Schema Connect instance ToSchema Connect where - schema = object "Connect" connectObjectSchema + schema = object connectObjectSchema connectObjectSchema :: ObjectSchema SwaggerDoc Connect connectObjectSchema = @@ -406,7 +406,7 @@ data MemberUpdateData = MemberUpdateData deriving (FromJSON, ToJSON, S.ToSchema) via Schema MemberUpdateData instance ToSchema MemberUpdateData where - schema = object "MemberUpdateData" memberUpdateDataObjectSchema + schema = object memberUpdateDataObjectSchema memberUpdateDataObjectSchema :: ObjectSchema SwaggerDoc MemberUpdateData memberUpdateDataObjectSchema = @@ -438,7 +438,6 @@ data OtrMessage = OtrMessage instance ToSchema OtrMessage where schema = objectWithDocModifier - "OtrMessage" (description ?~ "Encrypted message of a conversation") otrMessageObjectSchema @@ -475,7 +474,7 @@ data ConversationReset = ConversationReset instance ToSchema ConversationReset where schema = - object "ConversationReset" $ + object $ ConversationReset <$> (.groupId) .= field "group_id" schema <*> (.newGroupId) .= maybe_ (optField "new_group_id" schema) @@ -518,11 +517,11 @@ taggedEventDataSchema = memberLeaveSchema :: ValueSchema NamedSwaggerDoc (EdMemberLeftReason, QualifiedUserIdList) memberLeaveSchema = - object "QualifiedUserIdList_with_EdMemberLeftReason" $ + object $ (,) <$> fst .= field "reason" schema <*> snd .= qualifiedUserIdListObjectSchema instance ToSchema Event where - schema = object "Event" eventObjectSchema + schema = object eventObjectSchema eventObjectSchema :: ObjectSchema SwaggerDoc Event eventObjectSchema = @@ -590,7 +589,7 @@ data CellsEventType instance ToSchema CellsEventType where schema = - enum @Text "CellsEventType" $ + enum @Text $ mconcat [ element "conversation.create" CellsConvCreate ] @@ -599,7 +598,7 @@ makePrisms ''CellsEventData instance ToSchema CellsEvent where schema = - object "CellsEvent" $ + object $ mk <$> (cellsEventType &&& cellsEventData) .= taggedCellsEventDataSchema <*> convId .= field "qualified_conversation" schema diff --git a/libs/wire-api/src/Wire/API/Event/FeatureConfig.hs b/libs/wire-api/src/Wire/API/Event/FeatureConfig.hs index 7817fe94a7b..b1762b07307 100644 --- a/libs/wire-api/src/Wire/API/Event/FeatureConfig.hs +++ b/libs/wire-api/src/Wire/API/Event/FeatureConfig.hs @@ -43,7 +43,7 @@ data Event = Event deriving (Eq, Show, Generic) deriving (A.ToJSON, A.FromJSON) via Schema Event -arbitraryFeature :: forall cfg. (IsFeatureConfig cfg, Arbitrary cfg) => Gen A.Value +arbitraryFeature :: forall cfg. (Typeable cfg, IsFeatureConfig cfg, Arbitrary cfg) => Gen A.Value arbitraryFeature = toJSON <$> arbitrary @(LockableFeature cfg) class AllArbitraryFeatures cfgs where @@ -53,7 +53,8 @@ instance AllArbitraryFeatures '[] where allArbitraryFeatures = [] instance - ( IsFeatureConfig cfg, + ( Typeable cfg, + IsFeatureConfig cfg, Arbitrary cfg, AllArbitraryFeatures cfgs ) => @@ -75,7 +76,7 @@ data EventType = Update instance ToSchema EventType where schema = - enum @Text "EventType" $ + enum @Text $ mconcat [ element "feature-config.update" Update ] @@ -90,7 +91,7 @@ eventObjectSchema = instance ToSchema Event where schema = - object "Event" eventObjectSchema + object eventObjectSchema instance ToJSONObject Event where toJSONObject = @@ -101,7 +102,7 @@ instance ToJSONObject Event where instance S.ToSchema Event where declareNamedSchema = schemaToSwagger -mkUpdateEvent :: forall cfg. (IsFeatureConfig cfg) => TeamId -> LockableFeature cfg -> Event +mkUpdateEvent :: forall cfg. (Typeable cfg, IsFeatureConfig cfg) => TeamId -> LockableFeature cfg -> Event mkUpdateEvent tid ws = Event { _eventType = Update, diff --git a/libs/wire-api/src/Wire/API/Event/Federation.hs b/libs/wire-api/src/Wire/API/Event/Federation.hs index 82c3d7362d1..8db1c6da688 100644 --- a/libs/wire-api/src/Wire/API/Event/Federation.hs +++ b/libs/wire-api/src/Wire/API/Event/Federation.hs @@ -51,7 +51,7 @@ data EventType instance ToSchema EventType where schema = - enum @Text "EventType" $ + enum @Text $ mconcat [ element "federation.delete" FederationDelete ] @@ -63,7 +63,7 @@ eventObjectSchema = <*> _eventDomain .= field "domain" schema instance ToSchema Event where - schema = object "Event" eventObjectSchema + schema = object eventObjectSchema instance ToJSONObject Event where toJSONObject = diff --git a/libs/wire-api/src/Wire/API/Event/LeaveReason.hs b/libs/wire-api/src/Wire/API/Event/LeaveReason.hs index e01e7ab0290..c389f42e9e7 100644 --- a/libs/wire-api/src/Wire/API/Event/LeaveReason.hs +++ b/libs/wire-api/src/Wire/API/Event/LeaveReason.hs @@ -38,7 +38,7 @@ data EdMemberLeftReason instance ToSchema EdMemberLeftReason where schema = - enum @Text "EdMemberLeftReason" $ + enum @Text $ mconcat [ element "left" EdReasonLeft, element "user-deleted" EdReasonDeleted, diff --git a/libs/wire-api/src/Wire/API/Event/Team.hs b/libs/wire-api/src/Wire/API/Event/Team.hs index 3efdb53265f..e81b6e8b751 100644 --- a/libs/wire-api/src/Wire/API/Event/Team.hs +++ b/libs/wire-api/src/Wire/API/Event/Team.hs @@ -64,7 +64,7 @@ data Event = Event instance ToSchema Event where schema = - object "Event" $ + object $ Event <$> _eventTeam .= field "team" schema <*> _eventTime .= field "time" utcTimeSchema @@ -124,7 +124,6 @@ data EventType | ConvCreate | ConvDelete | CollaboratorAdd - | AppCreate | CollaboratorUpdate | CollaboratorRemove deriving stock (Eq, Show, Generic) @@ -133,7 +132,7 @@ data EventType instance ToSchema EventType where schema = - enum @Text "EventType" $ + enum @Text $ mconcat [ element "team.create" TeamCreate, element "team.delete" TeamDelete, @@ -144,7 +143,6 @@ instance ToSchema EventType where element "team.conversation-create" ConvCreate, element "team.conversation-delete" ConvDelete, element "team.collaborator-add" CollaboratorAdd, - element "team.app-create" AppCreate, element "team.collaborator-update" CollaboratorUpdate, element "team.collaborator-remove" CollaboratorRemove ] @@ -162,7 +160,6 @@ data EventData | EdConvCreate ConvId | EdConvDelete ConvId | EdCollaboratorAdd UserId [CollaboratorPermission] - | EdAppCreate UserId | EdCollaboratorUpdate UserId [CollaboratorPermission] | EdCollaboratorRemove UserId deriving stock (Eq, Show, Generic) @@ -170,7 +167,7 @@ data EventData -- FUTUREWORK: this is outright wrong; see "Wire.API.Event.Conversation" on how to do this properly. instance ToSchema EventData where schema = - object "EventData" $ + object $ EdTeamCreate <$> (undefined :: EventData -> Team) .= field "team" schema @@ -194,7 +191,6 @@ instance ToJSON EventData where [ "user" A..= usr, "permissions" A..= perms ] - toJSON (EdAppCreate usr) = A.object ["user" A..= usr] toJSON (EdCollaboratorUpdate usr perms) = A.object [ "user" A..= usr, @@ -212,7 +208,6 @@ eventDataType (EdMemberUpdate _ _) = MemberUpdate eventDataType (EdConvCreate _) = ConvCreate eventDataType (EdConvDelete _) = ConvDelete eventDataType (EdCollaboratorAdd _ _) = CollaboratorAdd -eventDataType (EdAppCreate _) = AppCreate eventDataType (EdCollaboratorUpdate _ _) = CollaboratorUpdate eventDataType (EdCollaboratorRemove _) = CollaboratorRemove @@ -245,10 +240,6 @@ parseEventData CollaboratorAdd Nothing = fail "missing event data for type 'team parseEventData CollaboratorAdd (Just j) = do let f o = EdCollaboratorAdd <$> o .: "user" <*> o .: "permissions" withObject "collaborator add data" f j -parseEventData AppCreate Nothing = fail "missing event data for type 'team.app-create'" -parseEventData AppCreate (Just j) = do - let f o = EdAppCreate <$> o .: "user" - withObject "app create data" f j parseEventData CollaboratorUpdate Nothing = fail "missing event data for type 'team.collaborator-update'" parseEventData CollaboratorUpdate (Just j) = do let f o = EdCollaboratorUpdate <$> o .: "user" <*> o .: "permissions" @@ -271,7 +262,6 @@ genEventData = \case ConvCreate -> EdConvCreate <$> arbitrary ConvDelete -> EdConvDelete <$> arbitrary CollaboratorAdd -> EdCollaboratorAdd <$> arbitrary <*> arbitrary - AppCreate -> EdAppCreate <$> arbitrary CollaboratorUpdate -> EdCollaboratorUpdate <$> arbitrary <*> arbitrary CollaboratorRemove -> EdCollaboratorRemove <$> arbitrary diff --git a/libs/wire-api/src/Wire/API/Event/WebSocketProtocol.hs b/libs/wire-api/src/Wire/API/Event/WebSocketProtocol.hs index 493e029cb09..9d726ddbb87 100644 --- a/libs/wire-api/src/Wire/API/Event/WebSocketProtocol.hs +++ b/libs/wire-api/src/Wire/API/Event/WebSocketProtocol.hs @@ -42,7 +42,7 @@ data AckData = AckData instance ToSchema AckData where schema = - object "AckData" $ + object $ AckData <$> (.deliveryTag) .= field "delivery_tag" schema <*> multiple .= field "multiple" schema @@ -57,7 +57,7 @@ data EventData = EventData instance ToSchema EventData where schema = - object "EventData" $ + object $ EventData <$> event .= field "event" schema <*> (.deliveryTag) .= field "delivery_tag" schema @@ -72,7 +72,7 @@ data SynchronizationData = SynchronizationData instance ToSchema SynchronizationData where schema = - object "SynchronizationData " $ + object $ SynchronizationData <$> markerId .= field "marker_id" schema <*> (.deliveryTag) .= field "delivery_tag" schema @@ -103,7 +103,7 @@ data MessageTypeServerToClient = MsgTypeEventMessage | MsgTypeEventFullSync | Ms msgTypeSchemaServerToClient :: ValueSchema NamedSwaggerDoc MessageTypeServerToClient msgTypeSchemaServerToClient = - enum @Text "MessageTypeServerToClient" $ + enum @Text $ mconcat $ [ element "event" MsgTypeEventMessage, element "notifications_missed" MsgTypeEventFullSync, @@ -112,7 +112,7 @@ msgTypeSchemaServerToClient = instance ToSchema MessageServerToClient where schema = - object "MessageServerToClient" $ + object $ fromTagged <$> toTagged .= bind (fst .= field "type" msgTypeSchemaServerToClient) (snd .= untaggedSchema) where toTagged :: MessageServerToClient -> (MessageTypeServerToClient, MessageServerToClient) @@ -142,7 +142,7 @@ data MessageTypeClientToServer = MsgTypeAckMessage | MsgTypeAckFullSync msgTypeSchemaClientToServer :: ValueSchema NamedSwaggerDoc MessageTypeClientToServer msgTypeSchemaClientToServer = - enum @Text "MessageTypeClientToServer" $ + enum @Text $ mconcat $ [ element "ack" MsgTypeAckMessage, element "ack_full_sync" MsgTypeAckFullSync @@ -150,7 +150,7 @@ msgTypeSchemaClientToServer = instance ToSchema MessageClientToServer where schema = - object "MessageClientToServer" $ + object $ fromTagged <$> toTagged .= bind (fst .= field "type" msgTypeSchemaClientToServer) (snd .= untaggedSchema) where toTagged :: MessageClientToServer -> (MessageTypeClientToServer, MessageClientToServer) diff --git a/libs/wire-api/src/Wire/API/FederationStatus.hs b/libs/wire-api/src/Wire/API/FederationStatus.hs index 8fd4dc3acb8..b3aeccd5f66 100644 --- a/libs/wire-api/src/Wire/API/FederationStatus.hs +++ b/libs/wire-api/src/Wire/API/FederationStatus.hs @@ -43,7 +43,7 @@ newtype RemoteDomains = RemoteDomains instance ToSchema RemoteDomains where schema = - objectWithDocModifier "RemoteDomains" (description ?~ "A set of remote domains") $ + objectWithDocModifier (description ?~ "A set of remote domains") $ RemoteDomains <$> (Set.map tDomain . rdDomains) .= field "domains" (Set.map (flip toRemoteUnsafe ()) <$> set schema) diff --git a/libs/wire-api/src/Wire/API/History.hs b/libs/wire-api/src/Wire/API/History.hs index 2462741fb3a..59cd7247718 100644 --- a/libs/wire-api/src/Wire/API/History.hs +++ b/libs/wire-api/src/Wire/API/History.hs @@ -109,7 +109,7 @@ instance ToSchema History where instance ToSchema HistorySharingConfig where schema = - object "HistorySharingConfig" $ + object $ HistorySharingConfig <$> (.depth) .= field "depth" schema diff --git a/libs/wire-api/src/Wire/API/Internal/BulkPush.hs b/libs/wire-api/src/Wire/API/Internal/BulkPush.hs index 0ffb9eec618..3dc67c1177a 100644 --- a/libs/wire-api/src/Wire/API/Internal/BulkPush.hs +++ b/libs/wire-api/src/Wire/API/Internal/BulkPush.hs @@ -40,7 +40,7 @@ data PushTarget = PushTarget instance S.ToSchema PushTarget where schema = - S.object "PushTarget" $ + S.object $ PushTarget <$> ptUserId S..= S.field "user_id" S.schema <*> ptConnId S..= S.field "conn_id" S.schema @@ -57,13 +57,13 @@ newtype BulkPushRequest = BulkPushRequest instance S.ToSchema BulkPushRequest where schema = - S.object "BulkPushRequest" $ + S.object $ BulkPushRequest <$> fromBulkPushRequest S..= S.field "bulkpush_req" (S.array bulkpushReqItemSchema) where bulkpushReqItemSchema :: ValueSchema S.NamedSwaggerDoc (Notification, [PushTarget]) bulkpushReqItemSchema = - S.object "(Notification, [PushTarget])" $ + S.object $ (,) <$> fst S..= S.field "notification" S.schema <*> snd S..= S.field "targets" (S.array S.schema) @@ -74,7 +74,7 @@ data PushStatus = PushStatusOk | PushStatusGone instance S.ToSchema PushStatus where schema = - S.enum @Text "PushStatus" $ + S.enum @Text $ mconcat [ S.element "push_status_ok" PushStatusOk, S.element "push_status_gone" PushStatusGone @@ -92,13 +92,13 @@ newtype BulkPushResponse = BulkPushResponse instance S.ToSchema BulkPushResponse where schema = - S.object "BulkPushResponse" $ + S.object $ BulkPushResponse <$> fromBulkPushResponse S..= S.field "bulkpush_resp" (S.array bulkPushResponseSchema) where bulkPushResponseSchema :: ValueSchema S.NamedSwaggerDoc (NotificationId, PushTarget, PushStatus) bulkPushResponseSchema = - S.object "(NotificationId, PushTarget, PushStatus)" $ + S.object $ (,,) <$> view _1 S..= S.field "notif_id" S.schema <*> view _2 S..= S.field "target" S.schema diff --git a/libs/wire-api/src/Wire/API/Internal/Notification.hs b/libs/wire-api/src/Wire/API/Internal/Notification.hs index 0226b913921..0beefd4621a 100644 --- a/libs/wire-api/src/Wire/API/Internal/Notification.hs +++ b/libs/wire-api/src/Wire/API/Internal/Notification.hs @@ -63,7 +63,7 @@ data Notification = Notification instance S.ToSchema Notification where schema = - S.object "Notification" $ + S.object $ Notification <$> ntfId S..= S.field "id" S.schema <*> ntfTransient S..= (fromMaybe False <$> S.optField "transient" S.schema) diff --git a/libs/wire-api/src/Wire/API/MLS/Credential.hs b/libs/wire-api/src/Wire/API/MLS/Credential.hs index d369727f3e1..607729eb902 100644 --- a/libs/wire-api/src/Wire/API/MLS/Credential.hs +++ b/libs/wire-api/src/Wire/API/MLS/Credential.hs @@ -103,7 +103,7 @@ cidQualifiedUser = fmap fst . cidQualifiedClient instance ToSchema ClientIdentity where schema = - object "ClientIdentity" $ + object $ ClientIdentity <$> ciDomain .= field "domain" schema <*> ciUser .= field "user_id" schema diff --git a/libs/wire-api/src/Wire/API/MLS/KeyPackage.hs b/libs/wire-api/src/Wire/API/MLS/KeyPackage.hs index eb736de6ea5..1f3e97d1098 100644 --- a/libs/wire-api/src/Wire/API/MLS/KeyPackage.hs +++ b/libs/wire-api/src/Wire/API/MLS/KeyPackage.hs @@ -69,7 +69,7 @@ data KeyPackageUpload = KeyPackageUpload instance ToSchema KeyPackageUpload where schema = - object "KeyPackageUpload" $ + object $ KeyPackageUpload <$> keyPackages .= field "key_packages" (array rawKeyPackageSchema) @@ -100,7 +100,7 @@ data KeyPackageBundleEntry = KeyPackageBundleEntry instance ToSchema KeyPackageBundleEntry where schema = - object "KeyPackageBundleEntry" $ + object $ KeyPackageBundleEntry <$> (.user) .= qualifiedObjectSchema "user" schema <*> (.client) .= field "client" schema @@ -113,7 +113,7 @@ newtype KeyPackageBundle = KeyPackageBundle {entries :: Set KeyPackageBundleEntr instance ToSchema KeyPackageBundle where schema = - object "KeyPackageBundle" $ + object $ KeyPackageBundle <$> (.entries) .= field "key_packages" (set schema) @@ -123,7 +123,7 @@ newtype KeyPackageCount = KeyPackageCount {unKeyPackageCount :: Int} instance ToSchema KeyPackageCount where schema = - object "OwnKeyPackages" $ + object $ KeyPackageCount <$> unKeyPackageCount .= field "count" schema newtype DeleteKeyPackages = DeleteKeyPackages @@ -133,7 +133,7 @@ newtype DeleteKeyPackages = DeleteKeyPackages instance ToSchema DeleteKeyPackages where schema = - object "DeleteKeyPackages" $ + object $ DeleteKeyPackages <$> unDeleteKeyPackages .= field diff --git a/libs/wire-api/src/Wire/API/MLS/Keys.hs b/libs/wire-api/src/Wire/API/MLS/Keys.hs index 971b2866b11..c40ad6a2492 100644 --- a/libs/wire-api/src/Wire/API/MLS/Keys.hs +++ b/libs/wire-api/src/Wire/API/MLS/Keys.hs @@ -41,9 +41,9 @@ data MLSKeysByPurpose a = MLSKeysByPurpose deriving (Eq, Show, Functor, Foldable, Traversable) deriving (FromJSON, ToJSON, S.ToSchema) via Schema (MLSKeysByPurpose a) -instance (ToSchema a) => ToSchema (MLSKeysByPurpose a) where +instance (Typeable a, ToSchema a) => ToSchema (MLSKeysByPurpose a) where schema = - object "MLSKeysByPurpose" $ + object $ MLSKeysByPurpose <$> (.removal) .= field "removal" schema @@ -56,9 +56,9 @@ data MLSKeys a = MLSKeys deriving (Eq, Show, Functor, Foldable, Traversable) deriving (FromJSON, ToJSON, S.ToSchema) via Schema (MLSKeys a) -instance (ToSchema a) => ToSchema (MLSKeys a) where +instance (Typeable a, ToSchema a) => ToSchema (MLSKeys a) where schema = - object "MLSKeys" $ + object $ MLSKeys <$> ed25519 .= field "ed25519" schema <*> ecdsa_secp256r1_sha256 .= field "ecdsa_secp256r1_sha256" schema @@ -74,7 +74,7 @@ data MLSPrivateKeys = MLSPrivateKeys instance ToSchema MLSPrivateKeys where schema = - object "MLSPrivateKeys" $ + object $ MLSPrivateKeys <$> (.mlsKeyPair_ed25519) .= field @NamedSwaggerDoc "ed25519" (opaqueSchema "KeyPair Ed25519") <*> (.mlsKeyPair_ecdsa_secp256r1_sha256) .= field @NamedSwaggerDoc "ecdsa_secp256r1_sha256" (opaqueSchema "KeyPair Ecdsa_secp256r1_sha256") @@ -137,7 +137,7 @@ data JWK = JWK instance ToSchema JWK where schema = - object "JWK" $ + object $ JWK <$> (.keyType) .= field "kty" schema <*> (.curve) .= field "crv" schema diff --git a/libs/wire-api/src/Wire/API/MLS/Message.hs b/libs/wire-api/src/Wire/API/MLS/Message.hs index 644e2743d45..544695bee96 100644 --- a/libs/wire-api/src/Wire/API/MLS/Message.hs +++ b/libs/wire-api/src/Wire/API/MLS/Message.hs @@ -370,7 +370,7 @@ data MLSMessageSendingStatus = MLSMessageSendingStatus instance ToSchema MLSMessageSendingStatus where schema = - object "MLSMessageSendingStatus" $ + object $ MLSMessageSendingStatus <$> mmssEvents .= fieldWithDocModifier diff --git a/libs/wire-api/src/Wire/API/MLS/SubConversation.hs b/libs/wire-api/src/Wire/API/MLS/SubConversation.hs index be1199c8193..e3db83ca081 100644 --- a/libs/wire-api/src/Wire/API/MLS/SubConversation.hs +++ b/libs/wire-api/src/Wire/API/MLS/SubConversation.hs @@ -85,8 +85,8 @@ data PublicSubConversation = PublicSubConversation publicSubConversationSchema :: Maybe Version -> ValueSchema NamedSwaggerDoc PublicSubConversation publicSubConversationSchema v = - objectWithDocModifier - ("PublicSubConversation" <> foldMap (T.toUpper . versionText) v) + versionedObjectWithDocModifier + v (description ?~ "An MLS subconversation") $ PublicSubConversation <$> pscParentConvId .= field "parent_qualified_id" schema @@ -150,7 +150,7 @@ convOrSubConvIdObjectSchema = instance ToSchema ConvOrSubConvId where schema = - object "ConvOrSubConvId" $ + object $ fromTagged <$> toTagged .= bind @@ -168,12 +168,12 @@ instance ToSchema ConvOrSubConvId where ConvTag -> tag _Conv - (unnamed $ object "" $ field "conv_id" schema) + (unnamed $ object $ field "conv_id" schema) SubConvTag -> tag _SubConv ( unnamed $ - object "" $ + object $ ( (,) <$> fst .= field "conv_id" schema <*> snd .= field "subconv_id" schema @@ -182,7 +182,7 @@ instance ToSchema ConvOrSubConvId where tagSchema :: ValueSchema NamedSwaggerDoc ConvOrSubTag tagSchema = - enum @Text "ConvOrSubTag" $ + enum @Text $ mconcat [ element "conv" ConvTag, element "subconv" SubConvTag diff --git a/libs/wire-api/src/Wire/API/Meeting.hs b/libs/wire-api/src/Wire/API/Meeting.hs index 6c1057efe30..44e2c956554 100644 --- a/libs/wire-api/src/Wire/API/Meeting.hs +++ b/libs/wire-api/src/Wire/API/Meeting.hs @@ -52,7 +52,7 @@ data Meeting = Meeting instance ToSchema Meeting where schema = - objectWithDocModifier "Meeting" (description ?~ "A scheduled meeting") $ + objectWithDocModifier (description ?~ "A scheduled meeting") $ Meeting <$> (.id) .= field "qualified_id" schema <*> (.title) .= field "title" schema @@ -95,7 +95,7 @@ data Frequency = Daily | Weekly | Monthly | Yearly instance ToSchema Frequency where schema = - enum @Text "Frequency" $ + enum @Text $ mconcat [ element "daily" Daily, element "weekly" Weekly, @@ -105,7 +105,7 @@ instance ToSchema Frequency where instance ToSchema NewMeeting where schema = - objectWithDocModifier "NewMeeting" (description ?~ "Request to create a new meeting") $ + objectWithDocModifier (description ?~ "Request to create a new meeting") $ NewMeeting <$> (.startTime) .= field "start_time" utcTimeSchema <*> (.endTime) .= field "end_time" utcTimeSchema @@ -127,7 +127,7 @@ data UpdateMeeting = UpdateMeeting instance ToSchema UpdateMeeting where schema = - objectWithDocModifier "UpdateMeeting" (description ?~ "Request to update a meeting") $ + objectWithDocModifier (description ?~ "Request to update a meeting") $ UpdateMeeting <$> (.startTime) .= maybe_ (optField "start_time" utcTimeSchema) <*> (.endTime) .= maybe_ (optField "end_time" utcTimeSchema) @@ -136,7 +136,7 @@ instance ToSchema UpdateMeeting where instance ToSchema Recurrence where schema = - objectWithDocModifier "Recurrence" (description ?~ "Recurrence pattern for meetings") $ + objectWithDocModifier (description ?~ "Recurrence pattern for meetings") $ Recurrence <$> (.freq) .= field "frequency" schema <*> (.interval) .= (fromMaybe 1 <$> optField "interval" schema) @@ -152,7 +152,7 @@ newtype MeetingEmailsInvitation = MeetingEmailsInvitation instance ToSchema MeetingEmailsInvitation where schema = - objectWithDocModifier "MeetingEmailsInvitation" (description ?~ "Emails invitation") $ + objectWithDocModifier (description ?~ "Emails invitation") $ MeetingEmailsInvitation <$> (.emails) .= field "emails" (array schema) diff --git a/libs/wire-api/src/Wire/API/Message.hs b/libs/wire-api/src/Wire/API/Message.hs index 85cdda18909..183c2a272b7 100644 --- a/libs/wire-api/src/Wire/API/Message.hs +++ b/libs/wire-api/src/Wire/API/Message.hs @@ -108,7 +108,7 @@ messageMetadataObjectSchema = <*> mmData .= maybe_ (optField "data" schema) instance ToSchema MessageMetadata where - schema = object "MessageMetadata" messageMetadataObjectSchema + schema = object messageMetadataObjectSchema defMessageMetadata :: MessageMetadata defMessageMetadata = @@ -146,7 +146,7 @@ newOtrMessageMetadata msg = instance ToSchema NewOtrMessage where schema = - object "new-otr-message" $ + object $ mk <$> newOtrSender .= field "sender" schema <*> newOtrRecipients .= field "recipients" schema @@ -298,7 +298,7 @@ data Priority = LowPriority | HighPriority instance ToSchema Priority where schema = - enum @Text "Priority" $ + enum @Text $ mconcat [ element "low" LowPriority, element "high" HighPriority @@ -487,7 +487,7 @@ instance Arbitrary ClientMismatch where instance ToSchema ClientMismatch where schema = - object "ClientMismatch" $ + object $ ClientMismatch <$> cmismatchTime .= field "time" schema <*> missingClients .= field "missing" schema @@ -508,7 +508,6 @@ data MessageSendingStatus = MessageSendingStatus instance ToSchema MessageSendingStatus where schema = objectWithDocModifier - "MessageSendingStatus" (description ?~ combinedDesc) $ MessageSendingStatus <$> mssTime .= field "time" schema diff --git a/libs/wire-api/src/Wire/API/Notification.hs b/libs/wire-api/src/Wire/API/Notification.hs index d3b5a40511d..69b53bd9c9f 100644 --- a/libs/wire-api/src/Wire/API/Notification.hs +++ b/libs/wire-api/src/Wire/API/Notification.hs @@ -134,7 +134,7 @@ queuedNotification = QueuedNotification instance ToSchema QueuedNotification where schema = - objectWithDocModifier "QueuedNotification" queuedNotificationDoc $ + objectWithDocModifier queuedNotificationDoc $ QueuedNotification <$> _queuedNotificationId .= field "id" schema @@ -160,7 +160,7 @@ queuedNotificationList = QueuedNotificationList instance ToSchema QueuedNotificationList where schema = - objectWithDocModifier "QueuedNotificationList" queuedNotificationListDoc $ + objectWithDocModifier queuedNotificationListDoc $ QueuedNotificationList <$> _queuedNotifications .= fieldWithDocModifier "notifications" notificationsDoc (array schema) @@ -205,7 +205,7 @@ newtype ServerTime = ServerTime {getServerTime :: UTCTime} instance ToSchema ServerTime where schema = - objectWithDocModifier "ServerTime" serverTimeDoc $ + objectWithDocModifier serverTimeDoc $ ServerTime <$> getServerTime .= field "time" utcTimeSchema where diff --git a/libs/wire-api/src/Wire/API/OAuth.hs b/libs/wire-api/src/Wire/API/OAuth.hs index 97c8d0bc223..a3ff2db1537 100644 --- a/libs/wire-api/src/Wire/API/OAuth.hs +++ b/libs/wire-api/src/Wire/API/OAuth.hs @@ -107,7 +107,7 @@ data OAuthClientConfig = OAuthClientConfig instance ToSchema OAuthClientConfig where schema = - object "OAuthClientConfig" $ + object $ OAuthClientConfig <$> applicationName .= fieldWithDocModifier "application_name" applicationNameDescription schema @@ -146,7 +146,7 @@ data OAuthClientCredentials = OAuthClientCredentials instance ToSchema OAuthClientCredentials where schema = - object "OAuthClientCredentials" $ + object $ OAuthClientCredentials <$> (.clientId) .= fieldWithDocModifier "client_id" clientIdDescription schema @@ -167,7 +167,7 @@ data OAuthClient = OAuthClient instance ToSchema OAuthClient where schema = - object "OAuthClient" $ + object $ OAuthClient <$> (.clientId) .= field "client_id" schema @@ -184,7 +184,7 @@ data OAuthResponseType = OAuthResponseTypeCode instance ToSchema OAuthResponseType where schema :: ValueSchema NamedSwaggerDoc OAuthResponseType schema = - enum @Text "OAuthResponseType" $ + enum @Text $ mconcat [ element "code" OAuthResponseTypeCode ] @@ -263,7 +263,7 @@ data CodeChallengeMethod = S256 instance ToSchema CodeChallengeMethod where schema :: ValueSchema NamedSwaggerDoc CodeChallengeMethod schema = - enum @Text "CodeChallengeMethod" $ + enum @Text $ mconcat [ element "S256" S256 ] @@ -326,7 +326,7 @@ data CreateOAuthAuthorizationCodeRequest = CreateOAuthAuthorizationCodeRequest instance ToSchema CreateOAuthAuthorizationCodeRequest where schema = - object "CreateOAuthAuthorizationCodeRequest" $ + object $ CreateOAuthAuthorizationCodeRequest <$> (.clientId) .= fieldWithDocModifier "client_id" clientIdDescription schema @@ -379,7 +379,7 @@ data OAuthGrantType = OAuthGrantTypeAuthorizationCode | OAuthGrantTypeRefreshTok instance ToSchema OAuthGrantType where schema = - enum @Text "OAuthGrantType" $ + enum @Text $ mconcat [ element "authorization_code" OAuthGrantTypeAuthorizationCode, element "refresh_token" OAuthGrantTypeRefreshToken @@ -417,7 +417,7 @@ data OAuthAccessTokenRequest = OAuthAccessTokenRequest instance ToSchema OAuthAccessTokenRequest where schema = - object "OAuthAccessTokenRequest" $ + object $ OAuthAccessTokenRequest <$> (.grantType) .= fieldWithDocModifier "grant_type" grantTypeDescription schema @@ -462,7 +462,7 @@ data OAuthAccessTokenType = OAuthAccessTokenTypeBearer instance ToSchema OAuthAccessTokenType where schema = - enum @Text "OAuthAccessTokenType" $ + enum @Text $ mconcat [ element "Bearer" OAuthAccessTokenTypeBearer ] @@ -516,7 +516,7 @@ data OAuthAccessTokenResponse = OAuthAccessTokenResponse instance ToSchema OAuthAccessTokenResponse where schema = - object "OAuthAccessTokenResponse" $ + object $ OAuthAccessTokenResponse <$> accessToken .= fieldWithDocModifier "access_token" accessTokenDescription schema @@ -593,7 +593,7 @@ data OAuthRefreshAccessTokenRequest = OAuthRefreshAccessTokenRequest instance ToSchema OAuthRefreshAccessTokenRequest where schema :: ValueSchema NamedSwaggerDoc OAuthRefreshAccessTokenRequest schema = - object "OAuthRefreshAccessTokenRequest" $ + object $ OAuthRefreshAccessTokenRequest <$> (.grantType) .= fieldWithDocModifier "grant_type" grantTypeDescription schema @@ -640,7 +640,7 @@ data OAuthRevokeRefreshTokenRequest = OAuthRevokeRefreshTokenRequest instance ToSchema OAuthRevokeRefreshTokenRequest where schema = - object "OAuthRevokeRefreshTokenRequest" $ + object $ OAuthRevokeRefreshTokenRequest <$> (.clientId) .= fieldWithDocModifier "client_id" clientIdDescription schema @@ -660,7 +660,7 @@ data OAuthSession = OAuthSession instance ToSchema OAuthSession where schema = - object "OAuthSession" $ + object $ OAuthSession <$> (.refreshTokenId) .= fieldWithDocModifier "refresh_token_id" refreshTokenIdDescription schema <*> (.createdAt) .= fieldWithDocModifier "created_at" createdAtDescription schema @@ -679,7 +679,7 @@ data OAuthApplication = OAuthApplication instance ToSchema OAuthApplication where schema = - object "OAuthApplication" $ + object $ OAuthApplication <$> applicationId .= fieldWithDocModifier "id" idDescription schema <*> (.name) .= fieldWithDocModifier "name" nameDescription schema diff --git a/libs/wire-api/src/Wire/API/Pagination.hs b/libs/wire-api/src/Wire/API/Pagination.hs index 8fae686b1fa..cfa9d158cd5 100644 --- a/libs/wire-api/src/Wire/API/Pagination.hs +++ b/libs/wire-api/src/Wire/API/Pagination.hs @@ -52,7 +52,7 @@ instance Arbitrary SortOrder where instance ToSchema SortOrder where schema = - enum @Text "SortOrder" $ + enum @Text $ mconcat [ element "asc" Asc, element "desc" Desc @@ -127,7 +127,7 @@ instance Default SortBy where instance ToSchema SortBy where schema = - enum @Text "SortBy" $ + enum @Text $ mconcat [ element "name" SortByName, element "created_at" SortByCreatedAt diff --git a/libs/wire-api/src/Wire/API/Password.hs b/libs/wire-api/src/Wire/API/Password.hs index dfb16d1d250..8289725834b 100644 --- a/libs/wire-api/src/Wire/API/Password.hs +++ b/libs/wire-api/src/Wire/API/Password.hs @@ -106,7 +106,7 @@ newtype PasswordReqBody = PasswordReqBody instance ToSchema PasswordReqBody where schema = - object "PasswordReqBody" $ + object $ PasswordReqBody <$> fromPasswordReqBody .= maybe_ (optField "password" schema) diff --git a/libs/wire-api/src/Wire/API/Presence.hs b/libs/wire-api/src/Wire/API/Presence.hs index 561e3b92f90..427e0a0f8af 100644 --- a/libs/wire-api/src/Wire/API/Presence.hs +++ b/libs/wire-api/src/Wire/API/Presence.hs @@ -86,7 +86,7 @@ data Presence = Presence instance ToSchema Presence where schema = - object "Presence" $ + object $ ( Presence <$> userId .= field "user_id" schema <*> connId .= field "device_id" schema diff --git a/libs/wire-api/src/Wire/API/Provider.hs b/libs/wire-api/src/Wire/API/Provider.hs index fbde37da2ce..2bc09542b05 100644 --- a/libs/wire-api/src/Wire/API/Provider.hs +++ b/libs/wire-api/src/Wire/API/Provider.hs @@ -82,7 +82,7 @@ data Provider = Provider instance ToSchema Provider where schema = - object "Provider" $ + object $ Provider <$> providerId .= field "id" schema <*> providerName .= field "name" schema @@ -115,7 +115,7 @@ data NewProvider = NewProvider instance ToSchema NewProvider where schema = - object "NewProvider" $ + object $ NewProvider <$> newProviderName .= field "name" schema <*> newProviderEmail .= field "email" schema @@ -136,7 +136,7 @@ data NewProviderResponse = NewProviderResponse instance ToSchema NewProviderResponse where schema = - object "NewProviderResponse" $ + object $ NewProviderResponse <$> rsNewProviderId .= field "id" schema <*> rsNewProviderPassword .= maybe_ (optField "password" schema) @@ -156,7 +156,7 @@ data UpdateProvider = UpdateProvider instance ToSchema UpdateProvider where schema = - object "UpdateProvider" $ + object $ UpdateProvider <$> updateProviderName .= maybe_ (optField "name" schema) <*> updateProviderUrl .= maybe_ (optField "url" schema) @@ -175,7 +175,7 @@ newtype ProviderActivationResponse = ProviderActivationResponse instance ToSchema ProviderActivationResponse where schema = - object "ProviderActivationResponse" $ + object $ ProviderActivationResponse <$> activatedProviderIdentity .= field "email" schema @@ -193,7 +193,7 @@ data ProviderLogin = ProviderLogin instance ToSchema ProviderLogin where schema = - object "ProviderLogin" $ + object $ ProviderLogin <$> providerLoginEmail .= field "email" schema <*> providerLoginPassword .= field "password" schema @@ -211,7 +211,7 @@ newtype DeleteProvider = DeleteProvider instance ToSchema DeleteProvider where schema = - object "DeleteProvider" $ + object $ DeleteProvider <$> deleteProviderPassword .= field "password" schema @@ -226,7 +226,7 @@ newtype PasswordReset = PasswordReset {email :: EmailAddress} instance ToSchema PasswordReset where schema = - object "PasswordReset" $ + object $ PasswordReset <$> (.email) .= field "email" schema @@ -242,7 +242,7 @@ data CompletePasswordReset = CompletePasswordReset instance ToSchema CompletePasswordReset where schema = - object "CompletePasswordReset" $ + object $ CompletePasswordReset <$> key .= field "key" schema <*> (.code) .= field "code" schema @@ -259,7 +259,7 @@ data PasswordChange = PasswordChange instance ToSchema PasswordChange where schema = - object "PasswordChange" $ + object $ PasswordChange <$> oldPassword .= field "old_password" schema <*> newPassword .= field "new_password" schema @@ -272,6 +272,6 @@ newtype EmailUpdate = EmailUpdate {email :: EmailAddress} instance ToSchema EmailUpdate where schema = - object "EmailUpdate" $ + object $ EmailUpdate <$> (.email) .= field "email" schema diff --git a/libs/wire-api/src/Wire/API/Provider/Bot.hs b/libs/wire-api/src/Wire/API/Provider/Bot.hs index e8a1f5b1c4a..58ab67e6ccc 100644 --- a/libs/wire-api/src/Wire/API/Provider/Bot.hs +++ b/libs/wire-api/src/Wire/API/Provider/Bot.hs @@ -56,7 +56,7 @@ data BotConvView = BotConvView instance ToSchema BotConvView where schema = - object "BotConvView" $ + object $ BotConvView <$> _botConvId .= field "id" schema <*> _botConvName .= maybe_ (optField "name" schema) @@ -81,7 +81,7 @@ data BotUserView = BotUserView instance ToSchema BotUserView where schema = - object "BotUserView" $ + object $ BotUserView <$> botUserViewId .= field "id" schema <*> botUserViewName .= field "name" schema diff --git a/libs/wire-api/src/Wire/API/Provider/Service.hs b/libs/wire-api/src/Wire/API/Provider/Service.hs index 979ae525e5c..2329ee4c102 100644 --- a/libs/wire-api/src/Wire/API/Provider/Service.hs +++ b/libs/wire-api/src/Wire/API/Provider/Service.hs @@ -90,7 +90,7 @@ data ServiceRef = ServiceRef instance ToSchema ServiceRef where schema = - object "ServiceRef" $ + object $ ServiceRef <$> _serviceRefId .= field "id" schema <*> _serviceRefProvider .= field "provider" schema @@ -118,7 +118,7 @@ data ServiceKey = ServiceKey instance ToSchema ServiceKey where schema = - object "ServiceKey" $ + object $ ServiceKey <$> serviceKeyType .= field "type" schema <*> serviceKeySize .= field "size" schema @@ -167,7 +167,7 @@ data ServiceKeyType instance ToSchema ServiceKeyType where schema = - enum @Text "ServiceKeyType" (element "rsa" RsaServiceKey) + enum @Text (element "rsa" RsaServiceKey) newtype ServiceKeyPEM = ServiceKeyPEM {unServiceKeyPEM :: PEM} deriving stock (Eq, Show) @@ -257,7 +257,7 @@ data Service = Service instance ToSchema Service where schema = - object "Service" $ + object $ Service <$> serviceId .= field "id" schema <*> serviceName .= field "name" schema @@ -304,7 +304,7 @@ data ServiceProfile = ServiceProfile instance ToSchema ServiceProfile where schema = - object "ServiceProfile" $ + object $ ServiceProfile <$> serviceProfileId .= field "id" schema <*> serviceProfileProvider .= field "provider" schema @@ -328,7 +328,7 @@ data ServiceProfilePage = ServiceProfilePage instance ToSchema ServiceProfilePage where schema = - object "ServiceProfilePage" $ + object $ ServiceProfilePage <$> serviceProfilePageHasMore .= field "has_more" schema <*> serviceProfilePageResults .= field "services" (array schema) @@ -353,7 +353,7 @@ data NewService = NewService instance ToSchema NewService where schema = - object "NewService" $ + object $ NewService <$> newServiceName .= field "name" schema <*> newServiceSummary .= field "summary" schema @@ -378,7 +378,7 @@ data NewServiceResponse = NewServiceResponse instance ToSchema NewServiceResponse where schema = - object "NewServiceResponse" $ + object $ NewServiceResponse <$> rsNewServiceId .= field "id" schema <*> rsNewServiceToken .= maybe_ (optField "auth_token" schema) @@ -400,7 +400,7 @@ data UpdateService = UpdateService instance ToSchema UpdateService where schema = - object "UpdateService" $ + object $ UpdateService <$> updateServiceName .= maybe_ (optField "name" schema) <*> updateServiceSummary .= maybe_ (optField "summary" schema) @@ -426,7 +426,7 @@ data UpdateServiceConn = UpdateServiceConn instance ToSchema UpdateServiceConn where schema = - object "UpdateServiceConn" $ + object $ UpdateServiceConn <$> updateServiceConnPassword .= field "password" schema <*> updateServiceConnUrl .= maybe_ (optField "base_url" schema) @@ -449,7 +449,7 @@ newtype DeleteService = DeleteService instance ToSchema DeleteService where schema = - object "DeleteService" $ + object $ DeleteService <$> deleteServicePassword .= field "password" schema @@ -467,7 +467,7 @@ data UpdateServiceWhitelist = UpdateServiceWhitelist instance ToSchema UpdateServiceWhitelist where schema = - object "UpdateServiceWhitelist" $ + object $ UpdateServiceWhitelist <$> updateServiceWhitelistProvider .= field "provider" schema <*> updateServiceWhitelistService .= field "id" schema diff --git a/libs/wire-api/src/Wire/API/Provider/Service/Tag.hs b/libs/wire-api/src/Wire/API/Provider/Service/Tag.hs index b643e7f0052..49f8b25ca69 100644 --- a/libs/wire-api/src/Wire/API/Provider/Service/Tag.hs +++ b/libs/wire-api/src/Wire/API/Provider/Service/Tag.hs @@ -191,7 +191,7 @@ instance ToByteString ServiceTag where builder WeatherTag = "weather" instance ToSchema ServiceTag where - schema = enum @Text "ServiceTag" . mconcat $ (\a -> element (decodeUtf8With lenientDecode $ toStrict $ toByteString a) a) <$> [minBound ..] + schema = enum @Text . mconcat $ (\a -> element (decodeUtf8With lenientDecode $ toStrict $ toByteString a) a) <$> [minBound ..] instance S.ToParamSchema ServiceTag where toParamSchema _ = diff --git a/libs/wire-api/src/Wire/API/Push/V2.hs b/libs/wire-api/src/Wire/API/Push/V2.hs index 0d628c892e5..a0258c66d09 100644 --- a/libs/wire-api/src/Wire/API/Push/V2.hs +++ b/libs/wire-api/src/Wire/API/Push/V2.hs @@ -104,7 +104,7 @@ data Route instance ToSchema Route where schema = - enum @Text "Route" $ + enum @Text $ mconcat [ element "any" RouteAny, element "direct" RouteDirect @@ -144,7 +144,7 @@ instance Arbitrary RecipientClients where instance ToSchema Recipient where schema = - object "Recipient" $ + object $ Recipient <$> _recipientId .= field "user_id" schema <*> _recipientRoute .= field "route" schema @@ -180,7 +180,7 @@ recipient u r = Recipient u r RecipientClientsAll -- ApsData newtype ApsSound = ApsSound {fromSound :: Text} - deriving (Eq, Show, ToJSON, FromJSON, Arbitrary) + deriving (Eq, Show, ToJSON, Ord, FromJSON, Arbitrary) instance ToSchema ApsSound where schema = @@ -195,7 +195,7 @@ instance ToSchema ApsSound where o = pure . A.String . fromSound newtype ApsLocKey = ApsLocKey {fromLocKey :: Text} - deriving (Eq, Show, ToJSON, FromJSON, Arbitrary) + deriving (Eq, Show, Ord, ToJSON, FromJSON, Arbitrary) instance ToSchema ApsLocKey where schema = @@ -215,7 +215,7 @@ data ApsData = ApsData _apsSound :: !(Maybe ApsSound), _apsBadge :: !Bool } - deriving (Eq, Show, Generic) + deriving (Eq, Show, Generic, Ord) deriving (Arbitrary) via GenericUniform ApsData deriving (FromJSON, ToJSON, S.ToSchema) via (Schema ApsData) @@ -224,7 +224,7 @@ apsData lk la = ApsData lk la Nothing True instance ToSchema ApsData where schema = - object "ApsData" $ + object $ ApsData <$> _apsLocKey .= field "loc_key" schema <*> withDefault "loc_args" _apsLocArgs (array schema) [] @@ -280,7 +280,7 @@ data Push = Push _pushPayload :: !(NonEmpty Object), _pushIsCellsEvent :: !Bool } - deriving (Eq, Show, Generic) + deriving (Eq, Show, Generic, Ord) deriving (FromJSON, ToJSON, S.ToSchema) via (Schema Push) deriving (Arbitrary) via (GenericUniform Push) @@ -305,7 +305,7 @@ singletonPayload = NonEmpty.singleton . toJSONObject instance ToSchema Push where schema = - object "Push" $ + object $ Push <$> _pushRecipients .= field "recipients" (set schema) <*> _pushOrigin .= maybe_ (optField "origin" schema) diff --git a/libs/wire-api/src/Wire/API/Push/V2/Token.hs b/libs/wire-api/src/Wire/API/Push/V2/Token.hs index 29560be5fe8..051647b5cb2 100644 --- a/libs/wire-api/src/Wire/API/Push/V2/Token.hs +++ b/libs/wire-api/src/Wire/API/Push/V2/Token.hs @@ -71,7 +71,7 @@ newtype PushTokenList = PushTokenList instance ToSchema PushTokenList where schema = - objectWithDocModifier "PushTokenList" (description ?~ "List of Native Push Tokens") $ + objectWithDocModifier (description ?~ "List of Native Push Tokens") $ PushTokenList <$> pushTokens .= fieldWithDocModifier "tokens" (description ?~ "Push tokens") (array schema) @@ -91,7 +91,7 @@ pushToken = PushToken instance ToSchema PushToken where schema = - objectWithDocModifier "PushToken" desc $ + objectWithDocModifier desc $ PushToken <$> _tokenTransport .= fieldWithDocModifier "transport" transDesc schema @@ -123,7 +123,7 @@ data Transport instance ToSchema Transport where schema = - enum @Text "Transport" $ + enum @Text $ mconcat [ element "GCM" GCM, element "APNS" APNS, diff --git a/libs/wire-api/src/Wire/API/Routes/FederationDomainConfig.hs b/libs/wire-api/src/Wire/API/Routes/FederationDomainConfig.hs index 6b5463bfdb9..9bd072d3fd3 100644 --- a/libs/wire-api/src/Wire/API/Routes/FederationDomainConfig.hs +++ b/libs/wire-api/src/Wire/API/Routes/FederationDomainConfig.hs @@ -56,12 +56,12 @@ deriving via Schema FederationRestriction instance (ToJSON FederationRestriction tagSchema :: ValueSchema NamedSwaggerDoc FederationRestrictionTag tagSchema = - enum @Text "FederationRestrictionTag" $ + enum @Text $ mconcat [element "allow_all" FederationRestrictionAllowAllTag, element "restrict_by_team" FederationRestrictionByTeamTag] instance ToSchema FederationRestriction where schema = - object "FederationRestriction" $ + object $ fromTagged <$> toTagged .= bind @@ -93,7 +93,7 @@ data FederationDomainConfig = FederationDomainConfig instance ToSchema FederationDomainConfig where schema = - object "FederationDomainConfig" $ + object $ FederationDomainConfig <$> domain .= field "domain" schema <*> searchPolicy .= field "search_policy" schema @@ -119,7 +119,6 @@ defFederationDomainConfigs = instance ToSchema FederationDomainConfigs where schema = objectWithDocModifier - "FederationDomainConfigs" (description ?~ "See https://docs.wire.com/understand/federation/backend-communication.html#configuring-remote-connections.") $ FederationDomainConfigs <$> strategy .= field "strategy" schema @@ -140,7 +139,7 @@ data FederationStrategy instance ToSchema FederationStrategy where schema = - enum @Text "FederationStrategy" $ + enum @Text $ mconcat [ element "allowNone" AllowNone, element "allowAll" AllowAll, @@ -156,6 +155,6 @@ newtype FederationRemoteTeam = FederationRemoteTeam instance ToSchema FederationRemoteTeam where schema = - object "FederationRemoteTeam" $ + object $ FederationRemoteTeam <$> teamId .= field "team_id" schema 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 1317d0b93a5..4a0e907c808 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs @@ -134,7 +134,7 @@ instance Default GetBy where instance ToSchema GetBy where schema = - object "GetBy" $ + object $ GetBy <$> (.includePendingInvitations) .= field "include_pending_invitations" schema <*> (.includeUsersWithExpiredInvitations) .= field "include_users_with_expired_invitations" schema @@ -173,7 +173,7 @@ data CreateGroupInternalRequest = CreateGroupInternalRequest instance ToSchema CreateGroupInternalRequest where schema = - object "CreateGroupInternalRequest" $ + object $ CreateGroupInternalRequest <$> (.managedBy) .= field "managed_by" schema <*> (.teamId) .= field "team_id" schema @@ -193,7 +193,7 @@ data UpdateGroupInternalRequest = UpdateGroupInternalRequest instance ToSchema UpdateGroupInternalRequest where schema = - object "UpdateGroupInternalRequest" $ + object $ UpdateGroupInternalRequest <$> (.teamId) .= field "team_id" schema <*> (.groupId) .= field "group_id" schema @@ -660,7 +660,7 @@ data NewKeyPackageRef = NewKeyPackageRef instance ToSchema NewKeyPackageRef where schema = - object "NewKeyPackageRef" $ + object $ NewKeyPackageRef <$> nkprUserId .= field "user_id" schema <*> nkprClientId .= field "client_id" schema @@ -724,6 +724,7 @@ type API = :<|> EnterpriseLoginApi :<|> SAMLIdPAPI :<|> DeleteApp + :<|> GetAppIds ) type SAMLIdPAPI = @@ -747,6 +748,15 @@ type DeleteApp = :> Delete '[Servant.JSON] NoContent ) +type GetAppIds = + Named + "i-get-app-ids" + ( "teams" + :> Capture "tid" TeamId + :> "apps" + :> Get '[Servant.JSON] [UserId] + ) + type IStatusAPI = Named "get-status" @@ -796,7 +806,7 @@ newtype FoundInvitationCode = FoundInvitationCode {getFoundInvitationCode :: Use instance ToSchema FoundInvitationCode where schema = FoundInvitationCode - <$> getFoundInvitationCode .= object "FoundInvitationCode" (field "code" (schema @User.InvitationCode)) + <$> getFoundInvitationCode .= object (field "code" (schema @User.InvitationCode)) type SuspendTeam = Named @@ -1027,7 +1037,7 @@ makePrisms ''IdpChangedNotification instance Data.Schema.ToSchema IdpChangedNotification where schema = - object "IdpChangedNotification" $ + object $ fromTagged <$> toTagged .= bind @@ -1049,26 +1059,26 @@ instance Data.Schema.ToSchema IdpChangedNotification where tagSchema :: ValueSchema NamedSwaggerDoc IdpChangedNotificationTag tagSchema = - enum @Text "Detail Tag" $ + enum @Text $ mconcat [element "created" IdPCreatedTag, element "deleted" IdPDeletedTag, element "updated" IdPUpdatedTag] createdSchema :: ValueSchema NamedSwaggerDoc (Maybe UserId, IdP) createdSchema = - object "IdPCreated" $ + object $ (,) <$> fst .= maybe_ (optField "user" schema) <*> snd .= field "idp" schema deletedSchema :: ValueSchema NamedSwaggerDoc (UserId, IdP) deletedSchema = - object "IdPDeleted" $ + object $ (,) <$> fst .= field "user" schema <*> snd .= field "idp" schema updatedSchema :: ValueSchema NamedSwaggerDoc (UserId, IdP, IdP) updatedSchema = - object "IdPUpdated" $ + object $ (,,) <$> fst3 .= field "user" schema <*> snd3 .= field "old" schema diff --git a/libs/wire-api/src/Wire/API/Routes/Internal/Brig/Connection.hs b/libs/wire-api/src/Wire/API/Routes/Internal/Brig/Connection.hs index 7f3d76810cf..cdfb0512f96 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/Brig/Connection.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Brig/Connection.hs @@ -36,7 +36,7 @@ data ConnectionsStatusRequest = ConnectionsStatusRequest instance ToSchema ConnectionsStatusRequest where schema = - object "ConnectionsStatusRequest" $ + object $ ConnectionsStatusRequest <$> csrFrom .= field "from" (array schema) <*> csrTo .= maybe_ (optField "to" (array schema)) @@ -51,7 +51,7 @@ data ConnectionsStatusRequestV2 = ConnectionsStatusRequestV2 instance ToSchema ConnectionsStatusRequestV2 where schema = - object "ConnectionsStatusRequestV2" $ + object $ ConnectionsStatusRequestV2 <$> csrv2From .= field "from" (array schema) <*> csrv2To .= maybe_ (optField "to" (array schema)) @@ -67,7 +67,7 @@ data ConnectionStatus = ConnectionStatus instance ToSchema ConnectionStatus where schema = - object "ConnectionStatus" $ + object $ ConnectionStatus <$> csFrom .= field "from" schema <*> csTo .= field "to" schema @@ -83,7 +83,7 @@ data ConnectionStatusV2 = ConnectionStatusV2 instance ToSchema ConnectionStatusV2 where schema = - object "ConnectionStatusV2" $ + object $ ConnectionStatusV2 <$> csv2From .= field "from" schema <*> csv2To .= field "qualified_to" schema diff --git a/libs/wire-api/src/Wire/API/Routes/Internal/Brig/EJPD.hs b/libs/wire-api/src/Wire/API/Routes/Internal/Brig/EJPD.hs index fca44780100..c57a8ea5b8a 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/Brig/EJPD.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Brig/EJPD.hs @@ -128,15 +128,15 @@ toEJPDResponseItemLeaf EJPDResponseItemRoot {..} = ---------------------------------------------------------------------- instance ToSchema EJPDRequestBody where - schema = object "EJPDRequestBody" do + schema = object do EJPDRequestBody <$> ejpdRequestBody .= field "EJPDRequest" (array schema) instance ToSchema EJPDResponseBody where - schema = object "EJPDResponseBody" do + schema = object do EJPDResponseBody <$> ejpdResponseBody .= field "EJPDResponse" (array schema) instance ToSchema EJPDResponseItemRoot where - schema = object "EJPDResponseItemRoot" do + schema = object do EJPDResponseItemRoot <$> ejpdResponseRootUserId .= field "UserId" schema <*> ejpdResponseRootTeamId .= maybe_ (optField "TeamId" schema) @@ -151,7 +151,7 @@ instance ToSchema EJPDResponseItemRoot where <*> (fmap Set.toList . ejpdResponseRootAssets) .= (Set.fromList <$$> maybe_ (optField "Assets" (array schema))) instance ToSchema EJPDResponseItemLeaf where - schema = object "EJPDResponseItemLeaf" do + schema = object do EJPDResponseItemLeaf <$> ejpdResponseLeafUserId .= field "UserId" schema <*> ejpdResponseLeafTeamId .= maybe_ (optField "TeamId" schema) @@ -165,20 +165,20 @@ instance ToSchema EJPDResponseItemLeaf where instance ToSchema EJPDContact where schema = - object "EJDPContact" do + object do EJPDContactFound <$> ejpdContactRelation .= field "contact_relation" schema <*> ejpdContactFound .= field "contact_item" schema instance ToSchema EJPDTeamContacts where - schema = object "EJPDTeamContacts" do + schema = object do EJPDTeamContacts <$> (Set.toList . ejpdTeamContacts) .= (Set.fromList <$> field "TeamContacts" (array schema)) <*> ejpdTeamContactsListType .= field "ListType" schema instance ToSchema EJPDConvInfo where schema = - object "EJPDConvInfo" $ + object $ EJPDConvInfo <$> ejpdConvName .= field "conv_name" schema <*> ejpdConvId .= field "conv_id" schema diff --git a/libs/wire-api/src/Wire/API/Routes/Internal/Galley/ConversationsIntra.hs b/libs/wire-api/src/Wire/API/Routes/Internal/Galley/ConversationsIntra.hs index a25baa28b23..1cd39377d54 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/Galley/ConversationsIntra.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Galley/ConversationsIntra.hs @@ -30,7 +30,7 @@ data DesiredMembership = Included | Excluded instance ToSchema DesiredMembership where schema = - enum @Text "DesiredMembership" $ + enum @Text $ mconcat [ element "included" Included, element "excluded" Excluded @@ -42,7 +42,7 @@ data Actor = LocalActor | RemoteActor instance ToSchema Actor where schema = - enum @Text "Actor" $ + enum @Text $ mconcat [ element "local_actor" LocalActor, element "remote_actor" RemoteActor @@ -60,7 +60,7 @@ data UpsertOne2OneConversationRequest = UpsertOne2OneConversationRequest instance ToSchema UpsertOne2OneConversationRequest where schema = - object "UpsertOne2OneConversationRequest" $ + object $ UpsertOne2OneConversationRequest <$> (tUntagged . uooLocalUser) .= field "local_user" (qTagUnsafe <$> schema) <*> (tUntagged . uooRemoteUser) .= field "remote_user" (qTagUnsafe <$> schema) diff --git a/libs/wire-api/src/Wire/API/Routes/Internal/Galley/TeamFeatureNoConfigMulti.hs b/libs/wire-api/src/Wire/API/Routes/Internal/Galley/TeamFeatureNoConfigMulti.hs index 8bb68c6eb38..11d7cbb681b 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/Galley/TeamFeatureNoConfigMulti.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Galley/TeamFeatureNoConfigMulti.hs @@ -34,9 +34,9 @@ data TeamStatus cfg = TeamStatus deriving (Show, Eq) deriving (A.ToJSON, A.FromJSON, S.ToSchema) via Schema (TeamStatus cfg) -instance ToSchema (TeamStatus cfg) where +instance forall k (cfg :: k). (Typeable k, Typeable cfg) => ToSchema (TeamStatus cfg) where schema = - object "TeamStatus" $ + object $ TeamStatus <$> team .= field "team" schema <*> status .= field "status" schema diff --git a/libs/wire-api/src/Wire/API/Routes/Internal/Galley/TeamsIntra.hs b/libs/wire-api/src/Wire/API/Routes/Internal/Galley/TeamsIntra.hs index 9398113741d..85c3b765248 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/Galley/TeamsIntra.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Galley/TeamsIntra.hs @@ -69,7 +69,7 @@ data TeamStatus instance S.ToSchema TeamStatus where schema = - S.enum @Text "TeamStatus" $ + S.enum @Text $ mconcat [ S.element "active" Active, S.element "pending_delete" PendingDelete, @@ -89,7 +89,7 @@ data TeamData = TeamData instance S.ToSchema TeamData where schema = - S.object "TeamData" $ + S.object $ TeamData <$> tdTeam S..= S.field "team" S.schema <*> tdStatus S..= S.field "status" S.schema @@ -105,7 +105,7 @@ data TeamStatusUpdate = TeamStatusUpdate instance S.ToSchema TeamStatusUpdate where schema = - S.object "TeamStatusUpdate" $ + S.object $ TeamStatusUpdate <$> tuStatus S..= S.field "status" S.schema <*> tuCurrency S..= S.maybe_ (S.optField "currency" S.genericToSchema) @@ -118,7 +118,7 @@ newtype TeamName = TeamName instance S.ToSchema TeamName where schema = - S.object "TeamName" $ + S.object $ TeamName <$> tnName S..= S.field "name" S.schema @@ -132,7 +132,7 @@ data GuardLegalholdPolicyConflicts = GuardLegalholdPolicyConflicts instance S.ToSchema GuardLegalholdPolicyConflicts where schema = - S.object "GuardLegalholdPolicyConflicts" $ + S.object $ GuardLegalholdPolicyConflicts <$> glhProtectee S..= S.field "glhProtectee" S.schema <*> glhUserClients S..= S.field "glhUserClients" S.schema diff --git a/libs/wire-api/src/Wire/API/Routes/MultiTablePaging.hs b/libs/wire-api/src/Wire/API/Routes/MultiTablePaging.hs index 2cdfaf692c9..d8390710146 100644 --- a/libs/wire-api/src/Wire/API/Routes/MultiTablePaging.hs +++ b/libs/wire-api/src/Wire/API/Routes/MultiTablePaging.hs @@ -67,12 +67,18 @@ type RequestSchemaConstraint name tables max def = (KnownNat max, KnownNat def, deriving via Schema (GetMultiTablePageRequest name tables max def) instance - (RequestSchemaConstraint name tables max def) => ToJSON (GetMultiTablePageRequest name tables max def) + ( Typeable tables, + RequestSchemaConstraint name tables max def + ) => + ToJSON (GetMultiTablePageRequest name tables max def) deriving via Schema (GetMultiTablePageRequest name tables max def) instance - (RequestSchemaConstraint name tables max def) => FromJSON (GetMultiTablePageRequest name tables max def) + ( Typeable tables, + RequestSchemaConstraint name tables max def + ) => + FromJSON (GetMultiTablePageRequest name tables max def) deriving via Schema (GetMultiTablePageRequest name tables max def) @@ -82,7 +88,12 @@ deriving via ) => S.ToSchema (GetMultiTablePageRequest name tables max def) -instance (RequestSchemaConstraint name tables max def) => ToSchema (GetMultiTablePageRequest name tables max def) where +instance + ( Typeable tables, + RequestSchemaConstraint name tables max def + ) => + ToSchema (GetMultiTablePageRequest name tables max def) + where schema = let addPagingStateDoc = description @@ -90,7 +101,6 @@ instance (RequestSchemaConstraint name tables max def) => ToSchema (GetMultiTabl \Every returned page contains a paging_state, this should be supplied to retrieve the next page." addSizeDoc = description ?~ ("optional, must be <= " <> textFromNat @max <> ", defaults to " <> textFromNat @def <> ".") in objectWithDocModifier - ("GetPaginated_" <> textFromSymbol @name) (description ?~ "A request to list some or all of a user's " <> textFromSymbol @name <> ", including remote ones") $ GetMultiTablePageRequest <$> gmtprSize .= (fromMaybe (toRange (Proxy @def)) <$> optFieldWithDocModifier "size" addSizeDoc schema) @@ -117,13 +127,19 @@ type PageSchemaConstraints name resultsKey tables a = (KnownSymbol resultsKey, K deriving via (Schema (MultiTablePage name resultsKey tables a)) instance - (PageSchemaConstraints name resultsKey tables a) => + ( Typeable tables, + Typeable a, + PageSchemaConstraints name resultsKey tables a + ) => ToJSON (MultiTablePage name resultsKey tables a) deriving via (Schema (MultiTablePage name resultsKey tables a)) instance - (PageSchemaConstraints name resultsKey tables a) => + ( Typeable tables, + Typeable a, + PageSchemaConstraints name resultsKey tables a + ) => FromJSON (MultiTablePage name resultsKey tables a) deriving via @@ -133,11 +149,17 @@ deriving via S.ToSchema (MultiTablePage name resultsKey tables a) instance - (KnownSymbol resultsKey, KnownSymbol name, ToSchema a, PagingTable tables) => + ( KnownSymbol resultsKey, + KnownSymbol name, + Typeable a, + ToSchema a, + Typeable tables, + PagingTable tables + ) => ToSchema (MultiTablePage name resultsKey tables a) where schema = - object (textFromSymbol @name <> "_Page") $ + object $ MultiTablePage <$> mtpResults .= field (textFromSymbol @resultsKey) (array schema) <*> mtpHasMore .= field "has_more" schema diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs b/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs index 4e7d5fdba14..2dbe0c784dc 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs @@ -805,7 +805,6 @@ data DeprecatedMatchingResult = DeprecatedMatchingResult instance ToSchema DeprecatedMatchingResult where schema = objectWithDocModifier - "DeprecatedMatchingResult" (S.deprecated ?~ True) $ DeprecatedMatchingResult <$ const [] diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Brig/DomainVerification.hs b/libs/wire-api/src/Wire/API/Routes/Public/Brig/DomainVerification.hs index e7447c46a0a..e674e035fa9 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Brig/DomainVerification.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Brig/DomainVerification.hs @@ -69,9 +69,8 @@ data DomainRedirectConfigTag instance ToSchema DomainRedirectConfigTag where schema = - enum @Text - "DomainRedirectConfigTag" - $ mconcat + enum @Text $ + mconcat [ element "remove" DomainRedirectConfigRemoveTag, element "backend" DomainRedirectConfigBackendTag, element "no-registration" DomainRedirectConfigNoRegistrationTag @@ -102,7 +101,7 @@ domainRedirectConfigV9Schema = DomainRedirectConfigRemoveTag -> tag _DomainRedirectConfigRemoveV9 (pure ()) instance ToSchema DomainRedirectConfigV9 where - schema = object "DomainRedirectConfigV9" domainRedirectConfigV9Schema + schema = object domainRedirectConfigV9Schema data DomainRedirectConfig = DomainRedirectConfigRemove @@ -141,7 +140,7 @@ domainRedirectConfigSchema = backendConfigObjectSchema :: ValueSchema NamedSwaggerDoc (HttpsUrl, HttpsUrl) backendConfigObjectSchema = - object "backend_config" $ + object $ (,) <$> fst .= field "config_url" schema <*> snd .= field "webapp_url" schema @@ -153,14 +152,14 @@ domainRedirectConfigToTag = \case DomainRedirectConfigNoRegistration -> DomainRedirectConfigNoRegistrationTag instance ToSchema DomainRedirectConfig where - schema = object "DomainRedirectConfig" domainRedirectConfigSchema + schema = object domainRedirectConfigSchema newtype GetDomainRegistrationRequest = GetDomainRegistrationRequest {domainRegistrationRequestEmail :: EmailAddress} deriving (A.FromJSON, A.ToJSON, S.ToSchema) via (Schema GetDomainRegistrationRequest) instance ToSchema GetDomainRegistrationRequest where schema = - object "GetDomainRegistrationRequest" $ + object $ GetDomainRegistrationRequest <$> domainRegistrationRequestEmail .= field "email" schema @@ -177,9 +176,8 @@ data TeamDomainRedirectTag = TeamNoRegistrationTag | TeamNoneTag instance ToSchema TeamDomainRedirectTag where schema = - enum @Text - "TeamDomainRedirectTag" - $ mconcat + enum @Text $ + mconcat [ element "no-registration" TeamNoRegistrationTag, element "none" TeamNoneTag ] @@ -225,7 +223,7 @@ data TeamInviteConfig = TeamInviteConfig instance ToSchema TeamInviteConfig where schema = - object "TeamInviteConfig" $ + object $ TeamInviteConfig <$> (.teamInvite) .= teamInviteObjectSchema <*> (maybeTeamDomainRedirectToTuple . (.domainRedirect)) .= maybeTeamDomainRedirectTargetObjectSchema @@ -244,7 +242,7 @@ data DomainVerificationChallenge = DomainVerificationChallenge instance ToSchema DomainVerificationChallenge where schema = - object "DomainVerificationChallenge" $ + object $ DomainVerificationChallenge <$> challengeId .= field "id" schema <*> token .= field "token" schema @@ -255,7 +253,7 @@ newtype ChallengeToken = ChallengeToken {unChallengeToken :: Token} instance ToSchema ChallengeToken where schema = - object "ChallengeToken" $ + object $ ChallengeToken <$> unChallengeToken .= field "challenge_token" schema @@ -264,16 +262,16 @@ newtype DomainOwnershipToken = DomainOwnershipToken {unDomainOwnershipToken :: T instance ToSchema DomainOwnershipToken where schema = - object "DomainOwnershipToken" $ + object $ DomainOwnershipToken <$> unDomainOwnershipToken .= field "domain_ownership_token" schema newtype RegisteredDomains (v :: Version) = RegisteredDomains {unRegisteredDomains :: [DomainRegistrationResponse v]} deriving (A.ToJSON, A.FromJSON, S.ToSchema) via Schema (RegisteredDomains v) -instance (SingI v) => ToSchema (RegisteredDomains v) where +instance (Typeable v, SingI v) => ToSchema (RegisteredDomains v) where schema = - object "RegisteredDomains" $ + object $ RegisteredDomains <$> unRegisteredDomains .= field "registered_domains" (array schema) @@ -295,7 +293,7 @@ deriving via Schema DomainRedirectResponseV9 instance S.ToSchema DomainRedirectR instance ToSchema DomainRedirectResponseV9 where schema = - object "DomainRedirectResponseV9" $ + object $ DomainRedirectResponse <$> (\r -> True <$ guard r.propagateUserExists) .= maybe_ @@ -314,7 +312,7 @@ deriving via Schema DomainRedirectResponseV10 instance S.ToSchema DomainRedirect instance ToSchema DomainRedirectResponseV10 where schema = - object "DomainRedirectResponseV10" $ + object $ DomainRedirectResponse <$> (\r -> True <$ guard r.propagateUserExists) .= maybe_ diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Galley/MLS.hs b/libs/wire-api/src/Wire/API/Routes/Public/Galley/MLS.hs index bc09fa549ac..d7637661df1 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley/MLS.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley/MLS.hs @@ -50,7 +50,7 @@ data MLSReset = MLSReset instance ToSchema MLSReset where schema = - object "MLSReset" $ + object $ MLSReset <$> (.groupId) .= field "group_id" schema <*> (.epoch) .= field "epoch" schema diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Galley/Team.hs b/libs/wire-api/src/Wire/API/Routes/Public/Galley/Team.hs index c8515b91068..c442cc975bc 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley/Team.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley/Team.hs @@ -50,7 +50,7 @@ data NonBindingNewTeam = NonBindingNewTeam instance ToSchema NonBindingNewTeam where schema = - object "NonBindingNewTeam" $ + object $ NonBindingNewTeam <$> (.teamName) .= fieldWithDocModifier "name" (description ?~ "team name") schema <*> (.teamIcon) .= fieldWithDocModifier "icon" (description ?~ "team icon (asset ID)") schema 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 ddf3e1c6b84..4e072cc0e3a 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Spar.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Spar.hs @@ -109,7 +109,7 @@ newtype GetByEmailReq = GetByEmailReq {email :: EmailAddress} instance ToSchema GetByEmailReq where schema = - object "GetByEmailReq" $ + object $ GetByEmailReq <$> email .= field "email" schema newtype GetByEmailResp = GetByEmailResp {ssoCode :: Maybe SAML.IdPId} @@ -118,7 +118,7 @@ newtype GetByEmailResp = GetByEmailResp {ssoCode :: Maybe SAML.IdPId} instance ToSchema GetByEmailResp where schema = - object "GetByEmailResp" $ + object $ GetByEmailResp <$> (fmap fromIdPId . ssoCode) .= maybe_ (optField "sso_code" (IdPId <$> uuidSchema)) diff --git a/libs/wire-api/src/Wire/API/Routes/Version.hs b/libs/wire-api/src/Wire/API/Routes/Version.hs index 064e66929e2..497a2dcf612 100644 --- a/libs/wire-api/src/Wire/API/Routes/Version.hs +++ b/libs/wire-api/src/Wire/API/Routes/Version.hs @@ -62,6 +62,10 @@ module Wire.API.Routes.Version Until, From, + -- * Versioned schema-profunctor things. + versionedObject, + versionedObjectWithDocModifier, + -- * Swagger module Wire.API.Routes.SpecialiseToVersion, ) @@ -71,6 +75,7 @@ import Control.Error (note) import Control.Lens (makePrisms, (?~)) import Data.Aeson (FromJSON, ToJSON (..)) import Data.Aeson qualified as Aeson +import Data.Aeson.Types qualified as Aeson import Data.Bifunctor import Data.Binary.Builder qualified as Builder import Data.ByteString.Conversion (ToByteString (builder), toByteString') @@ -179,7 +184,7 @@ versionByteString :: Version -> ByteString versionByteString = ("v" <>) . toByteString' . versionInt @Int instance ToSchema Version where - schema = enum @Text "Version" . mconcat $ (\v -> element (versionText v) v) <$> [minBound ..] + schema = enum @Text . mconcat $ (\v -> element (versionText v) v) <$> [minBound ..] instance FromHttpApiData Version where parseQueryParam v = note ("Unknown version: " <> v) $ @@ -206,7 +211,7 @@ newtype VersionNumber = VersionNumber {fromVersionNumber :: Version} instance ToSchema VersionNumber where schema = - enum @Integer "VersionNumber" . mconcat $ (\v -> element (versionInt v) (VersionNumber v)) <$> [minBound ..] + enum @Integer . mconcat $ (\v -> element (versionInt v) (VersionNumber v)) <$> [minBound ..] instance FromHttpApiData VersionNumber where parseHeader = first Text.pack . Aeson.eitherDecode . LBS.fromStrict @@ -235,7 +240,7 @@ data VersionInfo = VersionInfo instance ToSchema VersionInfo where schema = - objectWithDocModifier "VersionInfo" (S.schema . S.example ?~ toJSON example) $ + objectWithDocModifier (S.schema . S.example ?~ toJSON example) $ VersionInfo <$> vinfoSupported .= vinfoObjectSchema schema @@ -307,7 +312,7 @@ instance ToSchema VersionExp where <> tag _VersionExpDevelopment ( unnamed - (enum @Text "VersionExpDevelopment" (element "development" ())) + (enum @Text (element "development" ())) ) deriving via Schema VersionExp instance (FromJSON VersionExp) @@ -320,3 +325,24 @@ expandVersionExp (VersionExpConst v) = Set.singleton v expandVersionExp VersionExpDevelopment = Set.fromList developmentVersions $(promoteOrdInstances [''Version]) + +versionedObject :: + forall doc doc' a b. + (Typeable a, HasObject doc doc') => + Maybe Version -> + SchemaP doc Aeson.Object [Aeson.Pair] a b -> + SchemaP doc' Aeson.Value Aeson.Value a b +versionedObject version = namedObject (mkVersionedSchemaName @a version) + +versionedObjectWithDocModifier :: + forall doc doc' a. + (Typeable a, HasObject doc doc') => + Maybe Version -> + (doc' -> doc') -> + ObjectSchema doc a -> + ValueSchema doc' a +versionedObjectWithDocModifier v = namedObjectWithDocModifier (mkVersionedSchemaName @a v) + +mkVersionedSchemaName :: forall a. (Typeable a) => Maybe Version -> Text +mkVersionedSchemaName (Just v) = mkSchemaNameWith @a (versionText v) +mkVersionedSchemaName Nothing = mkSchemaName @a diff --git a/libs/wire-api/src/Wire/API/SystemSettings.hs b/libs/wire-api/src/Wire/API/SystemSettings.hs index 6f78a123fd8..b41a17acc59 100644 --- a/libs/wire-api/src/Wire/API/SystemSettings.hs +++ b/libs/wire-api/src/Wire/API/SystemSettings.hs @@ -40,7 +40,7 @@ data SystemSettingsPublic = SystemSettingsPublic instance ToSchema SystemSettingsPublic where schema = - object "SystemSettingsPublic" $ settingsPublicObjectSchema + object $ settingsPublicObjectSchema settingsPublicObjectSchema :: ObjectSchema SwaggerDoc SystemSettingsPublic settingsPublicObjectSchema = @@ -64,7 +64,7 @@ data SystemSettingsInternal = SystemSettingsInternal instance ToSchema SystemSettingsInternal where schema = - object "SystemSettingsInternal" $ settingsInternalObjectSchema + object $ settingsInternalObjectSchema settingsInternalObjectSchema :: ObjectSchema SwaggerDoc SystemSettingsInternal settingsInternalObjectSchema = @@ -81,7 +81,7 @@ data SystemSettings = SystemSettings instance ToSchema SystemSettings where schema = - object "SystemSettings" $ + object $ SystemSettings <$> ssPublic .= settingsPublicObjectSchema <*> ssInternal .= settingsInternalObjectSchema diff --git a/libs/wire-api/src/Wire/API/Team.hs b/libs/wire-api/src/Wire/API/Team.hs index 61be43b4b0c..f9c5dcf678c 100644 --- a/libs/wire-api/src/Wire/API/Team.hs +++ b/libs/wire-api/src/Wire/API/Team.hs @@ -105,7 +105,7 @@ newTeam tid uid nme ico tb = Team tid uid nme ico Nothing tb DefaultIcon instance ToSchema Team where schema = - objectWithDocModifier "Team" desc $ + objectWithDocModifier desc $ Team <$> _teamId .= field "id" schema <*> _teamCreator .= field "creator" schema @@ -147,7 +147,7 @@ data TeamBinding instance ToSchema TeamBinding where schema = over doc (deprecated ?~ True) $ - enum @Bool "TeamBinding" $ + enum @Bool $ mconcat [element True Binding, element False NonBinding] -------------------------------------------------------------------------------- @@ -166,7 +166,7 @@ newTeamList = TeamList instance ToSchema TeamList where schema = - object "TeamList" $ + object $ TeamList <$> _teamListTeams .= field "teams" (array schema) <*> _teamListHasMore .= field "has_more" schema @@ -191,7 +191,7 @@ newTeamObjectSchema = <*> newTeamIconKey .= maybe_ (optFieldWithDocModifier "icon_key" (description ?~ "The decryption key for the team icon S3 asset") schema) instance ToSchema NewTeam where - schema = object "NewTeam" newTeamObjectSchema + schema = object newTeamObjectSchema newNewTeam :: Range 1 256 Text -> Icon -> NewTeam newNewTeam nme ico = NewTeam nme ico Nothing @@ -260,7 +260,7 @@ validateTeamUpdateData u = instance ToSchema TeamUpdateData where schema = (`withParser` validateTeamUpdateData) - . object "TeamUpdateData" + . object $ TeamUpdateData <$> _nameUpdate .= maybe_ (optField "name" schema) <*> _iconUpdate .= maybe_ (optField "icon" schema) @@ -288,7 +288,7 @@ newTeamDeleteDataWithCode = TeamDeleteData instance ToSchema TeamDeleteData where schema = - object "TeamDeleteData" $ + object $ TeamDeleteData <$> _tdAuthPassword .= optField "password" (maybeWithDefault Null schema) <*> _tdVerificationCode .= maybe_ (optField "verification_code" schema) diff --git a/libs/wire-api/src/Wire/API/Team/Collaborator.hs b/libs/wire-api/src/Wire/API/Team/Collaborator.hs index c6d6e79a31a..d256ce92474 100644 --- a/libs/wire-api/src/Wire/API/Team/Collaborator.hs +++ b/libs/wire-api/src/Wire/API/Team/Collaborator.hs @@ -33,7 +33,7 @@ data CollaboratorPermission = CreateTeamConversation | ImplicitConnection instance ToSchema CollaboratorPermission where schema = - enum @Text "CollaboratorPermission" $ + enum @Text $ mconcat [ element "create_team_conversation" CreateTeamConversation, element "implicit_connection" ImplicitConnection @@ -54,7 +54,7 @@ data NewTeamCollaborator = NewTeamCollaborator instance ToSchema NewTeamCollaborator where schema = - object "NewTeamCollaborator" $ + object $ NewTeamCollaborator <$> (aUser .= field "user" schema) <*> (aPermissions .= field "permissions" (set schema)) @@ -69,7 +69,7 @@ data TeamCollaborator = TeamCollaborator instance ToSchema TeamCollaborator where schema = - object "TeamCollaborator" $ + object $ TeamCollaborator <$> (gUser .= field "user" schema) <*> (gTeam .= field "team" schema) diff --git a/libs/wire-api/src/Wire/API/Team/Conversation.hs b/libs/wire-api/src/Wire/API/Team/Conversation.hs index d3b240d9f54..53427886ce7 100644 --- a/libs/wire-api/src/Wire/API/Team/Conversation.hs +++ b/libs/wire-api/src/Wire/API/Team/Conversation.hs @@ -58,7 +58,6 @@ managedDesc = instance ToSchema TeamConversation where schema = objectWithDocModifier - "TeamConversation" (description ?~ "Team conversation data") $ TeamConversation <$> _conversationId .= field "conversation" schema @@ -86,7 +85,6 @@ newtype TeamConversationList = TeamConversationList {teamConversations :: [TeamC instance ToSchema TeamConversationList where schema = objectWithDocModifier - "TeamConversationList" (description ?~ "Team conversation list") $ TeamConversationList <$> teamConversations .= field "conversations" (array schema) diff --git a/libs/wire-api/src/Wire/API/Team/Export.hs b/libs/wire-api/src/Wire/API/Team/Export.hs index 156f541e5ed..ca4b6160080 100644 --- a/libs/wire-api/src/Wire/API/Team/Export.hs +++ b/libs/wire-api/src/Wire/API/Team/Export.hs @@ -70,7 +70,7 @@ data TeamExportUser = TeamExportUser instance ToSchema TeamExportUser where schema = - object "TeamExportUser" $ + object $ TeamExportUser <$> tExportDisplayName .= field "display_name" schema <*> tExportHandle .= maybe_ (optField "handle" schema) diff --git a/libs/wire-api/src/Wire/API/Team/Feature.hs b/libs/wire-api/src/Wire/API/Team/Feature.hs index 15117fde387..12185dbcc89 100644 --- a/libs/wire-api/src/Wire/API/Team/Feature.hs +++ b/libs/wire-api/src/Wire/API/Team/Feature.hs @@ -405,9 +405,9 @@ defUnlockedFeature = config = def } -instance (IsFeatureConfig cfg) => ToSchema (LockableFeature cfg) where +instance (Typeable cfg, IsFeatureConfig cfg) => ToSchema (LockableFeature cfg) where schema = - object name $ + object $ LockableFeature <$> (.status) .= field "status" schema <*> (.lockStatus) .= field "lockStatus" schema @@ -416,9 +416,6 @@ instance (IsFeatureConfig cfg) => ToSchema (LockableFeature cfg) where .= optField "ttl" (schema :: ValueSchema NamedSwaggerDoc FeatureTTL) - where - inner = schema @cfg - name = fromMaybe "" (getName (schemaDoc inner)) <> ".LockableFeature" instance (Arbitrary cfg, IsFeatureConfig cfg) => Arbitrary (LockableFeature cfg) where arbitrary = LockableFeature <$> arbitrary <*> arbitrary <*> arbitrary @@ -439,9 +436,9 @@ instance Default (LockableFeaturePatch cfg) where -- | The ToJSON implementation of `LockableFeaturePatch` will encode the trivial config as `"config": {}` -- when the value is a `Just`, if it's `Nothing` it will be omitted, which is the important part. -instance (ToSchema cfg) => ToSchema (LockableFeaturePatch cfg) where +instance (Typeable cfg, ToSchema cfg) => ToSchema (LockableFeaturePatch cfg) where schema = - object name $ + object $ LockableFeaturePatch <$> (.status) .= maybe_ (optField "status" schema) <*> (.lockStatus) .= maybe_ (optField "lockStatus" schema) @@ -450,9 +447,6 @@ instance (ToSchema cfg) => ToSchema (LockableFeaturePatch cfg) where .= optField "ttl" (schema :: ValueSchema NamedSwaggerDoc FeatureTTL) - where - inner = schema @cfg - name = fromMaybe "" (getName (schemaDoc inner)) <> ".LockableFeaturePatch" instance (Arbitrary cfg, IsFeatureConfig cfg) => Arbitrary (LockableFeaturePatch cfg) where arbitrary = LockableFeaturePatch <$> arbitrary <*> arbitrary <*> arbitrary @@ -476,9 +470,9 @@ forgetLock ws = Feature ws.status ws.config withLockStatus :: LockStatus -> Feature a -> LockableFeature a withLockStatus ls (Feature s c) = LockableFeature s ls c -instance (ToSchema cfg, ToObjectSchema cfg) => ToSchema (Feature cfg) where +instance (Typeable cfg, ToObjectSchema cfg) => ToSchema (Feature cfg) where schema = - object name $ + object $ Feature <$> (.status) .= field "status" schema <*> (.config) .= objectSchema @cfg @@ -486,12 +480,9 @@ instance (ToSchema cfg, ToObjectSchema cfg) => ToSchema (Feature cfg) where .= optField "ttl" (schema :: ValueSchema NamedSwaggerDoc FeatureTTL) - where - inner = schema @cfg - name = fromMaybe "" (getName (schemaDoc inner)) <> ".Feature" instance - (ToObjectSchema (Versioned v cfg), ToSchema (Versioned v cfg)) => + (Typeable cfg, Typeable v, ToObjectSchema (Versioned v cfg)) => ToSchema (Versioned v (Feature cfg)) where schema = Versioned . fmap unVersioned <$> (fmap Versioned . unVersioned) .= schema @(Feature (Versioned v cfg)) @@ -605,7 +596,7 @@ instance FromHttpApiData LockStatus where instance ToSchema LockStatus where schema = - enum @Text "LockStatus" $ + enum @Text $ mconcat [ element "locked" LockStatusLocked, element "unlocked" LockStatusUnlocked @@ -655,7 +646,7 @@ newtype LockStatusResponse = LockStatusResponse {_unlockStatus :: LockStatus} instance ToSchema LockStatusResponse where schema = - object "LockStatusResponse" $ + object $ LockStatusResponse <$> _unlockStatus .= field "lockStatus" schema @@ -669,7 +660,7 @@ data GuestLinksConfig = GuestLinksConfig deriving (ParseDbFeature, Default) via TrivialFeature GuestLinksConfig instance ToSchema GuestLinksConfig where - schema = object "GuestLinksConfig" objectSchema + schema = object objectSchema instance Default (LockableFeature GuestLinksConfig) where def = defUnlockedFeature @@ -701,7 +692,7 @@ instance IsFeatureConfig LegalholdConfig where featureSingleton = FeatureSingletonLegalholdConfig instance ToSchema LegalholdConfig where - schema = object "LegalholdConfig" objectSchema + schema = object objectSchema -------------------------------------------------------------------------------- -- SSO feature @@ -724,7 +715,7 @@ instance IsFeatureConfig SSOConfig where featureSingleton = FeatureSingletonSSOConfig instance ToSchema SSOConfig where - schema = object "SSOConfig" objectSchema + schema = object objectSchema -------------------------------------------------------------------------------- -- SearchVisibility available feature @@ -748,7 +739,7 @@ instance IsFeatureConfig SearchVisibilityAvailableConfig where featureSingleton = FeatureSingletonSearchVisibilityAvailableConfig instance ToSchema SearchVisibilityAvailableConfig where - schema = object "SearchVisibilityAvailableConfig" objectSchema + schema = object objectSchema type instance DeprecatedFeatureName V2 SearchVisibilityAvailableConfig = "search-visibility" @@ -769,7 +760,7 @@ data RequireExternalEmailVerificationConfig = RequireExternalEmailVerificationCo deriving (ParseDbFeature, Default) via (TrivialFeature RequireExternalEmailVerificationConfig) instance ToSchema RequireExternalEmailVerificationConfig where - schema = object "RequireExternalEmailVerificationConfig" objectSchema + schema = object objectSchema instance Default (LockableFeature RequireExternalEmailVerificationConfig) where def = defUnlockedFeature @@ -806,7 +797,7 @@ instance IsFeatureConfig DigitalSignaturesConfig where type instance DeprecatedFeatureName V2 DigitalSignaturesConfig = "digital-signatures" instance ToSchema DigitalSignaturesConfig where - schema = object "DigitalSignaturesConfig" objectSchema + schema = object objectSchema -------------------------------------------------------------------------------- -- ConferenceCalling feature @@ -875,9 +866,9 @@ instance IsFeatureConfig ConferenceCallingConfig where type FeatureSymbol ConferenceCallingConfig = "conferenceCalling" featureSingleton = FeatureSingletonConferenceCallingConfig -instance (OptWithDefault f) => ToSchema (ConferenceCallingConfigB Covered f) where +instance (Typeable f, OptWithDefault f) => ToSchema (ConferenceCallingConfigB Covered f) where schema = - object "ConferenceCallingConfig" $ + object $ ConferenceCallingConfig <$> one2OneCalls .= fromOpt @@ -893,7 +884,7 @@ data SndFactorPasswordChallengeConfig = SndFactorPasswordChallengeConfig deriving (ParseDbFeature, Default) via (TrivialFeature SndFactorPasswordChallengeConfig) instance ToSchema SndFactorPasswordChallengeConfig where - schema = object "SndFactorPasswordChallengeConfig" objectSchema + schema = object objectSchema instance Default (LockableFeature SndFactorPasswordChallengeConfig) where def = defLockedFeature @@ -926,7 +917,7 @@ instance IsFeatureConfig SearchVisibilityInboundConfig where featureSingleton = FeatureSingletonSearchVisibilityInboundConfig instance ToSchema SearchVisibilityInboundConfig where - schema = object "SearchVisibilityInboundConfig" objectSchema + schema = object objectSchema ---------------------------------------------------------------------- -- ClassifiedDomains feature @@ -952,7 +943,7 @@ deriving via (GenericUniform ClassifiedDomainsConfig) instance Arbitrary Classif instance ToSchema ClassifiedDomainsConfig where schema = - object "ClassifiedDomainsConfig" $ + object $ ClassifiedDomainsConfig <$> classifiedDomainsDomains .= field "domains" (array schema) @@ -998,9 +989,9 @@ deriving via (BarbieFeature AppLockConfigB) instance ToSchema AppLockConfig instance Default AppLockConfig where def = AppLockConfig (EnforceAppLock False) 60 -instance (FieldF f) => ToSchema (AppLockConfigB Covered f) where +instance (Typeable f, FieldF f) => ToSchema (AppLockConfigB Covered f) where schema = - object "AppLockConfig" $ + object $ AppLockConfig <$> (.enforce) .= fieldF "enforceAppLock" schema <*> (.timeout) .= fieldF "inactivityTimeoutSecs" schema @@ -1046,7 +1037,7 @@ instance IsFeatureConfig FileSharingConfig where featureSingleton = FeatureSingletonFileSharingConfig instance ToSchema FileSharingConfig where - schema = object "FileSharingConfig" objectSchema + schema = object objectSchema ---------------------------------------------------------------------- -- SelfDeletingMessagesConfig @@ -1079,9 +1070,9 @@ deriving via (BarbieFeature SelfDeletingMessagesConfigB) instance (ToSchema Self instance Default SelfDeletingMessagesConfig where def = SelfDeletingMessagesConfig 0 -instance (FieldF f) => ToSchema (SelfDeletingMessagesConfigB Covered f) where +instance (Typeable f, FieldF f) => ToSchema (SelfDeletingMessagesConfigB Covered f) where schema = - object "SelfDeletingMessagesConfig" $ + object $ SelfDeletingMessagesConfig <$> sdmEnforcedTimeoutSeconds .= fieldF "enforcedTimeoutSeconds" schema @@ -1139,9 +1130,9 @@ instance Default MLSConfig where mlsGroupInfoDiagnostics = Any False } -instance (FieldF f) => ToSchema (MLSConfigB Covered f) where +instance (Typeable f, FieldF f) => ToSchema (MLSConfigB Covered f) where schema = - object "MLSConfig" $ + object $ MLSConfig <$> mlsProtocolToggleUsers .= ( fieldWithDocModifierF @@ -1205,16 +1196,16 @@ data ChannelPermissions = TeamMembers | Everyone | Admins instance ToSchema ChannelPermissions where schema = - enum @Text "ChannelPermissions" $ + enum @Text $ mconcat [ element "team-members" TeamMembers, element "everyone" Everyone, element "admins" Admins ] -instance (FieldF f) => ToSchema (ChannelsConfigB Covered f) where +instance (Typeable f, FieldF f) => ToSchema (ChannelsConfigB Covered f) where schema = - object "ChannelsConfig" $ + object $ ChannelsConfig <$> allowedToCreateChannels .= fieldF "allowed_to_create_channels" schema <*> allowedToOpenChannels .= fieldF "allowed_to_open_channels" schema @@ -1249,7 +1240,7 @@ instance IsFeatureConfig ExposeInvitationURLsToTeamAdminConfig where featureSingleton = FeatureSingletonExposeInvitationURLsToTeamAdminConfig instance ToSchema ExposeInvitationURLsToTeamAdminConfig where - schema = object "ExposeInvitationURLsToTeamAdminConfig" objectSchema + schema = object objectSchema ---------------------------------------------------------------------- -- OutlookCalIntegrationConfig @@ -1273,7 +1264,7 @@ instance IsFeatureConfig OutlookCalIntegrationConfig where featureSingleton = FeatureSingletonOutlookCalIntegrationConfig instance ToSchema OutlookCalIntegrationConfig where - schema = object "OutlookCalIntegrationConfig" objectSchema + schema = object objectSchema ---------------------------------------------------------------------- -- MlsE2EIdConfig @@ -1329,9 +1320,9 @@ instance Arbitrary MlsE2EIdConfig where <*> fmap (Alt . pure) arbitrary <*> arbitrary -instance (FieldF f) => ToSchema (MlsE2EIdConfigB Covered f) where +instance (Typeable f, FieldF f) => ToSchema (MlsE2EIdConfigB Covered f) where schema = - object "MlsE2EIdConfig" $ + object $ MlsE2EIdConfig <$> ( (fmap toSeconds . verificationExpiration) .= fieldWithDocModifierF @@ -1414,9 +1405,9 @@ instance Arbitrary MlsMigrationConfig where finaliseRegardlessAfter = finaliseRegardlessAfter } -instance (NestedMaybe f) => ToSchema (MlsMigrationConfigB Covered f) where +instance (Typeable f, NestedMaybe f) => ToSchema (MlsMigrationConfigB Covered f) where schema = - object "MlsMigration" $ + object $ MlsMigrationConfig <$> startTime .= nestedMaybeField "startTime" (unnamed utcTimeSchema) <*> finaliseRegardlessAfter .= nestedMaybeField "finaliseRegardlessAfter" (unnamed utcTimeSchema) @@ -1467,9 +1458,9 @@ instance Default EnforceFileDownloadLocationConfig where instance Arbitrary EnforceFileDownloadLocationConfig where arbitrary = EnforceFileDownloadLocationConfig . fmap (T.pack . getPrintableString) <$> arbitrary -instance (NestedMaybe f) => ToSchema (EnforceFileDownloadLocationConfigB Covered f) where +instance (Typeable f, NestedMaybe f) => ToSchema (EnforceFileDownloadLocationConfigB Covered f) where schema = - object "EnforceFileDownloadLocation" $ + object $ EnforceFileDownloadLocationConfig <$> enforcedDownloadLocation .= nestedMaybeField "enforcedDownloadLocation" (unnamed schema) @@ -1508,7 +1499,7 @@ instance IsFeatureConfig LimitedEventFanoutConfig where featureSingleton = FeatureSingletonLimitedEventFanoutConfig instance ToSchema LimitedEventFanoutConfig where - schema = object "LimitedEventFanoutConfig" objectSchema + schema = object objectSchema -------------------------------------------------------------------------------- -- DomainRegistration feature @@ -1521,7 +1512,7 @@ data DomainRegistrationConfig = DomainRegistrationConfig deriving (Default, ParseDbFeature) via (TrivialFeature DomainRegistrationConfig) instance ToSchema DomainRegistrationConfig where - schema = object "DomainRegistrationConfig" objectSchema + schema = object objectSchema instance Default (LockableFeature DomainRegistrationConfig) where def = defLockedFeature @@ -1543,7 +1534,7 @@ data CellsPropertyStatus = Enabled | Disabled | Enforced instance ToSchema CellsPropertyStatus where schema = - enum @Text "CellsPropertyStatus" $ + enum @Text $ mconcat [ element "enabled" Enabled, element "disabled" Disabled, @@ -1560,7 +1551,7 @@ data CellsProperty = CellsProperty instance ToSchema CellsProperty where schema = - object "CellsProperty" $ + object $ CellsProperty <$> (.enabled) .= field "enabled" schema <*> (.default_) .= field "default" schema @@ -1575,7 +1566,7 @@ data CellsUsers = CellsUsers instance ToSchema CellsUsers where schema = - object "CellsUsers" $ + object $ CellsUsers <$> (.externals) .= field "externals" schema <*> (.guests) .= field "guests" schema @@ -1587,7 +1578,7 @@ newtype CellsCollaboraStatus = CellsCollaboraStatus {enabled :: Bool} instance ToSchema CellsCollaboraStatus where schema = - object "CellsCollaboraStatus" $ + object $ CellsCollaboraStatus <$> (.enabled) .= field "enabled" schema @@ -1604,7 +1595,7 @@ data CellsPublicLinks = CellsPublicLinks instance ToSchema CellsPublicLinks where schema = - object "CellsPublicLinks" $ + object $ CellsPublicLinks <$> enableFiles .= field "enableFiles" schema <*> enableFolders .= field "enableFolders" schema @@ -1623,7 +1614,7 @@ data CellsRecycle = CellsRecycle instance ToSchema CellsRecycle where schema = - object "CellsRecycle" $ + object $ CellsRecycle <$> autoPurgeDays .= field "autoPurgeDays" schema <*> disable .= field "disable" schema @@ -1639,7 +1630,7 @@ data CellsConfigStorage = CellsConfigStorage instance ToSchema CellsConfigStorage where schema = - object "CellsConfigStorage" $ + object $ CellsConfigStorage <$> perFileQuotaBytes .= field "perFileQuotaBytes" schema <*> recycle .= field "recycle" schema @@ -1654,7 +1645,7 @@ data CellsUserMetaTags = CellsUserMetaTags instance ToSchema CellsUserMetaTags where schema = - object "CellsUserMetaTags" $ + object $ CellsUserMetaTags <$> defaultValues .= field "defaultValues" (array schema) <*> allowFreeValues .= field "allowFreeValues" schema @@ -1666,7 +1657,7 @@ newtype CellsNamespaces = CellsNamespaces {usermetaTags :: CellsUserMetaTags} instance ToSchema CellsNamespaces where schema = - object "CellsNamespaces" $ + object $ CellsNamespaces <$> usermetaTags .= field "usermetaTags" schema @@ -1677,7 +1668,7 @@ newtype CellsMetadata = CellsMetadata {namespaces :: CellsNamespaces} instance ToSchema CellsMetadata where schema = - object "CellsMetadata" $ + object $ CellsMetadata <$> namespaces .= field "namespaces" schema @@ -1752,9 +1743,9 @@ instance Default CellsConfig where } } -instance (FieldF f) => ToSchema (CellsConfigB Covered f) where +instance (Typeable f, FieldF f) => ToSchema (CellsConfigB Covered f) where schema = - objectWithDocModifier "CellsConfig" (S.schema . S.example ?~ schemaToJSON (def @CellsConfig)) $ + objectWithDocModifier (S.schema . S.example ?~ schemaToJSON (def @CellsConfig)) $ CellsConfig <$> channels .= fieldF "channels" schema <*> groups .= fieldF "groups" schema @@ -1766,7 +1757,7 @@ instance (FieldF f) => ToSchema (CellsConfigB Covered f) where <*> metadata .= fieldF "metadata" schema instance ToSchema (Versioned V13 CellsConfig) where - schema = object "CellsConfigV13" objectSchema + schema = object objectSchema instance ToObjectSchema (Versioned V13 CellsConfig) where objectSchema = pure $ Versioned def @@ -1791,7 +1782,7 @@ data CollaboraEdition = No | Code | Cool instance ToSchema CollaboraEdition where schema = - enum @Text "CollaboraEdition" $ + enum @Text $ mconcat [ element "NO" No, element "CODE" Code, @@ -1807,7 +1798,7 @@ newtype CellsCollabora = CellsCollabora instance ToSchema CellsCollabora where schema = - object "CellsCollabora" $ + object $ CellsCollabora <$> edition .= field "edition" schema @@ -1819,7 +1810,7 @@ newtype CellsBackend = CellsBackend deriving newtype (Arbitrary) instance ToSchema CellsBackend where - schema = object "CellsBackend" $ CellsBackend <$> url .= field "url" schema + schema = object $ CellsBackend <$> url .= field "url" schema newtype NumBytes = NumBytes {unNumBytes :: BigIntString} deriving newtype (Show, Eq) @@ -1849,7 +1840,7 @@ newtype CellsStorage = CellsStorage instance ToSchema CellsStorage where schema = - object "CellsStorage" $ + object $ CellsStorage <$> perUserQuotaBytes .= field "perUserQuotaBytes" schema @@ -1888,9 +1879,9 @@ instance Default CellsInternalConfig where storage = CellsStorage $ NumBytes $ BigIntString 1000000000000 -- 1 TB } -instance (FieldF f) => ToSchema (CellsInternalConfigB Covered f) where +instance (Typeable f, FieldF f) => ToSchema (CellsInternalConfigB Covered f) where schema = - object "CellsInternalConfig" $ + object $ CellsInternalConfig <$> backend .= fieldF "backend" schema <*> (.collabora) .= fieldF "collabora" schema @@ -1927,7 +1918,7 @@ instance Default AllowedGlobalOperationsConfig where instance ToSchema AllowedGlobalOperationsConfig where schema = - object "AllowedGlobalOperationsConfig" $ + object $ AllowedGlobalOperationsConfig <$> mlsConversationReset .= field "mlsConversationReset" schema @@ -1958,7 +1949,7 @@ instance ParseDbFeature AssetAuditLogConfig where serialiseDbConfig = DbConfig . schemaToJSON instance ToSchema AssetAuditLogConfig where - schema = object "AssetAuditLogConfig" objectSchema + schema = object objectSchema instance Default AssetAuditLogConfig where def = AssetAuditLogConfig @@ -1984,7 +1975,7 @@ data ConsumableNotificationsConfig = ConsumableNotificationsConfig deriving (Default, ParseDbFeature) via (TrivialFeature ConsumableNotificationsConfig) instance ToSchema ConsumableNotificationsConfig where - schema = object "ConsumableNotificationsConfig" objectSchema + schema = object objectSchema instance Default (LockableFeature ConsumableNotificationsConfig) where def = defLockedFeature @@ -2006,7 +1997,7 @@ data ChatBubblesConfig = ChatBubblesConfig deriving (ParseDbFeature, Default) via TrivialFeature ChatBubblesConfig instance ToSchema ChatBubblesConfig where - schema = object "ChatBubblesConfig" objectSchema + schema = object objectSchema instance Default (LockableFeature ChatBubblesConfig) where def = defLockedFeature @@ -2028,7 +2019,7 @@ data AppsConfig = AppsConfig deriving (ParseDbFeature, Default) via TrivialFeature AppsConfig instance ToSchema AppsConfig where - schema = object "AppsConfig" objectSchema + schema = object objectSchema instance Default (LockableFeature AppsConfig) where def = defLockedFeature @@ -2053,7 +2044,7 @@ data SimplifiedUserConnectionRequestQRCodeConfig = SimplifiedUserConnectionReque deriving (ParseDbFeature, Default) via TrivialFeature SimplifiedUserConnectionRequestQRCodeConfig instance ToSchema SimplifiedUserConnectionRequestQRCodeConfig where - schema = object "SimplifiedUserConnectionRequestQRCode" objectSchema + schema = object objectSchema instance Default (LockableFeature SimplifiedUserConnectionRequestQRCodeConfig) where def = defUnlockedFeature @@ -2075,7 +2066,7 @@ data StealthUsersConfig = StealthUsersConfig deriving (ParseDbFeature, Default) via TrivialFeature StealthUsersConfig instance ToSchema StealthUsersConfig where - schema = object "StealthUsersConfig" objectSchema + schema = object objectSchema instance Default (LockableFeature StealthUsersConfig) where def = defLockedFeature @@ -2100,7 +2091,7 @@ data MeetingsConfig = MeetingsConfig deriving (ParseDbFeature, Default) via TrivialFeature MeetingsConfig instance ToSchema MeetingsConfig where - schema = object "MeetingsConfig" objectSchema + schema = object objectSchema instance Default (LockableFeature MeetingsConfig) where def = defUnlockedFeature @@ -2125,7 +2116,7 @@ data MeetingsPremiumConfig = MeetingsPremiumConfig deriving (ParseDbFeature, Default) via TrivialFeature MeetingsPremiumConfig instance ToSchema MeetingsPremiumConfig where - schema = object "MeetingsPremiumConfig" objectSchema + schema = object objectSchema instance Default (LockableFeature MeetingsPremiumConfig) where def = defLockedFeature @@ -2166,7 +2157,7 @@ instance ToHttpApiData FeatureStatus where instance ToSchema FeatureStatus where schema = - enum @Text "FeatureStatus" $ + enum @Text $ mconcat [ element "enabled" FeatureStatusEnabled, element "disabled" FeatureStatusDisabled @@ -2268,15 +2259,18 @@ instance (HObjectSchema c xs, c x) => HObjectSchema c ((x :: Type) : xs) where hobjectSchema f = (:*) <$> hd .= f <*> tl .= hobjectSchema @c @xs f -- | constraint synonym for 'ToSchema' 'AllTeamFeatures' -class (IsFeatureConfig cfg, ToSchema cfg) => FeatureFieldConstraints cfg +class (Typeable cfg, IsFeatureConfig cfg, ToSchema cfg) => FeatureFieldConstraints cfg -instance (IsFeatureConfig cfg, ToSchema cfg) => FeatureFieldConstraints cfg +instance (Typeable cfg, IsFeatureConfig cfg, ToSchema cfg) => FeatureFieldConstraints cfg instance ToSchema AllTeamFeatures where schema = - object "AllTeamFeatures" $ hobjectSchema @FeatureFieldConstraints featureField + object $ hobjectSchema @FeatureFieldConstraints featureField where - featureField :: forall cfg. (FeatureFieldConstraints cfg) => ObjectSchema SwaggerDoc (LockableFeature cfg) + featureField :: + forall cfg. + (FeatureFieldConstraints cfg) => + ObjectSchema SwaggerDoc (LockableFeature cfg) featureField = field (T.pack (symbolVal (Proxy @(FeatureSymbol cfg)))) schema class (Arbitrary cfg, IsFeatureConfig cfg) => ArbitraryFeatureConfig cfg @@ -2438,7 +2432,7 @@ instance Default TeamFeatureMigrationState where instance ToSchema TeamFeatureMigrationState where schema = - enum @Text "TeamFeatureMigrationState" $ + enum @Text $ mconcat [ element "not_started" MigrationNotStarted, element "in_progress" MigrationInProgress, diff --git a/libs/wire-api/src/Wire/API/Team/Invitation.hs b/libs/wire-api/src/Wire/API/Team/Invitation.hs index b51e52a0eef..e5ca562ea1b 100644 --- a/libs/wire-api/src/Wire/API/Team/Invitation.hs +++ b/libs/wire-api/src/Wire/API/Team/Invitation.hs @@ -74,7 +74,7 @@ instance ToSchema InvitationRequest where invitationRequestSchema :: Bool -> ValueSchema NamedSwaggerDoc InvitationRequest invitationRequestSchema allowExisting = - objectWithDocModifier "InvitationRequest" (DS.description ?~ "A request to join a team on Wire.") $ + objectWithDocModifier (DS.description ?~ "A request to join a team on Wire.") $ InvitationRequest <$> locale .= optFieldWithDocModifier "locale" (DS.description ?~ "Locale to use for the invitation.") (maybeWithDefault A.Null schema) @@ -111,7 +111,6 @@ data Invitation = Invitation instance ToSchema Invitation where schema = objectWithDocModifier - "Invitation" (DS.description ?~ "An invitation to join a team on Wire. If invitee is invited from an existing personal account, inviter email is included.") invitationObjectSchema @@ -191,7 +190,7 @@ data InvitationList = InvitationList instance ToSchema InvitationList where schema = - objectWithDocModifier "InvitationList" (DS.description ?~ "A list of sent team invitations.") $ + objectWithDocModifier (DS.description ?~ "A list of sent team invitations.") $ InvitationList <$> ilInvitations .= field "invitations" (array schema) <*> ilHasMore .= fieldWithDocModifier "has_more" (DS.description ?~ "Indicator that the server has more invitations than returned.") schema @@ -208,7 +207,7 @@ data AcceptTeamInvitation = AcceptTeamInvitation instance ToSchema AcceptTeamInvitation where schema = - objectWithDocModifier "AcceptTeamInvitation" (DS.description ?~ "Accept an invitation to join a team on Wire.") $ + objectWithDocModifier (DS.description ?~ "Accept an invitation to join a team on Wire.") $ AcceptTeamInvitation <$> (.code) .= fieldWithDocModifier "code" (DS.description ?~ "Invitation code to accept.") schema <*> (.password) .= fieldWithDocModifier "password" (DS.description ?~ "The user account password.") schema @@ -223,7 +222,7 @@ data InvitationUserView = InvitationUserView instance ToSchema InvitationUserView where schema = - object "InvitationUserView" $ + object $ InvitationUserView <$> invitation .= invitationObjectSchema <*> inviterEmail .= maybe_ (optField "created_by_email" schema) diff --git a/libs/wire-api/src/Wire/API/Team/LegalHold.hs b/libs/wire-api/src/Wire/API/Team/LegalHold.hs index c0bfa22047c..a7c65addd22 100644 --- a/libs/wire-api/src/Wire/API/Team/LegalHold.hs +++ b/libs/wire-api/src/Wire/API/Team/LegalHold.hs @@ -60,7 +60,7 @@ data NewLegalHoldService = NewLegalHoldService instance ToSchema NewLegalHoldService where schema = - object "NewLegalHoldService" $ + object $ NewLegalHoldService <$> newLegalHoldServiceUrl .= field "base_url" schema <*> newLegalHoldServiceKey .= field "public_key" schema @@ -84,7 +84,7 @@ data LHServiceStatus = Configured | NotConfigured | Disabled instance ToSchema LHServiceStatus where schema = - enum @Text "LHServiceStatus" $ + enum @Text $ mconcat [ element "configured" Configured, element "not_configured" NotConfigured, @@ -93,7 +93,7 @@ instance ToSchema LHServiceStatus where instance ToSchema ViewLegalHoldService where schema = - object "ViewLegalHoldService" $ + object $ toOutput .= recordSchema `withParser` validateViewLegalHoldService @@ -132,7 +132,7 @@ data ViewLegalHoldServiceInfo = ViewLegalHoldServiceInfo instance ToSchema ViewLegalHoldServiceInfo where schema = - object "ViewLegalHoldServiceInfo" $ + object $ ViewLegalHoldServiceInfo <$> viewLegalHoldServiceTeam .= field "team_id" schema <*> viewLegalHoldServiceUrl .= field "base_url" schema @@ -156,7 +156,7 @@ data UserLegalHoldStatusResponse = UserLegalHoldStatusResponse instance ToSchema UserLegalHoldStatusResponse where schema = - object "UserLegalHoldStatusResponse" $ + object $ UserLegalHoldStatusResponse <$> ulhsrStatus .= field "status" schema <*> ulhsrLastPrekey .= maybe_ (optField "last_prekey" schema) @@ -174,7 +174,7 @@ data RemoveLegalHoldSettingsRequest = RemoveLegalHoldSettingsRequest instance ToSchema RemoveLegalHoldSettingsRequest where schema = - object "RemoveLegalHoldSettingsRequest" $ + object $ RemoveLegalHoldSettingsRequest <$> rmlhsrPassword .= maybe_ (optField "password" schema) @@ -190,7 +190,7 @@ data DisableLegalHoldForUserRequest = DisableLegalHoldForUserRequest instance ToSchema DisableLegalHoldForUserRequest where schema = - object "DisableLegalHoldForUserRequest" $ + object $ DisableLegalHoldForUserRequest <$> dlhfuPassword .= maybe_ (optField "password" schema) @@ -206,7 +206,7 @@ data ApproveLegalHoldForUserRequest = ApproveLegalHoldForUserRequest instance ToSchema ApproveLegalHoldForUserRequest where schema = - object "ApproveLegalHoldForUserRequest" $ + object $ ApproveLegalHoldForUserRequest <$> alhfuPassword .= maybe_ (optField "password" schema) diff --git a/libs/wire-api/src/Wire/API/Team/LegalHold/External.hs b/libs/wire-api/src/Wire/API/Team/LegalHold/External.hs index c49b6b196fc..e481f224466 100644 --- a/libs/wire-api/src/Wire/API/Team/LegalHold/External.hs +++ b/libs/wire-api/src/Wire/API/Team/LegalHold/External.hs @@ -60,7 +60,7 @@ data RequestNewLegalHoldClientV0 = RequestNewLegalHoldClientV0 instance ToSchema RequestNewLegalHoldClientV0 where schema = - object "RequestNewLegalHoldClientV0" $ + object $ RequestNewLegalHoldClientV0 <$> (.userId) .= field "user_id" schema <*> (.teamId) .= field "team_id" schema @@ -75,7 +75,7 @@ data RequestNewLegalHoldClient = RequestNewLegalHoldClient instance ToSchema RequestNewLegalHoldClient where schema = - object "RequestNewLegalHoldClient" $ + object $ RequestNewLegalHoldClient <$> (.userId) .= field "qualified_user_id" schema <*> (.teamId) .= field "team_id" schema @@ -102,7 +102,7 @@ instance OpenApi.ToSchema NewLegalHoldClient where instance ToSchema NewLegalHoldClient where schema = - object "NewLegalHoldClient" $ + object $ NewLegalHoldClient <$> (.newLegalHoldClientPrekeys) .= field "prekeys" (array schema) <*> (.newLegalHoldClientLastKey) .= field "last_prekey" schema @@ -124,7 +124,7 @@ data LegalHoldServiceConfirm = LegalHoldServiceConfirm instance ToSchema LegalHoldServiceConfirm where schema = - object "LegalHoldServiceConfirm" $ + object $ LegalHoldServiceConfirm <$> (.clientId) .= field "client_id" schema <*> (.userId) .= field "qualified_user_id" schema @@ -144,7 +144,7 @@ data LegalHoldServiceConfirmV0 = LegalHoldServiceConfirmV0 instance ToSchema LegalHoldServiceConfirmV0 where schema = - object "LegalHoldServiceConfirmV0" $ + object $ LegalHoldServiceConfirmV0 <$> (.lhcClientId) .= field "client_id" schema <*> (.lhcUserId) .= field "user_id" schema @@ -165,7 +165,7 @@ data LegalHoldServiceRemove = LegalHoldServiceRemove instance ToSchema LegalHoldServiceRemove where schema = - object "LegalHoldServiceRemove" $ + object $ LegalHoldServiceRemove <$> (.userId) .= field "qualified_user_id" schema <*> (.teamId) .= field "team_id" schema @@ -180,7 +180,7 @@ data LegalHoldServiceRemoveV0 = LegalHoldServiceRemoveV0 instance ToSchema LegalHoldServiceRemoveV0 where schema = - object "LegalHoldServiceRemoveV0" $ + object $ LegalHoldServiceRemoveV0 <$> (.lhrUserId) .= field "user_id" schema <*> (.lhrTeamId) .= field "team_id" schema @@ -193,7 +193,7 @@ newtype SupportedVersions = SupportedVersions {supported :: [Int]} instance ToSchema SupportedVersions where schema = - object "SupportedVersions " $ + object $ SupportedVersions <$> supported .= field "supported" (array schema) diff --git a/libs/wire-api/src/Wire/API/Team/LegalHold/Internal.hs b/libs/wire-api/src/Wire/API/Team/LegalHold/Internal.hs index 7b269033d94..f1a3be47b42 100644 --- a/libs/wire-api/src/Wire/API/Team/LegalHold/Internal.hs +++ b/libs/wire-api/src/Wire/API/Team/LegalHold/Internal.hs @@ -32,6 +32,7 @@ import Data.Misc import Data.OpenApi qualified as Swagger import Data.Schema qualified as Schema import Imports +import Test.QuickCheck import Wire.API.Provider import Wire.API.Provider.Service import Wire.API.Team.LegalHold @@ -82,6 +83,9 @@ viewLegalHoldService :: LegalHoldService -> ViewLegalHoldService viewLegalHoldService (LegalHoldService tid u fpr t k) = ViewLegalHoldService $ ViewLegalHoldServiceInfo tid u fpr t (serviceKeyPEM k) +instance Arbitrary LegalHoldService where + arbitrary = LegalHoldService <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + -- | This request is used by Galley to notify Brig that a LegalHold client was requested. data LegalHoldClientRequest = LegalHoldClientRequest { lhcrRequester :: !UserId, @@ -90,10 +94,15 @@ data LegalHoldClientRequest = LegalHoldClientRequest deriving stock (Eq, Show, Generic) deriving (Swagger.ToSchema, FromJSON, ToJSON) via Schema.Schema LegalHoldClientRequest +instance Arbitrary LegalHoldClientRequest where + arbitrary = + LegalHoldClientRequest + <$> arbitrary + <*> arbitrary + instance Schema.ToSchema LegalHoldClientRequest where schema = - Schema.object - "LegalHoldClientRequest" - $ LegalHoldClientRequest + Schema.object $ + LegalHoldClientRequest <$> lhcrRequester Schema..= Schema.field "requester" Schema.schema <*> lhcrLastPrekey Schema..= Schema.field "last_prekey" Schema.schema diff --git a/libs/wire-api/src/Wire/API/Team/Member.hs b/libs/wire-api/src/Wire/API/Team/Member.hs index 55453872d7c..7a0b09dbe07 100644 --- a/libs/wire-api/src/Wire/API/Team/Member.hs +++ b/libs/wire-api/src/Wire/API/Team/Member.hs @@ -181,7 +181,7 @@ mkTeamMember :: mkTeamMember uid perms inv = TeamMember (NewTeamMember uid perms inv) instance ToSchema TeamMember where - schema = object "TeamMember" teamMemberObjectSchema + schema = object teamMemberObjectSchema teamMemberObjectSchema :: ObjectSchema SwaggerDoc TeamMember teamMemberObjectSchema = @@ -193,7 +193,7 @@ teamMemberObjectSchema = instance ToSchema (TeamMember' 'Optional) where schema = - objectWithDocModifier "TeamMember" (description ?~ "team member data") $ + objectWithDocModifier (description ?~ "team member data") $ TeamMember <$> _newTeamMember .= ( NewTeamMember @@ -249,7 +249,7 @@ mkSingleTeamMembersPage members = instance ToSchema TeamMembersPage where schema = - object "TeamMembersPage" $ + object $ TeamMembersPage <$> unTeamMembersPage .= ( MultiTablePage @@ -313,9 +313,9 @@ deriving via newTeamMemberList :: [TeamMember] -> ListType -> TeamMemberList newTeamMemberList = TeamMemberList -instance (ToSchema (TeamMember' tag)) => ToSchema (TeamMemberList' tag) where +instance (Typeable tag, ToSchema (TeamMember' tag)) => ToSchema (TeamMemberList' tag) where schema = - objectWithDocModifier "TeamMemberList" (description ?~ "list of team member") $ + objectWithDocModifier (description ?~ "list of team member") $ TeamMemberList <$> _teamMembers .= fieldWithDocModifier "members" (description ?~ "the array of team members") (array schema) @@ -332,7 +332,7 @@ data NewListType instance ToSchema NewListType where schema = - enum @Text "NewListType" $ + enum @Text $ mconcat [ element "list_complete" NewListComplete, element "list_truncated" NewListTruncated @@ -353,7 +353,7 @@ data ListType -- though we do want this to remain true/false instance ToSchema ListType where schema = - enum @Bool "ListType" $ + enum @Bool $ mconcat [element True ListTruncated, element False ListComplete] -------------------------------------------------------------------------------- @@ -428,9 +428,9 @@ invitedSchema' = withParser invitedSchema $ \(invby, invat) -> instance ToSchema NewTeamMember where schema = - objectWithDocModifier "NewTeamMember" (description ?~ "Required data when creating new team members") $ + objectWithDocModifier (description ?~ "Required data when creating new team members") $ fieldWithDocModifier "member" (description ?~ "the team member to add (the legalhold_status field must be null or missing!)") $ - unnamed (object "Unnamed" newTeamMemberSchema) + unnamed (object newTeamMemberSchema) -------------------------------------------------------------------------------- -- TeamMemberDeleteData @@ -444,7 +444,7 @@ newtype TeamMemberDeleteData = TeamMemberDeleteData instance ToSchema TeamMemberDeleteData where schema = - objectWithDocModifier "TeamMemberDeleteData" (description ?~ "Data for a team member deletion request in case of binding teams.") $ + objectWithDocModifier (description ?~ "Data for a team member deletion request in case of binding teams.") $ TeamMemberDeleteData <$> _tmdAuthPassword .= optFieldWithDocModifier "password" (description ?~ "The account password to authorise the deletion.") (maybeWithDefault Null schema) newTeamMemberDeleteData :: Maybe PlainTextPassword6 -> TeamMemberDeleteData diff --git a/libs/wire-api/src/Wire/API/Team/Member/Info.hs b/libs/wire-api/src/Wire/API/Team/Member/Info.hs index ccf19fc2054..96bf5960dbf 100644 --- a/libs/wire-api/src/Wire/API/Team/Member/Info.hs +++ b/libs/wire-api/src/Wire/API/Team/Member/Info.hs @@ -35,7 +35,7 @@ data TeamMemberInfo = TeamMemberInfo instance ToSchema TeamMemberInfo where schema = - object "TeamMemberInfo" $ + object $ TeamMemberInfo <$> (.userId) .= field "userId" schema <*> (.permissions) .= field "permissions" schema @@ -49,6 +49,6 @@ newtype TeamMemberInfoList = TeamMemberInfoList instance ToSchema TeamMemberInfoList where schema = - object "TeamMemberInfoList" $ + object $ TeamMemberInfoList <$> (.members) .= field "members" (array schema) diff --git a/libs/wire-api/src/Wire/API/Team/Permission.hs b/libs/wire-api/src/Wire/API/Team/Permission.hs index 974ef98926c..3c6fdcfec48 100644 --- a/libs/wire-api/src/Wire/API/Team/Permission.hs +++ b/libs/wire-api/src/Wire/API/Team/Permission.hs @@ -69,7 +69,7 @@ data Permissions = Permissions permissionsSchema :: ValueSchema NamedSwaggerDoc Permissions permissionsSchema = - objectWithDocModifier "Permissions" (description ?~ docs) $ + objectWithDocModifier (description ?~ docs) $ Permissions <$> (permsToInt . self) .= fieldWithDocModifier "self" selfDoc (intToPerms <$> schema) <*> (permsToInt . copy) .= fieldWithDocModifier "copy" copyDoc (intToPerms <$> schema) diff --git a/libs/wire-api/src/Wire/API/Team/Role.hs b/libs/wire-api/src/Wire/API/Team/Role.hs index c3dc0ca89ee..72b57d7e9ff 100644 --- a/libs/wire-api/src/Wire/API/Team/Role.hs +++ b/libs/wire-api/src/Wire/API/Team/Role.hs @@ -88,7 +88,7 @@ data Role = RoleOwner | RoleAdmin | RoleMember | RoleExternalPartner instance ToSchema Role where schema = - enum @Text "Role" $ + enum @Text $ flip foldMap [minBound .. maxBound] $ \r -> element (roleName r) r diff --git a/libs/wire-api/src/Wire/API/Team/SearchVisibility.hs b/libs/wire-api/src/Wire/API/Team/SearchVisibility.hs index 76d530f6f15..b55bcb25c3b 100644 --- a/libs/wire-api/src/Wire/API/Team/SearchVisibility.hs +++ b/libs/wire-api/src/Wire/API/Team/SearchVisibility.hs @@ -63,9 +63,8 @@ data TeamSearchVisibility instance ToSchema TeamSearchVisibility where schema = - enum @Text - "TeamSearchVisibility" - $ mconcat + enum @Text $ + mconcat [ element "standard" SearchVisibilityStandard, element "no-name-outside-team" SearchVisibilityNoNameOutsideTeam ] @@ -80,7 +79,7 @@ newtype TeamSearchVisibilityView = TeamSearchVisibilityView TeamSearchVisibility instance ToSchema TeamSearchVisibilityView where schema = - objectWithDocModifier "TeamSearchVisibilityView" (description ?~ "Search visibility value for the team") $ + objectWithDocModifier (description ?~ "Search visibility value for the team") $ TeamSearchVisibilityView <$> unwrap .= fieldWithDocModifier "search_visibility" (description ?~ "value of visibility") schema where diff --git a/libs/wire-api/src/Wire/API/Team/Size.hs b/libs/wire-api/src/Wire/API/Team/Size.hs index ce0d8fe6468..65f6c23b0d7 100644 --- a/libs/wire-api/src/Wire/API/Team/Size.hs +++ b/libs/wire-api/src/Wire/API/Team/Size.hs @@ -26,6 +26,8 @@ import Data.OpenApi qualified as S import Data.Schema import Imports import Numeric.Natural +import Test.QuickCheck (arbitrarySizedNatural) +import Wire.Arbitrary newtype TeamSize = TeamSize Natural deriving (Show, Eq) @@ -33,8 +35,11 @@ newtype TeamSize = TeamSize Natural instance ToSchema TeamSize where schema = - objectWithDocModifier "TeamSize" (description ?~ "A simple object with a total number of team members.") $ + objectWithDocModifier (description ?~ "A simple object with a total number of team members.") $ TeamSize <$> (unTeamSize .= fieldWithDocModifier "teamSize" (description ?~ "Team size.") schema) where unTeamSize :: TeamSize -> Natural unTeamSize (TeamSize n) = n + +instance Arbitrary TeamSize where + arbitrary = TeamSize <$> arbitrarySizedNatural diff --git a/libs/wire-api/src/Wire/API/User.hs b/libs/wire-api/src/Wire/API/User.hs index 9435e0e4ad2..889e22a6191 100644 --- a/libs/wire-api/src/Wire/API/User.hs +++ b/libs/wire-api/src/Wire/API/User.hs @@ -244,7 +244,7 @@ newtype UserIdList = UserIdList {mUsers :: [UserId]} instance ToSchema UserIdList where schema = - object "UserIdList" $ + object $ UserIdList <$> mUsers .= field "user_ids" (array schema) @@ -263,7 +263,7 @@ newtype UserIds = UserIds instance ToSchema UserIds where schema = - object "UserIds" $ + object $ UserIds <$> cUsers .= field "ids" (array schema) @@ -278,7 +278,7 @@ newtype GetActivationCodeResp = GetActivationCodeResp {fromGetActivationCodeResp instance ToSchema GetActivationCodeResp where schema = - object "GetActivationCodeResp" $ + object $ curry GetActivationCodeResp <$> (fst . fromGetActivationCodeResp) .= field "key" schema <*> (snd . fromGetActivationCodeResp) .= field "code" schema @@ -290,7 +290,7 @@ newtype GetPasswordResetCodeResp = GetPasswordResetCodeResp {fromGetPasswordRese instance ToSchema GetPasswordResetCodeResp where schema = - object "GetPasswordResetCodeResp" $ + object $ curry GetPasswordResetCodeResp <$> (fst . fromGetPasswordResetCodeResp) .= field "key" schema <*> (snd . fromGetPasswordResetCodeResp) .= field "code" schema @@ -317,7 +317,7 @@ newtype ManagedByUpdate = ManagedByUpdate {mbuManagedBy :: ManagedBy} instance ToSchema ManagedByUpdate where schema = - object "ManagedByUpdate" $ + object $ ManagedByUpdate <$> mbuManagedBy .= field "managed_by" schema @@ -328,7 +328,7 @@ newtype RichInfoUpdate = RichInfoUpdate {riuRichInfo :: RichInfoAssocList} instance ToSchema RichInfoUpdate where schema = - object "RichInfoUpdate" $ + object $ RichInfoUpdate <$> riuRichInfo .= field "rich_info" schema @@ -396,14 +396,14 @@ updateConnectionsInternalTag (CreateConnectionForTest _ _) = CreateConnectionFor instance ToSchema UpdateConnectionsInternalTag where schema = - enum @Text "UpdateConnectionsInternalTag" $ + enum @Text $ element "BlockForMissingLHConsent" BlockForMissingLHConsentTag <> element "RemoveLHBlocksInvolving" RemoveLHBlocksInvolvingTag <> element "CreateConnectionForTest" CreateConnectionForTestTag instance ToSchema UpdateConnectionsInternal where schema = - object "UpdateConnectionsInternal" $ + object $ snd <$> (updateConnectionsInternalTag &&& id) .= bind @@ -446,7 +446,7 @@ newtype QualifiedUserIdList = QualifiedUserIdList {qualifiedUserIdList :: [Quali instance ToSchema QualifiedUserIdList where schema = - object "QualifiedUserIdList" qualifiedUserIdListObjectSchema + object qualifiedUserIdListObjectSchema qualifiedUserIdListObjectSchema :: ObjectSchema SwaggerDoc QualifiedUserIdList qualifiedUserIdListObjectSchema = @@ -489,7 +489,7 @@ instance Default UserType where instance ToSchema UserType where schema = - Schema.enum @Text "UserType" $ + Schema.enum @Text $ mconcat [ Schema.element "regular" UserTypeRegular, Schema.element "app" UserTypeApp, @@ -543,7 +543,7 @@ data UserProfile = UserProfile deriving (FromJSON, ToJSON, S.ToSchema) via (Schema UserProfile) instance ToSchema UserProfile where - schema = object "UserProfile" userProfileObjectSchema + schema = object userProfileObjectSchema userProfileObjectSchema :: ObjectSchema SwaggerDoc UserProfile userProfileObjectSchema = @@ -657,7 +657,7 @@ userDeleted u = userStatus u == Deleted -- -- FUTUREWORK: -- -- disentangle json serializations for 'User', 'NewUser', 'UserIdentity', 'NewUserOrigin'. instance ToSchema User where - schema = object "User" userObjectSchema + schema = object userObjectSchema userObjectSchema :: ObjectSchema SwaggerDoc User userObjectSchema = @@ -850,7 +850,7 @@ data CreateUserTeam = CreateUserTeam instance ToSchema CreateUserTeam where schema = - object "CreateUserTeam" $ + object $ CreateUserTeam <$> createdTeamId .= field "team_id" schema <*> createdTeamName .= field "team_name" schema @@ -1016,7 +1016,7 @@ data NewUserSpar = NewUserSpar instance ToSchema NewUserSpar where schema = - object "NewUserSpar" $ + object $ NewUserSpar <$> newUserSparUUID .= field "newUserSparUUID" genericToSchema @@ -1169,7 +1169,7 @@ newUserRawObjectSchema = instance ToSchema (NewUser PlainTextPassword8) where schema = - object "NewUser" $ newUserToRaw .= withParser newUserRawObjectSchema newUserFromRaw + object $ newUserToRaw .= withParser newUserRawObjectSchema newUserFromRaw newUserToRaw :: NewUser PlainTextPassword8 -> NewUserRaw newUserToRaw NewUser {..} = @@ -1385,7 +1385,7 @@ data BindingNewTeamUser = BindingNewTeamUser instance ToSchema BindingNewTeamUser where schema = - object "BindingNewTeamUser" $ + object $ BindingNewTeamUser <$> bnuTeam .= newTeamObjectSchema @@ -1405,7 +1405,7 @@ data ScimUserInfo = ScimUserInfo instance ToSchema ScimUserInfo where schema = - object "ScimUserInfo" $ + object $ ScimUserInfo <$> suiUserId .= field "id" schema @@ -1426,7 +1426,7 @@ newtype UserSet = UserSet instance ToSchema UserSet where schema = - object "UserSet" $ + object $ UserSet <$> usUsrs .= field "users" (set schema) @@ -1448,7 +1448,7 @@ data UserUpdate = UserUpdate instance ToSchema UserUpdate where schema = - object "UserUpdate" $ + object $ UserUpdate <$> uupName .= maybe_ (optField "name" schema) @@ -1494,7 +1494,7 @@ instance ToSchema PasswordChange where ?~ "Data to change a password. The old password is required if \ \a password already exists." ) - . object "PasswordChange" + . object $ PasswordChange <$> oldPassword .= maybe_ (optField "old_password" schema) @@ -1530,7 +1530,7 @@ newtype LocaleUpdate = LocaleUpdate {luLocale :: Locale} instance ToSchema LocaleUpdate where schema = - object "LocaleUpdate" $ + object $ LocaleUpdate <$> luLocale .= field "locale" schema @@ -1542,7 +1542,7 @@ newtype EmailUpdate = EmailUpdate {euEmail :: EmailAddress} instance ToSchema EmailUpdate where schema = - object "EmailUpdate" $ + object $ EmailUpdate <$> euEmail .= field "email" schema @@ -1596,7 +1596,7 @@ newtype PhoneUpdate = PhoneUpdate {puPhone :: Phone} instance ToSchema PhoneUpdate where schema = - object "PhoneUpdate" $ + object $ PhoneUpdate <$> puPhone .= field "phone" schema @@ -1648,7 +1648,7 @@ newtype HandleUpdate = HandleUpdate {huHandle :: Text} instance ToSchema HandleUpdate where schema = - object "HandleUpdate" $ + object $ HandleUpdate <$> huHandle .= field "handle" schema data ChangeHandleError @@ -1682,7 +1682,7 @@ newtype NameUpdate = NameUpdate {nuHandle :: Text} instance ToSchema NameUpdate where schema = - object "NameUpdate" $ + object $ NameUpdate <$> nuHandle .= field "name" schema data ChangeEmailResponse @@ -1720,7 +1720,7 @@ newtype DeleteUser = DeleteUser instance ToSchema DeleteUser where schema = - object "DeleteUser" $ + object $ DeleteUser <$> deleteUserPassword .= maybe_ (optField "password" schema) @@ -1750,7 +1750,7 @@ data VerifyDeleteUser = VerifyDeleteUser instance ToSchema VerifyDeleteUser where schema = - objectWithDocModifier "VerifyDeleteUser" (Schema.description ?~ "Data for verifying an account deletion.") $ + objectWithDocModifier (Schema.description ?~ "Data for verifying an account deletion.") $ VerifyDeleteUser <$> verifyDeleteUserKey .= fieldWithDocModifier "key" (Schema.description ?~ "The identifying key of the account (i.e. user ID).") schema @@ -1766,7 +1766,7 @@ newtype DeletionCodeTimeout = DeletionCodeTimeout instance ToSchema DeletionCodeTimeout where schema = - object "DeletionCodeTimeout" $ + object $ DeletionCodeTimeout <$> fromDeletionCodeTimeout .= field "expires_in" schema @@ -1858,7 +1858,7 @@ data AccountStatus instance Schema.ToSchema AccountStatus where schema = - Schema.enum @Text "AccountStatus" $ + Schema.enum @Text $ mconcat [ Schema.element "active" Active, Schema.element "suspended" Suspended, @@ -1892,7 +1892,7 @@ data AccountStatusResp = AccountStatusResp {fromAccountStatusResp :: AccountStat instance Schema.ToSchema AccountStatusResp where schema = - object "AccountStatusResp" $ + object $ AccountStatusResp <$> fromAccountStatusResp .= field "status" schema newtype AccountStatusUpdate = AccountStatusUpdate {suStatus :: AccountStatus} @@ -1902,7 +1902,7 @@ newtype AccountStatusUpdate = AccountStatusUpdate {suStatus :: AccountStatus} instance Schema.ToSchema AccountStatusUpdate where schema = - object "AccountStatusUpdate" $ + object $ AccountStatusUpdate <$> suStatus .= field "status" schema ------------------------------------------------------------------------------- @@ -1927,7 +1927,7 @@ data NewUserScimInvitation = NewUserScimInvitation instance Schema.ToSchema NewUserScimInvitation where schema = - Schema.object "NewUserScimInvitation" $ + Schema.object $ NewUserScimInvitation <$> newUserScimInvTeamId Schema..= Schema.field "team_id" Schema.schema <*> newUserScimInvUserId Schema..= Schema.field "user_id" Schema.schema @@ -1950,7 +1950,7 @@ data VerificationAction instance ToSchema VerificationAction where schema = - enum @Text "VerificationAction" $ + enum @Text $ mconcat [ element "create_scim_token" CreateScimToken, element "login" Login, @@ -1998,7 +1998,7 @@ data SendVerificationCode = SendVerificationCode instance ToSchema SendVerificationCode where schema = - object "SendVerificationCode" $ + object $ SendVerificationCode <$> svcAction .= field "action" schema @@ -2034,7 +2034,7 @@ baseProtocolToProtocol BaseProtocolMLSTag = ProtocolMLSTag instance ToSchema BaseProtocolTag where schema = - enum @Text "BaseProtocol" $ + enum @Text $ mconcat [ element "proteus" BaseProtocolProteusTag, element "mls" BaseProtocolMLSTag @@ -2066,7 +2066,7 @@ newtype SupportedProtocolUpdate = SupportedProtocolUpdate instance ToSchema SupportedProtocolUpdate where schema = - object "SupportedProtocolUpdate" $ + object $ SupportedProtocolUpdate <$> unSupportedProtocolUpdate .= field "supported_protocols" (set schema) @@ -2081,7 +2081,7 @@ data ListUsersById = ListUsersById instance ToSchema ListUsersById where schema = - object "ListUsersById" $ + object $ ListUsersById <$> listUsersByIdFound .= field "found" (array schema) <*> listUsersByIdFailed .= maybe_ (optField "failed" $ nonEmptyArray schema) @@ -2133,7 +2133,7 @@ instance ToSchema Category where instance ToSchema NewApp where schema = - object "NewApp" $ + object $ NewApp <$> (.name) .= field "name" schema <*> (.assets) .= (fromMaybe [] <$> optField "assets" (array schema)) @@ -2143,7 +2143,7 @@ instance ToSchema NewApp where <*> (.password) .= field "password" schema instance ToSchema AppInfo where - schema = object "AppInfo" appInfoObjectSchema + schema = object appInfoObjectSchema appInfoObjectSchema :: ObjectSchema SwaggerDoc AppInfo appInfoObjectSchema = @@ -2153,7 +2153,7 @@ appInfoObjectSchema = instance ToSchema PutApp where schema = - object "PutApp" $ + object $ PutApp <$> (.name) .= maybe_ (optField "name" schema) <*> (.assets) .= maybe_ (optField "assets" (array schema)) @@ -2170,7 +2170,7 @@ data CreatedApp = CreatedApp instance ToSchema CreatedApp where schema = - object "CreatedApp" $ + object $ CreatedApp <$> (.user) .= field "user" schema <*> (.cookie) .= field "cookie" schema @@ -2182,7 +2182,7 @@ newtype RefreshAppCookieRequest = RefreshAppCookieRequest instance ToSchema RefreshAppCookieRequest where schema = - object "RefreshAppCookieRequest" $ + object $ RefreshAppCookieRequest <$> (.password) .= optFieldWithDocModifier @@ -2199,5 +2199,5 @@ newtype RefreshAppCookieResponse = RefreshAppCookieResponse instance ToSchema RefreshAppCookieResponse where schema = - object "RefreshAppCookieResponse" $ + object $ RefreshAppCookieResponse <$> (.cookie) .= field "cookie" schema diff --git a/libs/wire-api/src/Wire/API/User/Activation.hs b/libs/wire-api/src/Wire/API/User/Activation.hs index 3df4052062f..798011c53e6 100644 --- a/libs/wire-api/src/Wire/API/User/Activation.hs +++ b/libs/wire-api/src/Wire/API/User/Activation.hs @@ -19,21 +19,13 @@ -- with this program. If not, see . module Wire.API.User.Activation - ( -- * ActivationTarget - ActivationTarget (..), + ( ActivationTarget (..), ActivationKey (..), - - -- * ActivationCode ActivationCode (..), - - -- * Activate + ActivationPair, Activate (..), ActivationResponse (..), - - -- * SendActivationCode SendActivationCode (..), - - -- * Activation Activation (..), ) where @@ -104,6 +96,11 @@ instance FromHttpApiData ActivationCode where deriving instance C.Cql ActivationCode +-------------------------------------------------------------------------------- + +-- | A pair of 'ActivationKey' and 'ActivationCode' as required for activation. +type ActivationPair = (ActivationKey, ActivationCode) + -------------------------------------------------------------------------------- -- Activate @@ -119,7 +116,7 @@ data Activate = Activate instance ToSchema Activate where schema = - objectWithDocModifier "Activate" objectDocs $ + objectWithDocModifier objectDocs $ Activate <$> (maybeActivationTargetToTuple . activateTarget) .= maybeActivationTargetObjectSchema <*> activateCode .= fieldWithDocModifier "code" codeDocs schema @@ -182,7 +179,7 @@ data ActivationResponse = ActivationResponse instance ToSchema ActivationResponse where schema = - objectWithDocModifier "ActivationResponse" (description ?~ "Response body of a successful activation request") $ + objectWithDocModifier (description ?~ "Response body of a successful activation request") $ ActivationResponse <$> activatedIdentity .= userIdentityObjectSchema <*> activatedFirst .= (fromMaybe False <$> optFieldWithDocModifier "first" (description ?~ "Whether this is the first successful activation (i.e. account activation).") schema) @@ -202,7 +199,7 @@ data SendActivationCode = SendActivationCode instance ToSchema SendActivationCode where schema = - objectWithDocModifier "SendActivationCode" objectDesc $ + objectWithDocModifier objectDesc $ SendActivationCode <$> emailKey .= field "email" schema <*> locale diff --git a/libs/wire-api/src/Wire/API/User/Auth.hs b/libs/wire-api/src/Wire/API/User/Auth.hs index 7d592bdf2b9..bfa5a475f04 100644 --- a/libs/wire-api/src/Wire/API/User/Auth.hs +++ b/libs/wire-api/src/Wire/API/User/Auth.hs @@ -103,7 +103,7 @@ data LoginId -- NB. this should fail if (e.g.) the email is present but unparseable even if -- the JSON contains a valid handle. instance ToSchema LoginId where - schema = object "LoginId" loginObjectSchema + schema = object loginObjectSchema loginObjectSchema :: ObjectSchema SwaggerDoc LoginId loginObjectSchema = @@ -149,7 +149,7 @@ data PendingLoginCode = PendingLoginCode instance ToSchema PendingLoginCode where schema = - object "PendingLoginCode" $ + object $ PendingLoginCode <$> pendingLoginCode .= field "code" schema <*> pendingLoginTimeout .= field "expires_in" schema @@ -170,7 +170,6 @@ data SendLoginCode = SendLoginCode instance ToSchema SendLoginCode where schema = objectWithDocModifier - "SendLoginCode" (description ?~ "Payload for requesting a login code to be sent") $ SendLoginCode <$> lcPhone @@ -201,7 +200,6 @@ newtype LoginCodeTimeout = LoginCodeTimeout instance ToSchema LoginCodeTimeout where schema = objectWithDocModifier - "LoginCodeTimeout" (description ?~ "A response for a successfully sent login code") $ LoginCodeTimeout <$> fromLoginCodeTimeout @@ -223,7 +221,6 @@ data CookieList = CookieList instance ToSchema CookieList where schema = objectWithDocModifier - "CookieList" (description ?~ "List of cookie information") $ CookieList <$> cookieList .= field "cookies" (array schema) @@ -244,7 +241,7 @@ data Cookie a = Cookie instance ToSchema (Cookie ()) where schema = - object "Cookie" $ + object $ Cookie <$> cookieId .= field "id" schema <*> cookieType .= field "type" schema @@ -326,7 +323,7 @@ instance Cql CookieType where instance ToSchema CookieType where schema = - enum @Text "CookieType" $ + enum @Text $ element "session" SessionCookie <> element "persistent" PersistentCookie @@ -348,7 +345,7 @@ data Login = MkLogin instance ToSchema Login where schema = - object "Login" $ + object $ MkLogin <$> lId .= loginObjectSchema <*> lPassword .= field "password" schema @@ -370,7 +367,6 @@ data RemoveCookies = RemoveCookies instance ToSchema RemoveCookies where schema = objectWithDocModifier - "RemoveCookies" (description ?~ "Data required to remove cookies") $ RemoveCookies <$> rmCookiesPassword @@ -411,7 +407,7 @@ data AccessToken = AccessToken instance ToSchema AccessToken where schema = - object "AccessToken" $ + object $ AccessToken <$> user .= field "user" schema <*> @@ -448,7 +444,7 @@ data TokenType = Bearer deriving (FromJSON, ToJSON, S.ToSchema) via Schema TokenType instance ToSchema TokenType where - schema = enum @Text "TokenType" $ element "Bearer" Bearer + schema = enum @Text $ element "Bearer" Bearer -------------------------------------------------------------------------------- -- Access diff --git a/libs/wire-api/src/Wire/API/User/Auth/LegalHold.hs b/libs/wire-api/src/Wire/API/User/Auth/LegalHold.hs index b1f20c416a8..00f49b844d7 100644 --- a/libs/wire-api/src/Wire/API/User/Auth/LegalHold.hs +++ b/libs/wire-api/src/Wire/API/User/Auth/LegalHold.hs @@ -38,7 +38,7 @@ data LegalHoldLogin = LegalHoldLogin instance ToSchema LegalHoldLogin where schema = - object "LegalHoldLogin" $ + object $ LegalHoldLogin <$> lhlUserId .= field "user" schema <*> lhlPassword .= optField "password" (maybeWithDefault A.Null schema) diff --git a/libs/wire-api/src/Wire/API/User/Auth/ReAuth.hs b/libs/wire-api/src/Wire/API/User/Auth/ReAuth.hs index 0892089a90d..cce0dca72f3 100644 --- a/libs/wire-api/src/Wire/API/User/Auth/ReAuth.hs +++ b/libs/wire-api/src/Wire/API/User/Auth/ReAuth.hs @@ -29,6 +29,7 @@ import Data.OpenApi qualified as S import Data.Schema import Imports import Wire.API.User +import Wire.Arbitrary -- | Certain operations might require reauth of the user. These are available -- only for users that have already set a password. @@ -42,8 +43,11 @@ data ReAuthUser = ReAuthUser instance ToSchema ReAuthUser where schema = - object "ReAuthUser" $ + object $ ReAuthUser <$> reAuthPassword .= optField "password" (maybeWithDefault A.Null schema) <*> reAuthCode .= optField "verification_code" (maybeWithDefault A.Null schema) <*> reAuthCodeAction .= optField "action" (maybeWithDefault A.Null schema) + +instance Arbitrary ReAuthUser where + arbitrary = ReAuthUser <$> arbitrary <*> arbitrary <*> arbitrary diff --git a/libs/wire-api/src/Wire/API/User/Auth/Sso.hs b/libs/wire-api/src/Wire/API/User/Auth/Sso.hs index 0c9daa86859..c3d37d1ec54 100644 --- a/libs/wire-api/src/Wire/API/User/Auth/Sso.hs +++ b/libs/wire-api/src/Wire/API/User/Auth/Sso.hs @@ -34,7 +34,7 @@ data SsoLogin = SsoLogin instance ToSchema SsoLogin where schema = - object "SsoLogin" $ + object $ SsoLogin <$> ssoUserId .= field "user" schema <*> ssoLabel .= optField "label" (maybeWithDefault A.Null schema) diff --git a/libs/wire-api/src/Wire/API/User/Client.hs b/libs/wire-api/src/Wire/API/User/Client.hs index 0e490f0ff3c..2f954957722 100644 --- a/libs/wire-api/src/Wire/API/User/Client.hs +++ b/libs/wire-api/src/Wire/API/User/Client.hs @@ -47,6 +47,7 @@ module Wire.API.User.Client Client (..), clientSchema, PubClient (..), + toPubClient, ClientType (..), ClientClass (..), MLSPublicKeys, @@ -154,7 +155,7 @@ data ClientCapability instance ToSchema ClientCapability where schema = - enum @Text "ClientCapability" $ + enum @Text $ element "legalhold-implicit-consent" ClientSupportsLegalholdImplicitConsent <> element "consumable-notifications" ClientSupportsConsumableNotifications @@ -163,7 +164,7 @@ data ClientCapabilityV7 = ClientSupportsLegalholdImplicitConsentV7 capabilitySchemaV7 :: ValueSchema NamedSwaggerDoc ClientCapabilityV7 capabilitySchemaV7 = - enum @Text "ClientCapabilityV7" $ + enum @Text $ element "legalhold-implicit-consent" ClientSupportsLegalholdImplicitConsentV7 clientCapabilityFromV7 :: ClientCapabilityV7 -> ClientCapability @@ -193,7 +194,7 @@ instance ToSchema ClientCapabilityList where instance ToSchema (Versioned V6 ClientCapabilityList) where schema = - object "ClientCapabilityListV6Wrapper" $ + object $ Versioned <$> unVersioned .= field "capabilities" (capabilitiesSchema (Just V6)) @@ -333,7 +334,7 @@ instance Arbitrary QualifiedUserClientPrekeyMapV4 where instance ToSchema QualifiedUserClientPrekeyMapV4 where schema = - object "QualifiedUserClientPrekeyMapV4" $ + object $ QualifiedUserClientPrekeyMapV4 <$> fmap to' (from' .= field "qualified_user_client_prekeys" (map_ schema)) <*> failedToList .= maybe_ (optField "failed_to_list" (array schema)) @@ -385,7 +386,7 @@ data ClientInfo = ClientInfo instance ToSchema ClientInfo where schema = - object "ClientInfo" $ + object $ ClientInfo <$> (.clientId) .= field "id" schema <*> (.mlsSignatureKey) .= maybe_ (optField "mls_signature_key" base64Schema) @@ -542,7 +543,7 @@ mlsPublicKeysSchema = clientSchema :: Maybe Version -> ValueSchema NamedSwaggerDoc Client clientSchema mVersion = - object (versionedName mVersion "Client") $ + versionedObject mVersion $ Client <$> (.clientId) .= field "id" schema <*> clientType .= field "type" schema @@ -604,7 +605,7 @@ data ClientList = ClientList {clClients :: [ClientId]} instance ToSchema ClientList where schema = - object "ClientList" $ + object $ ClientList <$> clClients .= field "client_ids" (array schema) @@ -623,11 +624,18 @@ data PubClient = PubClient instance ToSchema PubClient where schema = - object "PubClient" $ + object $ PubClient <$> pubClientId .= field "id" schema <*> pubClientClass .= maybe_ (optField "class" schema) +toPubClient :: Client -> PubClient +toPubClient client = + PubClient + { pubClientId = client.clientId, + pubClientClass = client.clientClass + } + -------------------------------------------------------------------------------- -- Client Type/Class @@ -659,7 +667,7 @@ data ClientType instance ToSchema ClientType where schema = - enum @Text "ClientType" $ + enum @Text $ element "temporary" TemporaryClientType <> element "permanent" PermanentClientType <> element "legalhold" LegalHoldClientType @@ -686,7 +694,7 @@ data ClientClass instance ToSchema ClientClass where schema = - enum @Text "ClientClass" $ + enum @Text $ element "phone" PhoneClient <> element "tablet" TabletClient <> element "desktop" DesktopClient @@ -727,7 +735,7 @@ data NewClient = NewClient newClientSchema :: Maybe Version -> ValueSchema NamedSwaggerDoc NewClient newClientSchema mVersion = - object "NewClient" $ + object $ NewClient <$> newClientPrekeys .= fieldWithDocModifier @@ -846,7 +854,7 @@ defUpdateClient = updateClientSchema :: Maybe Version -> ValueSchema NamedSwaggerDoc UpdateClient updateClientSchema mVersion = - object "UpdateClient" $ + object $ UpdateClient <$> updateClientPrekeys .= ( fromMaybe [] @@ -899,7 +907,7 @@ newtype RmClient = RmClient instance ToSchema RmClient where schema = - object "DeleteClient" $ + object $ RmClient <$> rmPassword .= optFieldWithDocModifier diff --git a/libs/wire-api/src/Wire/API/User/Client/DPoPAccessToken.hs b/libs/wire-api/src/Wire/API/User/Client/DPoPAccessToken.hs index 980e376e7fd..90b4494d0ba 100644 --- a/libs/wire-api/src/Wire/API/User/Client/DPoPAccessToken.hs +++ b/libs/wire-api/src/Wire/API/User/Client/DPoPAccessToken.hs @@ -77,7 +77,7 @@ data AccessTokenType = DPoP instance ToSchema AccessTokenType where schema = - enum @Text "AccessTokenType" $ + enum @Text $ mconcat [ element "DPoP" DPoP ] @@ -92,7 +92,7 @@ data DPoPAccessTokenResponse = DPoPAccessTokenResponse instance ToSchema DPoPAccessTokenResponse where schema = - object "DPoPAccessTokenResponse" $ + object $ DPoPAccessTokenResponse <$> datrToken .= field "token" schema <*> datrType .= field "type" schema diff --git a/libs/wire-api/src/Wire/API/User/Client/Prekey.hs b/libs/wire-api/src/Wire/API/User/Client/Prekey.hs index 379b34f9e44..a8b383277c0 100644 --- a/libs/wire-api/src/Wire/API/User/Client/Prekey.hs +++ b/libs/wire-api/src/Wire/API/User/Client/Prekey.hs @@ -141,13 +141,13 @@ data UncheckedPrekeyBundle = UncheckedPrekeyBundle -- | Prekey bundle prekeyKey :: Text } - deriving stock (Eq, Show, Generic) + deriving stock (Eq, Show, Generic, Ord) deriving (Arbitrary) via (GenericUniform UncheckedPrekeyBundle) deriving (FromJSON, ToJSON, S.ToSchema) via Schema UncheckedPrekeyBundle instance ToSchema UncheckedPrekeyBundle where schema = - object "UncheckedPrekeyBundle" $ + object $ UncheckedPrekeyBundle <$> prekeyId .= field "id" schema <*> prekeyKey .= field "key" schema @@ -247,7 +247,7 @@ decodePrekeyBundlePrekeyPayload = do newtype LastPrekey = LastPrekey {unpackLastPrekey :: UncheckedPrekeyBundle} - deriving stock (Eq, Show, Generic) + deriving stock (Eq, Show, Generic, Ord) deriving (FromJSON, ToJSON, S.ToSchema) via Schema LastPrekey instance ToSchema LastPrekey where @@ -285,7 +285,7 @@ data PrekeyBundle = PrekeyBundle instance ToSchema PrekeyBundle where schema = - object "PrekeyBundle" $ + object $ PrekeyBundle <$> prekeyUser .= field "user" schema <*> prekeyClients .= field "clients" (array schema) @@ -303,7 +303,7 @@ data ClientPrekey = ClientPrekey instance ToSchema ClientPrekey where schema = - object "ClientPrekey" $ + object $ ClientPrekey <$> prekeyClient .= field "client" schema <*> prekeyData .= field "prekey" schema diff --git a/libs/wire-api/src/Wire/API/User/Handle.hs b/libs/wire-api/src/Wire/API/User/Handle.hs index 3db27ef8c12..29e37493bff 100644 --- a/libs/wire-api/src/Wire/API/User/Handle.hs +++ b/libs/wire-api/src/Wire/API/User/Handle.hs @@ -45,7 +45,7 @@ newtype UserHandleInfo = UserHandleInfo {userHandleId :: Qualified UserId} instance ToSchema UserHandleInfo where schema = - object "UserHandleInfo" $ + object $ UserHandleInfo <$> userHandleId .= field "qualified_user" schema <* (qUnqualified . userHandleId) @@ -80,7 +80,7 @@ instance FromJSON CheckHandles where instance ToSchema CheckHandles where schema = - object "CheckHandles" $ + object $ CheckHandles <$> checkHandlesList .= field "handles" (fromRange .= rangedSchema (array schema)) <*> checkHandlesNum .= field "return" schema diff --git a/libs/wire-api/src/Wire/API/User/IdentityProvider.hs b/libs/wire-api/src/Wire/API/User/IdentityProvider.hs index 8a67a4b4921..df3125a0340 100644 --- a/libs/wire-api/src/Wire/API/User/IdentityProvider.hs +++ b/libs/wire-api/src/Wire/API/User/IdentityProvider.hs @@ -91,7 +91,6 @@ data WireIdP = WireIdP instance Schema.ToSchema WireIdP where schema = Schema.object - "WireIdP" ( WireIdP <$> _team Schema..= Schema.field "team" Schema.schema <*> _apiVersion Schema..= Schema.field "apiVersion" (Schema.nullable (Schema.unnamed Schema.schema)) @@ -112,7 +111,7 @@ data WireIdPAPIVersion instance Schema.ToSchema WireIdPAPIVersion where schema = - Schema.enum @Text "WireIdPAPIVersion" $ + Schema.enum @Text $ mconcat [ Schema.element "WireIdPAPIV1" WireIdPAPIV1, Schema.element "WireIdPAPIV2" WireIdPAPIV2 diff --git a/libs/wire-api/src/Wire/API/User/Orphans.hs b/libs/wire-api/src/Wire/API/User/Orphans.hs index c3d44c7084e..326ed41e35e 100644 --- a/libs/wire-api/src/Wire/API/User/Orphans.hs +++ b/libs/wire-api/src/Wire/API/User/Orphans.hs @@ -128,7 +128,7 @@ instance O.ToSchema X509.SignedCertificate where declareNamedSchema _ = declareNamedSchema (Proxy @String) instance S.ToSchema Currency.Alpha where - schema = S.enum @Text "Currency.Alpha" cases & S.doc' . O.schema %~ swaggerTweaks + schema = S.enum @Text cases & S.doc' . O.schema %~ swaggerTweaks where cases :: SchemaP [A.Value] Text (Alt Maybe Text) Currency.Alpha Currency.Alpha cases = mconcat ((\cur -> S.element (T.pack (show cur)) cur) <$> [minBound @Currency.Alpha ..]) diff --git a/libs/wire-api/src/Wire/API/User/Password.hs b/libs/wire-api/src/Wire/API/User/Password.hs index 33ad254da73..079ccde88fa 100644 --- a/libs/wire-api/src/Wire/API/User/Password.hs +++ b/libs/wire-api/src/Wire/API/User/Password.hs @@ -70,7 +70,7 @@ data NewPasswordReset instance ToSchema NewPasswordReset where schema = - objectWithDocModifier "NewPasswordReset" objectDesc $ + objectWithDocModifier objectDesc $ (toTuple .= newPasswordResetTupleObjectSchema) `withParser` fromTuple where objectDesc :: NamedSwaggerDoc -> NamedSwaggerDoc @@ -115,7 +115,7 @@ data CompletePasswordReset = CompletePasswordReset instance ToSchema CompletePasswordReset where schema = - objectWithDocModifier "CompletePasswordReset" objectDocs $ + objectWithDocModifier objectDocs $ CompletePasswordReset <$> (maybePasswordResetIdentityToTuple . cpwrIdent) .= maybePasswordResetIdentityObjectSchema <*> cpwrCode .= fieldWithDocModifier "code" codeDocs schema @@ -219,7 +219,7 @@ data PasswordReset = PasswordReset instance ToSchema PasswordReset where schema = - objectWithDocModifier "PasswordReset" objectDocs $ + objectWithDocModifier objectDocs $ PasswordReset <$> pwrCode .= fieldWithDocModifier "code" codeDocs schema <*> pwrPassword .= fieldWithDocModifier "password" pwDocs schema diff --git a/libs/wire-api/src/Wire/API/User/Profile.hs b/libs/wire-api/src/Wire/API/User/Profile.hs index 372e980cabf..3fba25d81c9 100644 --- a/libs/wire-api/src/Wire/API/User/Profile.hs +++ b/libs/wire-api/src/Wire/API/User/Profile.hs @@ -127,16 +127,14 @@ data Asset = ImageAsset instance ToSchema Asset where schema = - object "UserAsset" $ + object $ ImageAsset <$> assetKey .= field "key" schema <*> assetSize .= maybe_ (optField "size" schema) <* const () .= field "type" typeSchema where typeSchema :: ValueSchema NamedSwaggerDoc () - typeSchema = - enum @Text @NamedSwaggerDoc "AssetType" $ - element "image" () + typeSchema = enum @Text $ element "image" () instance C.Cql Asset where -- Note: Type name and column names and types must match up with the @@ -184,7 +182,7 @@ data AssetSize = AssetComplete | AssetPreview instance ToSchema AssetSize where schema = - enum @Text "AssetSize" $ + enum @Text $ mconcat [ element "preview" AssetPreview, element "complete" AssetComplete @@ -226,7 +224,7 @@ data ManagedBy instance ToSchema ManagedBy where schema = - enum @Text "ManagedBy" $ + enum @Text $ mconcat [ element "wire" ManagedByWire, element "scim" ManagedByScim diff --git a/libs/wire-api/src/Wire/API/User/RichInfo.hs b/libs/wire-api/src/Wire/API/User/RichInfo.hs index 5309c4892d2..c53a1e611ea 100644 --- a/libs/wire-api/src/Wire/API/User/RichInfo.hs +++ b/libs/wire-api/src/Wire/API/User/RichInfo.hs @@ -342,7 +342,7 @@ instance ToSchema RichField where -- "value": ...}@ is how all other SCIM payloads are formatted, so it's quite possible -- that some provisioning agent would support "type" but not "name". schema = - object "RichField" $ + object $ RichField <$> richFieldType .= field "type" (CI.original .= (CI.mk <$> schema)) <*> richFieldValue .= field "value" schema diff --git a/libs/wire-api/src/Wire/API/User/Scim.hs b/libs/wire-api/src/Wire/API/User/Scim.hs index 174a4ef6b1b..8ca092eed10 100644 --- a/libs/wire-api/src/Wire/API/User/Scim.hs +++ b/libs/wire-api/src/Wire/API/User/Scim.hs @@ -62,7 +62,6 @@ import Data.Misc (PlainTextPassword6) import Data.OpenApi qualified as S import Data.Schema as Schema import Data.Text qualified as T -import Data.Text qualified as Text import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Data.These import Data.These.Combinators @@ -172,7 +171,7 @@ instance ToHttpApiData ScimToken where instance ToSchema ScimTokenInfo where schema = - object "ScimTokenInfo" $ + object $ ScimTokenInfo <$> (.stiTeam) .= field "team" schema <*> (.stiId) .= field "id" schema @@ -201,7 +200,7 @@ data ScimTokenInfoV7 = ScimTokenInfoV7 instance ToSchema ScimTokenInfoV7 where schema = - object "ScimTokenInfoV7" $ + object $ ScimTokenInfoV7 <$> (.stiTeam) .= field "team" schema <*> (.stiId) .= field "id" schema @@ -434,7 +433,7 @@ data CreateScimToken = CreateScimToken createScimTokenSchema :: Maybe Version -> ValueSchema NamedSwaggerDoc CreateScimToken createScimTokenSchema mVersion = - object ("CreateScimToken" <> foldMap (Text.toUpper . versionText) mVersion) $ + versionedObject mVersion $ CreateScimToken <$> (.description) .= field "description" schema <*> password .= optField "password" (maybeWithDefault A.Null schema) @@ -468,7 +467,7 @@ data CreateScimTokenResponse = CreateScimTokenResponse instance ToSchema CreateScimTokenResponse where schema = - object "CreateScimTokenResponse" $ + object $ CreateScimTokenResponse <$> (.token) .= field "token" schema <*> (.info) .= field "info" schema @@ -483,7 +482,7 @@ data CreateScimTokenResponseV7 = CreateScimTokenResponseV7 instance ToSchema CreateScimTokenResponseV7 where schema = - object "CreateScimTokenResponseV7" $ + object $ CreateScimTokenResponseV7 <$> (.token) .= field "token" schema <*> (.info) .= field "info" schema @@ -499,7 +498,7 @@ data ScimTokenList = ScimTokenList deriving (A.ToJSON, A.FromJSON, S.ToSchema) via (Schema.Schema ScimTokenList) instance ToSchema ScimTokenList where - schema = object "ScimTokenList" $ ScimTokenList <$> (.scimTokenListTokens) .= field "tokens" (array schema) + schema = object $ ScimTokenList <$> (.scimTokenListTokens) .= field "tokens" (array schema) data ScimTokenListV7 = ScimTokenListV7 { scimTokenListTokens :: [ScimTokenInfoV7] @@ -508,11 +507,11 @@ data ScimTokenListV7 = ScimTokenListV7 deriving (A.ToJSON, A.FromJSON, S.ToSchema) via (Schema.Schema ScimTokenListV7) instance ToSchema ScimTokenListV7 where - schema = object "ScimTokenListV7" $ ScimTokenListV7 <$> (.scimTokenListTokens) .= field "tokens" (array schema) + schema = object $ ScimTokenListV7 <$> (.scimTokenListTokens) .= field "tokens" (array schema) newtype ScimTokenName = ScimTokenName {fromScimTokenName :: Text} deriving (Eq, Show) deriving (A.ToJSON, A.FromJSON, S.ToSchema) via (Schema.Schema ScimTokenName) instance ToSchema ScimTokenName where - schema = object "ScimTokenName" $ ScimTokenName <$> fromScimTokenName .= field "name" schema + schema = object $ ScimTokenName <$> fromScimTokenName .= field "name" schema diff --git a/libs/wire-api/src/Wire/API/User/Search.hs b/libs/wire-api/src/Wire/API/User/Search.hs index 25ac61f78d6..07a5c27cd29 100644 --- a/libs/wire-api/src/Wire/API/User/Search.hs +++ b/libs/wire-api/src/Wire/API/User/Search.hs @@ -58,7 +58,6 @@ import Data.Schema import Data.Text qualified as T import Data.Text.Ascii (AsciiBase64Url, toText, validateBase64Url) import Data.Text.Encoding qualified as TE -import Data.Typeable (typeRep) import Imports import Servant.API (FromHttpApiData, ToHttpApiData (..)) import Web.Internal.HttpApiData (parseQueryParam) @@ -117,7 +116,7 @@ instance Traversable SearchResult where instance (ToSchema a, Typeable a) => ToSchema (SearchResult a) where schema = - object ("SearchResult_" <> T.pack (show $ typeRep $ Proxy @a)) $ + object $ SearchResult <$> searchFound .= fieldWithDocModifier "found" (S.description ?~ "Total number of hits") schema <*> searchReturned .= fieldWithDocModifier "returned" (S.description ?~ "Total number of hits returned") schema @@ -158,7 +157,7 @@ data Contact = Contact instance ToSchema Contact where schema = - objectWithDocModifier "Contact" (description ?~ "Contact discovered through search") $ + objectWithDocModifier (description ?~ "Contact discovered through search") $ Contact <$> contactQualifiedId .= field "qualified_id" schema <* (qUnqualified . contactQualifiedId) .= optField "id" schema @@ -182,7 +181,7 @@ data Sso = Sso instance ToSchema Sso where schema = - object "Sso" $ + object $ Sso <$> ssoIssuer .= field "issuer" schema <*> ssoNameId .= field "nameid" schema @@ -212,7 +211,7 @@ data TeamContact = TeamContact instance ToSchema TeamContact where schema = - object "TeamContact" $ + object $ TeamContact <$> teamContactUserId .= field "id" schema <*> teamContactUserType .= field "type" schema @@ -332,7 +331,7 @@ userTypeFilterToUserType UserTypeFilterApp = UserTypeApp instance ToSchema UserTypeFilter where schema = - enum @Text "UserTypeFilter" $ + enum @Text $ mconcat [ element "regular" UserTypeFilterRegular, element "app" UserTypeFilterApp @@ -363,7 +362,7 @@ data FederatedUserSearchPolicy instance ToSchema FederatedUserSearchPolicy where schema = - enum @Text "FederatedUserSearchPolicy" $ + enum @Text $ element "no_search" NoSearch <> element "exact_handle_search" ExactHandleSearch <> element "full_search" FullSearch @@ -389,7 +388,7 @@ data EmailVerificationFilter instance ToSchema EmailVerificationFilter where schema = - enum @Text "EmailVerificationFilter" $ + enum @Text $ element "unverified" EmailUnverified <> element "verified" EmailVerified @@ -424,6 +423,6 @@ data SetSearchable = SetSearchable instance ToSchema SetSearchable where schema = - object "SetSearchable" $ + object $ SetSearchable <$> setSearchable .= field "set_searchable" schema diff --git a/libs/wire-api/src/Wire/API/UserEvent.hs b/libs/wire-api/src/Wire/API/UserEvent.hs index 4c9863d317b..6da5a8c07e6 100644 --- a/libs/wire-api/src/Wire/API/UserEvent.hs +++ b/libs/wire-api/src/Wire/API/UserEvent.hs @@ -20,6 +20,7 @@ module Wire.API.UserEvent where +import Control.Lens ((?~)) import Control.Lens.TH import Data.Aeson qualified as A import Data.Aeson.KeyMap qualified as KM @@ -34,6 +35,7 @@ import System.Logger.Message hiding (field, (.=)) import Wire.API.Connection import Wire.API.Locale import Wire.API.Properties +import Wire.API.Push.V2 qualified as V2 import Wire.API.Routes.Version import Wire.API.User import Wire.API.User.Client @@ -47,6 +49,25 @@ data Event | UserGroupEvent !UserGroupEvent deriving stock (Eq, Show) +toApsData :: Event -> Maybe V2.ApsData +toApsData (ConnectionEvent (ConnectionUpdated uc name)) = + case (ucStatus uc, name) of + (MissingLegalholdConsent, _) -> Nothing + (Pending, n) -> apsConnRequest <$> n + (Accepted, n) -> apsConnAccept <$> n + (Blocked, _) -> Nothing + (Ignored, _) -> Nothing + (Sent, _) -> Nothing + (Cancelled, _) -> Nothing + where + apsConnRequest n = + V2.apsData (V2.ApsLocKey "push.notification.connection.request") [fromName n] + & V2.apsSound ?~ V2.ApsSound "new_message_apns.caf" + apsConnAccept n = + V2.apsData (V2.ApsLocKey "push.notification.connection.accepted") [fromName n] + & V2.apsSound ?~ V2.ApsSound "new_message_apns.caf" +toApsData _ = Nothing + eventType :: Event -> EventType eventType (UserEvent (UserCreated _)) = EventTypeUserCreated eventType (UserEvent (UserActivated _)) = EventTypeUserActivated @@ -91,11 +112,11 @@ data EventType | EventTypeUserGroupUpdated | EventTypeUserGroupDeleted | EventTypeUserSessionRefreshSuggested - deriving stock (Eq, Enum, Bounded) + deriving stock (Show, Eq, Enum, Bounded) instance ToSchema EventType where schema = - enum @Text "EventType" $ + enum @Text $ mconcat [ element "user.new" EventTypeUserCreated, element "user.activate" EventTypeUserActivated, @@ -260,7 +281,6 @@ eventObjectSchema = ( field "user" ( object - "UserUpdatedData" ( UserUpdatedData <$> eupId .= field "id" schema <*> eupName .= maybe_ (optField "name" schema) @@ -283,7 +303,6 @@ eventObjectSchema = ( field "user" ( object - "UserIdentityUpdatedData" ( UserIdentityUpdatedData <$> eiuId .= field "id" schema <*> eiuEmail .= maybe_ (optField "email" schema) @@ -300,7 +319,6 @@ eventObjectSchema = ( field "user" ( object - "UserIdentityRemovedData" ( UserIdentityRemovedData <$> eirId .= field "id" schema <*> eirEmail .= maybe_ (optField "email" schema) @@ -386,7 +404,7 @@ eventObjectSchema = _ConnectionEvent ( ConnectionUpdated <$> ucConn .= field "connection" schema - <*> ucName .= maybe_ (optField "user" (object "UserName" (field "name" schema))) + <*> ucName .= maybe_ (optField "user" (object (field "name" schema))) ) EventTypeUserGroupCreated -> tag @@ -421,7 +439,7 @@ instance ToJSONObject Event where toJSONObject = KM.fromList . fold . schemaOut eventObjectSchema instance ToSchema Event where - schema = object "UserEvent" eventObjectSchema + schema = object eventObjectSchema deriving via (Schema Event) instance A.ToJSON Event diff --git a/libs/wire-api/src/Wire/API/UserGroup.hs b/libs/wire-api/src/Wire/API/UserGroup.hs index f4dfa28d941..a61be18db5d 100644 --- a/libs/wire-api/src/Wire/API/UserGroup.hs +++ b/libs/wire-api/src/Wire/API/UserGroup.hs @@ -69,7 +69,7 @@ data NewUserGroup = NewUserGroup instance ToSchema NewUserGroup where schema = - object "NewUserGroup" $ + object $ NewUserGroup <$> (.name) .= field "name" schema <*> (.members) .= field "members" (vector schema) @@ -83,7 +83,7 @@ data UserGroupUpdate = UserGroupUpdate instance ToSchema UserGroupUpdate where schema = - object "UserGroupUpdate" $ + object $ UserGroupUpdate <$> (.name) .= field "name" schema @@ -96,7 +96,7 @@ newtype UserGroupAddUsers = UserGroupAddUsers instance ToSchema UserGroupAddUsers where schema = - object "UserGroupAddUsers" $ + object $ UserGroupAddUsers <$> (.members) .= field "members" (vector schema) @@ -145,7 +145,7 @@ deriving via Schema (UserGroup_ (Const ())) instance OpenApi.ToSchema (UserGroup instance ToSchema (UserGroup_ (Const ())) where schema = - object "UserGroupMeta" $ + object $ UserGroup_ <$> (.id_) .= field "id" schema <*> (.name) .= field "name" schema @@ -172,7 +172,7 @@ deriving via Schema (UserGroup_ Identity) instance OpenApi.ToSchema (UserGroup_ instance ToSchema (UserGroup_ Identity) where schema = - object "UserGroup" $ + object $ UserGroup_ <$> (.id_) .= field "id" schema <*> (.name) .= field "name" schema @@ -192,7 +192,7 @@ newtype UpdateUserGroupMembers = UpdateUserGroupMembers instance ToSchema UpdateUserGroupMembers where schema = - object "UpdateUserGroupMembers" $ + object $ UpdateUserGroupMembers <$> (.members) .= field "members" (vector schema) @@ -205,7 +205,7 @@ newtype UpdateUserGroupChannels = UpdateUserGroupChannels instance ToSchema UpdateUserGroupChannels where schema = - object "UpdateUserGroupChannels" $ + object $ UpdateUserGroupChannels <$> (.channels) .= field "channels" (vector schema) @@ -218,7 +218,7 @@ newtype CheckUserGroupName = CheckUserGroupName instance ToSchema CheckUserGroupName where schema = - object "CheckUserGroupName" $ + object $ CheckUserGroupName <$> (.name) .= field "name" schema @@ -231,6 +231,6 @@ newtype UserGroupNameAvailability = UserGroupNameAvailability instance ToSchema UserGroupNameAvailability where schema = - object "UserGroupNameAvailability" $ + object $ UserGroupNameAvailability <$> (.available) .= field "name_available" schema diff --git a/libs/wire-api/src/Wire/API/UserGroup/Pagination.hs b/libs/wire-api/src/Wire/API/UserGroup/Pagination.hs index 9e8ed1bb333..7cda7a5c358 100644 --- a/libs/wire-api/src/Wire/API/UserGroup/Pagination.hs +++ b/libs/wire-api/src/Wire/API/UserGroup/Pagination.hs @@ -76,9 +76,9 @@ data UserGroupPage_ a = UserGroupPage deriving (Eq, Show, Generic) deriving (A.FromJSON, A.ToJSON, S.ToSchema) via Schema (UserGroupPage_ a) -instance (ToSchema a) => ToSchema (UserGroupPage_ a) where +instance (Typeable a, ToSchema a) => ToSchema (UserGroupPage_ a) where schema = - objectWithDocModifier "UserGroupPage" addPageDocs $ + objectWithDocModifier addPageDocs $ UserGroupPage <$> page .= field "page" (array schema) <*> total .= field "total" schema 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 6533d66b963..b66a79c6076 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 @@ -63,13 +63,16 @@ import Wire.API.Team.Feature qualified as Team.Feature import Wire.API.Team.Invitation qualified as Team.Invitation import Wire.API.Team.LegalHold qualified as Team.LegalHold import Wire.API.Team.LegalHold.External qualified as Team.LegalHold.External +import Wire.API.Team.LegalHold.Internal as Team.LegalHold.Internal import Wire.API.Team.Member qualified as Team.Member import Wire.API.Team.Permission qualified as Team.Permission import Wire.API.Team.Role qualified as Team.Role import Wire.API.Team.SearchVisibility qualified as Team.SearchVisibility +import Wire.API.Team.Size qualified as Team import Wire.API.User qualified as User import Wire.API.User.Activation qualified as User.Activation import Wire.API.User.Auth qualified as User.Auth +import Wire.API.User.Auth.ReAuth qualified as User.Auth import Wire.API.User.Client qualified as User.Client import Wire.API.User.Client.Prekey qualified as User.Client.Prekey import Wire.API.User.Handle qualified as User.Handle @@ -359,7 +362,17 @@ tests = testRoundTrip @TeamsIntra.TeamStatusUpdate, testRoundTrip @TeamsIntra.TeamData, testRoundTrip @TeamsIntra.TeamName, - testRoundTrip @BackgroundJobs.Job + testRoundTrip @BackgroundJobs.Job, + testRoundTrip @User.ManagedByUpdate, + testRoundTrip @User.Auth.ReAuthUser, + testRoundTrip @User.RichInfoUpdate, + testRoundTrip @User.NewUserScimInvitation, + testRoundTripWithSwagger @EJPD.EJPDRequestBody, + testRoundTripWithSwagger @EJPD.EJPDResponseBody, + testRoundTrip @User.UpdateConnectionsInternal, + testRoundTrip @Team.TeamSize, + testRoundTrip @Team.LegalHold.Internal.LegalHoldService, + testRoundTrip @Team.LegalHold.Internal.LegalHoldClientRequest ] testRoundTrip :: diff --git a/libs/wire-subsystems/default.nix b/libs/wire-subsystems/default.nix index c731826f787..e62655cecc3 100644 --- a/libs/wire-subsystems/default.nix +++ b/libs/wire-subsystems/default.nix @@ -11,6 +11,8 @@ , amazonka-ses , amazonka-sqs , amqp +, asn1-encoding +, asn1-types , async , attoparsec , base @@ -29,6 +31,7 @@ , contravariant , cql , crypton +, crypton-pem , crypton-x509 , crypton-x509-store , currency-codes @@ -67,6 +70,7 @@ , iproute , iso639 , lens +, lens-aeson , lib , lrucaching , memory @@ -146,6 +150,8 @@ mkDerivation { amazonka-ses amazonka-sqs amqp + asn1-encoding + asn1-types async attoparsec base @@ -164,6 +170,7 @@ mkDerivation { contravariant cql crypton + crypton-pem crypton-x509 currency-codes data-default @@ -198,6 +205,7 @@ mkDerivation { iproute iso639 lens + lens-aeson lrucaching memory mime @@ -268,6 +276,8 @@ mkDerivation { amazonka-ses amazonka-sqs amqp + asn1-encoding + asn1-types async attoparsec base @@ -285,6 +295,7 @@ mkDerivation { contravariant cql crypton + crypton-pem crypton-x509 crypton-x509-store currency-codes @@ -320,6 +331,7 @@ mkDerivation { iproute iso639 lens + lens-aeson lrucaching memory mime diff --git a/libs/wire-subsystems/src/Wire/AppSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/AppSubsystem/Interpreter.hs index 819c692b4b0..c089e4294db 100644 --- a/libs/wire-subsystems/src/Wire/AppSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/AppSubsystem/Interpreter.hs @@ -129,7 +129,7 @@ createAppImpl lusr tid newApp = do internalUpdateSearchIndex u.id -- generate a team event - generateTeamEvents creator.id tid [EdAppCreate u.id] + generateTeamEvents creator.id tid [EdMemberJoin u.id] c :: Cookie (Token U) <- newCookie u.id Nothing PersistentCookie Nothing RevokeSameLabel pure diff --git a/libs/wire-subsystems/src/Wire/AuthenticationSubsystem.hs b/libs/wire-subsystems/src/Wire/AuthenticationSubsystem.hs index acf61f9072b..b4eff9d78da 100644 --- a/libs/wire-subsystems/src/Wire/AuthenticationSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/AuthenticationSubsystem.hs @@ -19,6 +19,7 @@ module Wire.AuthenticationSubsystem where +import Data.Code qualified as Code import Data.Id import Data.Misc import Data.Qualified @@ -77,6 +78,8 @@ data AuthenticationSubsystem m a where SameLabelPolicy -> AuthenticationSubsystem m (Either RetryAfter (Cookie (ZAuth.Token t))) RevokeCookies :: UserId -> [CookieId] -> [CookieLabel] -> AuthenticationSubsystem m () + -- Verification Codes + EnforceVerificationCodeEither :: Local UserId -> Maybe Code.Value -> VerificationAction -> AuthenticationSubsystem m (Either VerificationCodeError ()) -- For testing InternalLookupPasswordResetCode :: EmailKey -> AuthenticationSubsystem m (Maybe PasswordResetPair) diff --git a/libs/wire-subsystems/src/Wire/AuthenticationSubsystem/Error.hs b/libs/wire-subsystems/src/Wire/AuthenticationSubsystem/Error.hs index 73f305994a2..51e2384cb2b 100644 --- a/libs/wire-subsystems/src/Wire/AuthenticationSubsystem/Error.hs +++ b/libs/wire-subsystems/src/Wire/AuthenticationSubsystem/Error.hs @@ -58,6 +58,14 @@ data AuthenticationSubsystemError instance Exception AuthenticationSubsystemError +data VerificationCodeError + = VerificationCodeRequired + | VerificationCodeNoPendingCode + | VerificationCodeNoEmail + deriving (Show, Eq) + +instance Exception VerificationCodeError + authenticationSubsystemErrorToHttpError :: AuthenticationSubsystemError -> HttpError authenticationSubsystemErrorToHttpError = StdError . \case @@ -75,6 +83,20 @@ zauthError ZAuth.Falsified = authTokenFalsified zauthError ZAuth.Invalid = authTokenInvalid zauthError ZAuth.Unsupported = authTokenUnsupported +reauthError :: ReAuthError -> HttpError +reauthError ReAuthMissingPassword = StdError (errorToWai @'E.MissingAuth) +reauthError (ReAuthError e) = authError e +reauthError ReAuthCodeVerificationRequired = StdError verificationCodeRequired +reauthError ReAuthCodeVerificationNoPendingCode = StdError verificationCodeNoPendingCode +reauthError ReAuthCodeVerificationNoEmail = StdError verificationCodeNoEmail + +authError :: AuthError -> HttpError +authError AuthInvalidUser = StdError (errorToWai @'E.BadCredentials) +authError AuthInvalidCredentials = StdError (errorToWai @'E.BadCredentials) +authError AuthSuspended = StdError (errorToWai @'E.AccountSuspended) +authError AuthEphemeral = StdError (errorToWai @'E.AccountEphemeral) +authError AuthPendingInvitation = StdError (errorToWai @'E.AccountPending) + authTokenExpired :: Wai.Error authTokenExpired = Wai.mkError status403 "invalid-credentials" "Zauth token expired" @@ -86,3 +108,15 @@ authTokenFalsified = Wai.mkError status403 "invalid-credentials" "Zauth token fa authTokenUnsupported :: Wai.Error authTokenUnsupported = Wai.mkError status403 "invalid-credentials" "Unsupported token operation for this token type" + +verificationCodeAuthFailed :: Wai.Error +verificationCodeAuthFailed = Wai.mkError status403 "code-authentication-failed" "Code authentication failed." + +verificationCodeRequired :: Wai.Error +verificationCodeRequired = Wai.mkError status403 "code-authentication-required" "Verification code required." + +verificationCodeNoPendingCode :: Wai.Error +verificationCodeNoPendingCode = Wai.mkError status403 "code-authentication-failed" "Code authentication failed (no such code)." + +verificationCodeNoEmail :: Wai.Error +verificationCodeNoEmail = Wai.mkError status403 "code-authentication-failed" "Code authentication failed (no such email)." diff --git a/libs/wire-subsystems/src/Wire/AuthenticationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/AuthenticationSubsystem/Interpreter.hs index 223a0444942..0bf6b57f0cf 100644 --- a/libs/wire-subsystems/src/Wire/AuthenticationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/AuthenticationSubsystem/Interpreter.hs @@ -23,6 +23,8 @@ module Wire.AuthenticationSubsystem.Interpreter where import Data.ByteString.Conversion +import Data.Code qualified as Code +import Data.Default import Data.HavePendingInvitations import Data.Id import Data.Misc @@ -37,6 +39,7 @@ import Polysemy.TinyLog (TinyLog) import Polysemy.TinyLog qualified as Log import System.Logger import Wire.API.Allowlists qualified as AllowLists +import Wire.API.Team.Feature import Wire.API.User import Wire.API.User.Password import Wire.AuthenticationSubsystem @@ -45,6 +48,8 @@ import Wire.AuthenticationSubsystem.Cookie import Wire.AuthenticationSubsystem.Error import Wire.EmailSubsystem import Wire.Events +import Wire.GalleyAPIAccess (GalleyAPIAccess) +import Wire.GalleyAPIAccess qualified as GalleyAPIAccess import Wire.HashPassword import Wire.PasswordResetCodeStore import Wire.PasswordStore (PasswordStore) @@ -59,6 +64,10 @@ import Wire.UserStore (UserStore) import Wire.UserStore qualified as UserStore import Wire.UserSubsystem (UserSubsystem, getLocalAccountBy) import Wire.UserSubsystem qualified as User +import Wire.VerificationCode +import Wire.VerificationCodeGen +import Wire.VerificationCodeSubsystem (VerificationCodeSubsystem) +import Wire.VerificationCodeSubsystem qualified as VerificationCodeSubsystem interpretAuthenticationSubsystem :: forall r. @@ -75,7 +84,9 @@ interpretAuthenticationSubsystem :: Member RateLimit r, Member CryptoSign r, Member Random r, - Member Events r + Member Events r, + Member GalleyAPIAccess r, + Member VerificationCodeSubsystem r ) => InterpreterFor UserSubsystem r -> InterpreterFor AuthenticationSubsystem r @@ -96,6 +107,8 @@ interpretAuthenticationSubsystem userSubsystemInterpreter = NewCookie uid mcid typ mLabel policy -> newCookieImpl uid mcid typ mLabel policy NewCookieLimited uid mcid typ mLabel policy -> runError $ newCookieLimitedImpl uid mcid typ mLabel policy RevokeCookies uid ids labels -> revokeCookiesImpl uid ids labels + -- Verification Codes + EnforceVerificationCodeEither luid mCode action -> runError $ enforceVerificationCodeImpl luid mCode action -- Testing InternalLookupPasswordResetCode userKey -> internalLookupPasswordResetCodeImpl userKey @@ -110,12 +123,14 @@ data PasswordResetError = AllowListError | InvalidResetKey | InProgress + | SAMLUserNotAllowed deriving (Show) instance Exception PasswordResetError where displayException AllowListError = "email domain is not allowed for password reset" displayException InvalidResetKey = "invalid reset key for password reset" displayException InProgress = "password reset already in progress" + displayException SAMLUserNotAllowed = "SAML users are not allowed to reset password" authenticateEitherImpl :: ( Member UserStore r, @@ -203,7 +218,7 @@ createPasswordResetCodeImpl target = user <- lookupActiveUserByUserKey target >>= maybe (throw InvalidResetKey) pure let uid = userId user Log.debug $ field "user" (toByteString uid) . field "action" (val "User.beginPasswordReset") - + when (isSamlUser user) $ throw SAMLUserNotAllowed mExistingCode <- lookupPasswordResetCode uid when (isJust mExistingCode) $ throw InProgress @@ -310,6 +325,10 @@ resetPasswordImpl ident code pw = do case muid of Nothing -> throw AuthenticationSubsystemInvalidPasswordResetCode Just uid -> do + localUnit <- inputs (.local) + mUser <- User.getAccountNoFilter (qualifyAs localUnit uid) + when (maybe False isSamlUser mUser) $ + throw AuthenticationSubsystemInvalidPasswordResetCode let rateLimitKey = RateLimitUser uid Log.debug $ field "user" (toByteString uid) . field "action" (val "User.completePasswordReset") checkNewIsDifferent uid pw @@ -395,3 +414,35 @@ verifyUserPasswordErrorImpl :: verifyUserPasswordErrorImpl (tUnqualified -> uid) password = do unlessM (fst <$> verifyUserPasswordImpl uid password) do throw AuthenticationSubsystemBadCredentials + +enforceVerificationCodeImpl :: + forall r. + ( Member GalleyAPIAccess r, + Member VerificationCodeSubsystem r, + Member UserSubsystem r, + Member (Error VerificationCodeError) r + ) => + Local UserId -> + Maybe Code.Value -> + VerificationAction -> + Sem r () +enforceVerificationCodeImpl luid mCode action = do + (mEmail, mTid) <- getEmailAndTeamId luid + verificationRequired <- case mTid of + Just tid -> GalleyAPIAccess.getVerificationCodeEnabled tid + Nothing -> pure $ (def @(Feature SndFactorPasswordChallengeConfig)).status == FeatureStatusEnabled + isSsoUser <- maybe False isSamlUser <$> User.getAccountNoFilter luid + when (verificationRequired && not isSsoUser) $ do + case (mCode, mEmail) of + (Just code, Just email) -> do + codeValid <- isJust <$> VerificationCodeSubsystem.verifyCode (mkKey email) (scopeFromAction action) code + unless codeValid $ throw VerificationCodeNoPendingCode + (Nothing, _) -> throw VerificationCodeRequired + (_, Nothing) -> throw VerificationCodeNoEmail + where + getEmailAndTeamId u = do + mbAccount <- User.getAccountNoFilter u + pure + ( userEmail =<< mbAccount, + userTeam =<< mbAccount + ) diff --git a/libs/wire-subsystems/src/Wire/BrigAPIAccess.hs b/libs/wire-subsystems/src/Wire/BrigAPIAccess.hs index c3d089c81e5..a4e53f2b9b3 100644 --- a/libs/wire-subsystems/src/Wire/BrigAPIAccess.hs +++ b/libs/wire-subsystems/src/Wire/BrigAPIAccess.hs @@ -62,6 +62,7 @@ module Wire.BrigAPIAccess -- * Bots deleteBot, + getAppIdsForTeam, -- * User Groups createGroupInternal, @@ -71,6 +72,9 @@ module Wire.BrigAPIAccess deleteGroupInternal, deleteApp, DeleteGroupManagedError (..), + + -- * Account status + setAccountStatus, ) where @@ -170,6 +174,8 @@ data BrigAPIAccess m a where UpdateGroup :: UpdateGroupInternalRequest -> BrigAPIAccess m (Either Wai.Error ()) DeleteGroupInternal :: ManagedBy -> TeamId -> UserGroupId -> BrigAPIAccess m (Either DeleteGroupManagedError ()) DeleteApp :: TeamId -> UserId -> BrigAPIAccess m () + GetAppIdsForTeam :: TeamId -> BrigAPIAccess m [UserId] + SetAccountStatus :: UserId -> AccountStatus -> BrigAPIAccess m () makeSem ''BrigAPIAccess diff --git a/libs/wire-subsystems/src/Wire/BrigAPIAccess/Rpc.hs b/libs/wire-subsystems/src/Wire/BrigAPIAccess/Rpc.hs index e99e6a17e93..32703e2f923 100644 --- a/libs/wire-subsystems/src/Wire/BrigAPIAccess/Rpc.hs +++ b/libs/wire-subsystems/src/Wire/BrigAPIAccess/Rpc.hs @@ -53,7 +53,7 @@ import Wire.API.Team.Export import Wire.API.Team.Feature import Wire.API.Team.LegalHold.Internal import Wire.API.Team.Size -import Wire.API.User (EmailAddress, UpdateConnectionsInternal, User, UserIds (..), UserSet (..)) +import Wire.API.User (AccountStatus (..), AccountStatusUpdate (..), EmailAddress, UpdateConnectionsInternal, User, UserIds (..), UserSet (..)) import Wire.API.User.Auth.LegalHold import Wire.API.User.Auth.ReAuth import Wire.API.User.Client @@ -138,6 +138,10 @@ interpretBrigAccess brigEndpoint = deleteGroupInternal managedBy teamId groupId DeleteApp teamId userId -> deleteApp teamId userId + GetAppIdsForTeam teamId -> + getAppIdsForTeam teamId + SetAccountStatus uid status -> + setAccountStatus uid status brigRequest :: (Member Rpc r, Member (Input Endpoint) r) => (Request -> Request) -> Sem r (Response (Maybe LByteString)) brigRequest req = do @@ -716,6 +720,31 @@ deleteApp teamId userId = do . paths ["i", "teams", toByteString' teamId, "apps", toByteString' userId] . expect2xx +getAppIdsForTeam :: + (Member Rpc r, Member (Input Endpoint) r) => + TeamId -> + Sem r [UserId] +getAppIdsForTeam teamId = do + resp <- + brigRequest $ + method GET + . paths ["i", "teams", toByteString' teamId, "apps"] + . expect2xx + pure . fromMaybe [] . responseJsonMaybe $ resp + +setAccountStatus :: + (Member Rpc r, Member (Input Endpoint) r) => + UserId -> + AccountStatus -> + Sem r () +setAccountStatus uid status = + void $ + brigRequest $ + method PUT + . paths ["i", "users", toByteString' uid, "status"] + . json (AccountStatusUpdate status) + . expect2xx + is2xx :: ResponseLBS -> Bool is2xx = statusIs2xx . statusCode diff --git a/libs/wire-subsystems/src/Wire/ClientStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/ClientStore/Cassandra.hs index 8bd18d29f4c..57143288b43 100644 --- a/libs/wire-subsystems/src/Wire/ClientStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/ClientStore/Cassandra.hs @@ -104,11 +104,14 @@ lookupPubClientsBulkImpl uids = liftClient $ do pure . UserMap $ Map.fromList userClientTuples where getClientSetWithUser :: (MonadClient m) => UserId -> m (UserId, Imports.Set PubClient) - getClientSetWithUser u = (u,) . Set.fromList . map toPubClient <$> executeQuery u + getClientSetWithUser u = (u,) . Set.fromList . map mkPubClient <$> executeQuery u executeQuery :: (MonadClient m) => UserId -> m [(ClientId, Maybe ClientClass)] executeQuery u = retry x1 (query selectPubClients (params LocalQuorum (Identity u))) + mkPubClient :: (ClientId, Maybe ClientClass) -> PubClient + mkPubClient = uncurry PubClient + lookupClientsImpl :: (MonadClient m) => UserId -> m [Client] lookupClientsImpl u = do keys <- @@ -362,6 +365,3 @@ toClient keys (cid, cty, tme, lbl, cls, cok, mdl, cps, lastActive) = clientMLSPublicKeys = fmap (LBS.toStrict . fromBlob) (Map.fromList keys), clientLastActive = lastActive } - -toPubClient :: (ClientId, Maybe ClientClass) -> PubClient -toPubClient = uncurry PubClient diff --git a/libs/wire-subsystems/src/Wire/ClientSubsystem.hs b/libs/wire-subsystems/src/Wire/ClientSubsystem.hs index 69da2e93a7b..236eccdb016 100644 --- a/libs/wire-subsystems/src/Wire/ClientSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/ClientSubsystem.hs @@ -2,12 +2,62 @@ module Wire.ClientSubsystem where +import Data.Default +import Data.Domain import Data.Id +import Data.Misc +import Data.Qualified import Data.Time.Clock import Imports import Polysemy +import Wire.API.Team.LegalHold +import Wire.API.Team.LegalHold.Internal +import Wire.API.User.Client +import Wire.API.User.Client.Prekey +import Wire.API.UserEvent +import Wire.API.UserMap + +-- | Re-authentication policy. +-- +-- For a potential new client, a policy is a function that takes as arguments +-- the number of existing clients of the same type, and whether the client +-- already exists, and returns whether the user should be forced to +-- re-authenticate. +newtype ReAuthPolicy = ReAuthPolicy {unReAuthPolicy :: Int -> Bool -> Bool} + +-- | Default re-authentication policy. +-- +-- Re-authenticate if there is at least one other client. +reAuthForNewClients :: ReAuthPolicy +reAuthForNewClients = ReAuthPolicy {unReAuthPolicy = \count upsert -> count > 0 && not upsert} + +instance Default ReAuthPolicy where + def = reAuthForNewClients data ClientSubsystem m a where InternalGetActivityTimestamps :: UserId -> ClientSubsystem m [Maybe UTCTime] + LookupLocalClient :: UserId -> ClientId -> ClientSubsystem m (Maybe Client) + LookupLocalClients :: UserId -> ClientSubsystem m [Client] + LookupLocalPublicClientsBulk :: [UserId] -> ClientSubsystem m (UserMap (Set PubClient)) + LookupPublicClient :: Qualified UserId -> ClientId -> ClientSubsystem m (Maybe PubClient) + LookupPublicClients :: Qualified UserId -> ClientSubsystem m [PubClient] + LookupPublicClientsBulk :: [Qualified UserId] -> ClientSubsystem m (QualifiedUserMap (Set PubClient)) + AddClient :: Local UserId -> Maybe ConnId -> NewClient -> ClientSubsystem m Client + AddClientWithPolicy :: ReAuthPolicy -> Local UserId -> Maybe ConnId -> NewClient -> ClientSubsystem m Client + UpsertClient :: Local UserId -> ClientId -> NewClient -> Maybe ClientCapabilityList -> ClientSubsystem m (Client, [Client], Word) + OnClientEvent :: UserId -> Maybe ConnId -> ClientEvent -> ClientSubsystem m () + EnqueueClientDeletion :: UserId -> Maybe ConnId -> Client -> ClientSubsystem m () + RemoveClient :: UserId -> ConnId -> ClientId -> Maybe PlainTextPassword6 -> ClientSubsystem m () + RemoveLegalHoldClient :: UserId -> ClientSubsystem m () + PublishLegalHoldClientRequested :: UserId -> LegalHoldClientRequest -> ClientSubsystem m () + UpdateClient :: UserId -> ClientId -> UpdateClient -> ClientSubsystem m () + -- Prekeys + ClaimPrekey :: LegalholdProtectee -> UserId -> Domain -> ClientId -> ClientSubsystem m (Maybe ClientPrekey) + ClaimLocalPrekey :: LegalholdProtectee -> UserId -> ClientId -> ClientSubsystem m (Maybe ClientPrekey) + ClaimPrekeyBundle :: LegalholdProtectee -> Domain -> UserId -> ClientSubsystem m PrekeyBundle + ClaimLocalPrekeyBundle :: LegalholdProtectee -> UserId -> ClientSubsystem m PrekeyBundle + ClaimMultiPrekeyBundlesV3 :: LegalholdProtectee -> QualifiedUserClients -> ClientSubsystem m QualifiedUserClientPrekeyMap + ClaimMultiPrekeyBundles :: LegalholdProtectee -> QualifiedUserClients -> ClientSubsystem m QualifiedUserClientPrekeyMapV4 + ClaimLocalMultiPrekeyBundles :: LegalholdProtectee -> UserClients -> ClientSubsystem m UserClientPrekeyMap makeSem ''ClientSubsystem diff --git a/libs/wire-subsystems/src/Wire/ClientSubsystem/Error.hs b/libs/wire-subsystems/src/Wire/ClientSubsystem/Error.hs new file mode 100644 index 00000000000..8c9d24f31ed --- /dev/null +++ b/libs/wire-subsystems/src/Wire/ClientSubsystem/Error.hs @@ -0,0 +1,85 @@ +module Wire.ClientSubsystem.Error where + +import Data.Id +import Imports +import Network.HTTP.Types.Status +import Network.Wai.Utilities.Error qualified as Wai +import Wire.API.Error +import Wire.API.Error.Brig qualified as E +import Wire.API.Federation.Error +import Wire.AuthenticationSubsystem.Error +import Wire.Error + +data ClientDataError + = TooManyClients + | ClientReAuthError !ReAuthError + | ClientMissingAuth + | MalformedPrekeys + | MLSPublicKeyDuplicate + | MLSNotEnabled + | KeyPackageDecodingError + | InvalidKeyPackageRef + deriving (Show, Eq) + +data ClientError + = ClientNotFound + | ClientDataError !ClientDataError + | ClientUserNotFound !UserId + | ClientLegalHoldCannotBeRemoved + | ClientLegalHoldCannotBeAdded + | -- | this error is thrown if legalhold if incompatible with different features + -- for now, this is the case for MLS and federation + ClientLegalHoldIncompatible + | ClientFederationError FederationError + | ClientCapabilitiesCannotBeRemoved + | ClientMissingLegalholdConsentOldClients + | ClientMissingLegalholdConsent + | ClientCodeAuthenticationFailed + | ClientCodeAuthenticationRequired + deriving (Show) + +instance Exception ClientError + +clientErrorToHttpError :: ClientError -> HttpError +clientErrorToHttpError = + \case + ClientNotFound -> StdError $ errorToWai @'E.ClientNotFound + (ClientDataError e) -> clientDataErrorToHttpError e + (ClientUserNotFound _) -> StdError $ errorToWai @'E.InvalidUser + ClientLegalHoldCannotBeRemoved -> StdError $ can'tDeleteLegalHoldClient + ClientLegalHoldCannotBeAdded -> StdError $ can'tAddLegalHoldClient + ClientLegalHoldIncompatible -> StdError $ Wai.mkError status409 "mls-legal-hold-not-allowed" "A user who is under legal-hold may not participate in MLS conversations" + (ClientFederationError e) -> StdError $ federationErrorToWai e + ClientCapabilitiesCannotBeRemoved -> StdError $ clientCapabilitiesCannotBeRemoved + ClientMissingLegalholdConsentOldClients -> StdError $ errorToWai @'E.MissingLegalholdConsentOldClients + ClientMissingLegalholdConsent -> StdError $ errorToWai @'E.MissingLegalholdConsent + ClientCodeAuthenticationFailed -> StdError $ verificationCodeAuthFailed + ClientCodeAuthenticationRequired -> StdError $ verificationCodeRequired + +clientDataErrorToHttpError :: ClientDataError -> HttpError +clientDataErrorToHttpError = \case + TooManyClients -> StdError (errorToWai @'E.TooManyClients) + (ClientReAuthError e) -> reauthError e + ClientMissingAuth -> StdError (errorToWai @'E.MissingAuth) + MalformedPrekeys -> StdError (errorToWai @'E.MalformedPrekeys) + MLSPublicKeyDuplicate -> StdError (errorToWai @'E.MLSDuplicatePublicKey) + KeyPackageDecodingError -> StdError (errorToWai @'E.KeyPackageDecodingError) + InvalidKeyPackageRef -> StdError (errorToWai @'E.InvalidKeyPackageRef) + MLSNotEnabled -> StdError (errorToWai @'E.MLSNotEnabled) + +can'tDeleteLegalHoldClient :: Wai.Error +can'tDeleteLegalHoldClient = + Wai.mkError + status400 + "client-error" + "LegalHold clients cannot be deleted. LegalHold must be disabled on this user by an admin" + +can'tAddLegalHoldClient :: Wai.Error +can'tAddLegalHoldClient = + Wai.mkError + status400 + "client-error" + "LegalHold clients cannot be added manually. LegalHold must be enabled on this user by an admin" + +clientCapabilitiesCannotBeRemoved :: Wai.Error +clientCapabilitiesCannotBeRemoved = Wai.mkError status409 "client-capabilities-cannot-be-removed" "You can only add capabilities to a client, not remove them." diff --git a/libs/wire-subsystems/src/Wire/ClientSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/ClientSubsystem/Interpreter.hs index 2278119b32e..79ea965c8f6 100644 --- a/libs/wire-subsystems/src/Wire/ClientSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/ClientSubsystem/Interpreter.hs @@ -1,16 +1,683 @@ -module Wire.ClientSubsystem.Interpreter (runClientSubsystem) where +module Wire.ClientSubsystem.Interpreter + ( runClientSubsystem, + ClientError (..), + ClientDataError (..), + ClientSubsystemConfig (..), + ) +where +import Control.Monad +import Data.Bifunctor +import Data.ByteString.Conversion +import Data.Default +import Data.Domain import Data.Id +import Data.Json.Util (ToJSONObject (..), toUTCTimeMillis) +import Data.List.Extra (chunksOf) +import Data.Map qualified as Map +import Data.Misc +import Data.Qualified +import Data.Set ((\\)) +import Data.Set qualified as Set import Data.Time.Clock -import Imports +import Imports hiding ((\\)) import Polysemy -import Wire.ClientStore (ClientStore) +import Polysemy.Error +import Polysemy.Input +import Polysemy.TinyLog (TinyLog) +import System.Logger.Message +import Wire.API.Federation.API +import Wire.API.Federation.API.Brig as FederatedBrig +import Wire.API.Federation.Error +import Wire.API.Push.V2 qualified as V2 +import Wire.API.Team.LegalHold +import Wire.API.Team.LegalHold.Internal +import Wire.API.User as User +import Wire.API.User.Client hiding (UpdateClient) +import Wire.API.User.Client qualified as Data +import Wire.API.User.Client.Prekey +import Wire.API.UserEvent +import Wire.API.UserMap +import Wire.AuthenticationSubsystem (AuthenticationSubsystem) +import Wire.AuthenticationSubsystem qualified as Authentication +import Wire.AuthenticationSubsystem.Error +import Wire.ClientStore (ClientStore, DuplicateMLSPublicKey (..)) import Wire.ClientStore qualified as ClientStore -import Wire.ClientSubsystem +import Wire.ClientSubsystem (ClientSubsystem (..), ReAuthPolicy (..)) +import Wire.ClientSubsystem.Error +import Wire.DeleteQueue (DeleteQueue) +import Wire.DeleteQueue qualified as DeleteQueue +import Wire.EmailSubsystem (EmailSubsystem) +import Wire.EmailSubsystem qualified as Email +import Wire.Events as Events +import Wire.FederationAPIAccess +import Wire.GalleyAPIAccess as GalleyAPIAccess +import Wire.NotificationSubsystem +import Wire.Sem.Concurrency +import Wire.Sem.Logger qualified as Log +import Wire.Sem.Now qualified as Now +import Wire.UserSubsystem (UserSubsystem) +import Wire.UserSubsystem qualified as UserSubsystem +import Wire.Util -runClientSubsystem :: (Member ClientStore r) => InterpreterFor ClientSubsystem r -runClientSubsystem = interpret $ \case - InternalGetActivityTimestamps uid -> internalGetActivityTimestampsImpl uid +data ClientSubsystemConfig = ClientSubsystemConfig + { userMaxPermClients :: Int, + consumableNotificationsEnabled :: Bool + } -internalGetActivityTimestampsImpl :: (Member ClientStore r) => UserId -> Sem r [Maybe UTCTime] -internalGetActivityTimestampsImpl = ClientStore.getActivityTimestamps +runClientSubsystem :: + ( Member ClientStore r, + Member (Input (Local ())) r, + Member TinyLog r, + HasBrigFederationAccess m r, + Member (Error ClientError) r, + Member Now.Now r, + Member NotificationSubsystem r, + Member GalleyAPIAccess r, + Member Events r, + Member EmailSubsystem r, + Member DeleteQueue r, + Member (Input ClientSubsystemConfig) r, + Member (Error FederationError) r, + Member (Concurrency 'Unsafe) r + ) => + InterpreterFor AuthenticationSubsystem (UserSubsystem ': r) -> + InterpreterFor UserSubsystem r -> + InterpreterFor ClientSubsystem r +runClientSubsystem runAuth runUser = + interpret $ + runUser . runAuth . \case + InternalGetActivityTimestamps uid -> internalGetActivityTimestamps uid + LookupLocalClient uid cid -> lookupLocalClient uid cid + LookupLocalClients uid -> lookupLocalClients uid + LookupLocalPublicClientsBulk uids -> lookupLocalPublicClientsBulk uids + LookupPublicClient quid cid -> lookupPubClient quid cid + LookupPublicClients quid -> lookupPubClients quid + LookupPublicClientsBulk quids -> lookupPubClientsBulk quids + AddClient luid conn new -> addClient def luid conn new + AddClientWithPolicy policy luid conn new -> addClient policy luid conn new + UpsertClient luid client new capabilities -> mapError ClientDataError $ upsertClient def luid client new capabilities + OnClientEvent uid con event -> onClientEvent uid con event + EnqueueClientDeletion uid con client -> execDelete uid con client + RemoveClient uid conn cid mPwd -> rmClient uid conn cid mPwd + RemoveLegalHoldClient uid -> removeLegalHoldClient uid + PublishLegalHoldClientRequested uid req -> publishLegalHoldClientRequested uid req + UpdateClient uid cid payload -> updateClient uid cid payload + ClaimPrekey protectee uid domain cid -> claimPrekey protectee uid domain cid + ClaimLocalPrekey protectee uid cid -> claimLocalPrekey protectee uid cid + ClaimPrekeyBundle protectee domain uid -> claimPrekeyBundle protectee domain uid + ClaimLocalPrekeyBundle protectee uid -> claimLocalPrekeyBundle protectee uid + ClaimMultiPrekeyBundlesV3 protectee qucs -> claimMultiPrekeyBundlesV3 protectee qucs + ClaimMultiPrekeyBundles protectee qucs -> claimMultiPrekeyBundles protectee qucs + ClaimLocalMultiPrekeyBundles protectee ucs -> claimLocalMultiPrekeyBundles protectee ucs + +-- nb. We must ensure that the set of clients known to brig is always +-- a superset of the clients known to galley. +addClient :: + ( Member UserSubsystem r, + Member (Error ClientError) r, + Member ClientStore r, + Member Now.Now r, + Member AuthenticationSubsystem r, + Member NotificationSubsystem r, + Member GalleyAPIAccess r, + Member Events r, + Member EmailSubsystem r, + Member DeleteQueue r, + Member (Input ClientSubsystemConfig) r + ) => + ReAuthPolicy -> + Local UserId -> + Maybe ConnId -> + NewClient -> + Sem r Client +addClient policy luid@(tUnqualified -> uid) con new = do + conf <- input + usr <- UserSubsystem.getAccountNoFilter luid >>= maybe (throw (ClientUserNotFound uid)) pure + verifyCode (newClientVerificationCode new) + let mCapabilities :: Maybe ClientCapabilityList + mCapabilities = updateLhDevice $ newClientCapabilities new + where + updateLhDevice :: Maybe ClientCapabilityList -> Maybe ClientCapabilityList + updateLhDevice = + if newClientType new == LegalHoldClientType + then Just . ClientCapabilityList . maybe (Set.singleton implicitConsent) (Set.insert implicitConsent . fromClientCapabilityList) + else id + implicitConsent = ClientSupportsLegalholdImplicitConsent + (client0, old, count) <- mapError ClientDataError (upsertClient policy luid clientId new mCapabilities) + let client = client0 {clientMLSPublicKeys = newClientMLSPublicKeys new} + when (conf.consumableNotificationsEnabled && supportsConsumableNotifications client) $ + setupConsumableNotifications uid client.clientId + for_ old $ execDelete uid con + GalleyAPIAccess.newClient uid client.clientId + onClientEvent uid con (ClientAdded client) + when (clientType client == LegalHoldClientType) $ Events.generateUserEvent uid con (UserLegalHoldEnabled uid) + when (count > 1) $ + for_ (userEmail usr) $ \email -> + Email.sendNewClientEmail email (userDisplayName usr) client (userLocale usr) + pure client + where + clientId = clientIdFromPrekey (unpackLastPrekey $ newClientLastKey new) + + verifyCode mbCode = + -- this only happens inside the login flow (in particular, when logging in from a new device) + -- the code obtained for logging in is used a second time for adding the device + Authentication.enforceVerificationCodeEither luid mbCode User.Login >>= \case + Left VerificationCodeRequired -> throw ClientCodeAuthenticationRequired + Left VerificationCodeNoPendingCode -> throw ClientCodeAuthenticationFailed + Left VerificationCodeNoEmail -> throw ClientCodeAuthenticationFailed + Right () -> pure () + +upsertClient :: + forall r. + ( Member AuthenticationSubsystem r, + Member ClientStore r, + Member Now.Now r, + Member (Error ClientDataError) r, + Member (Input ClientSubsystemConfig) r + ) => + ReAuthPolicy -> + Local UserId -> + ClientId -> + NewClient -> + Maybe ClientCapabilityList -> + Sem r (Client, [Client], Word) +upsertClient (ReAuthPolicy reAuthPolicy) u newId c caps = do + conf <- input + clients <- ClientStore.lookupClients (tUnqualified u) + let typed = filter ((== newClientType c) . clientType) clients + count = length typed + upsert = any exists typed + when (reAuthPolicy count upsert) do + (Authentication.reauthenticateEither (tUnqualified u) (newClientPassword c)) + >>= either (throw . ClientReAuthError) pure + let capacity = fmap (+ (-count)) (limit conf) + unless (maybe True (> 0) capacity || upsert) $ throw TooManyClients + new <- insert (tUnqualified u) + let !total = fromIntegral (length clients + if upsert then 0 else 1) + old = maybe (filter (not . exists) typed) (const []) (limit conf) + pure (new, old, total) + where + limit :: ClientSubsystemConfig -> Maybe Int + limit conf = case newClientType c of + PermanentClientType -> Just conf.userMaxPermClients + TemporaryClientType -> Nothing + LegalHoldClientType -> Nothing + + exists :: Client -> Bool + exists = (==) newId . (.clientId) + + insert uid = do + now <- toUTCTimeMillis <$> Now.get + let prekeys = unpackLastPrekey (newClientLastKey c) : newClientPrekeys c + unless (all checkPrekeyBundle prekeys) $ + throw MalformedPrekeys + mErr <- ClientStore.upsert uid newId now (c {newClientCapabilities = caps}) + case mErr of + Just DuplicateMLSPublicKey -> throw MLSPublicKeyDuplicate + Nothing -> + pure $! + Client + { clientId = newId, + clientType = newClientType c, + clientTime = now, + clientClass = newClientClass c, + clientLabel = newClientLabel c, + clientCookie = newClientCookie c, + clientModel = newClientModel c, + clientCapabilities = fromMaybe mempty caps, + clientMLSPublicKeys = mempty, + clientLastActive = Nothing + } + +internalGetActivityTimestamps :: (Member ClientStore r) => UserId -> Sem r [Maybe UTCTime] +internalGetActivityTimestamps = ClientStore.getActivityTimestamps + +lookupLocalClient :: (Member ClientStore r) => UserId -> ClientId -> Sem r (Maybe Client) +lookupLocalClient uid = ClientStore.lookupClient uid + +lookupLocalClients :: (Member ClientStore r) => UserId -> Sem r [Client] +lookupLocalClients = ClientStore.lookupClients + +lookupPubClient :: + ( Member ClientStore r, + Member (Input (Local ())) r, + Member TinyLog r, + HasBrigFederationAccess m r + ) => + Qualified UserId -> ClientId -> Sem r (Maybe PubClient) +lookupPubClient qid cid = do + clients <- lookupPubClients qid + pure $ find ((== cid) . pubClientId) clients + +lookupPubClients :: + ( Member ClientStore r, + Member (Input (Local ())) r, + Member TinyLog r, + HasBrigFederationAccess m r + ) => + Qualified UserId -> Sem r [PubClient] +lookupPubClients qid@(Qualified uid domain) = do + getForUser <$> lookupPubClientsBulk [qid] + where + getForUser :: QualifiedUserMap (Set PubClient) -> [PubClient] + getForUser qmap = fromMaybe [] $ do + um <- userMap <$> Map.lookup domain (qualifiedUserMap qmap) + Set.toList <$> Map.lookup uid um + +lookupPubClientsBulk :: + ( Member ClientStore r, + Member (Input (Local ())) r, + Member TinyLog r, + HasBrigFederationAccess m r + ) => + [Qualified UserId] -> Sem r (QualifiedUserMap (Set PubClient)) +lookupPubClientsBulk qualifiedUids = do + loc <- qualifyLocal () + let (localUsers, remoteUsers) = partitionQualified loc qualifiedUids + remoteUserClientMap <- getRemoteClients $ indexQualified (fmap tUntagged remoteUsers) + localUserClientMap <- Map.singleton (tDomain loc) <$> ClientStore.lookupPubClientsBulk localUsers + pure $ QualifiedUserMap (Map.union localUserClientMap remoteUserClientMap) + where + getRemoteClients uids = do + results <- + traverse + (\(d, ids) -> mapLeft (const d) . fmap (d,) <$> (getFederatedUserClients d (GetUserClients ids))) + (Map.toList uids) + forM_ (lefts results) $ \d -> + Log.warn $ + field "remote_domain" (domainText d) + ~~ msg (val "Failed to fetch clients for domain") + pure $ Map.fromList (rights results) + +lookupLocalPublicClientsBulk :: (Member ClientStore r) => [UserId] -> Sem r (UserMap (Set PubClient)) +lookupLocalPublicClientsBulk = ClientStore.lookupPubClientsBulk + +getFederatedUserClients :: + ( Member TinyLog r, + HasBrigFederationAccess m r + ) => + Domain -> + GetUserClients -> + Sem r (Either FederationError (UserMap (Set PubClient))) +getFederatedUserClients domain guc = do + Log.info $ msg @Text "Brig-federation: get users' clients from remote backend" + runFederatedEither (toRemoteUnsafe domain ()) $ fedClient @'Brig @"get-user-clients" guc + +onClientEvent :: + (Member NotificationSubsystem r) => + -- | Originator of the event. + UserId -> + -- | Client connection ID. + Maybe ConnId -> + -- | The event. + ClientEvent -> + Sem r () +onClientEvent orig conn e = do + let event = ClientEvent e + let rcpt = Recipient orig V2.RecipientClientsAll + pushNotifications + [ def + { origin = Just orig, + json = toJSONObject event, + recipients = [rcpt], + conn, + apsData = toApsData event + } + ] + +-- | Enqueue an orderly deletion of an existing client. +execDelete :: + ( Member DeleteQueue r, + Member AuthenticationSubsystem r, + Member ClientStore r + ) => + UserId -> + Maybe ConnId -> + Client -> + Sem r () +execDelete u con c = do + for_ (clientCookie c) $ \l -> Authentication.revokeCookies u [] [l] + DeleteQueue.enqueueClientDeletion c.clientId u con + ClientStore.delete u c.clientId + +-- nb. We must ensure that the set of clients known to brig is always +-- a superset of the clients known to galley. +rmClient :: + ( Member AuthenticationSubsystem r, + Member ClientStore r, + Member (Error ClientError) r, + Member DeleteQueue r + ) => + UserId -> + ConnId -> + ClientId -> + Maybe PlainTextPassword6 -> + Sem r () +rmClient u con clt pw = + maybe (throw ClientNotFound) fn =<< ClientStore.lookupClient u clt + where + fn client = do + case clientType client of + -- Legal hold clients can't be removed + LegalHoldClientType -> throw ClientLegalHoldCannotBeRemoved + -- Temporary clients don't need to re-auth + TemporaryClientType -> pure () + -- All other clients must authenticate + _ -> + (Authentication.reauthenticateEither u pw) + >>= either (throw . ClientDataError . ClientReAuthError) (const $ pure ()) + execDelete u (Just con) client + +removeLegalHoldClient :: + ( Member Events r, + Member ClientStore r, + Member DeleteQueue r, + Member AuthenticationSubsystem r + ) => + UserId -> + Sem r () +removeLegalHoldClient uid = do + clients <- ClientStore.lookupClients uid + -- Should only be one; but just in case we'll treat it as a list + let legalHoldClients = filter ((== LegalHoldClientType) . clientType) clients + -- maybe log if this isn't the case + forM_ legalHoldClients (execDelete uid Nothing) + Events.generateUserEvent uid Nothing (UserLegalHoldDisabled uid) + +publishLegalHoldClientRequested :: (Member Events r) => UserId -> LegalHoldClientRequest -> Sem r () +publishLegalHoldClientRequested targetUser (LegalHoldClientRequest _requester lastPrekey') = + Events.generateUserEvent targetUser Nothing lhClientEvent + where + clientId :: ClientId + clientId = clientIdFromPrekey $ unpackLastPrekey lastPrekey' + + eventData :: LegalHoldClientRequestedData + eventData = LegalHoldClientRequestedData targetUser lastPrekey' clientId + + lhClientEvent :: UserEvent + lhClientEvent = LegalHoldClientRequested eventData + +updateClient :: + ( Member NotificationSubsystem r, + Member ClientStore r, + Member (Error ClientError) r, + Member (Input ClientSubsystemConfig) r + ) => + UserId -> + ClientId -> + Data.UpdateClient -> + Sem r () +updateClient uid cid req = do + conf <- input + client <- ClientStore.lookupClient uid cid >>= maybe (throw ClientNotFound) pure + for_ req.updateClientLabel $ ClientStore.updateLabel uid cid . Just + for_ req.updateClientCapabilities $ \caps -> do + if client.clientCapabilities.fromClientCapabilityList `Set.isSubsetOf` caps.fromClientCapabilityList + then do + -- first set up the notification queues then save the data is more robust than the other way around + let addedCapabilities = caps.fromClientCapabilityList \\ client.clientCapabilities.fromClientCapabilityList + when (conf.consumableNotificationsEnabled && ClientSupportsConsumableNotifications `Set.member` addedCapabilities) $ do + setupConsumableNotifications uid cid + ClientStore.updateCapabilities uid cid . Just $ caps + else throw ClientCapabilitiesCannotBeRemoved + let lk = maybeToList (unpackLastPrekey <$> req.updateClientLastKey) + prekeys = lk ++ req.updateClientPrekeys + unless (all checkPrekeyBundle prekeys) $ throw (ClientDataError MalformedPrekeys) + ClientStore.updatePrekeys uid cid prekeys + mErr <- ClientStore.addMLSPublicKeys uid cid (Map.assocs req.updateClientMLSPublicKeys) + case mErr of + Just DuplicateMLSPublicKey -> throw (ClientDataError MLSPublicKeyDuplicate) + Nothing -> pure () + +--------------------------------------------------------------------------------------- +-- Prekeys + +claimPrekey :: + ( Member (Input (Local ())) r, + Member TinyLog r, + Member ClientStore r, + Member DeleteQueue r, + Member AuthenticationSubsystem r, + Member GalleyAPIAccess r, + HasBrigFederationAccess m r, + Member (Error FederationError) r + ) => + LegalholdProtectee -> + UserId -> + Domain -> + ClientId -> + Sem r (Maybe ClientPrekey) +claimPrekey protectee uid domain cid = do + isDomainLocal <- isLocalDomain domain + if isDomainLocal + then claimLocalPrekey protectee uid cid + else claimRemotePrekey (Qualified uid domain) cid + +claimLocalPrekey :: + ( Member ClientStore r, + Member TinyLog r, + Member DeleteQueue r, + Member AuthenticationSubsystem r, + Member GalleyAPIAccess r + ) => + LegalholdProtectee -> + UserId -> + ClientId -> + Sem r (Maybe ClientPrekey) +claimLocalPrekey protectee user client = do + GalleyAPIAccess.guardLegalHold protectee (mkUserClients [(user, [client])]) + prekey <- ClientStore.claimPrekey user client + when (isNothing prekey) (noPrekeys user client) + pure prekey + +claimRemotePrekey :: + ( Member TinyLog r, + HasBrigFederationAccess m r, + Member (Error FederationError) r + ) => + Qualified UserId -> + ClientId -> + Sem r (Maybe ClientPrekey) +claimRemotePrekey (Qualified user domain) client = do + Log.info $ msg @Text "Brig-federation: claiming remote prekey" + runFederated (toRemoteUnsafe domain ()) $ fedClient @'Brig @"claim-prekey" (user, client) + +claimPrekeyBundle :: + ( Member ClientStore r, + Member TinyLog r, + HasBrigFederationAccess m r, + Member GalleyAPIAccess r, + Member (Input (Local ())) r, + Member (Error ClientError) r + ) => + LegalholdProtectee -> Domain -> UserId -> Sem r PrekeyBundle +claimPrekeyBundle protectee domain uid = do + isDomainLocal <- isLocalDomain domain + if isDomainLocal + then claimLocalPrekeyBundle protectee uid + else claimRemotePrekeyBundle (Qualified uid domain) + +claimLocalPrekeyBundle :: (Member ClientStore r, Member GalleyAPIAccess r) => LegalholdProtectee -> UserId -> Sem r PrekeyBundle +claimLocalPrekeyBundle protectee u = do + clients <- map (.clientId) <$> ClientStore.lookupClients u + GalleyAPIAccess.guardLegalHold protectee (mkUserClients [(u, clients)]) + PrekeyBundle u . catMaybes <$> mapM (ClientStore.claimPrekey u) clients + +claimRemotePrekeyBundle :: + ( Member TinyLog r, + HasBrigFederationAccess m r, + Member (Error ClientError) r + ) => + Qualified UserId -> + Sem r PrekeyBundle +claimRemotePrekeyBundle (Qualified user domain) = do + Log.info $ msg @Text "Brig-federation: claiming remote prekey bundle" + mapError ClientFederationError $ runFederated (toRemoteUnsafe domain ()) $ fedClient @'Brig @"claim-prekey-bundle" user + +claimMultiPrekeyBundlesInternal :: + forall r. + ( Member (Concurrency 'Unsafe) r, + Member ClientStore r, + Member (Input (Local ())) r, + Member GalleyAPIAccess r, + Member TinyLog r, + Member DeleteQueue r, + Member AuthenticationSubsystem r + ) => + LegalholdProtectee -> + QualifiedUserClients -> + Sem r ([Qualified UserClientPrekeyMap], [Remote UserClients]) +claimMultiPrekeyBundlesInternal protectee quc = do + loc <- qualifyLocal () + let (locals, remotes) = + partitionQualifiedAndTag + loc + ( map + (fmap UserClients . uncurry (flip Qualified)) + (Map.assocs (qualifiedUserClients quc)) + ) + localPrekeys <- traverse claimLocal locals + pure (localPrekeys, remotes) + where + claimLocal :: + Local UserClients -> + Sem r (Qualified UserClientPrekeyMap) + claimLocal luc = + tUntagged . qualifyAs luc + <$> claimLocalMultiPrekeyBundles protectee (tUnqualified luc) + +claimMultiPrekeyBundlesV3 :: + forall r m. + ( Member (Concurrency 'Unsafe) r, + Member ClientStore r, + Member GalleyAPIAccess r, + Member TinyLog r, + HasBrigFederationAccess m r, + Member (Input (Local ())) r, + Member AuthenticationSubsystem r, + Member DeleteQueue r, + Member (Error FederationError) r + ) => + LegalholdProtectee -> + QualifiedUserClients -> + Sem r QualifiedUserClientPrekeyMap +claimMultiPrekeyBundlesV3 protectee quc = do + (localPrekeys, remotes) <- claimMultiPrekeyBundlesInternal protectee quc + Log.info $ msg @Text "Brig-federation: claiming remote multi-user prekey bundle" + remotePrekeys :: [Remote UserClientPrekeyMap] <- runFederatedConcurrently remotes $ \rucs -> fedClient @'Brig @"claim-multi-prekey-bundle" (mconcat $ tUnqualified rucs) + pure . qualifiedUserClientPrekeyMapFromList $ localPrekeys <> (fmap tUntagged remotePrekeys) + +-- Similar to claimMultiPrekeyBundles except for the following changes +-- 1) A new return type that contains both the client map and a list of +-- users that prekeys couldn't be fetched for. +-- 2) A semantic change on federation errors when gathering remote clients. +-- Remote federation errors at this step no-longer cause the entire call +-- to fail, allowing partial results to be returned. +claimMultiPrekeyBundles :: + forall r m. + ( Member (Concurrency 'Unsafe) r, + Member ClientStore r, + Member GalleyAPIAccess r, + Member TinyLog r, + HasBrigFederationAccess m r, + Member (Input (Local ())) r, + Member AuthenticationSubsystem r, + Member DeleteQueue r + ) => + LegalholdProtectee -> + QualifiedUserClients -> + Sem r QualifiedUserClientPrekeyMapV4 +claimMultiPrekeyBundles protectee quc = do + (localPrekeys, remotes) <- claimMultiPrekeyBundlesInternal protectee quc + Log.info $ msg @Text "Brig-federation: claiming remote multi-user prekey bundle" + remotePrekeys <- + fmap (fmap (bimap (first collapseRemoteUsers) tUntagged)) $ + runFederatedConcurrentlyEither remotes $ \rucs -> + fedClient @'Brig @"claim-multi-prekey-bundle" (mconcat $ tUnqualified rucs) + let prekeys = + getQualifiedUserClientPrekeyMap $ + qualifiedUserClientPrekeyMapFromList $ + localPrekeys <> rights remotePrekeys + failed = lefts remotePrekeys >>= toQualifiedUser . fst + pure $ + QualifiedUserClientPrekeyMapV4 prekeys $ + if null failed + then Nothing + else pure failed + where + toQualifiedUser :: Remote UserClients -> [Qualified UserId] + toQualifiedUser r = fmap (\u -> Qualified u $ tDomain r) . Map.keys . userClients . qUnqualified $ tUntagged r + + collapseRemoteUsers :: Remote [UserClients] -> Remote UserClients + collapseRemoteUsers rucs = toRemoteUnsafe (tDomain rucs) (mconcat $ tUnqualified rucs) + +claimLocalMultiPrekeyBundles :: + forall r. + ( Member (Concurrency 'Unsafe) r, + Member ClientStore r, + Member GalleyAPIAccess r, + Member TinyLog r, + Member DeleteQueue r, + Member AuthenticationSubsystem r + ) => + LegalholdProtectee -> + UserClients -> + Sem r UserClientPrekeyMap +claimLocalMultiPrekeyBundles protectee ucs = do + GalleyAPIAccess.guardLegalHold protectee ucs + fmap mkUserClientPrekeyMap + . foldMap (getChunk . Map.fromList) + . chunksOf 16 + . Map.toList + . userClients + $ ucs + where + getChunk :: Map UserId (Set ClientId) -> Sem r (Map UserId (Map ClientId (Maybe UncheckedPrekeyBundle))) + getChunk m = + Map.fromListWith (<>) + <$> unsafePooledMapConcurrentlyN + 16 + (\(u, cids) -> (u,) <$> getUserKeys u cids) + (Map.toList m) + + getUserKeys :: UserId -> Set ClientId -> Sem r (Map ClientId (Maybe UncheckedPrekeyBundle)) + getUserKeys u = + sequenceA . Map.fromSet (getClientKeys u) + + getClientKeys :: UserId -> ClientId -> Sem r (Maybe UncheckedPrekeyBundle) + getClientKeys u c = do + key <- fmap prekeyData <$> ClientStore.claimPrekey u c + when (isNothing key) $ noPrekeys u c + pure key + +-- Utilities + +-- | Defensive measure when no prekey is found for a +-- requested client: Ensure that the client does indeed +-- not exist, since there must be no client without prekeys, +-- thus repairing any inconsistencies related to distributed +-- (and possibly duplicated) client data. +noPrekeys :: + ( Member ClientStore r, + Member TinyLog r, + Member DeleteQueue r, + Member AuthenticationSubsystem r + ) => + UserId -> + ClientId -> + Sem r () +noPrekeys uid cid = do + mclient <- ClientStore.lookupClient uid cid + case mclient of + Nothing -> do + Log.warn $ + field "user" (toByteString uid) + ~~ field "client" (toByteString cid) + ~~ msg (val "No prekey found. Client is missing, so doing nothing.") + Just client -> do + Log.warn $ + field "user" (toByteString uid) + ~~ field "client" (toByteString cid) + ~~ msg (val "No prekey found. Deleting client.") + execDelete uid Nothing client diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Util.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Util.hs index 1d044ab5f2e..16f70e955ca 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Util.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Util.hs @@ -106,7 +106,7 @@ ensureAccessRole :: Member (ErrorS 'ConvAccessDenied) r ) => Set Public.AccessRole -> - [(UserId, Maybe TeamMember)] -> + [(UserId, Maybe TeamMember {- isJust iff user and conv are in the same team -})] -> Sem r () ensureAccessRole roles users = do when (Set.null roles) $ throwS @'ConvAccessDenied @@ -785,12 +785,6 @@ ensureLocal loc = foldQualified loc pure (\_ -> throw FederationNotImplemented) -------------------------------------------------------------------------------- -- Federation -qualifyLocal :: (Member (Input (Local ())) r) => a -> Sem r (Local a) -qualifyLocal a = toLocalUnsafe <$> fmap getDomain input <*> pure a - where - getDomain :: Local () -> Domain - getDomain = tDomain - runLocalInput :: Local x -> Sem (Input (Local ()) ': r) a -> Sem r a runLocalInput = runInputConst . void diff --git a/libs/wire-subsystems/src/Wire/FederationAPIAccess.hs b/libs/wire-subsystems/src/Wire/FederationAPIAccess.hs index 4d457295ec5..6476cc08de5 100644 --- a/libs/wire-subsystems/src/Wire/FederationAPIAccess.hs +++ b/libs/wire-subsystems/src/Wire/FederationAPIAccess.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TemplateHaskell #-} -- This file is part of the Wire Server implementation. @@ -17,16 +18,31 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Wire.FederationAPIAccess where +module Wire.FederationAPIAccess + ( module Wire.FederationAPIAccess, + FederationMonad, + Component (..), + RunClient, + ) +where import Data.Kind import Data.Qualified import Imports import Polysemy import Polysemy.Error +import Servant.Client.Core.RunClient (RunClient) +import Wire.API.Federation.API import Wire.API.Federation.Component import Wire.API.Federation.Error +type HasBrigFederationAccess m r = + ( Member (FederationAPIAccess m) r, + RunClient (m 'Brig), + FederationMonad m, + Typeable m + ) + data FederationAPIAccess (fedM :: Component -> Type -> Type) m a where RunFederatedEither :: (KnownComponent c) => diff --git a/libs/wire-subsystems/src/Wire/GalleyAPIAccess.hs b/libs/wire-subsystems/src/Wire/GalleyAPIAccess.hs index 37e2e0ebacc..f70fa3addf8 100644 --- a/libs/wire-subsystems/src/Wire/GalleyAPIAccess.hs +++ b/libs/wire-subsystems/src/Wire/GalleyAPIAccess.hs @@ -40,6 +40,7 @@ import Wire.API.Team.Member qualified as Team import Wire.API.Team.Member.Info qualified as Team import Wire.API.Team.Role import Wire.API.Team.SearchVisibility +import Wire.API.User.Client (UserClients) data ShowOrHideInvitationUrl = ShowInvitationUrl | HideInvitationUrl deriving (Eq, Show) @@ -164,5 +165,6 @@ data GalleyAPIAccess m a where GalleyAPIAccess m (Maybe Team.TeamMemberList) GetConversationConfig :: GalleyAPIAccess m ConversationSubsystemConfig + GuardLegalHold :: LegalholdProtectee -> UserClients -> GalleyAPIAccess m () makeSem ''GalleyAPIAccess diff --git a/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs b/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs index 026a5c7b35f..4a01842e676 100644 --- a/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs +++ b/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs @@ -18,7 +18,9 @@ module Wire.GalleyAPIAccess.Rpc where import Bilge hiding (head, options, requestId) +import Control.Lens import Data.Aeson +import Data.Aeson.Lens import Data.ByteString.Conversion import Data.ByteString.Lazy qualified as BL import Data.Coerce (coerce) @@ -43,6 +45,7 @@ import Util.Options import Wire.API.Conversation hiding (Member) import Wire.API.Conversation.Config (ConversationSubsystemConfig) import Wire.API.Routes.Internal.Brig.EJPD (EJPDConvInfo) +import Wire.API.Routes.Internal.Galley.TeamsIntra import Wire.API.Routes.Internal.Galley.TeamsIntra qualified as Team import Wire.API.Routes.Version import Wire.API.Team @@ -55,6 +58,8 @@ import Wire.API.Team.Member.Info import Wire.API.Team.Role import Wire.API.Team.SearchVisibility import Wire.API.User (UserIds (UserIds)) +import Wire.API.User.Client (UserClients) +import Wire.ClientSubsystem.Interpreter (ClientError (..)) import Wire.GalleyAPIAccess (GalleyAPIAccess (..), MLSOneToOneEstablished (..), ShowOrHideInvitationUrl (..)) import Wire.ParseException import Wire.Rpc @@ -62,7 +67,8 @@ import Wire.Rpc interpretGalleyAPIAccessToRpc :: ( Member (Error ParseException) r, Member Rpc r, - Member TinyLog r + Member TinyLog r, + Member (Error ClientError) r ) => Set Version -> Endpoint -> @@ -104,6 +110,7 @@ interpretGalleyAPIAccessToRpc disabledVersions galleyEndpoint = InternalGetConversation id' -> internalGetConversation id' GetTeamContacts uid -> getTeamContacts uid GetConversationConfig -> getConversationConfig + GuardLegalHold protectee userClient -> guardLegalhold protectee userClient getUserLegalholdStatus :: ( Member TinyLog r, @@ -787,6 +794,8 @@ getTeamContacts uid = do where req = method GET + . paths ["i", "users", toByteString' uid, "team", "members"] + . expect [status200, status404] getConversationConfig :: ( Member Rpc r, @@ -802,3 +811,33 @@ getConversationConfig = do . paths ["i", "conversations", "config"] . expect2xx ) + +guardLegalhold :: + ( Member Rpc r, + Member (Input Endpoint) r, + Member (Error ClientError) r, + Member (Error ParseException) r + ) => + LegalholdProtectee -> + UserClients -> + Sem r () +guardLegalhold protectee userClients = do + res <- galleyRequest req + case Bilge.statusCode res of + 200 -> pure () + 403 -> case Bilge.responseJsonMaybe @Value res >>= (^? key "label") of + Just "missing-legalhold-consent" -> throw ClientMissingLegalholdConsent + Just "missing-legalhold-consent-old-clients" -> throw ClientMissingLegalholdConsentOldClients + _ -> + -- only happens if galley misbehaves (fisx: this could also be a parse error if we + -- used a more constraining type to send back & forth between brig and galley, but + -- merging brig and galley would make this train of thought go away more naturally). + throw ClientMissingLegalholdConsent + 404 -> pure () -- allow for galley not to be ready, so the set of valid deployment orders is non-empty. + sc -> throw $ ParseException "galley" ("expected status codes 200, 403, or 404, but got: " <> show sc) + where + req = + method PUT + . paths ["i", "guard-legalhold-policy-conflicts"] + . header "Content-Type" "application/json" + . lbytes (encode $ GuardLegalholdPolicyConflicts protectee userClients) diff --git a/libs/wire-subsystems/src/Wire/IndexedUserStore/ElasticSearch.hs b/libs/wire-subsystems/src/Wire/IndexedUserStore/ElasticSearch.hs index 8d070b05edd..a4a9a903052 100644 --- a/libs/wire-subsystems/src/Wire/IndexedUserStore/ElasticSearch.hs +++ b/libs/wire-subsystems/src/Wire/IndexedUserStore/ElasticSearch.hs @@ -451,7 +451,10 @@ mkUserQuery searcher mSearcherTeamId teamSearchInfo mTypes q = -- be a more readable way to express -- "not(exists(searchable)) or searchable = true" in -- Elastic Search. - [ES.TermQuery (ES.Term "searchable" "false") Nothing], + [ES.TermQuery (ES.Term "searchable" "false") Nothing] + <> + -- Exclude apps from other teams + maybeToList (matchAppsFromOtherTeams mSearcherTeamId), ES.boolQueryMustMatch = [ restrictSearchSpaceByTeam mSearcherTeamId teamSearchInfo, restrictSearchSpaceByUserType mTypes, @@ -488,6 +491,45 @@ termQ f v = matchSelf :: UserId -> Maybe ES.Query matchSelf searcher = Just (termQ "_id" (idToText searcher)) +-- | Exclude apps from other teams. +-- Apps should only be searchable within their own team. +matchAppsFromOtherTeams :: Maybe TeamId -> Maybe ES.Query +matchAppsFromOtherTeams mSearcherTeamId = + Just $ + ES.QueryBoolQuery + boolQuery + { ES.boolQueryMustMatch = + [ -- Match apps (type = "app") + termQ "type" "app", + -- That are from a different team than the searcher + case mSearcherTeamId of + -- If searcher has no team, exclude all apps + Nothing -> + ES.QueryExistsQuery (ES.FieldName "team") + -- If searcher has a team, exclude apps from other teams or with no team + Just searcherTeam -> + ES.QueryBoolQuery + boolQuery + { ES.boolQueryShouldMatch = + [ -- Apps with no team + ES.QueryBoolQuery + boolQuery + { ES.boolQueryMustNotMatch = + [ES.QueryExistsQuery (ES.FieldName "team")] + }, + -- Apps from a different team + ES.QueryBoolQuery + boolQuery + { ES.boolQueryMustMatch = + [ES.QueryExistsQuery (ES.FieldName "team")], + ES.boolQueryMustNotMatch = + [termQ "team" (idToText searcherTeam)] + } + ] + } + ] + } + -- | See 'TeamSearchInfo' restrictSearchSpaceByTeam :: Maybe TeamId -> TeamSearchInfo -> ES.Query -- diff --git a/libs/wire-subsystems/src/Wire/NotificationSubsystem.hs b/libs/wire-subsystems/src/Wire/NotificationSubsystem.hs index 9084d564986..de3d526028c 100644 --- a/libs/wire-subsystems/src/Wire/NotificationSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/NotificationSubsystem.hs @@ -71,7 +71,7 @@ data Push = Push apsData :: Maybe ApsData, isCellsEvent :: Bool } - deriving stock (Eq, Generic, Show) + deriving stock (Eq, Generic, Show, Ord) deriving (Arbitrary) via GenericUniform Push data LocalConversationUpdate = LocalConversationUpdate diff --git a/services/galley/src/Galley/Options.hs b/libs/wire-subsystems/src/Wire/Options/Galley.hs similarity index 99% rename from services/galley/src/Galley/Options.hs rename to libs/wire-subsystems/src/Wire/Options/Galley.hs index 4af6462a1a3..8383ee97e4f 100644 --- a/services/galley/src/Galley/Options.hs +++ b/libs/wire-subsystems/src/Wire/Options/Galley.hs @@ -17,7 +17,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.Options +module Wire.Options.Galley ( Settings (..), httpPoolSize, maxTeamSize, @@ -76,7 +76,6 @@ import Data.Domain (Domain) import Data.Id (TeamId) import Data.Misc import Data.Range -import Galley.Keys import Hasql.Pool.Extended import Imports import Network.AMQP.Extended @@ -87,6 +86,7 @@ import Wire.API.Conversation.Protocol import Wire.API.Routes.Version import Wire.API.Team.FeatureFlags import Wire.API.Team.Member +import Wire.Options.Keys import Wire.PostgresMigrationOpts import Wire.RateLimit.Interpreter (RateLimitConfig) diff --git a/services/galley/src/Galley/Keys.hs b/libs/wire-subsystems/src/Wire/Options/Keys.hs similarity index 99% rename from services/galley/src/Galley/Keys.hs rename to libs/wire-subsystems/src/Wire/Options/Keys.hs index e11faa1454a..53d3057ef78 100644 --- a/services/galley/src/Galley/Keys.hs +++ b/libs/wire-subsystems/src/Wire/Options/Keys.hs @@ -16,7 +16,7 @@ -- with this program. If not, see . -- | Handling of MLS private keys used for signing external proposals. -module Galley.Keys +module Wire.Options.Keys ( MLSPrivateKeyPaths, loadAllMLSKeys, ) diff --git a/libs/wire-subsystems/src/Wire/StoredUser.hs b/libs/wire-subsystems/src/Wire/StoredUser.hs index eec62c97a97..7aec8368fbe 100644 --- a/libs/wire-subsystems/src/Wire/StoredUser.hs +++ b/libs/wire-subsystems/src/Wire/StoredUser.hs @@ -62,7 +62,20 @@ data StoredUser = StoredUser searchable :: Maybe Bool } deriving (Show, Eq, Ord, Generic) - deriving (Arbitrary) via (GenericUniform StoredUser) + +instance Arbitrary StoredUser where + arbitrary = do + GenericUniform u <- arbitrary @(GenericUniform StoredUser) + -- Ensure users are never bots and don't have service IDs + let userType' = case u.userType of + Just UserTypeBot -> Nothing -- Will be inferred as Regular + other -> other + pure $ + u + { userType = userType', + serviceId = Nothing, + providerId = Nothing + } recordInstance ''StoredUser diff --git a/libs/wire-subsystems/src/Wire/UserGroupSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserGroupSubsystem/Interpreter.hs index 20b9ea71d94..7e6b9ba959b 100644 --- a/libs/wire-subsystems/src/Wire/UserGroupSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserGroupSubsystem/Interpreter.hs @@ -31,7 +31,7 @@ import Data.Vector qualified as V import Imports import Polysemy import Polysemy.Error -import Polysemy.Input (Input, input) +import Polysemy.Input (Input) import Wire.API.BackgroundJobs import Wire.API.Conversation qualified as Conversation import Wire.API.Error @@ -54,6 +54,7 @@ import Wire.TeamSubsystem import Wire.UserGroupStore qualified as Store import Wire.UserGroupSubsystem (UserGroupSubsystem (..)) import Wire.UserSubsystem (UserSubsystem, getLocalUserProfiles, getUserTeam) +import Wire.Util interpretUserGroupSubsystem :: ( Member Random.Random r, @@ -199,11 +200,6 @@ mmkEvent mAuthor evt recipients = mkEvent :: UserId -> UserGroupEvent -> [UserId] -> Push mkEvent = mmkEvent . Just -qualifyLocal :: (Member (Input (Local ())) r) => a -> Sem r (Local a) -qualifyLocal a = do - l <- input - pure $ qualifyAs l a - getUserGroup :: ( Member UserSubsystem r, Member Store.UserGroupStore r, diff --git a/libs/wire-subsystems/src/Wire/UserStore/IndexUser.hs b/libs/wire-subsystems/src/Wire/UserStore/IndexUser.hs index ddf6a1a6acb..09ac630d191 100644 --- a/libs/wire-subsystems/src/Wire/UserStore/IndexUser.hs +++ b/libs/wire-subsystems/src/Wire/UserStore/IndexUser.hs @@ -22,6 +22,7 @@ module Wire.UserStore.IndexUser where import Cassandra.Util import Data.ByteString.Builder import Data.ByteString.Lazy qualified as LBS +import Data.Default import Data.Handle import Data.Id import Data.Json.Util @@ -67,7 +68,7 @@ data IndexUser = IndexUser type instance TupleType IndexUser = ( UserId, - UserType, + Maybe UserType, Maybe TeamId, Maybe (Writetime TeamId), Name, Writetime Name, Maybe AccountStatus, Maybe (Writetime AccountStatus), @@ -86,7 +87,7 @@ type instance indexUserFromTuple :: TupleType IndexUser -> IndexUser indexUserFromTuple ( userId, - userType, + mbUserType, teamId, tTeam, name, tName, accountStatus, tStatus, @@ -104,7 +105,7 @@ indexUserFromTuple createdAt = writetimeToUTC tActivated, updatedAt = maximum $ catMaybes [writetimeToUTC <$> tTeam, Just $ writetimeToUTC tName, - writetimeToUTC <$> tStatus, + writetimeToUTC <$> tStatus, writetimeToUTC <$> tHandle, writetimeToUTC <$> tEmail, Just $ writetimeToUTC tColour, @@ -116,6 +117,7 @@ indexUserFromTuple writetimeToUTC <$> tSearchable, writetimeToUTC <$> tWriteTimeBumper ], + userType = fromMaybe def mbUserType, .. } {- ORMOLU_ENABLE -} diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem.hs b/libs/wire-subsystems/src/Wire/UserSubsystem.hs index 8e20fdece8a..3980bbf6b8f 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem.hs @@ -118,9 +118,6 @@ data ChangeEmailResult ChangeEmailIdempotent deriving (Show) -data UserProfileFilter = Everything | RegularOnly | AppsOnly - deriving (Eq, Show) - data UserSubsystem m a where -- | First arg is for authorization only. GetUserProfiles :: Local UserId -> [Qualified UserId] -> UserSubsystem m [UserProfile] @@ -131,7 +128,9 @@ data UserSubsystem m a where -- FederationError)], [UserProfile])` to maintain API compatibility.) GetUserProfilesWithErrors :: Local UserId -> [Qualified UserId] -> UserSubsystem m ([(Qualified UserId, FederationError)], [UserProfile]) -- | Sometimes we don't have any identity of a requesting user, and local profiles are public. - GetLocalUserProfilesFiltered :: UserProfileFilter -> Local [UserId] -> UserSubsystem m [UserProfile] + GetLocalUserProfiles :: Local [UserId] -> UserSubsystem m [UserProfile] + -- | Get profiles for all app users in a team, touching only the apps table (efficient). + GetLocalAppProfiles :: Local TeamId -> UserSubsystem m [UserProfile] -- | Get the union of all user accounts matching the `GetBy` argument *and* having a non-empty UserIdentity. GetAccountsBy :: Local GetBy -> UserSubsystem m [User] -- | Get user accounts matching the `[EmailAddress]` argument (accounts with missing @@ -194,30 +193,20 @@ data CheckHandleResp makeSem ''UserSubsystem -getUserProfile :: (Member UserSubsystem r) => Local UserId -> Qualified UserId -> Sem r (Maybe UserProfile) +getUserProfile :: + (Member UserSubsystem r) => + Local UserId -> + Qualified UserId -> + Sem r (Maybe UserProfile) getUserProfile luid targetUser = listToMaybe <$> getUserProfiles luid [targetUser] -getLocalUserProfile :: (Member UserSubsystem r) => Local UserId -> Sem r (Maybe UserProfile) +getLocalUserProfile :: + (Member UserSubsystem r) => + Local UserId -> Sem r (Maybe UserProfile) getLocalUserProfile targetUser = listToMaybe <$> getLocalUserProfiles ((: []) <$> targetUser) -getLocalUserProfileFiltered :: (Member UserSubsystem r) => UserProfileFilter -> Local UserId -> Sem r (Maybe UserProfile) -getLocalUserProfileFiltered upf targetUser = - listToMaybe <$> getLocalUserProfilesFiltered upf ((: []) <$> targetUser) - -getLocalUserProfileFiltered404 :: - (Member (Error UserSubsystemError) r, Member UserSubsystem r) => - UserProfileFilter -> Local UserId -> Sem r UserProfile -getLocalUserProfileFiltered404 upf targetUser = - getLocalUserProfileFiltered upf targetUser >>= note UserSubsystemProfileNotFound - -getLocalUserProfiles :: - (Member UserSubsystem r) => - Local [UserId] -> - Sem r [UserProfile] -getLocalUserProfiles = getLocalUserProfilesFiltered Everything - getLocalAccountBy :: (Member UserSubsystem r) => HavePendingInvitations -> diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs index f3644d7af33..ac8347ed4ed 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs @@ -71,7 +71,10 @@ import Wire.API.User as User import Wire.API.User.RichInfo import Wire.API.User.Search import Wire.API.UserEvent +import Wire.AppStore (AppStore) +import Wire.AppStore qualified as AppStore import Wire.AppSubsystem +import Wire.AppSubsystem.Interpreter import Wire.AuthenticationSubsystem import Wire.BlockListStore as BlockList import Wire.ClientSubsystem (ClientSubsystem) @@ -107,7 +110,8 @@ import Wire.UserSubsystem.UserSubsystemConfig import Witherable (wither) runUserSubsystem :: - ( Member UserStore r, + ( Member AppStore r, + Member UserStore r, Member UserKeyStore r, Member GalleyAPIAccess r, Member BlockListStore r, @@ -130,20 +134,22 @@ runUserSubsystem :: Member (Input UserSubsystemConfig) r, Member TeamSubsystem r, Member UserGroupStore r, - Member ClientSubsystem r, Member (Input (Local any)) r ) => - InterpreterFor AuthenticationSubsystem (AppSubsystem ': r) -> - InterpreterFor AppSubsystem r -> + InterpreterFor AuthenticationSubsystem (AppSubsystem ': ClientSubsystem ': r) -> + InterpreterFor AppSubsystem (ClientSubsystem ': r) -> + InterpreterFor ClientSubsystem r -> Sem (UserSubsystem ': r) a -> Sem r a -runUserSubsystem authInterpreter appInterpreter = +runUserSubsystem authInterpreter appInterpreter clientInterpreter = interpret $ - appInterpreter . authInterpreter . \case + clientInterpreter . appInterpreter . authInterpreter . \case GetUserProfiles self others -> getUserProfilesImpl self others - GetLocalUserProfilesFiltered upf others -> - getLocalUserProfilesFilteredImpl upf others + GetLocalUserProfiles others -> + getLocalUserProfilesImpl others + GetLocalAppProfiles ltid -> + getLocalAppProfilesOnlyImpl ltid GetAccountsBy getBy -> getAccountsByImpl getBy GetAccountsByEmailNoFilter emails -> @@ -345,7 +351,7 @@ getUserProfilesImpl self others = (getUserProfilesFromDomain self) (bucketQualified others) -getLocalUserProfilesFilteredImpl :: +getLocalUserProfilesImpl :: forall r any. ( Member UserStore r, Member (Input UserSubsystemConfig) r, @@ -356,10 +362,38 @@ getLocalUserProfilesFilteredImpl :: Member TeamSubsystem r, Member AppSubsystem r ) => - UserProfileFilter -> Local [UserId] -> Sem r [UserProfile] -getLocalUserProfilesFilteredImpl upf = getUserProfilesLocalPart upf Nothing +getLocalUserProfilesImpl = getUserProfilesLocalPart Nothing + +getLocalAppProfilesOnlyImpl :: + forall r any. + ( Member AppStore r, + Member UserStore r, + Member (Input UserSubsystemConfig) r, + Member DeleteQueue r, + Member Now r, + Member (Concurrency Unsafe) r, + Member (Input (Local any)) r, + Member AppSubsystem r, + Member TeamSubsystem r + ) => + Local TeamId -> + Sem r [UserProfile] +getLocalAppProfilesOnlyImpl ltid = do + apps <- AppStore.getApps (tUnqualified ltid) + profiles <- getUserProfilesLocalPart Nothing (ltid $> map (.id) apps) + let appsMap :: Map UserId AppStore.StoredApp + appsMap = Map.fromList ((\app -> (app.id, app)) <$> apps) + + injectPreloadedApp :: UserProfile -> UserProfile + injectPreloadedApp profile = + let key = qUnqualified profile.profileQualifiedId + in case Map.lookup key appsMap of + Just app -> profile {profileApp = Just (storedAppToAppInfo app)} + Nothing -> profile + + pure (injectPreloadedApp <$> profiles) getUserProfilesFromDomain :: ( Member (Error FederationError) r, @@ -379,11 +413,12 @@ getUserProfilesFromDomain :: Local UserId -> Qualified [UserId] -> Sem r [UserProfile] -getUserProfilesFromDomain self = +getUserProfilesFromDomain self uids = do foldQualified self - (getUserProfilesLocalPart Everything (Just self)) + (getUserProfilesLocalPart (Just self)) getUserProfilesRemotePart + uids getUserProfilesRemotePart :: ( Member (FederationAPIAccess fedM) r, @@ -408,11 +443,10 @@ getUserProfilesLocalPart :: Member AppSubsystem r, Member TeamSubsystem r ) => - UserProfileFilter -> Maybe (Local UserId) -> Local [UserId] -> Sem r [UserProfile] -getUserProfilesLocalPart upf requestingUser luids = do +getUserProfilesLocalPart requestingUser luids = do emailVisibilityConfig <- inputs emailVisibilityConfig requestingUserInfo <- join <$> traverse getRequestingUserInfo requestingUser let canSeeEmails = maybe False (isAdminOrOwner . view (newTeamMember . nPermissions) . snd) requestingUserInfo @@ -421,7 +455,7 @@ getUserProfilesLocalPart upf requestingUser luids = do EmailVisibleToSelf -> EmailVisibleToSelf EmailVisibleIfOnTeam -> EmailVisibleIfOnTeam EmailVisibleIfOnSameTeam () -> EmailVisibleIfOnSameTeam requestingUserInfo - injectAppsIntoUserProfiles . filter goUpf . catMaybes + injectAppsIntoUserProfiles . catMaybes -- FUTUREWORK: (in the interpreters where it makes sense) pull paginated lists from the DB, -- not just single rows. =<< unsafePooledForConcurrentlyN 8 (sequence luids) (getLocalUserProfileInternal emailVisibilityConfigWithViewer) @@ -440,12 +474,6 @@ getUserProfilesLocalPart upf requestingUser luids = do Nothing -> pure Nothing Just tid -> (tid,) <$$> internalGetTeamMember (tUnqualified self) tid - goUpf :: UserProfile -> Bool - goUpf prof = case upf of - Everything -> True - AppsOnly -> prof.profileType == UserTypeApp - RegularOnly -> prof.profileType == UserTypeRegular - getLocalUserProfileInternal :: forall r. ( Member UserStore r, diff --git a/libs/wire-subsystems/src/Wire/Util.hs b/libs/wire-subsystems/src/Wire/Util.hs index 6d660be24a8..0e9c476cace 100644 --- a/libs/wire-subsystems/src/Wire/Util.hs +++ b/libs/wire-subsystems/src/Wire/Util.hs @@ -18,10 +18,12 @@ module Wire.Util where import Cassandra hiding (Set) +import Data.Domain +import Data.Qualified import Imports import Polysemy import Polysemy.Embed -import Polysemy.Input (Input, input) +import Polysemy.Input import Polysemy.TinyLog import System.Logger.Message @@ -35,3 +37,13 @@ embedClientInput :: (Member (Embed IO) r, Member (Input ClientState) r) => Clien embedClientInput a = do client <- input embedClient client a + +qualifyLocal :: (Member (Input (Local ())) r) => a -> Sem r (Local a) +qualifyLocal a = do + l <- input + pure $ qualifyAs l a + +isLocalDomain :: (Member (Input (Local ())) r) => Domain -> Sem r Bool +isLocalDomain domain = do + l <- input + pure $ domain == qDomain (tUntagged l) diff --git a/libs/wire-subsystems/src/Wire/VerificationCodeSubsystem.hs b/libs/wire-subsystems/src/Wire/VerificationCodeSubsystem.hs index b77ac4484d0..bbf7c71b775 100644 --- a/libs/wire-subsystems/src/Wire/VerificationCodeSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/VerificationCodeSubsystem.hs @@ -35,6 +35,8 @@ data VerificationCodeSubsystemError = VerificationCodeThrottled RetryAfter deriving (Show, Eq) +instance Exception VerificationCodeSubsystemError + verificationCodeSubsystemErrorToHttpError :: VerificationCodeSubsystemError -> HttpError verificationCodeSubsystemErrorToHttpError = \case VerificationCodeThrottled t -> diff --git a/libs/wire-subsystems/test/unit/Wire/AuthenticationSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/AuthenticationSubsystem/InterpreterSpec.hs index 5c368928eea..ac5139937c9 100644 --- a/libs/wire-subsystems/test/unit/Wire/AuthenticationSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/AuthenticationSubsystem/InterpreterSpec.hs @@ -19,6 +19,7 @@ module Wire.AuthenticationSubsystem.InterpreterSpec (spec) where +import Data.Default import Data.Domain import Data.Id import Data.Map qualified as Map @@ -41,6 +42,7 @@ import Test.Hspec.QuickCheck import Test.QuickCheck import Wire.API.Allowlists (AllowlistEmailDomains (AllowlistEmailDomains)) import Wire.API.Password +import Wire.API.Team.Feature import Wire.API.User import Wire.API.User.Auth import Wire.API.User.Password @@ -52,6 +54,7 @@ import Wire.AuthenticationSubsystem.Interpreter import Wire.AuthenticationSubsystem.ZAuth (randomConnId) import Wire.EmailSubsystem import Wire.Events +import Wire.GalleyAPIAccess import Wire.HashPassword import Wire.MiniBackend import Wire.MockInterpreters @@ -66,11 +69,21 @@ import Wire.SessionStore import Wire.StoredUser import Wire.UserKeyStore import Wire.UserStore +import Wire.VerificationCode +import Wire.VerificationCodeGen +import Wire.VerificationCodeStore +import Wire.VerificationCodeSubsystem +import Wire.VerificationCodeSubsystem.Interpreter type AllEffects = [ AuthenticationSubsystem, + GalleyAPIAccess, + VerificationCodeSubsystem, + Input VerificationCodeThrottleTTL, + VerificationCodeStore, Events, Error AuthenticationSubsystemError, + Error VerificationCodeSubsystemError, Error RateLimitExceeded, RateLimit, Random, @@ -83,7 +96,6 @@ type AllEffects = State (Map UserId [Cookie ()]), PasswordStore, PasswordResetCodeStore, - State (Map PasswordResetKey (PRQueryData Identity)), TinyLog, EmailSubsystem, UserStore, @@ -94,10 +106,21 @@ type AllEffects = ] runAllEffects :: Domain -> [StoredUser] -> Map UserId Password -> Maybe [Text] -> Sem AllEffects a -> Either AuthenticationSubsystemError a -runAllEffects domain users passwords emailDomains action = snd $ runAllEffectsWithEventState domain users passwords emailDomains action +runAllEffects domain users passwords emailDomains action = snd $ runAllEffectsWithEventStateAndFeatures domain users passwords emailDomains def action runAllEffectsWithEventState :: Domain -> [StoredUser] -> Map UserId Password -> Maybe [Text] -> Sem AllEffects a -> ([MiniEvent], Either AuthenticationSubsystemError a) runAllEffectsWithEventState localDomain preexistingUsers preexistingPasswords mAllowedEmailDomains = + runAllEffectsWithEventStateAndFeatures localDomain preexistingUsers preexistingPasswords mAllowedEmailDomains def + +runAllEffectsWithEventStateAndFeatures :: + Domain -> + [StoredUser] -> + Map UserId Password -> + Maybe [Text] -> + AllTeamFeatures -> + Sem AllEffects a -> + ([MiniEvent], Either AuthenticationSubsystemError a) +runAllEffectsWithEventStateAndFeatures localDomain preexistingUsers preexistingPasswords mAllowedEmailDomains galleyFeatures = let cfg = defaultAuthenticationSubsystemConfig { allowlistEmailDomains = AllowlistEmailDomains <$> mAllowedEmailDomains, @@ -111,8 +134,7 @@ runAllEffectsWithEventState localDomain preexistingUsers preexistingPasswords mA . runInMemoryUserStoreInterpreter preexistingUsers preexistingPasswords . inMemoryEmailSubsystemInterpreter . discardTinyLogs - . evalState mempty - . inMemoryPasswordResetCodeStore + . runInMemoryPasswordResetCodeStore . runInMemoryPasswordStoreInterpreter . evalState mempty . inMemorySessionStoreInterpreter @@ -124,8 +146,13 @@ runAllEffectsWithEventState localDomain preexistingUsers preexistingPasswords mA . runRandomPure . noRateLimit . runErrorUnsafe + . runErrorUnsafe . runError . miniEventInterpreter + . runInMemoryVerificationCodeStore + . runInputConst (VerificationCodeThrottleTTL 60) + . interpretVerificationCodeSubsystem + . miniGalleyAPIAccess mempty galleyFeatures . interpretAuthenticationSubsystem inMemoryUserSubsystemInterpreter toInputPassword :: PlainTextPassword8 -> PlainTextPassword6 @@ -141,7 +168,8 @@ spec = describe "AuthenticationSubsystem.Interpreter" do userNoEmail { email = Just email, emailUnvalidated = Nothing, - status = Just Active + status = Just Active, + ssoId = Nothing } uid = user.id passwords = foldMap (Map.singleton uid . hashPassword) mPreviousPassword @@ -169,7 +197,8 @@ spec = describe "AuthenticationSubsystem.Interpreter" do userNoEmail { email = Just email, emailUnvalidated = Nothing, - status = Just Active + status = Just Active, + ssoId = Nothing } uid = user.id passwords = foldMap (Map.singleton uid . hashPassword) mPreviousPassword @@ -201,7 +230,8 @@ spec = describe "AuthenticationSubsystem.Interpreter" do userNoEmail { email = Just email, emailUnvalidated = Nothing, - status = Just Active + status = Just Active, + ssoId = Nothing } createPasswordResetCodeResult = runAllEffects testDomain [user] mempty (Just [decodeUtf8 $ domainPart email]) $ @@ -237,7 +267,8 @@ spec = describe "AuthenticationSubsystem.Interpreter" do userNoEmail { email = Just email, emailUnvalidated = Nothing, - status = Just Active + status = Just Active, + ssoId = Nothing } uid = user.id Right (newPasswordVerification, mCaughtException) = @@ -260,7 +291,8 @@ spec = describe "AuthenticationSubsystem.Interpreter" do userNoEmail { email = Just email, emailUnvalidated = Nothing, - status = Just Active + status = Just Active, + ssoId = Nothing } uid = user.id passwords = Map.singleton uid $ hashPassword oldPassword @@ -305,7 +337,8 @@ spec = describe "AuthenticationSubsystem.Interpreter" do userNoEmail { email = Just email, emailUnvalidated = Nothing, - status = Just Active + status = Just Active, + ssoId = Nothing } uid = user.id passwords = Map.singleton uid $ hashPassword oldPassword @@ -326,7 +359,8 @@ spec = describe "AuthenticationSubsystem.Interpreter" do userNoEmail { email = Just email, emailUnvalidated = Nothing, - status = Just Active + status = Just Active, + ssoId = Nothing } uid = user.id passwords = Map.singleton uid $ hashPassword oldPassword @@ -356,6 +390,52 @@ spec = describe "AuthenticationSubsystem.Interpreter" do wrongResetErrors == replicate wrongResetAttempts (Just AuthenticationSubsystemInvalidPasswordResetCode) .&&. resetPassworedWithCorectCodeResult === expectedFinalResetResult .&&. assertPasswordVerification + prop "reset code not generated for SAML user" $ + \email userNoEmail samlUserRef -> + let user = + userNoEmail + { email = Just email, + emailUnvalidated = Nothing, + status = Just Active, + ssoId = Just (UserSSOId samlUserRef), + activated = True + } + createPasswordResetCodeResult = + runAllEffects testDomain [user] mempty Nothing $ do + createPasswordResetCode (mkEmailKey email) + expectNoEmailSent + internalLookupPasswordResetCode (mkEmailKey email) + in case createPasswordResetCodeResult of + Right Nothing -> property True + Right mResetCode -> + counterexample ("expected no stored password reset code, got: " <> show mResetCode) False + Left e -> + counterexample ("expected Right Nothing, got Left: " <> show e) False + + prop "issued reset code is rejected if user becomes SAML before completion" $ + \email userNoEmail samlUserRef oldPassword newPassword -> + let user = + userNoEmail + { email = Just email, + emailUnvalidated = Nothing, + status = Just Active, + ssoId = Nothing, + activated = True + } + uid = user.id + passwords = Map.singleton uid $ hashPassword oldPassword + Right (oldPasswordVerification, newPasswordVerification, resetPasswordResult) = + runAllEffects testDomain [user] passwords Nothing $ do + createPasswordResetCode (mkEmailKey email) + (_, resetCode) <- expect1ResetPasswordEmail email + void $ updateSSOId uid (Just (UserSSOId samlUserRef)) + mCaughtExc <- catchExpectedError $ resetPassword (PasswordResetEmailIdentity email) resetCode newPassword + (,,mCaughtExc) + <$> verifyUserPassword uid (toInputPassword oldPassword) + <*> verifyUserPassword uid (toInputPassword newPassword) + in resetPasswordResult === Just AuthenticationSubsystemInvalidPasswordResetCode + .&&. fst oldPasswordVerification === True + .&&. fst newPasswordVerification === False describe "internalLookupPasswordResetCode" do prop "should find password reset code by email" $ @@ -364,7 +444,8 @@ spec = describe "AuthenticationSubsystem.Interpreter" do userNoEmail { email = Just email, emailUnvalidated = Nothing, - status = Just Active + status = Just Active, + ssoId = Nothing } uid = user.id Right newPasswordVerification = @@ -469,6 +550,66 @@ spec = describe "AuthenticationSubsystem.Interpreter" do .&&. (event <$> events) === [UserEvent UserSessionRefreshSuggested] .&&. (Event.userId <$> events) === [uidA] + describe "enforceVerificationCodeEither" do + let setEmail user email tid = + user + { email = email, + emailUnvalidated = Nothing, + status = Just Active, + activated = True, + ssoId = Nothing, + teamId = tid + } + prop "accepts a valid code for the requested action" $ + \email userNoEmail action tid status -> + let user = setEmail userNoEmail (Just email) (Just tid) + luid = toLocalUnsafe testDomain user.id + features = npUpdate @SndFactorPasswordChallengeConfig (LockableFeature status LockStatusUnlocked def) def + (_, Right result) = + runAllEffectsWithEventStateAndFeatures testDomain [user] mempty Nothing features $ do + code <- createCodeOverwritePrevious (mk6DigitVerificationCodeGen email) (scopeFromAction action) 2 300 Nothing + enforceVerificationCodeEither luid (Just code.codeValue) action + in result === Right () + + prop "rejects invalid code for the requested action" $ + \email userNoEmail wrongCode action tid status -> + let user = setEmail userNoEmail (Just email) (Just tid) + luid = toLocalUnsafe testDomain user.id + features = npUpdate @SndFactorPasswordChallengeConfig (LockableFeature status LockStatusUnlocked def) def + (_, Right result) = + runAllEffectsWithEventStateAndFeatures testDomain [user] mempty Nothing features $ do + _ <- createCodeOverwritePrevious (mk6DigitVerificationCodeGen email) (scopeFromAction action) 2 300 Nothing + enforceVerificationCodeEither luid (Just wrongCode) action + in if status == FeatureStatusEnabled + then result === Left VerificationCodeNoPendingCode + else result === Right () + + prop "rejects missing code for the requested action" $ + \email userNoEmail action tid status -> + let user = setEmail userNoEmail (Just email) (Just tid) + luid = toLocalUnsafe testDomain user.id + features = npUpdate @SndFactorPasswordChallengeConfig (LockableFeature status LockStatusUnlocked def) def + (_, Right result) = + runAllEffectsWithEventStateAndFeatures testDomain [user] mempty Nothing features $ do + _ <- createCodeOverwritePrevious (mk6DigitVerificationCodeGen email) (scopeFromAction action) 2 300 Nothing + enforceVerificationCodeEither luid Nothing action + in if status == FeatureStatusEnabled + then result === Left VerificationCodeRequired + else result === Right () + + prop "rejects if no email" $ + \email userNoEmail action tid status -> + let user = setEmail userNoEmail Nothing (Just tid) + luid = toLocalUnsafe testDomain user.id + features = npUpdate @SndFactorPasswordChallengeConfig (LockableFeature status LockStatusUnlocked def) def + (_, Right result) = + runAllEffectsWithEventStateAndFeatures testDomain [user] mempty Nothing features $ do + code <- createCodeOverwritePrevious (mk6DigitVerificationCodeGen email) (scopeFromAction action) 2 300 Nothing + enforceVerificationCodeEither luid (Just code.codeValue) action + in if status == FeatureStatusEnabled + then result === Left VerificationCodeNoEmail + else result === Right () + describe "randomConnId" $ do it "generates different connection ids" $ do let connIds = run . runRandomPure $ replicateM 100 randomConnId diff --git a/libs/wire-subsystems/test/unit/Wire/ClientSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/ClientSubsystem/InterpreterSpec.hs new file mode 100644 index 00000000000..769dc9d82bf --- /dev/null +++ b/libs/wire-subsystems/test/unit/Wire/ClientSubsystem/InterpreterSpec.hs @@ -0,0 +1,491 @@ +module Wire.ClientSubsystem.InterpreterSpec (spec) where + +import Data.Aeson qualified as A +import Data.Default +import Data.Id +import Data.Json.Util (toUTCTimeMillis) +import Data.Map qualified as Map +import Data.Qualified +import Data.Set qualified as Set +import Imports +import Polysemy +import Polysemy.Error +import Polysemy.Input +import Polysemy.State +import System.Logger.Message (Msg) +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck qualified as QC +import Test.QuickCheck.Property +import Wire.API.Federation.Client (FederatorClient) +import Wire.API.Federation.Error (FederationError) +import Wire.API.Push.V2 qualified as V2 +import Wire.API.Team.LegalHold (LegalholdProtectee (..)) +import Wire.API.Team.LegalHold.Internal +import Wire.API.User.Client +import Wire.API.User.Client.Prekey +import Wire.API.UserEvent +import Wire.Arbitrary +import Wire.ClientStore hiding (claimPrekey) +import Wire.ClientSubsystem +import Wire.ClientSubsystem.Error +import Wire.ClientSubsystem.Interpreter +import Wire.DeleteQueue +import Wire.DeleteQueue.InMemory +import Wire.EmailSubsystem +import Wire.Events +import Wire.FederationAPIAccess +import Wire.FederationAPIAccess.Interpreter +import Wire.GalleyAPIAccess hiding (newClient) +import Wire.InternalEvent +import Wire.MockInterpreters +import Wire.NotificationSubsystem +import Wire.Sem.Concurrency +import Wire.Sem.Concurrency.Sequential +import Wire.Sem.Logger +import Wire.Sem.Now (Now) +import Wire.StoredUser +import Wire.Util + +data ClientSubsystemTestResult a = ClientSubsystemTestResult + { authState :: MockAuthenticationState, + result :: Either ClientError a, + deletions :: [InternalNotification], + events :: [MiniEvent], + pushes :: [Push] + } + +type ClientSubsystemTestEffects = + [ ClientStore, + State ClientStoreState, + Now, + NotificationSubsystem, + GalleyAPIAccess, + Events, + EmailSubsystem, + DeleteQueue, + Input ClientSubsystemConfig, + Input (Local ()), + FederationAPIAccess FederatorClient, + Logger (Msg -> Msg), + Concurrency 'Unsafe, + Error ClientError, + Error FederationError, + State [Push], + State [MiniEvent], + State [InternalNotification], + State MockAuthenticationState + ] + +runClientSubsystemTest :: + forall a. + [StoredUser] -> + Sem (ClientSubsystem ': ClientSubsystemTestEffects) a -> + ClientSubsystemTestResult a +runClientSubsystemTest users action = + let interpreted :: Sem ClientSubsystemTestEffects a + interpreted = + runClientSubsystem + mockAuthenticationSubsystemInterpreter + (runInMemoryUserSubsytemInterpreter users mempty) + action + (authState, (deletions, (events, (pushes, result)))) = + run + . runState emptyMockAuthenticationState + . runState @[InternalNotification] [] + . runState @[MiniEvent] [] + . runState @[Push] [] + . runError + . runError + . sequentiallyPerformConcurrency + . noopLogger + . noFederationAPIAccess @_ @FederatorClient + . runInputConst (toLocalUnsafe testDomain ()) + . runInputConst (ClientSubsystemConfig 7 False) + . inMemoryDeleteQueueInterpreter + . noopEmailSubsystemInterpreter + . miniEventInterpreter + . miniGalleyAPIAccess mempty def + . inMemoryNotificationSubsystemInterpreter + . interpretNowConst defaultTime + . evalState emptyClientStoreState + . runInMemoryClientStoreInterpreterWithState + $ interpreted + in ClientSubsystemTestResult {authState, result = fromRight (error "unexpected federation error") result, deletions, events, pushes} + +expectRight :: + (Show e, Show a) => + Either e a -> + (a -> Property) -> + Property +expectRight result' assertRight = + counterexample ("unexpected result: " <> show result') $ + case result' of + Left resultErr -> counterexample ("unexpected error: " <> show resultErr) False + Right value -> assertRight value + +assertSingle :: + (Show a) => + String -> + [a] -> + (a -> Property) -> + Property +assertSingle what xs assertItem = case xs of + [] -> counterexample ("expected one " <> what <> ", but got none") False + [x] -> assertItem x + _ : _ -> counterexample ("expected one " <> what <> ", but got many: " <> show xs) False + +assertClientEvent :: UserId -> Maybe ConnId -> Event -> MiniEvent -> Property +assertClientEvent uid mConn expected miniEvent = + conjoin + [ miniEvent.userId === uid, + miniEvent.mConnId === mConn, + miniEvent.event === expected + ] + +assertClientPush :: UserId -> Maybe ConnId -> EventType -> Push -> Property +assertClientPush uid mConn expected push = + case A.fromJSON @Event (A.Object push.json) of + A.Success actual -> + conjoin + [ push.origin === Just uid, + push.conn === mConn, + push.transient === False, + push.route === V2.RouteAny, + push.nativePriority === Nothing, + push.recipients === [Recipient uid V2.RecipientClientsAll], + push.apsData === Nothing, + push.isCellsEvent === False, + eventType actual === expected + ] + _ -> counterexample ("Failed to decode push: " <> show push) False + +spec :: Spec +spec = describe "ClientSubsystem.Interpreter" do + prop "adds and looks up a client" $ \user (FakeLastPrekey lpk) -> + let luid = toLocalUnsafe testDomain user.id + new = newClient PermanentClientType lpk + clientId = clientIdFromPrekey (unpackLastPrekey lpk) + expectedClient = + Client + { clientId, + clientType = PermanentClientType, + clientTime = toUTCTimeMillis defaultTime, + clientClass = Nothing, + clientLabel = Nothing, + clientCookie = Nothing, + clientModel = Nothing, + clientCapabilities = mempty, + clientMLSPublicKeys = mempty, + clientLastActive = Nothing + } + testResult = + runClientSubsystemTest [user] do + added <- addClient luid Nothing new + stored <- lookupLocalClients user.id + pure (added, stored) + auth = testResult.authState + in expectRight testResult.result $ \value -> + conjoin + [ value === (expectedClient, [expectedClient]), + auth.verificationCodeCalls === 1, + auth.reAuthCalls === 0, + auth.revokeCookiesCalls === 0, + testResult.deletions === [], + testResult.events === [], + assertSingle "push" testResult.pushes (assertClientPush user.id Nothing EventTypeClientAdded) + ] + + prop "removes client" $ \user conn (FakeLastPrekey lpk) -> + let uid = user.id + luid = toLocalUnsafe testDomain user.id + new = newClient PermanentClientType lpk + clientId = clientIdFromPrekey (unpackLastPrekey lpk) + expectedClient = + Client + { clientId, + clientType = PermanentClientType, + clientTime = toUTCTimeMillis defaultTime, + clientClass = Nothing, + clientLabel = Nothing, + clientCookie = Nothing, + clientModel = Nothing, + clientCapabilities = mempty, + clientMLSPublicKeys = mempty, + clientLastActive = Nothing + } + testResult = + runClientSubsystemTest [user] do + added <- addClient luid Nothing new + removeClient uid conn clientId Nothing + stored <- lookupLocalClients user.id + pure (added, stored) + auth = testResult.authState + in expectRight testResult.result $ \(added, clients) -> + conjoin + [ added === expectedClient, + clients === [], + auth.verificationCodeCalls === 1, + auth.reAuthCalls === 1, + auth.revokeCookiesCalls === 0, + testResult.deletions === [DeleteClient clientId uid (Just conn)], + testResult.events === [], + assertSingle "push" testResult.pushes (assertClientPush uid Nothing EventTypeClientAdded) + ] + + prop "legal hold client cannot be removed" $ \user conn (FakeLastPrekey lpk) -> + let uid = user.id + luid = toLocalUnsafe testDomain user.id + new = newClient LegalHoldClientType lpk + clientId = clientIdFromPrekey (unpackLastPrekey lpk) + testResult = + runClientSubsystemTest [user] do + void $ addClient luid Nothing new + removeClient uid conn clientId Nothing + in counterexample ("unexpected result: " <> show testResult.result) $ + case testResult.result of + Left ClientLegalHoldCannotBeRemoved -> + conjoin + [ testResult.authState.verificationCodeCalls === 1, + testResult.authState.reAuthCalls === 0, + testResult.authState.revokeCookiesCalls === 0, + testResult.deletions === [], + assertSingle "event" testResult.events (assertClientEvent uid Nothing (UserEvent (UserLegalHoldEnabled uid))), + assertSingle "push" testResult.pushes (assertClientPush uid Nothing EventTypeClientAdded) + ] + Left clientErr -> + counterexample ("unexpected ClientError: " <> show clientErr) False + Right _ -> + counterexample "legal hold client removal was expected to fail, but it succeeded" False + + prop "adds and removes legal hold client" $ \user (FakeLastPrekey lpk) -> + let uid = user.id + luid = toLocalUnsafe testDomain user.id + new = newClient LegalHoldClientType lpk + clientId = clientIdFromPrekey (unpackLastPrekey lpk) + expectedClient = + Client + { clientId, + clientType = LegalHoldClientType, + clientTime = toUTCTimeMillis defaultTime, + clientClass = Just LegalHoldClient, + clientLabel = Nothing, + clientCookie = Nothing, + clientModel = Nothing, + clientCapabilities = ClientCapabilityList (Set.singleton ClientSupportsLegalholdImplicitConsent), + clientMLSPublicKeys = mempty, + clientLastActive = Nothing + } + testResult = + runClientSubsystemTest [user] do + added <- addClient luid Nothing new + removeLegalHoldClient uid + stored <- lookupLocalClients user.id + pure (added, stored) + auth = testResult.authState + in expectRight testResult.result $ \(added, clients) -> + conjoin + [ added === expectedClient, + clients === [], + auth.verificationCodeCalls === 1, + auth.reAuthCalls === 0, + auth.revokeCookiesCalls === 0, + testResult.deletions === [DeleteClient clientId uid Nothing], + testResult.events + === [ MkMiniEvent uid Nothing (UserEvent (UserLegalHoldDisabled uid)), + MkMiniEvent uid Nothing (UserEvent (UserLegalHoldEnabled uid)) + ], + assertSingle "push" testResult.pushes (assertClientPush uid Nothing EventTypeClientAdded) + ] + + prop "requests a legal hold client" $ \user (FakeLastPrekey lpk) -> + let uid = user.id + req = LegalHoldClientRequest uid lpk + clientId = clientIdFromPrekey (unpackLastPrekey lpk) + expectedEvent = + UserEvent + ( LegalHoldClientRequested + (LegalHoldClientRequestedData uid lpk clientId) + ) + testResult = + runClientSubsystemTest [user] do + publishLegalHoldClientRequested uid req + in expectRight testResult.result $ \() -> + conjoin + [ testResult.deletions === [], + assertSingle "event" testResult.events (assertClientEvent uid Nothing expectedEvent), + testResult.pushes === [] + ] + + prop "update client" $ \user (FakeUpdateClient update) (FakeLastPrekey lpk) -> + let uid = user.id + luid = toLocalUnsafe testDomain uid + new = newClient PermanentClientType lpk + clientId = clientIdFromPrekey (unpackLastPrekey lpk) + expectedClient = + Client + { clientId, + clientType = PermanentClientType, + clientTime = toUTCTimeMillis defaultTime, + clientClass = Nothing, + clientLabel = update.updateClientLabel, + clientCookie = Nothing, + clientModel = Nothing, + clientCapabilities = fromMaybe mempty update.updateClientCapabilities, + clientMLSPublicKeys = update.updateClientMLSPublicKeys, + clientLastActive = Nothing + } + testResult = + runClientSubsystemTest [user] do + void $ addClient luid Nothing new + updateClient uid clientId update + stored <- lookupLocalClients user.id + pure (head stored) + auth = testResult.authState + in expectRight testResult.result $ \value -> + conjoin + [ value === expectedClient, + auth.verificationCodeCalls === 1, + auth.reAuthCalls === 0, + auth.revokeCookiesCalls === 0, + testResult.deletions === [], + testResult.events === [], + assertSingle "push" testResult.pushes (assertClientPush uid Nothing EventTypeClientAdded) + ] + + prop "claim prekey" $ \user (FakeLastPrekey lpk) -> + let uid = user.id + domain = testDomain + luid = toLocalUnsafe domain uid + new = newClient PermanentClientType lpk + clientId = clientIdFromPrekey (unpackLastPrekey lpk) + testResult = + runClientSubsystemTest [user] do + void $ addClient luid Nothing new + claimPrekey (ProtectedUser uid) uid domain clientId + in expectRight testResult.result $ \case + Nothing -> counterexample "expected a client prekey, but got nothing" False + Just pk -> pk.prekeyClient === clientId + + prop "claim local prekey" $ \user (FakeLastPrekey lpk) -> + let uid = user.id + domain = testDomain + luid = toLocalUnsafe domain uid + new = newClient PermanentClientType lpk + clientId = clientIdFromPrekey (unpackLastPrekey lpk) + testResult = + runClientSubsystemTest [user] do + void $ addClient luid Nothing new + claimLocalPrekey (ProtectedUser uid) uid clientId + in expectRight testResult.result $ \case + Nothing -> counterexample "expected a client prekey, but got nothing" False + Just pk -> pk.prekeyClient === clientId + + prop "claim prekey bundle" $ \user (FakeLastPrekey lpk1) (FakeLastPrekey lpk2) -> + (lpk1 /= lpk2) + ==> let uid = user.id + domain = testDomain + luid = toLocalUnsafe domain uid + new1 = newClient PermanentClientType lpk1 + new2 = newClient PermanentClientType lpk2 + clientId1 = clientIdFromPrekey (unpackLastPrekey lpk1) + clientId2 = clientIdFromPrekey (unpackLastPrekey lpk2) + expectedClientIds = Set.fromList [clientId1, clientId2] + testResult = + runClientSubsystemTest [user] do + void $ addClient luid Nothing new1 + void $ addClient luid Nothing new2 + claimPrekeyBundle (ProtectedUser uid) domain uid + in expectRight testResult.result $ \bundle -> + (bundle.prekeyUser === uid) + .&&. (Set.fromList (fmap (.prekeyClient) bundle.prekeyClients) === expectedClientIds) + + prop "claim local prekey bundle" $ \user (FakeLastPrekey lpk1) (FakeLastPrekey lpk2) -> + (lpk1 /= lpk2) + ==> let uid = user.id + domain = testDomain + luid = toLocalUnsafe domain uid + new1 = newClient PermanentClientType lpk1 + new2 = newClient PermanentClientType lpk2 + clientId1 = clientIdFromPrekey (unpackLastPrekey lpk1) + clientId2 = clientIdFromPrekey (unpackLastPrekey lpk2) + expectedClientIds = Set.fromList [clientId1, clientId2] + testResult = + runClientSubsystemTest [user] do + void $ addClient luid Nothing new1 + void $ addClient luid Nothing new2 + claimLocalPrekeyBundle (ProtectedUser uid) uid + in expectRight testResult.result $ \bundle -> + (bundle.prekeyUser === uid) + .&&. (Set.fromList (fmap (.prekeyClient) bundle.prekeyClients) === expectedClientIds) + + prop "claim multi prekey bundles v3" $ \protectee testData -> + (unique testData) + ==> let domain = testDomain + testResult = + runClientSubsystemTest (fmap fst testData) do + for_ testData $ \(user, (FakeLastPrekey lpk)) -> do + let uid = user.id + luid = toLocalUnsafe domain uid + new = newClient PermanentClientType lpk + addClient luid Nothing new + let qUserClients = QualifiedUserClients $ Map.fromList [(domain, Map.fromList (fmap toUserClients testData))] + claimMultiPrekeyBundlesV3 (ProtectedUser protectee) qUserClients + in expectRight testResult.result $ \m -> + let qClientMap = m.getQualifiedUserClientPrekeyMap.qualifiedUserClientMap + userMap = fromMaybe mempty $ Map.lookup domain qClientMap + in Map.size qClientMap === 1 .&&. Map.size userMap === length testData + + prop "claim multi prekey bundles" $ \protectee testData -> + (unique testData) + ==> let domain = testDomain + testResult = + runClientSubsystemTest (fmap fst testData) do + for_ testData $ \(user, (FakeLastPrekey lpk)) -> do + let uid = user.id + luid = toLocalUnsafe domain uid + new = newClient PermanentClientType lpk + addClient luid Nothing new + let qUserClients = QualifiedUserClients $ Map.fromList [(domain, Map.fromList (fmap toUserClients testData))] + claimMultiPrekeyBundles (ProtectedUser protectee) qUserClients + in expectRight testResult.result $ \m -> + let qClientMap = m.qualifiedUserClientPrekeys.qualifiedUserClientMap + userMap = fromMaybe mempty $ Map.lookup domain qClientMap + in Map.size qClientMap === 1 .&&. Map.size userMap === length testData + + prop "claim local multi prekey bundles" $ \protectee testData -> + (unique testData) + ==> let domain = testDomain + testResult = + runClientSubsystemTest (fmap fst testData) do + for_ testData $ \(user, (FakeLastPrekey lpk)) -> do + let uid = user.id + luid = toLocalUnsafe domain uid + new = newClient PermanentClientType lpk + addClient luid Nothing new + let userClients = UserClients $ Map.fromList (fmap toUserClients testData) + claimLocalMultiPrekeyBundles (ProtectedUser protectee) userClients + in expectRight testResult.result $ \m -> + let clientMap = m.getUserClientPrekeyMap.userClientMap + in Map.size clientMap === length testData + where + toUserClients (user, FakeLastPrekey lpk) = (user.id, Set.fromList [clientIdFromPrekey (unpackLastPrekey lpk)]) + + unique testData = + length testData == length (Set.fromList (fmap ((.id) . fst) testData)) + && length testData == length (Set.fromList ((fmap snd) testData)) + +newtype FakeUpdateClient = FakeUpdateClient {unFakeUpdateClient :: UpdateClient} + deriving (Show, Eq, Generic) + +instance Arbitrary FakeUpdateClient where + arbitrary = do + update <- arbitrary + (FakeLastPrekey lpk) <- arbitrary + keys <- QC.sublistOf somePrekeys + pure $ + FakeUpdateClient $ + update + { updateClientLastKey = lpk <$ update.updateClientLastKey, + updateClientPrekeys = keys + } diff --git a/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs b/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs index bfc15af38f7..d64f1e10b5b 100644 --- a/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs +++ b/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs @@ -72,7 +72,7 @@ import Polysemy.Input import Polysemy.Internal import Polysemy.State import Polysemy.TinyLog -import Servant.Client.Core +import Servant.Client.Core hiding (ClientError) import System.Logger qualified as Log import Test.QuickCheck import Type.Reflection @@ -138,6 +138,9 @@ import Wire.UserStore import Wire.UserSubsystem import Wire.UserSubsystem.Error import Wire.UserSubsystem.Interpreter +import Wire.VerificationCodeStore +import Wire.VerificationCodeSubsystem +import Wire.VerificationCodeSubsystem.Interpreter newtype PendingNotEmptyIdentityStoredUser = PendingNotEmptyIdentityStoredUser StoredUser deriving (Show, Eq) @@ -214,8 +217,10 @@ type AllErrors = Error AppSubsystemError, Error FederationError, Error AuthenticationSubsystemError, + Error VerificationCodeSubsystemError, Error RateLimitExceeded, - Error TeamCollaboratorsError + Error TeamCollaboratorsError, + Error ClientError ] type MiniBackendEffects = @@ -223,7 +228,7 @@ type MiniBackendEffects = `Append` '[TeamCollaboratorsSubsystem] `Append` MiniBackendLowerEffects -type AuthUserAppRecursiveEffects = '[AuthenticationSubsystem, UserSubsystem, AppSubsystem] +type AuthUserAppRecursiveEffects = '[AuthenticationSubsystem, UserSubsystem, AppSubsystem, ClientSubsystem] ---------------------------------------------------------------------- -- lower effect interpreters (hierarchically) @@ -248,10 +253,10 @@ data MiniBackendParams r = MiniBackendParams -- organize along effect types ("all `State`s"), but the domain ("everything about block -- lists"). type MiniBackendLowerEffects = - '[ ClientSubsystem, - TeamSubsystem, + '[ TeamSubsystem, EmailSubsystem, NotificationSubsystem, + VerificationCodeSubsystem, GalleyAPIAccess, SparAPIAccess, ClientStore, @@ -267,6 +272,7 @@ type MiniBackendLowerEffects = FederationConfigStore, DRS.DomainRegistrationStore, PasswordResetCodeStore, + VerificationCodeStore, SessionStore, UserGroupStore, RateLimit, @@ -288,6 +294,7 @@ type MiniBackendLowerEffects = miniBackendLowerEffectsInterpreters :: forall r a. + (Members AllErrors r) => MiniBackendParams r -> Sem (MiniBackendLowerEffects `Append` r) a -> Sem r (MiniBackend, a) @@ -307,6 +314,7 @@ miniBackendLowerEffectsInterpreters mb@(MiniBackendParams {..}) = . noRateLimit . userGroupStoreTestInterpreter . runInMemorySessionStore + . runInMemoryVerificationCodeStore . runInMemoryPasswordResetCodeStore . inMemoryDomainRegistrationStoreInterpreter . runFederationConfigStoreInMemory @@ -322,10 +330,10 @@ miniBackendLowerEffectsInterpreters mb@(MiniBackendParams {..}) = . runInMemoryClientStoreInterpreter . miniSparAPIAccess . miniGalleyAPIAccess teams galleyConfigs + . interpretVerificationCodeSubsystem . inMemoryNotificationSubsystemInterpreter . noopEmailSubsystemInterpreter . interpretTeamSubsystemToGalleyAPI - . runClientSubsystem type StateEffects = '[ State [Push], @@ -372,7 +380,9 @@ type InputEffects = Input AppSubsystemConfig, Input (Maybe AllowlistEmailDomains), Input (Map TeamId IdPList), + Input VerificationCodeThrottleTTL, Input AuthenticationSubsystemConfig, + Input ClientSubsystemConfig, Input (Local ()) ] @@ -413,6 +423,13 @@ defaultAuthenticationSubsystemConfig = defaultLocalDomain :: Local () defaultLocalDomain = (toLocalUnsafe (Domain "localdomain") ()) +defaultClientSubsystemConfig :: ClientSubsystemConfig +defaultClientSubsystemConfig = + ClientSubsystemConfig + { userMaxPermClients = 7, + consumableNotificationsEnabled = False + } + inputEffectsInterpreters :: forall r a. UserSubsystemConfig -> @@ -422,7 +439,9 @@ inputEffectsInterpreters :: Sem r a inputEffectsInterpreters usrCfg appCfg teamIdps = runInputConst defaultLocalDomain + . runInputConst defaultClientSubsystemConfig . runInputConst defaultAuthenticationSubsystemConfig + . runInputConst (VerificationCodeThrottleTTL 60) . runInputConst teamIdps . runInputConst Nothing . runInputConst appCfg @@ -650,7 +669,15 @@ runNoFederationStackUserSubsystemErrorEither localBackend teams cfg = run . userSubsystemErrorEitherUnsafe . interpretNoFederationStack localBackend teams def cfg userSubsystemErrorEitherUnsafe :: Sem AllErrors a -> Sem '[] (Either UserSubsystemError a) -userSubsystemErrorEitherUnsafe = runErrorUnsafe . runErrorUnsafe . runErrorUnsafe . runErrorUnsafe . runErrorUnsafe . runError +userSubsystemErrorEitherUnsafe = + runErrorUnsafe + . runErrorUnsafe + . runErrorUnsafe + . runErrorUnsafe + . runErrorUnsafe + . runErrorUnsafe + . runErrorUnsafe + . runError interpretNoFederationStack :: (Members AllErrors r) => @@ -697,19 +724,22 @@ interpretMaybeFederationStackState mb = -- diplicate this function whenever we need it. runRecursiveAuthUserApp :: (Members AllErrors r, Members (TeamCollaboratorsSubsystem ': MiniBackendLowerEffects) r) => - Sem (AuthenticationSubsystem ': UserSubsystem ': AppSubsystem ': r) a -> + Sem (AuthenticationSubsystem ': UserSubsystem ': AppSubsystem ': ClientSubsystem ': r) a -> Sem r a -runRecursiveAuthUserApp = runApp . runUser . runAuth +runRecursiveAuthUserApp = runClient . runApp . runUser . runAuth where runAuth :: forall r. (Members AllErrors r, Members (TeamCollaboratorsSubsystem ': MiniBackendLowerEffects) r) => InterpreterFor AuthenticationSubsystem r runAuth = interpretAuthenticationSubsystem runUser runUser :: forall r. (Members AllErrors r, Members (TeamCollaboratorsSubsystem ': MiniBackendLowerEffects) r) => InterpreterFor UserSubsystem r - runUser = runUserSubsystem runAuth runApp + runUser = runUserSubsystem runAuth runApp runClient runApp :: forall r. (Members AllErrors r, Members (TeamCollaboratorsSubsystem ': MiniBackendLowerEffects) r) => InterpreterFor AppSubsystem r runApp = runAppSubsystem runUser runAuth + runClient :: forall r. (Members AllErrors r, Members (TeamCollaboratorsSubsystem ': MiniBackendLowerEffects) r) => InterpreterFor ClientSubsystem r + runClient = runClientSubsystem runAuth runUser + liftInvitationInfoStoreState :: (Member (State MiniBackend) r) => Sem (State (Map InvitationCode StoredInvitation) : r) a -> Sem r a liftInvitationInfoStoreState = interpret \case Polysemy.State.Get -> gets (.invitationInfos) @@ -771,7 +801,7 @@ liftIndexedUserStoreState = interpret $ \case Put newUserIndex -> modify $ \b -> (b :: MiniBackend) {userIndex = newUserIndex} runAllErrorsUnsafe :: forall a. (HasCallStack) => Sem AllErrors a -> a -runAllErrorsUnsafe = run . runErrorUnsafe . runErrorUnsafe . runErrorUnsafe . runErrorUnsafe . runErrorUnsafe . runErrorUnsafe +runAllErrorsUnsafe = run . runErrorUnsafe . runErrorUnsafe . runErrorUnsafe . runErrorUnsafe . runErrorUnsafe . runErrorUnsafe . runErrorUnsafe . runErrorUnsafe emptyFederationAPIAcesss :: InterpreterFor (FederationAPIAccess MiniFederationMonad) r emptyFederationAPIAcesss = interpret $ \case diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters.hs index a426ffa4910..c1bdcdb2628 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters.hs @@ -22,6 +22,7 @@ module Wire.MockInterpreters (module MockInterpreters) where import Wire.MockInterpreters.ActivationCodeStore as MockInterpreters import Wire.MockInterpreters.AppStore as MockInterpreters +import Wire.MockInterpreters.AuthenticationSubsystem as MockInterpreters import Wire.MockInterpreters.BackgroundJobPublisher as MockInterpreters import Wire.MockInterpreters.BlockListStore as MockInterpreters import Wire.MockInterpreters.ClientStore as MockInterpreters diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/AuthenticationSubsystem.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/AuthenticationSubsystem.hs new file mode 100644 index 00000000000..1873f17a118 --- /dev/null +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/AuthenticationSubsystem.hs @@ -0,0 +1,35 @@ +module Wire.MockInterpreters.AuthenticationSubsystem where + +import Imports +import Polysemy +import Polysemy.State +import Wire.AuthenticationSubsystem + +data MockAuthenticationState = MockAuthenticationState + { verificationCodeCalls :: Int, + reAuthCalls :: Int, + revokeCookiesCalls :: Int + } + deriving stock (Eq, Show) + +emptyMockAuthenticationState :: MockAuthenticationState +emptyMockAuthenticationState = + MockAuthenticationState + { verificationCodeCalls = 0, + reAuthCalls = 0, + revokeCookiesCalls = 0 + } + +mockAuthenticationSubsystemInterpreter :: + (Member (State MockAuthenticationState) r) => + InterpreterFor AuthenticationSubsystem r +mockAuthenticationSubsystemInterpreter = interpret \case + ReauthenticateEither {} -> do + modify \st -> st {reAuthCalls = st.reAuthCalls + 1} + pure $ Right () + RevokeCookies {} -> + modify \st -> st {revokeCookiesCalls = st.revokeCookiesCalls + 1} + EnforceVerificationCodeEither {} -> do + modify \st -> st {verificationCodeCalls = st.verificationCodeCalls + 1} + pure $ pure () + _ -> error "mockAuthenticationSubsystemInterpreter: implement on demand" diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/ClientStore.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/ClientStore.hs index ed8f85f4a9f..5c6918bfd9f 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/ClientStore.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/ClientStore.hs @@ -1,25 +1,128 @@ module Wire.MockInterpreters.ClientStore where +import Data.ByteString.Lazy qualified as LBS +import Data.Id +import Data.Map qualified as Map +import Data.Set qualified as Set import Imports import Polysemy +import Polysemy.State +import Wire.API.User.Client +import Wire.API.User.Client.Prekey +import Wire.API.UserMap import Wire.ClientStore +data StoredClient = StoredClient + { client :: Client, + prekeys :: [UncheckedPrekeyBundle] + } + +newtype ClientStoreState = ClientStoreState + { byUser :: Map UserId (Map ClientId StoredClient) + } + +emptyClientStoreState :: ClientStoreState +emptyClientStoreState = ClientStoreState mempty + runInMemoryClientStoreInterpreter :: InterpreterFor ClientStore r -runInMemoryClientStoreInterpreter = interpret $ \case - Upsert {} -> error "not implemented: Upsert" - Delete {} -> error "not implemented: Delete" - UpdateLabel {} -> error "not implemented: UpdateLabel" - UpdateCapabilities {} -> error "not implemented: UpdateCapabilities" - UpdateLastActive {} -> error "not implemented: UpdateLastActive" - LookupClient {} -> error "not implemented: LookupClient" - LookupClients {} -> error "not implemented: LookupClients" - LookupClientIds {} -> error "not implemented: LookupClientIds" - LookupClientIdsBulk {} -> error "not implemented: LookupClientIdsBulk" - LookupClientsBulk {} -> error "not implemented: LookupClientsBulk" - LookupPubClientsBulk {} -> error "not implemented: LookupPubClientsBulk" - LookupPrekeyIds {} -> error "not implemented: LookupPrekeyIds" - GetActivityTimestamps {} -> pure [] - UpdatePrekeys {} -> error "not implemented: UpdatePrekeys" - ClaimPrekey {} -> error "not implemented: ClaimPrekey" - AddMLSPublicKeys {} -> error "not implemented: AddMLSPublicKeys" - LookupMLSPublicKey {} -> error "not implemented: LookupMLSPublicKey" +runInMemoryClientStoreInterpreter = + evalState emptyClientStoreState . reinterpret handleClientStore + +runInMemoryClientStoreInterpreterWithState :: (Member (State ClientStoreState) r) => InterpreterFor ClientStore r +runInMemoryClientStoreInterpreterWithState = interpret handleClientStore + +handleClientStore :: (Member (State ClientStoreState) r) => ClientStore m a -> Sem r a +handleClientStore = \case + Upsert uid cid now new -> do + let client = + Client + { clientId = cid, + clientType = new.newClientType, + clientTime = now, + clientClass = new.newClientClass, + clientLabel = new.newClientLabel, + clientCookie = new.newClientCookie, + clientModel = new.newClientModel, + clientCapabilities = fromMaybe mempty new.newClientCapabilities, + clientMLSPublicKeys = new.newClientMLSPublicKeys, + clientLastActive = Nothing + } + stored = + StoredClient + { client, + prekeys = unpackLastPrekey new.newClientLastKey : new.newClientPrekeys + } + modify \st -> st {byUser = Map.alter (Just . Map.insert cid stored . fromMaybe mempty) uid st.byUser} + pure Nothing + Delete uid cid -> + modify \st -> st {byUser = Map.update (\clients -> Just $ Map.delete cid clients) uid st.byUser} + UpdateLabel uid cid label -> + modifyStoredClient uid cid \stored -> + stored {client = stored.client {clientLabel = label}} + UpdateCapabilities uid cid capabilities -> + modifyStoredClient uid cid \stored -> stored {client = stored.client {clientCapabilities = fromMaybe mempty capabilities}} + UpdateLastActive uid cid lastActive -> + modifyStoredClient uid cid \stored -> stored {client = stored.client {clientLastActive = Just lastActive}} + LookupClient uid cid -> + gets $ fmap (.client) . Map.lookup cid . Map.findWithDefault mempty uid . (.byUser) + LookupClients uid -> + gets $ map (.client) . Map.elems . Map.findWithDefault mempty uid . (.byUser) + LookupClientIds uid -> + gets $ Map.keys . Map.findWithDefault mempty uid . (.byUser) + LookupClientIdsBulk uids -> + gets $ \st -> + mkUserClients + [ (uid, Map.keys $ Map.findWithDefault mempty uid st.byUser) + | uid <- uids + ] + LookupClientsBulk uids -> + gets $ \st -> + UserMap $ + Map.fromList + [ (uid, Set.fromList $ map (.client) $ Map.elems $ Map.findWithDefault mempty uid st.byUser) + | uid <- uids + ] + LookupPubClientsBulk uids -> + gets $ \st -> + UserMap $ + Map.fromList + [ (uid, Set.fromList $ toPubClient . (.client) <$> Map.elems (Map.findWithDefault mempty uid st.byUser)) + | uid <- uids + ] + LookupPrekeyIds uid cid -> + gets $ maybe [] (map (.prekeyId) . (.prekeys)) . Map.lookup cid . Map.findWithDefault mempty uid . (.byUser) + GetActivityTimestamps uid -> + gets $ map (.client.clientLastActive) . Map.elems . Map.findWithDefault mempty uid . (.byUser) + UpdatePrekeys uid cid prekeys -> + modifyStoredClient uid cid \stored -> stored {prekeys} + ClaimPrekey uid cid -> do + mStored <- gets $ Map.lookup cid . Map.findWithDefault mempty uid . (.byUser) + case mStored of + Nothing -> pure Nothing + Just stored -> case stored.prekeys of + [] -> pure Nothing + prekey : rest -> do + modifyStoredClient uid cid \stored' -> stored' {prekeys = rest} + pure (Just (ClientPrekey cid prekey)) + AddMLSPublicKeys uid cid keys -> do + modifyStoredClient uid cid \stored -> + let merged = Map.union stored.client.clientMLSPublicKeys (Map.fromList keys) + in stored {client = stored.client {clientMLSPublicKeys = merged}} + pure Nothing + LookupMLSPublicKey uid cid scheme -> + gets $ + fmap (LBS.fromStrict) + . ( ( Map.lookup scheme + . (.client.clientMLSPublicKeys) + ) + <=< (Map.lookup cid . Map.findWithDefault mempty uid . (.byUser)) + ) + +modifyStoredClient :: + (Member (State ClientStoreState) r) => + UserId -> + ClientId -> + (StoredClient -> StoredClient) -> + Sem r () +modifyStoredClient uid cid update = + modify \st -> st {byUser = Map.adjust (Map.adjust update cid) uid st.byUser} diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/GalleyAPIAccess.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/GalleyAPIAccess.hs index d640690a650..2f08144ef81 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/GalleyAPIAccess.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/GalleyAPIAccess.hs @@ -26,7 +26,7 @@ import Data.Range import Imports import Polysemy import Wire.API.Conversation.Config (ConversationSubsystemConfig (..)) -import Wire.API.Team.Feature (AllTeamFeatures, IsFeatureConfig (..), LockableFeature (..), npProject') +import Wire.API.Team.Feature (AllTeamFeatures, FeatureStatus (..), IsFeatureConfig (..), LockableFeature (..), SndFactorPasswordChallengeConfig, npProject') import Wire.API.Team.FeatureFlags import Wire.API.Team.Member import Wire.API.Team.Member.Info (TeamMemberInfoList (..)) @@ -44,7 +44,7 @@ miniGalleyAPIAccess teams configs = interpret $ \case CreateSelfConv _ -> error "CreateSelfConv not implemented in miniGalleyAPIAccess" GetConv _ _ -> error "GetConv not implemented in miniGalleyAPIAccess" GetTeamConv {} -> error "GetTeamConv not implemented in miniGalleyAPIAccess" - NewClient _ _ -> error "NewClient not implemented in miniGalleyAPIAccess" + NewClient _ _ -> pure () CheckUserCanJoinTeam _ -> pure Nothing AddTeamMember {} -> error "AddTeamMember not implemented in miniGalleyAPIAccess" CreateTeam {} -> error "CreateTeam not implemented in miniGalleyAPIAccess" @@ -69,7 +69,11 @@ miniGalleyAPIAccess teams configs = interpret $ \case GetFeatureConfigForTeam tid -> pure $ getFeatureConfigForTeamImpl configs tid GetConfiguredFeatureFlags -> pure def - GetVerificationCodeEnabled _ -> error "GetVerificationCodeEnabled not implemented in miniGalleyAPIAccess" + GetVerificationCodeEnabled _ -> + pure $ + case npProject' (Proxy @SndFactorPasswordChallengeConfig) configs of + LockableFeature FeatureStatusEnabled _ _ -> True + LockableFeature FeatureStatusDisabled _ _ -> False GetExposeInvitationURLsToTeamAdmin _ -> pure ShowInvitationUrl IsMLSOne2OneEstablished _ _ -> error "IsMLSOne2OneEstablished not implemented in miniGalleyAPIAccess" UnblockConversation {} -> error "UnblockConversation not implemented in miniGalleyAPIAccess" @@ -88,6 +92,7 @@ miniGalleyAPIAccess teams configs = interpret $ \case maxConvSize = 500, listClientsUsingBrig = False } + GuardLegalHold {} -> pure () -- this is called but the result is not needed in unit tests selectTeamMemberInfosImpl :: Map TeamId [TeamMember] -> TeamId -> [UserId] -> TeamMemberInfoList diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/NotificationSubsystem.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/NotificationSubsystem.hs index 8c1bb637f45..6f3b30533d9 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/NotificationSubsystem.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/NotificationSubsystem.hs @@ -32,4 +32,4 @@ inMemoryNotificationSubsystemInterpreter = interpret \case CleanupUser {} -> error "CleanupUser: Implement on demand" UnregisterPushClient {} -> error "UnregisterPushClient: Implement on demand" GetPushTokens {} -> error "GetPushTokens: Implement on demand" - SetupConsumableNotifications {} -> error "SetupConsumableNotifications: Implement on demand" + SetupConsumableNotifications {} -> pure () diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserSubsystem.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserSubsystem.hs index caf83cc4f7b..c5feaeae032 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserSubsystem.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserSubsystem.hs @@ -65,11 +65,15 @@ inMemoryUserSubsystemInterpreter = IsBlocked _ -> pure False GetUserProfiles _ _ -> error "GetUserProfiles: implement on demand (userSubsystemInterpreter)" GetUserProfilesWithErrors _ _ -> error "GetUserProfilesWithErrors: implement on demand (userSubsystemInterpreter)" - GetLocalUserProfilesFiltered upf luids -> case upf of - Everything -> toProfile . mkUserFromStored testDomain testLocale <$$> UserStore.getUsers (tUnqualified luids) - _ -> error "GetLocalUserProfilesFiltered : unsupported filter (userSubsystemInterpreter)" + GetLocalUserProfiles luids -> + toProfile . mkUserFromStored testDomain testLocale + <$$> UserStore.getUsers (tUnqualified luids) + GetLocalAppProfiles _ -> + error "GetLocalAppProfiles: implement on demand (userSubsystemInterpreter)" GetAccountsBy (tUnqualified -> GetBy NoPendingInvitations True True uids []) -> mkUserFromStored testDomain testLocale <$$> UserStore.getUsers uids + GetAccountsBy (tUnqualified -> GetBy _ _ _ uids []) -> + mkUserFromStored testDomain testLocale <$$> UserStore.getUsers uids GetAccountsBy _ -> error "GetAccountsBy: implement on demand (userSubsystemInterpreter)" UpdateUserProfile {} -> error "UpdateUserProfile: implement on demand (userSubsystemInterpreter)" CheckHandle _ -> error "CheckHandle: implement on demand (userSubsystemInterpreter)" diff --git a/libs/wire-subsystems/test/unit/Wire/NotificationSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/NotificationSubsystem/InterpreterSpec.hs index 033c3ac7394..8a2c56fc69b 100644 --- a/libs/wire-subsystems/test/unit/Wire/NotificationSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/NotificationSubsystem/InterpreterSpec.hs @@ -103,7 +103,7 @@ spec = describe "NotificationSubsystem.Interpreter" do -- It's ok to use chunkPushes here because we're testing -- that separately chunkPushes mockConfig.chunkSize pushes - actualPushes `shouldBe` expectedPushes + Set.fromList actualPushes `shouldBe` Set.fromList expectedPushes it "respects maximum fanout limit" do let mockConfig = diff --git a/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs index 80f64d8a955..9f3eb8da2c9 100644 --- a/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs @@ -61,6 +61,7 @@ import Wire.API.User.Search import Wire.API.UserEvent import Wire.AppSubsystem import Wire.AuthenticationSubsystem.Error +import Wire.ClientSubsystem.Error (ClientError) import Wire.DomainRegistrationStore qualified as DRS import Wire.IndexedUserStore qualified as IU import Wire.InvitationStore (InsertInvitation, StoredInvitation) @@ -77,6 +78,7 @@ import Wire.UserSubsystem.Error import Wire.UserSubsystem.HandleBlacklist import Wire.UserSubsystem.Interpreter (UserSubsystemConfig (..)) import Wire.Util +import Wire.VerificationCodeSubsystem spec :: Spec spec = describe "UserSubsystem.Interpreter" do @@ -129,9 +131,11 @@ spec = describe "UserSubsystem.Interpreter" do localBackend = def {users = [viewer]} result = run + . runErrorUnsafe @ClientError . runErrorUnsafe @UserSubsystemError . runErrorUnsafe @AppSubsystemError . runErrorUnsafe @AuthenticationSubsystemError + . runErrorUnsafe @VerificationCodeSubsystemError . runErrorUnsafe @RateLimitExceeded . runErrorUnsafe @TeamCollaboratorsError . runError @FederationError diff --git a/libs/wire-subsystems/test/unit/Wire/Util.hs b/libs/wire-subsystems/test/unit/Wire/Util.hs index 0f0ffa7fa51..f658461a617 100644 --- a/libs/wire-subsystems/test/unit/Wire/Util.hs +++ b/libs/wire-subsystems/test/unit/Wire/Util.hs @@ -21,7 +21,9 @@ import Data.Text qualified as T import Data.Text.Encoding qualified as T import Imports import Test.QuickCheck +import Test.QuickCheck qualified as QC import Wire.API.User +import Wire.API.User.Client.Prekey -- | Quickcheck helper to generate the first part of an email address -- (@\@@) @@ -39,3 +41,76 @@ instance Arbitrary EmailUsername where -- | Generator to get any element from a NonEmpty list anyElementOf :: NonEmptyList a -> Gen a anyElementOf = elements . toList . getNonEmpty + +newtype FakeLastPrekey = FakeLastPrekey {unFakeLastPrekey :: LastPrekey} + deriving (Show, Eq, Generic, Ord) + +instance Arbitrary FakeLastPrekey where + arbitrary = FakeLastPrekey <$> QC.elements someLastPrekeys + +newtype FakePrekey = FakePrekey {unFakePrekey :: UncheckedPrekeyBundle} + deriving (Show, Eq, Generic) + +instance Arbitrary FakePrekey where + arbitrary = FakePrekey <$> QC.elements somePrekeys + +someLastPrekeys :: [LastPrekey] +someLastPrekeys = + lastPrekey + <$> [ "pQABARn//wKhAFggnCcZIK1pbtlJf4wRQ44h4w7/sfSgj5oWXMQaUGYAJ/sDoQChAFgglacihnqg/YQJHkuHNFU7QD6Pb3KN4FnubaCF2EVOgRkE9g==", + "pQABARn//wKhAFggwO2any+CjiGP8XFYrY67zHPvLgp+ysY5k7vci57aaLwDoQChAFgglacihnqg/YQJHkuHNFU7QD6Pb3KN4FnubaCF2EVOgRkE9g==", + "pQABARn//wKhAFggoChErA5oTI5JT769hJV+VINmU8kougGdYqGd2U7hPa8DoQChAFgglacihnqg/YQJHkuHNFU7QD6Pb3KN4FnubaCF2EVOgRkE9g==", + "pQABARn//wKhAFggPLk4BBJ8THVLGm7r0K7EJITRlJnt6bpNzM9GTNRYcCcDoQChAFgglacihnqg/YQJHkuHNFU7QD6Pb3KN4FnubaCF2EVOgRkE9g==", + "pQABARn//wKhAFggqHASsRlZ1i8dESXRXBL2OvR+0yGUtqK9vJfzol1E+osDoQChAFgglacihnqg/YQJHkuHNFU7QD6Pb3KN4FnubaCF2EVOgRkE9g==", + "pQABARn//wKhAFggx/N1YhKXSJYJQxhWgHSA4ASaJKIHDJfmEnojfnp9VQ8DoQChAFgglacihnqg/YQJHkuHNFU7QD6Pb3KN4FnubaCF2EVOgRkE9g==", + "pQABARn//wKhAFggVL6QIpoqmtKxmB8HToiAPxfjSDEzJEUAoFKfhXou06YDoQChAFgglacihnqg/YQJHkuHNFU7QD6Pb3KN4FnubaCF2EVOgRkE9g==", + "pQABARn//wKhAFggRs74/ViOrHN+aS2RbGCwC0sJv1Sp/Q0pmRB15s9DCBMDoQChAFgglacihnqg/YQJHkuHNFU7QD6Pb3KN4FnubaCF2EVOgRkE9g==", + "pQABARn//wKhAFggtNO/hrwzt9M/1X6eK2sG6YFmA7BDqlFMEipbZOsg0vcDoQChAFgglacihnqg/YQJHkuHNFU7QD6Pb3KN4FnubaCF2EVOgRkE9g==", + "pQABARn//wKhAFgg1rZEY6vbAnEz+Ern5kRny/uKiIrXTb/usQxGnceV2HADoQChAFgglacihnqg/YQJHkuHNFU7QD6Pb3KN4FnubaCF2EVOgRkE9g==", + "pQABARn//wKhAFgg2647mOAVeOdhW57Q1zXDigDxRz/hB8ITFSZ7uo+pXH4DoQChAFgglacihnqg/YQJHkuHNFU7QD6Pb3KN4FnubaCF2EVOgRkE9g==", + "pQABARn//wKhAFggjddbHizABYOY0T6rvJeZCvV20dvTT9BYv95ri9bqSb8DoQChAFgglacihnqg/YQJHkuHNFU7QD6Pb3KN4FnubaCF2EVOgRkE9g==", + "pQABARn//wKhAFggCKT/GspZquUY6vKC4TFvaFqTH1QGG1ptauiaulnfqkUDoQChAFgglacihnqg/YQJHkuHNFU7QD6Pb3KN4FnubaCF2EVOgRkE9g==", + "pQABARn//wKhAFggv7bf/kEsTKFDGSgswsywq6AIxBq5AqZbLjDYDHfGjrcDoQChAFgglacihnqg/YQJHkuHNFU7QD6Pb3KN4FnubaCF2EVOgRkE9g==", + "pQABARn//wKhAFggUbjGhhh8EwZEPSz+Y31rYNUu7jsRR8dy1F5FSiJXfXEDoQChAFgglacihnqg/YQJHkuHNFU7QD6Pb3KN4FnubaCF2EVOgRkE9g==", + "pQABARn//wKhAFgg/4nz1uHiPBVGFvYjTMwGQ31bSFNctbU0r2nBtpsK9kcDoQChAFgglacihnqg/YQJHkuHNFU7QD6Pb3KN4FnubaCF2EVOgRkE9g==", + "pQABARn//wKhAFggwbJDyKl7T3+3Ihc0YF06Dz2J11My5qn7JKG+U+ti8lQDoQChAFgglacihnqg/YQJHkuHNFU7QD6Pb3KN4FnubaCF2EVOgRkE9g==", + "pQABARn//wKhAFgglc6nCoZR2/qjLp0tr7vRyuXqb7ugdHHDadjX7zSl4uMDoQChAFgglacihnqg/YQJHkuHNFU7QD6Pb3KN4FnubaCF2EVOgRkE9g==", + "pQABARn//wKhAFgg5ER8h0/bIADXjBXe/XPKdzekgv6nhJ4hp3vJ3jtTSbUDoQChAFgglacihnqg/YQJHkuHNFU7QD6Pb3KN4FnubaCF2EVOgRkE9g==", + "pQABARn//wKhAFggsgV6jq+GuNuvXk+ctHh570cNqEmfPhz34wcYCMCf9xIDoQChAFgglacihnqg/YQJHkuHNFU7QD6Pb3KN4FnubaCF2EVOgRkE9g==", + "pQABARn//wKhAFggdQdlPqkBw6+phKhohp3YaWQL710euZDnyMLFwf2cS0oDoQChAFgglacihnqg/YQJHkuHNFU7QD6Pb3KN4FnubaCF2EVOgRkE9g==", + "pQABARn//wKhAFggKlsI/snuQMoYcZRw/kN+BobPV5gwYeBClp0Wx9btTGUDoQChAFgglacihnqg/YQJHkuHNFU7QD6Pb3KN4FnubaCF2EVOgRkE9g==", + "pQABARn//wKhAFggtruFBClEgdPKvjpHsYLlWMev9L4OmYZwlxbY0NwvzOwDoQChAFgglacihnqg/YQJHkuHNFU7QD6Pb3KN4FnubaCF2EVOgRkE9g==", + "pQABARn//wKhAFggRUdh4cuYtFNL46RLnPy65goYInyreStKwsEcY3pPlLkDoQChAFgglacihnqg/YQJHkuHNFU7QD6Pb3KN4FnubaCF2EVOgRkE9g==", + "pQABARn//wKhAFggQtT7lLZzH171F4jCbHNwxEAt28FwdQ8Kt2tbxFzPgC0DoQChAFgglacihnqg/YQJHkuHNFU7QD6Pb3KN4FnubaCF2EVOgRkE9g==", + "pQABARn//wKhAFggQeUPM119c+6zRsEupA8zshTfrZiLpXx1Ji0UMMumq9IDoQChAFgglacihnqg/YQJHkuHNFU7QD6Pb3KN4FnubaCF2EVOgRkE9g==" + ] + +somePrekeys :: [UncheckedPrekeyBundle] +somePrekeys = + [ UncheckedPrekeyBundle (PrekeyId 1) "pQABAQECoQBYIOjl7hw0D8YRNqkkBQETCxyr7/ywE/2R5RWcUPM+GJACA6EAoQBYILLf1TIwSB62q69Ojs/X1tzJ+dYHNAw4QbW/7TC5vSZqBPY=", + UncheckedPrekeyBundle (PrekeyId 2) "pQABAQICoQBYIGoXawUQWQ9ZW+MXhvuo9ALOBUjLff8S5VdAokN29C1OA6EAoQBYILLf1TIwSB62q69Ojs/X1tzJ+dYHNAw4QbW/7TC5vSZqBPY=", + UncheckedPrekeyBundle (PrekeyId 3) "pQABAQMCoQBYIEjdt+YWd3lHmG8pamULLMubAMZw556IO8kW7s1MLFytA6EAoQBYILLf1TIwSB62q69Ojs/X1tzJ+dYHNAw4QbW/7TC5vSZqBPY=", + UncheckedPrekeyBundle (PrekeyId 4) "pQABAQQCoQBYIPIaOA3Xqfk4Lh2/pU88Owd2eW5eplHpywr+Mx4QGyiMA6EAoQBYILLf1TIwSB62q69Ojs/X1tzJ+dYHNAw4QbW/7TC5vSZqBPY=", + UncheckedPrekeyBundle (PrekeyId 5) "pQABAQUCoQBYIHnafNR4Gh3ID71lYzToewEVag4EKskDFq+gaeraOlSJA6EAoQBYILLf1TIwSB62q69Ojs/X1tzJ+dYHNAw4QbW/7TC5vSZqBPY=", + UncheckedPrekeyBundle (PrekeyId 6) "pQABAQYCoQBYIFXUkVftE7kK22waAzhOjOmJVex3EBTU8RHZFx2o1Ed8A6EAoQBYILLf1TIwSB62q69Ojs/X1tzJ+dYHNAw4QbW/7TC5vSZqBPY=", + UncheckedPrekeyBundle (PrekeyId 7) "pQABAQcCoQBYIDXdN8VlKb5lbgPmoDPLPyqNIEyShG4oT/DlW0peRRZUA6EAoQBYILLf1TIwSB62q69Ojs/X1tzJ+dYHNAw4QbW/7TC5vSZqBPY=", + UncheckedPrekeyBundle (PrekeyId 8) "pQABAQgCoQBYIJH1ewvIVV3yGqQvdr/QM9HARzMgo5ksOTRyKEuN2aZzA6EAoQBYILLf1TIwSB62q69Ojs/X1tzJ+dYHNAw4QbW/7TC5vSZqBPY=", + UncheckedPrekeyBundle (PrekeyId 9) "pQABAQkCoQBYIFcAnXdx0M1Q1hoDDfgMK9r+Zchn8YlVHHaQwQYhRk1dA6EAoQBYILLf1TIwSB62q69Ojs/X1tzJ+dYHNAw4QbW/7TC5vSZqBPY=", + UncheckedPrekeyBundle (PrekeyId 10) "pQABAQoCoQBYIGs3vyxwmzEZ+qKNy4wpFkxc+Bgkb0D76ZEbxeeh/9DVA6EAoQBYILLf1TIwSB62q69Ojs/X1tzJ+dYHNAw4QbW/7TC5vSZqBPY=", + UncheckedPrekeyBundle (PrekeyId 11) "pQABAQsCoQBYIGUiBeOJALP5dkMduUZ/u6MDhHNrsrBUa3f0YlSSWZbzA6EAoQBYILLf1TIwSB62q69Ojs/X1tzJ+dYHNAw4QbW/7TC5vSZqBPY=", + UncheckedPrekeyBundle (PrekeyId 12) "pQABAQwCoQBYIMp6QNNTPDZgL3DSSD/QWWnBI7LsTZp2RhY/HLqnIwRZA6EAoQBYILLf1TIwSB62q69Ojs/X1tzJ+dYHNAw4QbW/7TC5vSZqBPY=", + UncheckedPrekeyBundle (PrekeyId 13) "pQABAQ0CoQBYIJXSSUrE5RCNyB5pg+m6vGwK7RvJ+rs9dsdHitxnfDhuA6EAoQBYILLf1TIwSB62q69Ojs/X1tzJ+dYHNAw4QbW/7TC5vSZqBPY=", + UncheckedPrekeyBundle (PrekeyId 14) "pQABAQ4CoQBYIHmtOX7jCKBHFDysb4H0z/QWoCSaEyjerZaT/HOP8bgDA6EAoQBYILLf1TIwSB62q69Ojs/X1tzJ+dYHNAw4QbW/7TC5vSZqBPY=", + UncheckedPrekeyBundle (PrekeyId 15) "pQABAQ8CoQBYIIaMCTcPKj2HuYQ7i9ZaxUw9j5Bz8TPjoAaTZ5eB0w1kA6EAoQBYILLf1TIwSB62q69Ojs/X1tzJ+dYHNAw4QbW/7TC5vSZqBPY=", + UncheckedPrekeyBundle (PrekeyId 16) "pQABARACoQBYIHWAOacKuWH81moJVveJ0FSfipWocfspOIBhaU6VLWUsA6EAoQBYILLf1TIwSB62q69Ojs/X1tzJ+dYHNAw4QbW/7TC5vSZqBPY=", + UncheckedPrekeyBundle (PrekeyId 17) "pQABARECoQBYIA8XtUXtnMxQslULnNAeHBIivlLRe/+qdh2j6nTfDAchA6EAoQBYILLf1TIwSB62q69Ojs/X1tzJ+dYHNAw4QbW/7TC5vSZqBPY=", + UncheckedPrekeyBundle (PrekeyId 18) "pQABARICoQBYIGgzg6SzgTTOgnk48pa6y2Rgjy004DkeBo4CMld3Jlr6A6EAoQBYILLf1TIwSB62q69Ojs/X1tzJ+dYHNAw4QbW/7TC5vSZqBPY=", + UncheckedPrekeyBundle (PrekeyId 19) "pQABARMCoQBYIEoEFiIpCHgn74CAD+GhIfIgbQtdCqQqkOXHWxRlG6Y6A6EAoQBYILLf1TIwSB62q69Ojs/X1tzJ+dYHNAw4QbW/7TC5vSZqBPY=", + UncheckedPrekeyBundle (PrekeyId 20) "pQABARQCoQBYINVEwTRxNSe0rxZxon4Rifz2l4rtQZn7mHtKYCiFAK9IA6EAoQBYILLf1TIwSB62q69Ojs/X1tzJ+dYHNAw4QbW/7TC5vSZqBPY=", + UncheckedPrekeyBundle (PrekeyId 21) "pQABARUCoQBYIN3aeX2Ayi2rPFbiaYb+O2rdHUpFhzRs2j28pCmbGpflA6EAoQBYILLf1TIwSB62q69Ojs/X1tzJ+dYHNAw4QbW/7TC5vSZqBPY=", + UncheckedPrekeyBundle (PrekeyId 22) "pQABARYCoQBYIJe5OJ17YKQrNmIH3sE++r++4Z5ld36axqAMjjQ3jtQWA6EAoQBYILLf1TIwSB62q69Ojs/X1tzJ+dYHNAw4QbW/7TC5vSZqBPY=", + UncheckedPrekeyBundle (PrekeyId 23) "pQABARcCoQBYIASE94LjK6Raipk/lN/YewouqO+kcQGpxIqP+iW2hyHiA6EAoQBYILLf1TIwSB62q69Ojs/X1tzJ+dYHNAw4QbW/7TC5vSZqBPY=", + UncheckedPrekeyBundle (PrekeyId 24) "pQABARgYAqEAWCBZ222LpS6/99Btlw+83PihrA655skwsNevt//8oz5axQOhAKEAWCCy39UyMEgetquvTo7P19bcyfnWBzQMOEG1v+0wub0magT2", + UncheckedPrekeyBundle (PrekeyId 25) "pQABARgZAqEAWCDGEwo61w4O8T8lyw0HdoOjGWBKQUNqo6+jSfrPR9alrAOhAKEAWCCy39UyMEgetquvTo7P19bcyfnWBzQMOEG1v+0wub0magT2", + UncheckedPrekeyBundle (PrekeyId 26) "pQABARgaAqEAWCBMSQoQ6B35plB80i1O3AWlJSftCEbCbju97Iykg5+NWQOhAKEAWCCy39UyMEgetquvTo7P19bcyfnWBzQMOEG1v+0wub0magT2" + ] diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index 87830c3837d..546a155cb3c 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -91,6 +91,8 @@ common common-all , amazonka-ses , amazonka-sqs , amqp + , asn1-encoding + , asn1-types , async , attoparsec , base @@ -108,6 +110,7 @@ common common-all , contravariant , cql , crypton + , crypton-pem , currency-codes , data-default , data-timeout @@ -140,6 +143,7 @@ common common-all , iproute , iso639 , lens + , lens-aeson , lrucaching , memory , mime @@ -232,6 +236,7 @@ library Wire.ClientStore.Cassandra Wire.ClientStore.DynamoDB Wire.ClientSubsystem + Wire.ClientSubsystem.Error Wire.ClientSubsystem.Interpreter Wire.CodeStore Wire.CodeStore.Cassandra @@ -330,6 +335,8 @@ library Wire.MigrationLock Wire.NotificationSubsystem Wire.NotificationSubsystem.Interpreter + Wire.Options.Galley + Wire.Options.Keys Wire.PaginationState Wire.ParseException Wire.PasswordResetCodeStore @@ -529,6 +536,7 @@ test-suite wire-subsystems-tests Wire.ActivationCodeStore.InterpreterSpec Wire.AuthenticationSubsystem.InterpreterSpec Wire.BrigAPIAccess.RpcSpec + Wire.ClientSubsystem.InterpreterSpec Wire.EnterpriseLoginSubsystem.InterpreterSpec Wire.FederationSubsystem.InternalsSpec Wire.HashPassword.InterpreterSpec @@ -538,6 +546,7 @@ test-suite wire-subsystems-tests Wire.MockInterpreters Wire.MockInterpreters.ActivationCodeStore Wire.MockInterpreters.AppStore + Wire.MockInterpreters.AuthenticationSubsystem Wire.MockInterpreters.BackgroundJobPublisher Wire.MockInterpreters.BlockListStore Wire.MockInterpreters.ClientStore diff --git a/nix/local-haskell-packages.nix b/nix/local-haskell-packages.nix index 2e065b6d403..c1cc9ce6a3e 100644 --- a/nix/local-haskell-packages.nix +++ b/nix/local-haskell-packages.nix @@ -5,7 +5,6 @@ { gitignoreSource }: hsuper: hself: { integration = hself.callPackage ../integration/default.nix { inherit gitignoreSource; }; bilge = hself.callPackage ../libs/bilge/default.nix { inherit gitignoreSource; }; - brig-types = hself.callPackage ../libs/brig-types/default.nix { inherit gitignoreSource; }; cargohold-types = hself.callPackage ../libs/cargohold-types/default.nix { inherit gitignoreSource; }; cassandra-util = hself.callPackage ../libs/cassandra-util/default.nix { inherit gitignoreSource; }; deriving-swagger2 = hself.callPackage ../libs/deriving-swagger2/default.nix { inherit gitignoreSource; }; @@ -60,7 +59,6 @@ entreprise-provisioning = hself.callPackage ../tools/entreprise-provisioning/default.nix { inherit gitignoreSource; }; mlsstats = hself.callPackage ../tools/mlsstats/default.nix { inherit gitignoreSource; }; rabbitmq-consumer = hself.callPackage ../tools/rabbitmq-consumer/default.nix { inherit gitignoreSource; }; - rex = hself.callPackage ../tools/rex/default.nix { inherit gitignoreSource; }; stern = hself.callPackage ../tools/stern/default.nix { inherit gitignoreSource; }; test-stats = hself.callPackage ../tools/test-stats/default.nix { inherit gitignoreSource; }; } diff --git a/services/background-worker/background-worker.cabal b/services/background-worker/background-worker.cabal index 67f15e28abc..e6433d047c5 100644 --- a/services/background-worker/background-worker.cabal +++ b/services/background-worker/background-worker.cabal @@ -121,6 +121,7 @@ executable background-worker background-worker , HsOpenSSL , imports + , optparse-applicative , types-common hs-source-dirs: exec diff --git a/services/background-worker/background-worker.integration.yaml b/services/background-worker/background-worker.integration.yaml index 167dfc498b9..eaee5a414c4 100644 --- a/services/background-worker/background-worker.integration.yaml +++ b/services/background-worker/background-worker.integration.yaml @@ -24,33 +24,18 @@ cassandra: port: 9042 keyspace: gundeck_test -cassandraGalley: - endpoint: - host: 127.0.0.1 - port: 9042 - keyspace: galley_test - cassandraBrig: endpoint: host: 127.0.0.1 port: 9042 keyspace: brig_test -postgresql: - host: 127.0.0.1 - port: "5432" - user: wire-server - dbname: backendA - password: posty-the-gres - postgresqlPool: size: 5 acquisitionTimeout: 10s agingTimeout: 1d idlenessTimeout: 10m -federationDomain: example.org - rabbitmq: host: 127.0.0.1 port: 5671 diff --git a/services/background-worker/default.nix b/services/background-worker/default.nix index df8fcd9b573..6137da6af87 100644 --- a/services/background-worker/default.nix +++ b/services/background-worker/default.nix @@ -30,6 +30,7 @@ , lib , metrics-wai , monad-control +, optparse-applicative , polysemy , polysemy-conc , polysemy-wire-zoo @@ -103,7 +104,12 @@ mkDerivation { wire-api-federation wire-subsystems ]; - executableHaskellDepends = [ HsOpenSSL imports types-common ]; + executableHaskellDepends = [ + HsOpenSSL + imports + optparse-applicative + types-common + ]; testHaskellDepends = [ aeson amqp diff --git a/services/background-worker/exec/Main.hs b/services/background-worker/exec/Main.hs index 81f3dd4706d..ab40ecaa8f2 100644 --- a/services/background-worker/exec/Main.hs +++ b/services/background-worker/exec/Main.hs @@ -19,12 +19,37 @@ module Main where import Imports import OpenSSL (withOpenSSL) +import Options.Applicative import Util.Options import Wire.BackgroundWorker +configPathsParser :: FilePath -> FilePath -> Parser (FilePath, FilePath) +configPathsParser backgroundWorkerConfigPath defaultGalleyConfigPath = + (,) + <$> strOption + ( long "config-file" + <> short 'c' + <> help "Config file to load" + <> showDefault + <> value backgroundWorkerConfigPath + ) + <*> strOption + ( long "galley-config-file" + <> help "Galley config file to load" + <> showDefault + <> value defaultGalleyConfigPath + ) + main :: IO () main = withOpenSSL $ do let desc = "Background Worker" - defaultPath = "/etc/wire/background-worker/conf/background-worker.yaml" - options <- getOptions desc Nothing defaultPath - run options + backgroundWorkerConfigPath = "/etc/wire/background-worker/conf/background-worker.yaml" + defaultGalleyConfigPath = "/etc/wire/galley/conf/galley.yaml" + (config, galleyConfig) <- + execParser + $ info + (configPathsParser backgroundWorkerConfigPath defaultGalleyConfigPath <**> helper) + (header desc <> fullDesc) + backgroundWorkerOptions <- decodeConfigFile config + galleyOptions <- decodeConfigFile galleyConfig + run backgroundWorkerOptions galleyOptions diff --git a/services/background-worker/src/Wire/BackendNotificationPusher.hs b/services/background-worker/src/Wire/BackendNotificationPusher.hs index 938f5efdacb..cadce5c0270 100644 --- a/services/background-worker/src/Wire/BackendNotificationPusher.hs +++ b/services/background-worker/src/Wire/BackendNotificationPusher.hs @@ -136,7 +136,7 @@ pushNotification runningFlag targetDomain (msg, envelope) = do UnliftIO.bracket_ (takeMVar runningFlag) (putMVar runningFlag ()) go where go :: AppT IO () - go = case A.eitherDecode @(PayloadBundle _) (Q.msgBody msg) of + go = case A.eitherDecode @(PayloadBundle 'Brig) (Q.msgBody msg) of Left e -> do case A.eitherDecode @BackendNotification (Q.msgBody msg) of Left eBN -> do diff --git a/services/background-worker/src/Wire/BackgroundWorker.hs b/services/background-worker/src/Wire/BackgroundWorker.hs index c5e16331ede..e89ed926f43 100644 --- a/services/background-worker/src/Wire/BackgroundWorker.hs +++ b/services/background-worker/src/Wire/BackgroundWorker.hs @@ -35,11 +35,12 @@ import Wire.BackgroundWorker.Jobs.Consumer qualified as Jobs import Wire.BackgroundWorker.Options import Wire.DeadUserNotificationWatcher qualified as DeadUserNotificationWatcher import Wire.Migration +import Wire.Options.Galley qualified as Galley import Wire.PostgresMigrations qualified as Migrations -run :: Opts -> IO () -run opts = do - env <- mkEnv opts +run :: Opts -> Galley.Opts -> IO () +run opts galleyOpts = do + env <- mkEnv opts galleyOpts let amqpEP = either id demoteOpts opts.rabbitmq.unRabbitMqOpts cleanupBackendNotifPusher <- runAppT env $ diff --git a/services/background-worker/src/Wire/BackgroundWorker/Env.hs b/services/background-worker/src/Wire/BackgroundWorker/Env.hs index 4af2a9df1bc..20dc97d1263 100644 --- a/services/background-worker/src/Wire/BackgroundWorker/Env.hs +++ b/services/background-worker/src/Wire/BackgroundWorker/Env.hs @@ -44,6 +44,7 @@ import System.Logger.Class (Logger, MonadLogger (..)) import System.Logger.Extended qualified as Log import Util.Options import Wire.BackgroundWorker.Options +import Wire.Options.Galley qualified as Galley import Wire.PostgresMigrationOpts type IsWorking = Bool @@ -106,11 +107,11 @@ mkWorkerRunningGauge :: IO (Vector Text Gauge) mkWorkerRunningGauge = register (vector "worker" $ gauge $ Prometheus.Info "wire_background_worker_running_workers" "Set to 1 when a worker is running") -mkEnv :: Opts -> IO Env -mkEnv opts = do +mkEnv :: Opts -> Galley.Opts -> IO Env +mkEnv opts galleyOpts = do logger <- Log.mkLogger opts.logLevel Nothing opts.logFormat cassandra <- defInitCassandra opts.cassandra =<< setLoggerName "cassandra-gundeck" logger - cassandraGalley <- defInitCassandra opts.cassandraGalley =<< setLoggerName "cassandra-galley" logger + cassandraGalley <- defInitCassandra galleyOpts._cassandra =<< setLoggerName "cassandra-galley" logger cassandraBrig <- defInitCassandra opts.cassandraBrig =<< setLoggerName "cassandra-brig" logger http2Manager <- initHttp2Manager httpManager <- newManager defaultManagerSettings @@ -131,14 +132,14 @@ mkEnv opts = do backendNotificationMetrics <- mkBackendNotificationMetrics let backendNotificationsConfig = opts.backendNotificationPusher backgroundJobsConfig = opts.backgroundJobs - federationDomain = opts.federationDomain + federationDomain = galleyOpts._settings._federationDomain postgresMigration = opts.postgresMigration brigEndpoint = opts.brig galleyEndpoint = opts.galley gundeckEndpoint = opts.gundeck sparEndpoint = opts.spar workerRunningGauge <- mkWorkerRunningGauge - hasqlPool <- initPostgresPool opts.postgresqlPool opts.postgresql opts.postgresqlPassword + hasqlPool <- initPostgresPool opts.postgresqlPool galleyOpts._postgresql galleyOpts._postgresqlPassword amqpJobsPublisherChannel <- mkRabbitMqChannelMVar logger (Just "background-worker-jobs-publisher") $ either id demoteOpts opts.rabbitmq.unRabbitMqOpts diff --git a/services/background-worker/src/Wire/BackgroundWorker/Jobs/Registry.hs b/services/background-worker/src/Wire/BackgroundWorker/Jobs/Registry.hs index d9ae7db190f..4c13bf2d047 100644 --- a/services/background-worker/src/Wire/BackgroundWorker/Jobs/Registry.hs +++ b/services/background-worker/src/Wire/BackgroundWorker/Jobs/Registry.hs @@ -59,6 +59,7 @@ import Wire.BackgroundJobsRunner (runJob) import Wire.BackgroundJobsRunner.Interpreter hiding (runJob) import Wire.BackgroundWorker.Env (AppT, Env (..)) import Wire.BrigAPIAccess.Rpc +import Wire.ClientSubsystem.Error (ClientError) import Wire.ConversationStore.Cassandra import Wire.ConversationStore.Postgres (interpretConversationStoreToPostgres) import Wire.ConversationSubsystem.Interpreter (interpretConversationSubsystem) @@ -180,6 +181,7 @@ dispatchJob job = do . interpretRace . runDelay . runError + . mapError @ClientError (T.pack . displayException) . mapError @FederationError (T.pack . displayException) . mapError @UsageError (T.pack . show) . mapError @ParseException (T.pack . displayException) diff --git a/services/background-worker/src/Wire/BackgroundWorker/Options.hs b/services/background-worker/src/Wire/BackgroundWorker/Options.hs index 981fc7538d7..c616d1e5a4e 100644 --- a/services/background-worker/src/Wire/BackgroundWorker/Options.hs +++ b/services/background-worker/src/Wire/BackgroundWorker/Options.hs @@ -18,7 +18,6 @@ module Wire.BackgroundWorker.Options where import Data.Aeson -import Data.Domain (Domain) import Data.Misc import Data.Range (Range) import GHC.Generics @@ -44,20 +43,14 @@ data Opts = Opts defederationTimeout :: Maybe Int, backendNotificationPusher :: BackendNotificationsConfig, cassandra :: CassandraOpts, - cassandraGalley :: CassandraOpts, cassandraBrig :: CassandraOpts, - -- | Postgresql settings, the key values must be in libpq format. - -- https://www.postgresql.org/docs/17/libpq-connect.html#LIBPQ-PARAMKEYWORDS - postgresql :: !(Map Text Text), - postgresqlPassword :: !(Maybe FilePathSecrets), postgresqlPool :: !PoolConfig, postgresMigration :: !PostgresMigrationOpts, migrateConversations :: !Bool, migrateConversationsOptions :: !MigrationOptions, migrateConversationCodes :: !Bool, migrateTeamFeatures :: !Bool, - backgroundJobs :: BackgroundJobsConfig, - federationDomain :: Domain + backgroundJobs :: BackgroundJobsConfig } deriving (Show, Generic) deriving (FromJSON) via Generically Opts diff --git a/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs b/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs index bb326d7ff0d..30a9c045733 100644 --- a/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs +++ b/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs @@ -419,6 +419,10 @@ spec = do -- Wait for first call untilM (readTVarIO mockAdmin.listQueuesVHostCalls >>= \calls -> pure $ not $ null calls) + -- Wait a bit to ensure at least one retry happens while the API is still broken + -- The retry policy uses exponential backoff starting at 10ms, so 50ms should be enough + threadDelay 50000 + -- Unbreak the API atomically $ writeTVar mockAdmin.broken False diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal index 5950ef6270e..1f711c37aec 100644 --- a/services/brig/brig.cabal +++ b/services/brig/brig.cabal @@ -77,7 +77,6 @@ library -- cabal-fmt: expand src exposed-modules: Brig.API.Auth - Brig.API.Client Brig.API.Connection Brig.API.Connection.Remote Brig.API.Connection.Util @@ -105,7 +104,6 @@ library Brig.Calling.Internal Brig.CanonicalInterpreter Brig.Data.Activation - Brig.Data.Client Brig.Data.Connection Brig.Data.MLS.KeyPackage Brig.Data.Nonce @@ -119,7 +117,6 @@ library Brig.Effects.SFT Brig.Effects.UserPendingActivationStore Brig.Effects.UserPendingActivationStore.Cassandra - Brig.Federation.Client Brig.Index.Eval Brig.Index.Options Brig.Index.Types @@ -134,6 +131,7 @@ library Brig.Provider.DB Brig.Provider.Email Brig.Provider.RPC + Brig.Provider.Tag Brig.Provider.Template Brig.Queue Brig.Queue.Stomp @@ -197,6 +195,7 @@ library Brig.User.API.Handle Brig.User.Auth Brig.User.Auth.Cookie + Brig.User.Client Brig.User.EJPD Brig.User.Search.Index Brig.User.Search.SearchIndex @@ -223,7 +222,6 @@ library , base64-bytestring >=1.0 , bilge >=0.21.1 , bloodhound >=0.13 - , brig-types >=0.91.1 , bytestring >=0.10 , bytestring-conversion >=0.2 , cassandra-util >=0.16.2 @@ -263,7 +261,6 @@ library , jose , jwt-tools , lens >=3.8 - , lens-aeson >=1.0 , memory , metrics-core >=0.3 , metrics-wai >=0.3 @@ -293,15 +290,12 @@ library , servant-openapi3 , servant-server , servant-swagger-ui - , split >=0.2 , ssl-util , stomp-queue >=0.3 , template >=0.2 , template-haskell , text >=0.11 , time >=1.1 - , time-out - , time-units , tinylog >=0.10 , transformers >=0.3 , types-common >=0.16 @@ -391,7 +385,6 @@ executable brig-integration , bilge , bloodhound , brig - , brig-types , bytestring >=0.9 , bytestring-conversion , case-insensitive @@ -512,7 +505,6 @@ test-suite brig-tests , base , binary , brig - , brig-types , bytestring , containers , data-timeout diff --git a/services/brig/default.nix b/services/brig/default.nix index c567f842ebb..447c430910d 100644 --- a/services/brig/default.nix +++ b/services/brig/default.nix @@ -19,7 +19,6 @@ , bilge , binary , bloodhound -, brig-types , bytestring , bytestring-conversion , case-insensitive @@ -111,7 +110,6 @@ , servant-server , servant-swagger-ui , spar -, split , ssl-util , stomp-queue , streaming-commons @@ -126,7 +124,6 @@ , temporary , text , time -, time-out , time-units , tinylog , transformers @@ -173,7 +170,6 @@ mkDerivation { base64-bytestring bilge bloodhound - brig-types bytestring bytestring-conversion cassandra-util @@ -213,7 +209,6 @@ mkDerivation { jose jwt-tools lens - lens-aeson memory metrics-core metrics-wai @@ -243,15 +238,12 @@ mkDerivation { servant-openapi3 servant-server servant-swagger-ui - split ssl-util stomp-queue template template-haskell text time - time-out - time-units tinylog transformers types-common @@ -280,7 +272,6 @@ mkDerivation { base16-bytestring bilge bloodhound - brig-types bytestring bytestring-conversion case-insensitive @@ -370,7 +361,6 @@ mkDerivation { aeson base binary - brig-types bytestring containers data-timeout diff --git a/services/brig/src/Brig/API/Auth.hs b/services/brig/src/Brig/API/Auth.hs index d551cb7ea27..b47366621fc 100644 --- a/services/brig/src/Brig/API/Auth.hs +++ b/services/brig/src/Brig/API/Auth.hs @@ -52,7 +52,7 @@ import Wire.ActivationCodeStore (ActivationCodeStore) import Wire.AuthenticationSubsystem import Wire.AuthenticationSubsystem qualified as Authentication import Wire.AuthenticationSubsystem.Config -import Wire.AuthenticationSubsystem.Error (zauthError) +import Wire.AuthenticationSubsystem.Error import Wire.AuthenticationSubsystem.ZAuth import Wire.BlockListStore import Wire.ClientStore (ClientStore) @@ -73,7 +73,6 @@ import Wire.UserSubsystem (UpdateOriginType (..), UserSubsystem) import Wire.UserSubsystem qualified as User import Wire.UserSubsystem.Error import Wire.UserSubsystem.UserSubsystemConfig -import Wire.VerificationCodeSubsystem (VerificationCodeSubsystem) accessH :: ( Member TinyLog r, @@ -134,15 +133,13 @@ sendLoginCode _ = throwStd (errorToWai @'E.InvalidPhone) login :: - ( Member GalleyAPIAccess r, - Member TinyLog r, + ( Member TinyLog r, Member UserKeyStore r, Member UserStore r, Member Events r, Member (Input (Local ())) r, Member UserSubsystem r, Member ActivationCodeStore r, - Member VerificationCodeSubsystem r, Member AuthenticationSubsystem r, Member (Input AuthenticationSubsystemConfig) r, Member (Concurrency Unsafe) r, @@ -286,11 +283,7 @@ getLoginCode :: Phone -> Handler r PendingLoginCode getLoginCode _ = throwStd loginCodeNotFound reauthenticate :: - ( Member GalleyAPIAccess r, - Member VerificationCodeSubsystem r, - Member AuthenticationSubsystem r, - Member UserSubsystem r - ) => + (Member AuthenticationSubsystem r) => Local UserId -> ReAuthUser -> Handler r () @@ -299,11 +292,12 @@ reauthenticate luid@(tUnqualified -> uid) body = do >>= either (throwE . reauthError) (const $ pure ()) case reAuthCodeAction body of Just action -> - Auth.verifyCode (reAuthCode body) action luid - `catchE` \case - VerificationCodeRequired -> throwE $ reauthError ReAuthCodeVerificationRequired - VerificationCodeNoPendingCode -> throwE $ reauthError ReAuthCodeVerificationNoPendingCode - VerificationCodeNoEmail -> throwE $ reauthError ReAuthCodeVerificationNoEmail + lift (liftSem $ Authentication.enforceVerificationCodeEither luid (reAuthCode body) action) + >>= \case + Left VerificationCodeRequired -> throwE $ reauthError ReAuthCodeVerificationRequired + Left VerificationCodeNoPendingCode -> throwE $ reauthError ReAuthCodeVerificationNoPendingCode + Left VerificationCodeNoEmail -> throwE $ reauthError ReAuthCodeVerificationNoEmail + Right () -> pure () Nothing -> pure () -------------------------------------------------------------------------------- diff --git a/services/brig/src/Brig/API/Client.hs b/services/brig/src/Brig/API/Client.hs deleted file mode 100644 index ce43b65844d..00000000000 --- a/services/brig/src/Brig/API/Client.hs +++ /dev/null @@ -1,650 +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 . - --- TODO: Move to Brig.User.Client -module Brig.API.Client - ( -- * Clients - addClient, - addClientWithReAuthPolicy, - updateClient, - rmClient, - pubClient, - legalHoldClientRequested, - removeLegalHoldClient, - lookupLocalClient, - lookupLocalClients, - lookupPubClient, - lookupPubClients, - lookupPubClientsBulk, - lookupLocalPubClientsBulk, - createAccessToken, - - -- * Prekeys - claimLocalMultiPrekeyBundles, - claimLocalPrekeyBundle, - claimPrekey, - claimLocalPrekey, - claimPrekeyBundle, - claimMultiPrekeyBundles, - claimMultiPrekeyBundlesV3, - ) -where - -import Brig.API.Error (clientError) -import Brig.API.Handler (Handler) -import Brig.API.Types -import Brig.API.Util -import Brig.App -import Brig.Data.Client qualified as Data -import Brig.Data.Nonce as Nonce -import Brig.Effects.JwtTools (JwtTools) -import Brig.Effects.JwtTools qualified as JwtTools -import Brig.Effects.PublicKeyBundle (PublicKeyBundle) -import Brig.Effects.PublicKeyBundle qualified as PublicKeyBundle -import Brig.Federation.Client (getUserClients) -import Brig.Federation.Client qualified as Federation -import Brig.IO.Intra (guardLegalhold) -import Brig.IO.Intra qualified as Intra -import Brig.Options qualified as Opt -import Brig.Types.Intra -import Brig.User.Auth qualified as UserAuth -import Brig.User.Auth.Cookie qualified as Auth -import Cassandra (MonadClient) -import Control.Error -import Control.Monad.Trans.Except (except) -import Data.ByteString (toStrict) -import Data.ByteString.Conversion -import Data.Code as Code -import Data.Domain -import Data.HavePendingInvitations -import Data.Id (ClientId, ConnId, UserId) -import Data.List.Split (chunksOf) -import Data.Map.Strict qualified as Map hiding ((\\)) -import Data.Misc (PlainTextPassword6) -import Data.Qualified -import Data.Set ((\\)) -import Data.Set qualified as Set -import Data.Text.Encoding qualified as T -import Data.Text.Encoding.Error -import Imports hiding ((\\)) -import Network.HTTP.Types.Method (StdMethod) -import Network.Wai.Utilities -import Polysemy -import Servant (Link, ToHttpApiData (toUrlPiece)) -import System.Logger.Class (field, msg, val, (~~)) -import System.Logger.Class qualified as Log -import Wire.API.Federation.API.Brig (GetUserClients (GetUserClients)) -import Wire.API.Federation.Error -import Wire.API.MLS.Credential (ClientIdentity (..)) -import Wire.API.MLS.Epoch (addToEpoch) -import Wire.API.Message qualified as Message -import Wire.API.Routes.Internal.Brig -import Wire.API.Team.LegalHold (LegalholdProtectee (..)) -import Wire.API.Team.LegalHold.Internal -import Wire.API.User -import Wire.API.User qualified as Code -import Wire.API.User.Client -import Wire.API.User.Client.DPoPAccessToken -import Wire.API.User.Client.Prekey -import Wire.API.UserEvent -import Wire.API.UserMap (QualifiedUserMap (QualifiedUserMap, qualifiedUserMap), UserMap (userMap)) -import Wire.AuthenticationSubsystem (AuthenticationSubsystem) -import Wire.AuthenticationSubsystem qualified as Authentication -import Wire.ClientStore (ClientStore, DuplicateMLSPublicKey (..)) -import Wire.ClientStore qualified as ClientStore -import Wire.DeleteQueue -import Wire.EmailSubsystem (EmailSubsystem, sendNewClientEmail) -import Wire.Events (Events) -import Wire.Events qualified as Events -import Wire.GalleyAPIAccess (GalleyAPIAccess) -import Wire.GalleyAPIAccess qualified as GalleyAPIAccess -import Wire.NotificationSubsystem -import Wire.Sem.Concurrency -import Wire.Sem.FromUTC (FromUTC (fromUTCTime)) -import Wire.Sem.Now as Now -import Wire.UserSubsystem (UserSubsystem) -import Wire.UserSubsystem qualified as User -import Wire.VerificationCodeSubsystem (VerificationCodeSubsystem) - -lookupLocalClient :: (Member ClientStore r) => UserId -> ClientId -> AppT r (Maybe Client) -lookupLocalClient uid = liftSem . ClientStore.lookupClient uid - -lookupLocalClients :: (Member ClientStore r) => UserId -> AppT r [Client] -lookupLocalClients = liftSem . ClientStore.lookupClients - -lookupPubClient :: (Member ClientStore r) => Qualified UserId -> ClientId -> ExceptT ClientError (AppT r) (Maybe PubClient) -lookupPubClient qid cid = do - clients <- lookupPubClients qid - pure $ find ((== cid) . pubClientId) clients - -lookupPubClients :: (Member ClientStore r) => Qualified UserId -> ExceptT ClientError (AppT r) [PubClient] -lookupPubClients qid@(Qualified uid domain) = do - getForUser <$> lookupPubClientsBulk [qid] - where - getForUser :: QualifiedUserMap (Set PubClient) -> [PubClient] - getForUser qmap = fromMaybe [] $ do - um <- userMap <$> Map.lookup domain (qualifiedUserMap qmap) - Set.toList <$> Map.lookup uid um - -lookupPubClientsBulk :: (Member ClientStore r) => [Qualified UserId] -> ExceptT ClientError (AppT r) (QualifiedUserMap (Set PubClient)) -lookupPubClientsBulk qualifiedUids = do - loc <- qualifyLocal () - let (localUsers, remoteUsers) = partitionQualified loc qualifiedUids - remoteUserClientMap <- lift $ getRemoteClients $ indexQualified (fmap tUntagged remoteUsers) - localUserClientMap <- Map.singleton (tDomain loc) <$> lookupLocalPubClientsBulk localUsers - pure $ QualifiedUserMap (Map.union localUserClientMap remoteUserClientMap) - where - getRemoteClients :: Map Domain [UserId] -> AppT r (Map Domain (UserMap (Set PubClient))) - getRemoteClients uids = do - results <- - traverse - (\(d, ids) -> mapLeft (const d) . fmap (d,) <$> runExceptT (getUserClients d (GetUserClients ids))) - (Map.toList uids) - forM_ (lefts results) $ \d -> - Log.warn $ - field "remote_domain" (domainText d) - ~~ msg (val "Failed to fetch clients for domain") - pure $ Map.fromList (rights results) - -lookupLocalPubClientsBulk :: (Member ClientStore r) => [UserId] -> ExceptT ClientError (AppT r) (UserMap (Set PubClient)) -lookupLocalPubClientsBulk = lift . liftSem . ClientStore.lookupPubClientsBulk - -addClient :: - ( Member GalleyAPIAccess r, - Member NotificationSubsystem r, - Member UserSubsystem r, - Member DeleteQueue r, - Member EmailSubsystem r, - Member AuthenticationSubsystem r, - Member VerificationCodeSubsystem r, - Member Events r, - Member ClientStore r - ) => - Local UserId -> - Maybe ConnId -> - NewClient -> - ExceptT ClientError (AppT r) Client -addClient = addClientWithReAuthPolicy Data.reAuthForNewClients - --- nb. We must ensure that the set of clients known to brig is always --- a superset of the clients known to galley. -addClientWithReAuthPolicy :: - forall r. - ( Member GalleyAPIAccess r, - Member NotificationSubsystem r, - Member DeleteQueue r, - Member EmailSubsystem r, - Member Events r, - Member UserSubsystem r, - Member AuthenticationSubsystem r, - Member VerificationCodeSubsystem r, - Member ClientStore r - ) => - Data.ReAuthPolicy -> - Local UserId -> - Maybe ConnId -> - NewClient -> - ExceptT ClientError (AppT r) Client -addClientWithReAuthPolicy policy luid@(tUnqualified -> u) con new = do - usr <- - (lift . liftSem $ User.getAccountNoFilter luid) - >>= maybe (throwE (ClientUserNotFound u)) pure - verifyCode (newClientVerificationCode new) luid - maxPermClients <- fromMaybe Opt.defUserMaxPermClients <$> asks (.settings.userMaxPermClients) - let mCaps :: Maybe ClientCapabilityList - mCaps = updlhdev $ newClientCapabilities new - where - updlhdev :: Maybe ClientCapabilityList -> Maybe ClientCapabilityList - updlhdev = - if newClientType new == LegalHoldClientType - then Just . ClientCapabilityList . maybe (Set.singleton lhcaps) (Set.insert lhcaps . fromClientCapabilityList) - else id - lhcaps = ClientSupportsLegalholdImplicitConsent - (clt0, old, count) <- - (Data.addClientWithReAuthPolicy policy luid clientId' new maxPermClients mCaps) - !>> ClientDataError - let clt = clt0 {clientMLSPublicKeys = newClientMLSPublicKeys new} - consumableNotificationsEnabled <- asks (.settings.consumableNotifications) - when (consumableNotificationsEnabled && supportsConsumableNotifications clt) $ lift $ liftSem $ do - setupConsumableNotifications u clt.clientId - lift $ do - for_ old $ execDelete u con - liftSem $ GalleyAPIAccess.newClient u clt.clientId - liftSem $ Intra.onClientEvent u con (ClientAdded clt) - when (clientType clt == LegalHoldClientType) $ liftSem $ Events.generateUserEvent u con (UserLegalHoldEnabled u) - when (count > 1) $ - for_ (userEmail usr) $ - \email -> - liftSem $ sendNewClientEmail email (userDisplayName usr) clt (userLocale usr) - pure clt - where - clientId' = clientIdFromPrekey (unpackLastPrekey $ newClientLastKey new) - - verifyCode :: - Maybe Code.Value -> - Local UserId -> - ExceptT ClientError (AppT r) () - verifyCode mbCode luid1 = - -- this only happens inside the login flow (in particular, when logging in from a new device) - -- the code obtained for logging in is used a second time for adding the device - UserAuth.verifyCode mbCode Code.Login luid1 `catchE` \case - VerificationCodeRequired -> throwE ClientCodeAuthenticationRequired - VerificationCodeNoPendingCode -> throwE ClientCodeAuthenticationFailed - VerificationCodeNoEmail -> throwE ClientCodeAuthenticationFailed - -updateClient :: - (Member NotificationSubsystem r, Member ClientStore r) => - UserId -> - ClientId -> - UpdateClient -> - (Handler r) () -updateClient uid cid req = do - client <- (lift (liftSem (ClientStore.lookupClient uid cid)) >>= maybe (throwE ClientNotFound) pure) !>> clientError - consumableNotificationsEnabled <- asks (.settings.consumableNotifications) - lift . liftSem $ for_ req.updateClientLabel $ ClientStore.updateLabel uid cid . Just - for_ req.updateClientCapabilities $ \caps -> do - if client.clientCapabilities.fromClientCapabilityList `Set.isSubsetOf` caps.fromClientCapabilityList - then do - -- first set up the notification queues then save the data is more robust than the other way around - let addedCapabilities = caps.fromClientCapabilityList \\ client.clientCapabilities.fromClientCapabilityList - when (consumableNotificationsEnabled && ClientSupportsConsumableNotifications `Set.member` addedCapabilities) $ lift $ liftSem $ do - setupConsumableNotifications uid cid - lift . liftSem . ClientStore.updateCapabilities uid cid . Just $ caps - else throwE $ clientError ClientCapabilitiesCannotBeRemoved - let lk = maybeToList (unpackLastPrekey <$> req.updateClientLastKey) - prekeys = lk ++ req.updateClientPrekeys - ( do - unless (all checkPrekeyBundle prekeys) $ - throwE MalformedPrekeys - lift . liftSem $ ClientStore.updatePrekeys uid cid prekeys - mErr <- lift . liftSem $ ClientStore.addMLSPublicKeys uid cid (Map.assocs req.updateClientMLSPublicKeys) - case mErr of - Just DuplicateMLSPublicKey -> throwE MLSPublicKeyDuplicate - Nothing -> pure () - ) - !>> ClientDataError - !>> clientError - --- nb. We must ensure that the set of clients known to brig is always --- a superset of the clients known to galley. -rmClient :: - ( Member DeleteQueue r, - Member AuthenticationSubsystem r, - Member ClientStore r - ) => - UserId -> - ConnId -> - ClientId -> - Maybe PlainTextPassword6 -> - ExceptT ClientError (AppT r) () -rmClient u con clt pw = - maybe (throwE ClientNotFound) fn =<< lift (liftSem $ ClientStore.lookupClient u clt) - where - fn client = do - case clientType client of - -- Legal hold clients can't be removed - LegalHoldClientType -> throwE ClientLegalHoldCannotBeRemoved - -- Temporary clients don't need to re-auth - TemporaryClientType -> pure () - -- All other clients must authenticate - _ -> - (lift . liftSem $ Authentication.reauthenticateEither u pw) - >>= either (throwE . ClientDataError . ClientReAuthError) (const $ pure ()) - lift $ execDelete u (Just con) client - -claimPrekey :: - ( Member DeleteQueue r, - Member AuthenticationSubsystem r, - Member ClientStore r - ) => - LegalholdProtectee -> - UserId -> - Domain -> - ClientId -> - ExceptT ClientError (AppT r) (Maybe ClientPrekey) -claimPrekey protectee u d c = do - isLocalDomain <- (d ==) <$> viewFederationDomain - if isLocalDomain - then claimLocalPrekey protectee u c - else wrapClientE $ claimRemotePrekey (Qualified u d) c - -claimLocalPrekey :: - ( Member DeleteQueue r, - Member AuthenticationSubsystem r, - Member ClientStore r - ) => - LegalholdProtectee -> - UserId -> - ClientId -> - ExceptT ClientError (AppT r) (Maybe ClientPrekey) -claimLocalPrekey protectee user client = do - guardLegalhold protectee (mkUserClients [(user, [client])]) - lift $ do - prekey <- liftSem $ ClientStore.claimPrekey user client - when (isNothing prekey) (noPrekeys user client) - pure prekey - -claimRemotePrekey :: - ( MonadReader Env m, - Log.MonadLogger m, - MonadClient m - ) => - Qualified UserId -> - ClientId -> - ExceptT ClientError m (Maybe ClientPrekey) -claimRemotePrekey quser client = fmapLT ClientFederationError $ Federation.claimPrekey quser client - -claimPrekeyBundle :: (Member ClientStore r) => LegalholdProtectee -> Domain -> UserId -> ExceptT ClientError (AppT r) PrekeyBundle -claimPrekeyBundle protectee domain uid = do - isLocalDomain <- (domain ==) <$> viewFederationDomain - if isLocalDomain - then claimLocalPrekeyBundle protectee uid - else claimRemotePrekeyBundle (Qualified uid domain) - -claimLocalPrekeyBundle :: (Member ClientStore r) => LegalholdProtectee -> UserId -> ExceptT ClientError (AppT r) PrekeyBundle -claimLocalPrekeyBundle protectee u = do - clients <- map (.clientId) <$> lift (liftSem (ClientStore.lookupClients u)) - guardLegalhold protectee (mkUserClients [(u, clients)]) - PrekeyBundle u . catMaybes <$> lift (mapM (liftSem . ClientStore.claimPrekey u) clients) - -claimRemotePrekeyBundle :: Qualified UserId -> ExceptT ClientError (AppT r) PrekeyBundle -claimRemotePrekeyBundle quser = do - Federation.claimPrekeyBundle quser !>> ClientFederationError - -claimMultiPrekeyBundlesInternal :: - forall r. - ( Member (Concurrency 'Unsafe) r, - Member DeleteQueue r, - Member AuthenticationSubsystem r, - Member ClientStore r - ) => - LegalholdProtectee -> - QualifiedUserClients -> - ExceptT - ClientError - (AppT r) - ([Qualified UserClientPrekeyMap], [Remote UserClients]) -claimMultiPrekeyBundlesInternal protectee quc = do - loc <- qualifyLocal () - let (locals, remotes) = - partitionQualifiedAndTag - loc - ( map - (fmap UserClients . uncurry (flip Qualified)) - (Map.assocs (qualifiedUserClients quc)) - ) - localPrekeys <- traverse claimLocal locals - pure (localPrekeys, remotes) - where - claimLocal :: - Local UserClients -> - ExceptT ClientError (AppT r) (Qualified UserClientPrekeyMap) - claimLocal luc = - tUntagged . qualifyAs luc - <$> claimLocalMultiPrekeyBundles protectee (tUnqualified luc) - -claimMultiPrekeyBundlesV3 :: - ( Member (Concurrency 'Unsafe) r, - Member DeleteQueue r, - Member AuthenticationSubsystem r, - Member ClientStore r - ) => - LegalholdProtectee -> - QualifiedUserClients -> - ExceptT ClientError (AppT r) QualifiedUserClientPrekeyMap -claimMultiPrekeyBundlesV3 protectee quc = do - (localPrekeys, remotes) <- claimMultiPrekeyBundlesInternal protectee quc - remotePrekeys <- - mapExceptT wrapHttpClient $ - traverseConcurrentlyWithErrors - claimRemote - remotes - !>> ClientFederationError - pure . qualifiedUserClientPrekeyMapFromList $ localPrekeys <> remotePrekeys - where - claimRemote :: - ( Log.MonadLogger m, - MonadIO m, - MonadReader Env m - ) => - Remote UserClients -> - ExceptT FederationError m (Qualified UserClientPrekeyMap) - claimRemote ruc = - tUntagged . qualifyAs ruc - <$> Federation.claimMultiPrekeyBundle (tDomain ruc) (tUnqualified ruc) - --- Similar to claimMultiPrekeyBundles except for the following changes --- 1) A new return type that contains both the client map and a list of --- users that prekeys couldn't be fetched for. --- 2) A semantic change on federation errors when gathering remote clients. --- Remote federation errors at this step no-longer cause the entire call --- to fail, allowing partial results to be returned. -claimMultiPrekeyBundles :: - forall r. - ( Member (Concurrency 'Unsafe) r, - Member DeleteQueue r, - Member AuthenticationSubsystem r, - Member ClientStore r - ) => - LegalholdProtectee -> - QualifiedUserClients -> - ExceptT ClientError (AppT r) QualifiedUserClientPrekeyMapV4 -claimMultiPrekeyBundles protectee quc = do - (localPrekeys, remotes) <- claimMultiPrekeyBundlesInternal protectee quc - remotePrekeys <- mapExceptT wrapHttpClient $ lift $ traverseConcurrentlySem claimRemote remotes - let prekeys = - getQualifiedUserClientPrekeyMap $ - qualifiedUserClientPrekeyMapFromList $ - localPrekeys <> rights remotePrekeys - failed = lefts remotePrekeys >>= toQualifiedUser . fst - pure $ - QualifiedUserClientPrekeyMapV4 prekeys $ - if null failed - then Nothing - else pure failed - where - toQualifiedUser :: Remote UserClients -> [Qualified UserId] - toQualifiedUser r = fmap (\u -> Qualified u $ tDomain r) . Map.keys . userClients . qUnqualified $ tUntagged r - claimRemote :: Remote UserClients -> ExceptT FederationError HttpClientIO (Qualified UserClientPrekeyMap) - claimRemote ruc = - tUntagged . qualifyAs ruc - <$> Federation.claimMultiPrekeyBundle (tDomain ruc) (tUnqualified ruc) - -claimLocalMultiPrekeyBundles :: - forall r. - ( Member (Concurrency 'Unsafe) r, - Member DeleteQueue r, - Member AuthenticationSubsystem r, - Member ClientStore r - ) => - LegalholdProtectee -> - UserClients -> - ExceptT ClientError (AppT r) UserClientPrekeyMap -claimLocalMultiPrekeyBundles protectee userClients = do - guardLegalhold protectee userClients - lift - . fmap mkUserClientPrekeyMap - . foldMap (getChunk . Map.fromList) - . chunksOf 16 - . Map.toList - . Message.userClients - $ userClients - where - getChunk :: Map UserId (Set ClientId) -> AppT r (Map UserId (Map ClientId (Maybe UncheckedPrekeyBundle))) - getChunk m = do - e <- ask - AppT $ - lift $ - Map.fromListWith (<>) - <$> unsafePooledMapConcurrentlyN - 16 - (\(u, cids) -> (u,) <$> lowerAppT e (getUserKeys u cids)) - (Map.toList m) - getUserKeys :: - UserId -> - Set ClientId -> - (AppT r) (Map ClientId (Maybe UncheckedPrekeyBundle)) - getUserKeys u = - sequenceA . Map.fromSet (getClientKeys u) - getClientKeys :: - UserId -> - ClientId -> - (AppT r) (Maybe UncheckedPrekeyBundle) - getClientKeys u c = do - key <- fmap prekeyData <$> liftSem (ClientStore.claimPrekey u c) - when (isNothing key) $ noPrekeys u c - pure key - --- Utilities - --- | Enqueue an orderly deletion of an existing client. -execDelete :: - ( Member DeleteQueue r, - Member AuthenticationSubsystem r, - Member ClientStore r - ) => - UserId -> - Maybe ConnId -> - Client -> - AppT r () -execDelete u con c = do - for_ (clientCookie c) $ \l -> liftSem $ Auth.revokeCookies u [] [l] - liftSem $ enqueueClientDeletion c.clientId u con - liftSem $ ClientStore.delete u c.clientId - --- | Defensive measure when no prekey is found for a --- requested client: Ensure that the client does indeed --- not exist, since there must be no client without prekeys, --- thus repairing any inconsistencies related to distributed --- (and possibly duplicated) client data. -noPrekeys :: - ( Member DeleteQueue r, - Member AuthenticationSubsystem r, - Member ClientStore r - ) => - UserId -> - ClientId -> - (AppT r) () -noPrekeys u c = do - mclient <- liftSem $ ClientStore.lookupClient u c - case mclient of - Nothing -> do - Log.warn $ - field "user" (toByteString u) - ~~ field "client" (toByteString c) - ~~ msg (val "No prekey found. Client is missing, so doing nothing.") - Just client -> do - Log.warn $ - field "user" (toByteString u) - ~~ field "client" (toByteString c) - ~~ msg (val "No prekey found. Deleting client.") - execDelete u Nothing client - -pubClient :: Client -> PubClient -pubClient c = - PubClient - { pubClientId = c.clientId, - pubClientClass = clientClass c - } - -legalHoldClientRequested :: (Member Events r) => UserId -> LegalHoldClientRequest -> AppT r () -legalHoldClientRequested targetUser (LegalHoldClientRequest _requester lastPrekey') = - liftSem $ Events.generateUserEvent targetUser Nothing lhClientEvent - where - clientId :: ClientId - clientId = clientIdFromPrekey $ unpackLastPrekey lastPrekey' - eventData :: LegalHoldClientRequestedData - eventData = LegalHoldClientRequestedData targetUser lastPrekey' clientId - lhClientEvent :: UserEvent - lhClientEvent = LegalHoldClientRequested eventData - -removeLegalHoldClient :: - ( Member DeleteQueue r, - Member Events r, - Member AuthenticationSubsystem r, - Member ClientStore r - ) => - UserId -> - AppT r () -removeLegalHoldClient uid = do - clients <- liftSem $ ClientStore.lookupClients uid - -- Should only be one; but just in case we'll treat it as a list - let legalHoldClients = filter ((== LegalHoldClientType) . clientType) clients - -- maybe log if this isn't the case - forM_ legalHoldClients (execDelete uid Nothing) - liftSem $ Events.generateUserEvent uid Nothing (UserLegalHoldDisabled uid) - -createAccessToken :: - (Member JwtTools r, Member Now r, Member PublicKeyBundle r, Member UserSubsystem r) => - Local UserId -> - ClientId -> - StdMethod -> - Link -> - Proof -> - ExceptT CertEnrollmentError (AppT r) (DPoPAccessTokenResponse, CacheControl) -createAccessToken luid cid method link proof = do - let domain = tDomain luid - let uid = tUnqualified luid - (tid, handle, displayName) <- do - mUser <- - fmap listToMaybe - . lift - . liftSem - . User.getAccountsBy - . qualifyAs luid - $ getByNoFilters {getByUserId = [tUnqualified luid], includePendingInvitations = NoPendingInvitations} - except $ - (,,) - <$> note NotATeamUser (userTeam =<< mUser) - <*> note MissingHandle (userHandle =<< mUser) - <*> note MissingName (userDisplayName <$> mUser) - nonce <- - ExceptT $ - note NonceNotFound - <$> wrapClient - ( Nonce.lookupAndDeleteNonce - uid - (T.decodeUtf8With lenientDecode . toStrict $ toByteString cid) - ) - httpsUrl <- - except $ - note MisconfiguredRequestUrl $ - fromByteString $ - "https://" <> toByteString' domain <> "/" <> T.encodeUtf8 (toUrlPiece link) - maxSkewSeconds <- Opt.setDpopMaxSkewSecs <$> asks (.settings) - expiresIn <- Opt.dpopTokenExpirationTimeSecs <$> asks (.settings) - now <- fromUTCTime <$> lift (liftSem Now.get) - let expiresAt = now & addToEpoch expiresIn - pubKeyBundle <- do - pathToKeys <- ExceptT (note KeyBundleError <$> asks (.settings.publicKeyBundle)) - ExceptT $ note KeyBundleError <$> liftSem (PublicKeyBundle.get pathToKeys) - token <- - ExceptT $ - liftSem $ - JwtTools.generateDPoPAccessToken - proof - (ClientIdentity domain uid cid) - handle - displayName - tid - nonce - httpsUrl - method - maxSkewSeconds - expiresAt - pubKeyBundle - pure $ (DPoPAccessTokenResponse token DPoP expiresIn, NoStore) diff --git a/services/brig/src/Brig/API/Connection.hs b/services/brig/src/Brig/API/Connection.hs index ce2390f04cc..375a5300f93 100644 --- a/services/brig/src/Brig/API/Connection.hs +++ b/services/brig/src/Brig/API/Connection.hs @@ -43,7 +43,6 @@ import Brig.Data.Types (resultHasMore, resultList) import Brig.IO.Intra qualified as Intra import Brig.IO.Logging import Brig.Options -import Brig.Types.Connection import Control.Error import Control.Monad.Catch (throwM) import Data.Id as Id @@ -65,22 +64,14 @@ import Wire.API.Error.Brig qualified as E import Wire.API.Routes.Public.Util (ResponseForExistedCreated (..)) import Wire.API.User import Wire.API.UserEvent +import Wire.FederationAPIAccess import Wire.FederationConfigStore -import Wire.GalleyAPIAccess -import Wire.GalleyAPIAccess qualified as GalleyAPIAccess +import Wire.GalleyAPIAccess as GalleyAPIAccess import Wire.NotificationSubsystem import Wire.TeamSubsystem (TeamSubsystem) -import Wire.UserStore -import Wire.UserStore qualified as UserStore +import Wire.UserStore as UserStore import Wire.UserSubsystem -ensureNotSameTeam :: (Member GalleyAPIAccess r) => Local UserId -> Local UserId -> (ConnectionM r) () -ensureNotSameTeam self target = do - selfTeam <- lift $ liftSem $ GalleyAPIAccess.getTeamId (tUnqualified self) - targetTeam <- lift $ liftSem $ GalleyAPIAccess.getTeamId (tUnqualified target) - when (isJust selfTeam && selfTeam == targetTeam) $ - throwE ConnectSameBindingTeamUsers - createConnection :: ( Member FederationConfigStore r, Member GalleyAPIAccess r, @@ -89,7 +80,8 @@ createConnection :: Member UserStore r, Member UserSubsystem r, Member (Embed HttpClientIO) r, - Member TeamSubsystem r + Member TeamSubsystem r, + HasBrigFederationAccess m r ) => Local UserId -> ConnId -> @@ -123,6 +115,7 @@ createConnectionToLocalUser self conn target = do ensureIsActivated target checkLegalholdPolicyConflict self target ensureNotSameTeam self target + ensureNoApps self (tUntagged . fmap Left <$> [self, target]) s2o <- lift . wrapClient $ Data.lookupConnection self (tUntagged target) o2s <- lift . wrapClient $ Data.lookupConnection target (tUntagged self) @@ -233,7 +226,8 @@ updateConnection :: Member TinyLog r, Member (Embed HttpClientIO) r, Member GalleyAPIAccess r, - Member UserStore r + Member UserStore r, + HasBrigFederationAccess m r ) => Local UserId -> Qualified UserId -> diff --git a/services/brig/src/Brig/API/Connection/Remote.hs b/services/brig/src/Brig/API/Connection/Remote.hs index 5b4cbd54333..09d8e11e086 100644 --- a/services/brig/src/Brig/API/Connection/Remote.hs +++ b/services/brig/src/Brig/API/Connection/Remote.hs @@ -27,7 +27,6 @@ import Brig.API.Connection.Util import Brig.API.Types (ConnectionError (..)) import Brig.App import Brig.Data.Connection qualified as Data -import Brig.Federation.Client as Federation import Brig.IO.Intra qualified as Intra import Brig.Options import Control.Comonad @@ -37,22 +36,22 @@ import Data.Id as Id import Data.Qualified import Galley.Types.Conversations.One2One (one2OneConvId) import Imports -import Network.Wai.Utilities.Error import Polysemy +import System.Logger.Class qualified as Log +import Wire.API.Component import Wire.API.Connection +import Wire.API.Federation.API import Wire.API.Federation.API.Brig - ( NewConnectionResponse (..), - RemoteConnectionAction (..), - ) import Wire.API.Routes.Internal.Galley.ConversationsIntra import Wire.API.Routes.Public.Util (ResponseForExistedCreated (..)) import Wire.API.User import Wire.API.UserEvent +import Wire.FederationAPIAccess import Wire.FederationConfigStore import Wire.GalleyAPIAccess import Wire.NotificationSubsystem -import Wire.UserStore -import Wire.UserStore qualified as UserStore +import Wire.UserStore as UserStore +import Wire.UserSubsystem data LocalConnectionAction = LocalConnect @@ -224,35 +223,37 @@ pushEvent self mzcon connection = do liftSem $ Intra.onConnectionEvent (tUnqualified self) mzcon event performLocalAction :: - (Member GalleyAPIAccess r, Member NotificationSubsystem r, Member UserStore r) => + ( Member GalleyAPIAccess r, + Member NotificationSubsystem r, + Member UserStore r, + HasBrigFederationAccess m r + ) => Local UserId -> Maybe ConnId -> Remote UserId -> Maybe UserConnection -> LocalConnectionAction -> (ConnectionM r) (ResponseForExistedCreated UserConnection, Bool) -performLocalAction self mzcon other mconnection action = do +performLocalAction luid mzcon other mconnection action = do let rel0 = maybe Cancelled ucStatus mconnection - checkLimitForLocalAction self rel0 action + checkLimitForLocalAction luid rel0 action mrel2 <- for (transition (LCA action) rel0) $ \rel1 -> do mreaction <- fmap join . for (remoteAction action) $ \ra -> do - mSelfTeam <- lift . liftSem . UserStore.getUserTeam . tUnqualified $ self - response <- - sendConnectionAction - self - (qualifyAs self <$> mSelfTeam) - other - ra - !>> ConnectFederationError - case (response :: NewConnectionResponse) of - NewConnectionResponseOk reaction -> pure reaction - NewConnectionResponseNotFederating -> throwE ConnectTeamFederationError - NewConnectionResponseUserNotActivated -> throwE (InvalidUser (tUntagged other)) + let uid = tUnqualified luid + mSelfTeam <- lift $ liftSem $ UserStore.getUserTeam uid + Log.info $ Log.msg @Text "Brig-federation: sending connection action to remote backend" + let req = NewConnectionRequest uid mSelfTeam (qUnqualified $ tUntagged other) ra + response <- lift $ liftSem $ runFederatedEither other $ fedClient @'Brig @"send-connection-action" req + case response of + Right (NewConnectionResponseOk reaction) -> pure reaction + Right NewConnectionResponseNotFederating -> throwE ConnectTeamFederationError + Right NewConnectionResponseUserNotActivated -> throwE (InvalidUser (tUntagged other)) + Left e -> throwE $ ConnectFederationError e pure $ fromMaybe rel1 $ do reactionAction <- (mreaction :: Maybe RemoteConnectionAction) transition (RCA reactionAction) rel1 - transitionTo self mzcon other mconnection mrel2 LocalActor + transitionTo luid mzcon other mconnection mrel2 LocalActor where remoteAction :: LocalConnectionAction -> Maybe RemoteConnectionAction remoteAction LocalConnect = Just RemoteConnect @@ -301,7 +302,9 @@ createConnectionToRemoteUser :: ( Member GalleyAPIAccess r, Member FederationConfigStore r, Member UserStore r, - Member NotificationSubsystem r + Member UserSubsystem r, + Member NotificationSubsystem r, + HasBrigFederationAccess m r ) => Local UserId -> ConnId -> @@ -309,7 +312,11 @@ createConnectionToRemoteUser :: ConnectionM r (ResponseForExistedCreated UserConnection) createConnectionToRemoteUser self zcon other = do ensureNotSameAndActivated self (tUntagged other) - ensureFederatesWith other + mbOtherProfile <- ensureFederatesWith other + let selfInfo, otherInfo :: [Qualified (Either UserId UserProfile)] + selfInfo = [tUntagged $ Left <$> self] + otherInfo = [tUntagged $ qualifyAs other (Right op) | op <- maybeToList mbOtherProfile] + ensureNoApps self $ selfInfo <> otherInfo mconnection <- lift . wrapClient $ Data.lookupConnection self (tUntagged other) fst <$> performLocalAction self (Just zcon) other mconnection LocalConnect @@ -317,7 +324,8 @@ updateConnectionToRemoteUser :: ( Member GalleyAPIAccess r, Member NotificationSubsystem r, Member FederationConfigStore r, - Member UserStore r + Member UserStore r, + HasBrigFederationAccess m r ) => Local UserId -> Remote UserId -> @@ -325,7 +333,7 @@ updateConnectionToRemoteUser :: Maybe ConnId -> (ConnectionM r) (Maybe UserConnection) updateConnectionToRemoteUser self other rel1 zcon = do - ensureFederatesWith other + void $ ensureFederatesWith other mconnection <- lift . wrapClient $ Data.lookupConnection self (tUntagged other) action <- actionForTransition rel1 @@ -346,16 +354,22 @@ checkLimitForLocalAction u oldRel action = when (oldRel `notElem` [Accepted, Sent] && (action == LocalConnect)) $ checkLimit u --- | Check if the local backend federates with the remote user's team. Throw an --- exception if it does not federate. +-- | Check if the local backend federates with the remote user's +-- team. Throw an exception if it does not federate. Return the +-- profile of the remote user because we sometimes need it again, and +-- don't want to fetch it twice. ensureFederatesWith :: - (Member FederationConfigStore r) => + ( Member FederationConfigStore r, + HasBrigFederationAccess m r + ) => Remote UserId -> - ConnectionM r () + ConnectionM r (Maybe UserProfile) ensureFederatesWith remote = do + lift $ Log.info $ Log.msg ("Brig-federation: get users by ids on remote backends" :: ByteString) profiles <- - withExceptT ConnectFederationError $ - getUsersByIds (tDomain remote) [tUnqualified remote] + either (throwE . ConnectFederationError) pure + =<< lift (liftSem $ runFederatedEither remote $ fedClient @'Brig @"get-users-by-ids" [tUnqualified remote]) let rTeam = qualifyAs remote $ profileTeam =<< listToMaybe profiles unlessM (lift . liftSem . backendFederatesWith $ rTeam) $ throwE ConnectTeamFederationError + pure (listToMaybe profiles) diff --git a/services/brig/src/Brig/API/Connection/Util.hs b/services/brig/src/Brig/API/Connection/Util.hs index e256ff373f4..ccbba0284c1 100644 --- a/services/brig/src/Brig/API/Connection/Util.hs +++ b/services/brig/src/Brig/API/Connection/Util.hs @@ -20,6 +20,8 @@ module Brig.API.Connection.Util checkLimit, ensureIsActivated, ensureNotSameAndActivated, + ensureNotSameTeam, + ensureNoApps, ) where @@ -30,11 +32,15 @@ import Brig.Options (Settings (userMaxConnections)) import Control.Error (MaybeT, noteT) import Control.Monad.Trans.Except import Data.Id (UserId) +import Data.Map.Strict qualified as Map import Data.Qualified import Imports import Polysemy import Wire.API.Connection (Relation (..)) +import Wire.API.User +import Wire.GalleyAPIAccess import Wire.UserStore +import Wire.UserSubsystem type ConnectionM r = ExceptT ConnectionError (AppT r) @@ -57,3 +63,46 @@ ensureIsActivated :: (Member UserStore r) => Local UserId -> MaybeT (AppT r) () ensureIsActivated lusr = do active <- lift . liftSem $ isActivated (tUnqualified lusr) guard active + +ensureNotSameTeam :: (Member GalleyAPIAccess r) => Local UserId -> Local UserId -> (ConnectionM r) () +ensureNotSameTeam self target = do + selfTeam <- lift $ liftSem $ getTeamId (tUnqualified self) + targetTeam <- lift $ liftSem $ getTeamId (tUnqualified target) + when (isJust selfTeam && selfTeam == targetTeam) $ + throwE ConnectSameBindingTeamUsers + +ensureNoApps :: + (Member UserSubsystem r) => + Local UserId -> + [Qualified (Either UserId UserProfile)] -> + (ConnectionM r) () +ensureNoApps asker uidOrProfiles = do + -- Step 1: Collect all qualified uids that need to be looked up + let uidsToLookup :: [Qualified UserId] + uidsToLookup = flip mapMaybe uidOrProfiles $ \qEither -> + either (Just . flip Qualified (qDomain qEither)) (const Nothing) (qUnqualified qEither) + + -- Step 2: Call getUserProfiles once for all uids that need lookup + profiles <- lift $ liftSem $ getUserProfiles asker uidsToLookup + + -- Step 3: Build a Map from qualified uid to profile for quick lookup + let profileMap :: Map.Map (Qualified UserId) UserProfile + profileMap = Map.fromList $ map (\p -> (p.profileQualifiedId, p)) profiles + + -- Step 4: Process the original list, checking each entry for app type + let checkForApp :: Qualified (Either UserId UserProfile) -> Maybe (Qualified UserId) + checkForApp qEither = case qUnqualified qEither of + Right prof -> checkProfile prof + Left uid -> + let quid = Qualified uid (qDomain qEither) + in checkProfile =<< Map.lookup quid profileMap + + checkProfile :: UserProfile -> Maybe (Qualified UserId) + checkProfile prof = case prof.profileType of + UserTypeApp -> Just prof.profileQualifiedId + UserTypeRegular -> Nothing + UserTypeBot -> Nothing + + case mapMaybe checkForApp uidOrProfiles of + [] -> pure () + (appId : _) -> throwE (InvalidUser appId) diff --git a/services/brig/src/Brig/API/Error.hs b/services/brig/src/Brig/API/Error.hs index e28ac67a98c..733550000c8 100644 --- a/services/brig/src/Brig/API/Error.hs +++ b/services/brig/src/Brig/API/Error.hs @@ -28,6 +28,7 @@ import Wire.API.Error import Wire.API.Error.Brig qualified as E import Wire.API.Federation.Error import Wire.API.User +import Wire.AuthenticationSubsystem.Error import Wire.Error throwStd :: (MonadError HttpError m) => Wai.Error -> m a @@ -98,34 +99,6 @@ loginError (LoginBlocked wait) = loginError LoginCodeRequired = StdError (errorToWai @'E.CodeAuthenticationRequired) loginError LoginCodeInvalid = StdError (errorToWai @'E.CodeAuthenticationFailed) -authError :: AuthError -> HttpError -authError AuthInvalidUser = StdError (errorToWai @'E.BadCredentials) -authError AuthInvalidCredentials = StdError (errorToWai @'E.BadCredentials) -authError AuthSuspended = StdError (errorToWai @'E.AccountSuspended) -authError AuthEphemeral = StdError (errorToWai @'E.AccountEphemeral) -authError AuthPendingInvitation = StdError (errorToWai @'E.AccountPending) - -reauthError :: ReAuthError -> HttpError -reauthError ReAuthMissingPassword = StdError (errorToWai @'E.MissingAuth) -reauthError (ReAuthError e) = authError e -reauthError ReAuthCodeVerificationRequired = StdError verificationCodeRequired -reauthError ReAuthCodeVerificationNoPendingCode = StdError verificationCodeNoPendingCode -reauthError ReAuthCodeVerificationNoEmail = StdError verificationCodeNoEmail - -clientError :: ClientError -> HttpError -clientError ClientNotFound = StdError (errorToWai @'E.ClientNotFound) -clientError (ClientDataError e) = clientDataError e -clientError (ClientUserNotFound _) = StdError (errorToWai @'E.InvalidUser) -clientError ClientLegalHoldCannotBeRemoved = StdError can'tDeleteLegalHoldClient -clientError ClientLegalHoldCannotBeAdded = StdError can'tAddLegalHoldClient -clientError ClientLegalHoldIncompatible = StdError $ Wai.mkError status409 "mls-legal-hold-not-allowed" "A user who is under legal-hold may not participate in MLS conversations" -clientError (ClientFederationError e) = fedError e -clientError ClientCapabilitiesCannotBeRemoved = StdError clientCapabilitiesCannotBeRemoved -clientError ClientMissingLegalholdConsentOldClients = StdError (errorToWai @'E.MissingLegalholdConsentOldClients) -clientError ClientMissingLegalholdConsent = StdError (errorToWai @'E.MissingLegalholdConsent) -clientError ClientCodeAuthenticationFailed = StdError verificationCodeAuthFailed -clientError ClientCodeAuthenticationRequired = StdError verificationCodeRequired - -- Note that UnknownError, FfiError, and ImplementationError semantically should rather be 500s than 400s. -- However, the errors returned from the FFI are not always correct, -- and we don't want to bombard our environments with 500 log messages, so we treat them as 400s, for now. @@ -185,16 +158,6 @@ certEnrollmentError MissingName = StdError $ Wai.mkError status400 "missing-name fedError :: FederationError -> HttpError fedError = StdError . federationErrorToWai -clientDataError :: ClientDataError -> HttpError -clientDataError TooManyClients = StdError (errorToWai @'E.TooManyClients) -clientDataError (ClientReAuthError e) = reauthError e -clientDataError ClientMissingAuth = StdError (errorToWai @'E.MissingAuth) -clientDataError MalformedPrekeys = StdError (errorToWai @'E.MalformedPrekeys) -clientDataError MLSPublicKeyDuplicate = StdError (errorToWai @'E.MLSDuplicatePublicKey) -clientDataError KeyPackageDecodingError = StdError (errorToWai @'E.KeyPackageDecodingError) -clientDataError InvalidKeyPackageRef = StdError (errorToWai @'E.InvalidKeyPackageRef) -clientDataError MLSNotEnabled = StdError (errorToWai @'E.MLSNotEnabled) - deleteUserError :: DeleteUserError -> HttpError deleteUserError DeleteUserInvalid = StdError (errorToWai @'E.InvalidUser) deleteUserError DeleteUserInvalidCode = StdError (errorToWai @'E.InvalidCode) @@ -218,9 +181,6 @@ verificationCodeThrottledError (VerificationCodeThrottled t) = -- WAI Errors ----------------------------------------------------------------- -clientCapabilitiesCannotBeRemoved :: Wai.Error -clientCapabilitiesCannotBeRemoved = Wai.mkError status409 "client-capabilities-cannot-be-removed" "You can only add capabilities to a client, not remove them." - -- One of two cases: -- (1) the email is in use by any other account or invitation; -- (2) (when posting an invitation) the email is in use by a member of another team (and we can't steal away those, invitee has to be personal user). @@ -305,31 +265,6 @@ invalidRange :: LText -> Wai.Error invalidRange = Wai.mkError status400 "client-error" --- Legalhold -can'tDeleteLegalHoldClient :: Wai.Error -can'tDeleteLegalHoldClient = - Wai.mkError - status400 - "client-error" - "LegalHold clients cannot be deleted. LegalHold must be disabled on this user by an admin" - -can'tAddLegalHoldClient :: Wai.Error -can'tAddLegalHoldClient = - Wai.mkError - status400 - "client-error" - "LegalHold clients cannot be added manually. LegalHold must be enabled on this user by an admin" legalHoldNotEnabled :: Wai.Error legalHoldNotEnabled = Wai.mkError status403 "legalhold-not-enabled" "LegalHold must be enabled and configured on the team first" - -verificationCodeRequired :: Wai.Error -verificationCodeRequired = Wai.mkError status403 "code-authentication-required" "Verification code required." - -verificationCodeNoPendingCode :: Wai.Error -verificationCodeNoPendingCode = Wai.mkError status403 "code-authentication-failed" "Code authentication failed (no such code)." - -verificationCodeNoEmail :: Wai.Error -verificationCodeNoEmail = Wai.mkError status403 "code-authentication-failed" "Code authentication failed (no such email)." - -verificationCodeAuthFailed :: Wai.Error -verificationCodeAuthFailed = Wai.mkError status403 "code-authentication-failed" "Code authentication failed." diff --git a/services/brig/src/Brig/API/Federation.hs b/services/brig/src/Brig/API/Federation.hs index d5389db4e59..3641348b490 100644 --- a/services/brig/src/Brig/API/Federation.hs +++ b/services/brig/src/Brig/API/Federation.hs @@ -19,9 +19,7 @@ module Brig.API.Federation (federationSitemap, FederationAPI) where -import Brig.API.Client qualified as API import Brig.API.Connection.Remote (performRemoteAction) -import Brig.API.Error import Brig.API.Handler (Handler) import Brig.API.Internal qualified as Internal import Brig.API.MLS.CipherSuite @@ -66,9 +64,10 @@ import Wire.API.User.Client.Prekey import Wire.API.User.Search hiding (searchPolicy) import Wire.API.UserEvent import Wire.API.UserMap (UserMap) -import Wire.AuthenticationSubsystem import Wire.ClientStore (ClientStore) -import Wire.DeleteQueue +import Wire.ClientSubsystem (ClientSubsystem) +import Wire.ClientSubsystem qualified as ClientSubsystem +import Wire.ClientSubsystem.Error (clientErrorToHttpError) import Wire.Error import Wire.FederationConfigStore (FederationConfigStore) import Wire.FederationConfigStore qualified as E @@ -89,9 +88,8 @@ federationSitemap :: Member NotificationSubsystem r, Member UserSubsystem r, Member UserStore r, - Member DeleteQueue r, - Member AuthenticationSubsystem r, - Member ClientStore r + Member ClientStore r, + Member ClientSubsystem r ) => ServerT FederationAPI (Handler r) federationSitemap = @@ -184,30 +182,23 @@ getUsersByIds _ uids = do lift $ liftSem $ UserSubsystem.getLocalUserProfiles luids claimPrekey :: - ( Member DeleteQueue r, - Member AuthenticationSubsystem r, - Member ClientStore r - ) => + (Member ClientSubsystem r) => Domain -> (UserId, ClientId) -> (Handler r) (Maybe ClientPrekey) claimPrekey _ (user, client) = do - API.claimLocalPrekey LegalholdPlusFederationNotImplemented user client !>> clientError + lift $ liftSem $ ClientSubsystem.claimLocalPrekey LegalholdPlusFederationNotImplemented user client -claimPrekeyBundle :: (Member ClientStore r) => Domain -> UserId -> (Handler r) PrekeyBundle +claimPrekeyBundle :: (Member ClientSubsystem r) => Domain -> UserId -> (Handler r) PrekeyBundle claimPrekeyBundle _ user = - API.claimLocalPrekeyBundle LegalholdPlusFederationNotImplemented user !>> clientError + lift $ liftSem $ ClientSubsystem.claimLocalPrekeyBundle LegalholdPlusFederationNotImplemented user claimMultiPrekeyBundle :: - ( Member (Concurrency 'Unsafe) r, - Member DeleteQueue r, - Member AuthenticationSubsystem r, - Member ClientStore r - ) => + (Member ClientSubsystem r) => Domain -> UserClients -> Handler r UserClientPrekeyMap -claimMultiPrekeyBundle _ uc = API.claimLocalMultiPrekeyBundles LegalholdPlusFederationNotImplemented uc !>> clientError +claimMultiPrekeyBundle _ uc = lift $ liftSem $ ClientSubsystem.claimLocalMultiPrekeyBundles LegalholdPlusFederationNotImplemented uc fedClaimKeyPackages :: ( Member GalleyAPIAccess r, @@ -275,7 +266,7 @@ searchUsers domain (SearchRequest searchTerm mTeam mOnlyInTeams mbUserTypeFilter mFoundUserTeamId <- lift $ liftSem $ UserStore.getUserTeam foundUser localFoundUser <- qualifyLocal foundUser if isTeamAllowed mOnlyInTeams mFoundUserTeamId - then lift $ liftSem $ (fmap contactFromProfile . maybeToList) <$> UserSubsystem.getLocalUserProfile localFoundUser + then lift . liftSem $ (fmap contactFromProfile . maybeToList) <$> UserSubsystem.getLocalUserProfile localFoundUser else pure [] let filterTypes = case mbUserTypeFilter of Just [] -> id @@ -289,8 +280,8 @@ searchUsers domain (SearchRequest searchTerm mTeam mOnlyInTeams mbUserTypeFilter isTeamAllowed (Just _) Nothing = False isTeamAllowed (Just teams) (Just tid) = tid `elem` teams -getUserClients :: (Member ClientStore r) => Domain -> GetUserClients -> (Handler r) (UserMap (Set PubClient)) -getUserClients _ (GetUserClients uids) = API.lookupLocalPubClientsBulk uids !>> clientError +getUserClients :: (Member ClientSubsystem r) => Domain -> GetUserClients -> (Handler r) (UserMap (Set PubClient)) +getUserClients _ (GetUserClients uids) = lift (liftSem $ ClientSubsystem.lookupLocalPublicClientsBulk uids) !>> clientErrorToHttpError getMLSClients :: (Member ClientStore r) => Domain -> MLSClientsRequest -> Handler r (Set ClientInfo) getMLSClients _domain mcr = do diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index ff8d6d5eb31..6a6f17dbb80 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -24,7 +24,6 @@ module Brig.API.Internal where import Brig.API.Auth -import Brig.API.Client qualified as API import Brig.API.Connection qualified as API import Brig.API.Error import Brig.API.Handler @@ -34,16 +33,12 @@ import Brig.API.Types import Brig.API.User qualified as API import Brig.App as App import Brig.Data.Activation -import Brig.Data.Client qualified as Data import Brig.Data.Connection qualified as Data import Brig.Data.MLS.KeyPackage qualified as Data import Brig.Effects.UserPendingActivationStore (UserPendingActivationStore) import Brig.Options hiding (internalEvents) import Brig.Provider.API qualified as Provider import Brig.Team.API qualified as Team -import Brig.Types.Connection -import Brig.Types.Intra -import Brig.Types.User import Brig.User.EJPD qualified import Brig.User.Search.Index qualified as Search import Control.Error hiding (bool) @@ -95,6 +90,8 @@ import Wire.API.UserGroup (UserGroup) import Wire.API.UserGroup.Pagination import Wire.API.UserMap import Wire.ActivationCodeStore (ActivationCodeStore) +import Wire.AppStore (AppStore) +import Wire.AppStore qualified as AppStore import Wire.AppSubsystem (AppSubsystem) import Wire.AppSubsystem qualified as AppSubsystem import Wire.AuthenticationSubsystem (AuthenticationSubsystem) @@ -102,7 +99,8 @@ import Wire.AuthenticationSubsystem.Config (AuthenticationSubsystemConfig) import Wire.BlockListStore (BlockListStore) import Wire.ClientStore (ClientStore) import Wire.ClientStore qualified as ClientStore -import Wire.DeleteQueue (DeleteQueue) +import Wire.ClientSubsystem (ClientSubsystem, ReAuthPolicy (ReAuthPolicy)) +import Wire.ClientSubsystem qualified as ClientSubsystem import Wire.DomainRegistrationStore hiding (domain) import Wire.EmailSubsystem (EmailSubsystem) import Wire.EnterpriseLoginSubsystem @@ -147,7 +145,6 @@ import Wire.VerificationCodeSubsystem servantSitemap :: forall r p. ( Member BlockListStore r, - Member DeleteQueue r, Member (Concurrency 'Unsafe) r, Member (Embed HttpClientIO) r, Member FederationConfigStore r, @@ -186,8 +183,10 @@ servantSitemap :: Member CryptoSign r, Member Random r, Member SAMLEmailSubsystem r, + Member AppStore r, Member AppSubsystem r, - Member ClientStore r + Member ClientStore r, + Member ClientSubsystem r ) => ServerT BrigIRoutes.API (Handler r) servantSitemap = @@ -207,6 +206,7 @@ servantSitemap = :<|> enterpriseLoginApi :<|> samlIdPApi :<|> Named @"i-delete-app" deleteAppH + :<|> Named @"i-get-app-ids" getAppIdsH istatusAPI :: forall r. ServerT BrigIRoutes.IStatusAPI (Handler r) istatusAPI = Named @"get-status" (pure NoContent) @@ -231,7 +231,6 @@ accountAPI :: ( Member BlockListStore r, Member GalleyAPIAccess r, Member AuthenticationSubsystem r, - Member DeleteQueue r, Member (UserPendingActivationStore p) r, Member (Embed HttpClientIO) r, Member NotificationSubsystem r, @@ -242,7 +241,6 @@ accountAPI :: Member UserStore r, Member TinyLog r, Member EmailSubsystem r, - Member VerificationCodeSubsystem r, Member PropertySubsystem r, Member Events r, Member PasswordResetCodeStore r, @@ -257,7 +255,8 @@ accountAPI :: Member SparAPIAccess r, Member EnterpriseLoginSubsystem r, Member (Concurrency Unsafe) r, - Member ClientStore r + Member ClientStore r, + Member ClientSubsystem r ) => ServerT BrigIRoutes.AccountAPI (Handler r) accountAPI = @@ -346,7 +345,6 @@ authAPI :: Member TinyLog r, Member Events r, Member UserSubsystem r, - Member VerificationCodeSubsystem r, Member AuthenticationSubsystem r, Member (Input AuthenticationSubsystemConfig) r, Member (Concurrency Unsafe) r, @@ -539,16 +537,7 @@ getDomainRegistrationH domain = -- | Add a client without authentication checks addClientInternalH :: - ( Member GalleyAPIAccess r, - Member NotificationSubsystem r, - Member DeleteQueue r, - Member EmailSubsystem r, - Member Events r, - Member UserSubsystem r, - Member VerificationCodeSubsystem r, - Member AuthenticationSubsystem r, - Member ClientStore r - ) => + (Member ClientSubsystem r) => UserId -> Maybe Bool -> NewClient -> @@ -556,25 +545,21 @@ addClientInternalH :: (Handler r) Client addClientInternalH usr mSkipReAuth new connId = do let policy - | mSkipReAuth == Just True = \_ _ -> False - | otherwise = Data.reAuthForNewClients + | mSkipReAuth == Just True = ReAuthPolicy $ \_ _ -> False + | otherwise = def lusr <- qualifyLocal usr - API.addClientWithReAuthPolicy policy lusr connId new !>> clientError + lift $ liftSem $ ClientSubsystem.addClientWithPolicy policy lusr connId new -legalHoldClientRequestedH :: (Member Events r) => UserId -> LegalHoldClientRequest -> (Handler r) NoContent +legalHoldClientRequestedH :: (Member ClientSubsystem r) => UserId -> LegalHoldClientRequest -> (Handler r) NoContent legalHoldClientRequestedH targetUser clientRequest = do - lift $ NoContent <$ API.legalHoldClientRequested targetUser clientRequest + lift $ liftSem $ NoContent <$ ClientSubsystem.publishLegalHoldClientRequested targetUser clientRequest removeLegalHoldClientH :: - ( Member DeleteQueue r, - Member Events r, - Member AuthenticationSubsystem r, - Member ClientStore r - ) => + (Member ClientSubsystem r) => UserId -> (Handler r) NoContent removeLegalHoldClientH uid = do - lift $ NoContent <$ API.removeLegalHoldClient uid + lift $ liftSem $ NoContent <$ ClientSubsystem.removeLegalHoldClient uid internalListClientsH :: (Member ClientStore r) => UserSet -> (Handler r) UserClients internalListClientsH (UserSet usrs) = @@ -1065,3 +1050,6 @@ deleteGroupManagedInternalH tid gid managedBy = do deleteAppH :: (Member AppSubsystem r) => TeamId -> UserId -> Handler r NoContent deleteAppH tid uid = lift . liftSem $ AppSubsystem.deleteApp tid uid >> pure NoContent + +getAppIdsH :: (Member AppStore r) => TeamId -> Handler r [UserId] +getAppIdsH tid = lift . liftSem $ map (.id) <$> AppStore.getApps tid diff --git a/services/brig/src/Brig/API/MLS/KeyPackages.hs b/services/brig/src/Brig/API/MLS/KeyPackages.hs index 03e933cb38c..08f1f727caf 100644 --- a/services/brig/src/Brig/API/MLS/KeyPackages.hs +++ b/services/brig/src/Brig/API/MLS/KeyPackages.hs @@ -29,7 +29,6 @@ module Brig.API.MLS.KeyPackages ) where -import Brig.API.Error import Brig.API.Handler import Brig.API.MLS.CipherSuite import Brig.API.MLS.KeyPackages.Validation @@ -37,8 +36,6 @@ import Brig.API.MLS.Util import Brig.API.Types import Brig.App import Brig.Data.MLS.KeyPackage qualified as Data -import Brig.Federation.Client -import Brig.IO.Intra import Control.Monad.Trans.Except import Control.Monad.Trans.Maybe import Data.CommaSeparatedList @@ -59,7 +56,10 @@ import Wire.API.User (AccountStatus (..)) import Wire.API.User.Client import Wire.ClientStore (ClientStore) import Wire.ClientStore qualified as ClientStore +import Wire.ClientSubsystem.Error +import Wire.FederationAPIAccess import Wire.GalleyAPIAccess (GalleyAPIAccess, getUserLegalholdStatus) +import Wire.GalleyAPIAccess qualified as GalleyAPIAccess import Wire.StoredUser import Wire.UserStore (UserStore, getUser) @@ -73,7 +73,8 @@ uploadKeyPackages lusr cid kps = do claimKeyPackages :: ( Member GalleyAPIAccess r, Member UserStore r, - Member ClientStore r + Member ClientStore r, + HasBrigFederationAccess m r ) => Local UserId -> Maybe ClientId -> @@ -85,7 +86,8 @@ claimKeyPackages lusr mClient target = claimKeyPackagesV7 lusr mClient target . claimKeyPackagesV7 :: ( Member GalleyAPIAccess r, Member UserStore r, - Member ClientStore r + Member ClientStore r, + HasBrigFederationAccess m r ) => Local UserId -> Maybe ClientId -> @@ -98,7 +100,7 @@ claimKeyPackagesV7 lusr mClient target mSuite = do suite <- getCipherSuite mSuite foldQualified lusr - (withExceptT clientError . claimLocalKeyPackages (tUntagged lusr) mClient suite) + (withExceptT clientErrorToHttpError . claimLocalKeyPackages (tUntagged lusr) mClient suite) (claimRemoteKeyPackages lusr (tagCipherSuite suite)) target @@ -131,9 +133,11 @@ claimLocalKeyPackages qusr skipOwn suite qTarget = do foldQualified qTarget ( \lusr -> - guardLegalhold - (ProtectedUser (tUnqualified lusr)) - (mkUserClients [(target, clients)]) + lift $ + liftSem $ + GalleyAPIAccess.guardLegalHold + (ProtectedUser (tUnqualified lusr)) + (mkUserClients [(target, clients)]) ) (\_ -> pure ()) qusr @@ -163,29 +167,30 @@ claimLocalKeyPackages qusr skipOwn suite qTarget = do Nothing -> pure () claimRemoteKeyPackages :: - (Member ClientStore r) => + ( Member ClientStore r, + HasBrigFederationAccess m r + ) => Local UserId -> CipherSuite -> Remote UserId -> Handler r KeyPackageBundle claimRemoteKeyPackages lusr suite target = do + let req = + ClaimKeyPackageRequest + { claimant = tUnqualified lusr, + target = tUnqualified target, + cipherSuite = suite + } bundle <- - withExceptT clientError - . (handleFailure =<<) - $ withExceptT ClientFederationError - $ runBrigFederatorClient (tDomain target) - $ fedClient @'Brig @"claim-key-packages" - $ ClaimKeyPackageRequest - { claimant = tUnqualified lusr, - target = tUnqualified target, - cipherSuite = suite - } - + lift (liftSem $ runFederatedEither target $ fedClient @'Brig @"claim-key-packages" req) >>= \case + Left e -> throwE $ clientErrorToHttpError $ ClientFederationError e + Right Nothing -> throwE $ clientErrorToHttpError $ ClientUserNotFound (tUnqualified target) + Right (Just bundle) -> pure bundle -- validate all claimed key packages for_ bundle.entries $ \e -> do let cid = mkClientIdentity e.user e.client kpRaw <- - withExceptT (const . clientDataError $ KeyPackageDecodingError) + withExceptT (const . clientDataErrorToHttpError $ KeyPackageDecodingError) . except . decodeMLS' . kpData @@ -193,13 +198,10 @@ claimRemoteKeyPackages lusr suite target = do (refVal, _, _) <- validateUploadedKeyPackage cid kpRaw unless (refVal == e.ref) . throwE - . clientDataError + . clientDataErrorToHttpError $ InvalidKeyPackageRef pure bundle - where - handleFailure :: (Monad m) => Maybe x -> ExceptT ClientError m x - handleFailure = maybe (throwE (ClientUserNotFound (tUnqualified target))) pure countKeyPackages :: Local UserId -> ClientId -> CipherSuite -> Handler r KeyPackageCount countKeyPackages lusr c = countKeyPackagesV7 lusr c . Just diff --git a/services/brig/src/Brig/API/MLS/Util.hs b/services/brig/src/Brig/API/MLS/Util.hs index b23308d55b8..d489be84592 100644 --- a/services/brig/src/Brig/API/MLS/Util.hs +++ b/services/brig/src/Brig/API/MLS/Util.hs @@ -17,13 +17,12 @@ module Brig.API.MLS.Util where -import Brig.API.Error import Brig.API.Handler import Brig.App -import Brig.Data.Client import Brig.Options import Control.Error import Imports +import Wire.ClientSubsystem.Error isMLSEnabled :: Handler r Bool isMLSEnabled = fromMaybe False <$> asks (.settings.enableMLS) @@ -31,4 +30,4 @@ isMLSEnabled = fromMaybe False <$> asks (.settings.enableMLS) assertMLSEnabled :: Handler r () assertMLSEnabled = unlessM isMLSEnabled $ - throwE (clientDataError MLSNotEnabled) + throwE (clientDataErrorToHttpError MLSNotEnabled) diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index 5834e64788a..b22f0ff6df6 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -29,7 +29,6 @@ module Brig.API.Public where import Brig.API.Auth -import Brig.API.Client qualified as API import Brig.API.Connection qualified as API import Brig.API.Error import Brig.API.Handler @@ -52,10 +51,9 @@ import Brig.Options hiding (internalEvents) import Brig.Provider.API import Brig.Team.API qualified as Team import Brig.Template (InvitationUrlTemplates) -import Brig.Types.Activation (ActivationPair) -import Brig.Types.Intra import Brig.User.API.Handle qualified as Handle import Brig.User.Auth.Cookie qualified as Auth +import Brig.User.Client qualified as API import Cassandra qualified as C import Cassandra qualified as Data import Control.Error hiding (bool, note) @@ -160,9 +158,13 @@ import Wire.AppSubsystem (AppSubsystem) import Wire.AppSubsystem qualified as AppSubsystem import Wire.AuthenticationSubsystem as AuthenticationSubsystem import Wire.AuthenticationSubsystem.Config (AuthenticationSubsystemConfig) +import Wire.BackendNotificationQueueAccess import Wire.BlockListStore (BlockListStore) import Wire.ClientStore (ClientStore) import Wire.ClientStore qualified as ClientStore +import Wire.ClientSubsystem (ClientSubsystem) +import Wire.ClientSubsystem qualified as ClientSubsystem +import Wire.ClientSubsystem.Error import Wire.DeleteQueue import Wire.DomainRegistrationStore (DomainRegistrationStore) import Wire.EmailSending (EmailSending) @@ -171,8 +173,9 @@ import Wire.EnterpriseLoginSubsystem (EnterpriseLoginSubsystem) import Wire.EnterpriseLoginSubsystem qualified as EnterpriseLogin import Wire.Error import Wire.Events (Events) +import Wire.FederationAPIAccess import Wire.FederationConfigStore (FederationConfigStore) -import Wire.GalleyAPIAccess (GalleyAPIAccess) +import Wire.GalleyAPIAccess import Wire.GalleyAPIAccess qualified as GalleyAPIAccess import Wire.HashPassword (HashPassword) import Wire.IndexedUserStore (IndexedUserStore) @@ -366,7 +369,7 @@ internalEndpointsSwaggerDocsAPI service examplePort swagger Nothing = & cleanupSwagger servantSitemap :: - forall r p. + forall r p m. ( Member (Embed HttpClientIO) r, Member (Embed IO) r, Member (Error UserSubsystemError) r, @@ -415,7 +418,11 @@ servantSitemap :: Member TeamCollaboratorsSubsystem r, Member TeamSubsystem r, Member AppSubsystem r, - Member ClientStore r + Member ClientStore r, + Member ClientSubsystem r, + Member (Error FederationError) r, + Member BackendNotificationQueueAccess r, + HasBrigFederationAccess m r ) => ServerT BrigAPI (Handler r) servantSitemap = @@ -525,9 +532,9 @@ servantSitemap = Named @"add-client@v6" addClient :<|> Named @"add-client@v7" addClient :<|> Named @"add-client" addClient - :<|> Named @"update-client@v6" API.updateClient - :<|> Named @"update-client@v7" API.updateClient - :<|> Named @"update-client" API.updateClient + :<|> Named @"update-client@v6" updateClient + :<|> Named @"update-client@v7" updateClient + :<|> Named @"update-client" updateClient :<|> Named @"delete-client" deleteClient :<|> Named @"list-clients@v6" listClients :<|> Named @"list-clients@v7" listClients @@ -541,7 +548,7 @@ servantSitemap = :<|> Named @"get-client-prekeys" getClientPrekeys :<|> Named @"head-nonce" newNonce :<|> Named @"get-nonce" newNonce - :<|> Named @"create-access-token" (createAccessToken @UserClientAPI @CreateAccessToken POST) + :<|> Named @"create-access-token" (createClientDPoPAccessToken @UserClientAPI @CreateAccessToken POST) connectionAPI :: ServerT ConnectionAPI (Handler r) connectionAPI = @@ -676,10 +683,7 @@ listPropertyKeysAndValuesH :: (Member PropertySubsystem r) => UserId -> Handler listPropertyKeysAndValuesH u = lift . liftSem $ getAllProperties u getPrekeyUnqualifiedH :: - ( Member DeleteQueue r, - Member AuthenticationSubsystem r, - Member ClientStore r - ) => + (Member ClientSubsystem r) => UserId -> UserId -> ClientId -> @@ -689,33 +693,26 @@ getPrekeyUnqualifiedH zusr user client = do getPrekeyH zusr (Qualified user domain) client getPrekeyH :: - ( Member DeleteQueue r, - Member AuthenticationSubsystem r, - Member ClientStore r - ) => + (Member ClientSubsystem r) => UserId -> Qualified UserId -> ClientId -> (Handler r) Public.ClientPrekey getPrekeyH zusr (Qualified user domain) client = do - mPrekey <- API.claimPrekey (ProtectedUser zusr) user domain client !>> clientError + mPrekey <- lift $ liftSem $ ClientSubsystem.claimPrekey (ProtectedUser zusr) user domain client ifNothing (notFound "prekey not found") mPrekey -getPrekeyBundleUnqualifiedH :: (Member ClientStore r) => UserId -> UserId -> (Handler r) Public.PrekeyBundle +getPrekeyBundleUnqualifiedH :: (Member ClientSubsystem r) => UserId -> UserId -> (Handler r) Public.PrekeyBundle getPrekeyBundleUnqualifiedH zusr uid = do domain <- viewFederationDomain - API.claimPrekeyBundle (ProtectedUser zusr) domain uid !>> clientError + lift $ liftSem $ ClientSubsystem.claimPrekeyBundle (ProtectedUser zusr) domain uid -getPrekeyBundleH :: (Member ClientStore r) => UserId -> Qualified UserId -> (Handler r) Public.PrekeyBundle +getPrekeyBundleH :: (Member ClientSubsystem r) => UserId -> Qualified UserId -> (Handler r) Public.PrekeyBundle getPrekeyBundleH zusr (Qualified uid domain) = - API.claimPrekeyBundle (ProtectedUser zusr) domain uid !>> clientError + lift $ liftSem $ ClientSubsystem.claimPrekeyBundle (ProtectedUser zusr) domain uid getMultiUserPrekeyBundleUnqualifiedH :: - ( Member (Concurrency 'Unsafe) r, - Member DeleteQueue r, - Member AuthenticationSubsystem r, - Member ClientStore r - ) => + (Member ClientSubsystem r) => UserId -> Public.UserClients -> Handler r Public.UserClientPrekeyMap @@ -723,7 +720,7 @@ getMultiUserPrekeyBundleUnqualifiedH zusr userClients = do maxSize <- fromIntegral <$> asks (.settings.maxConvSize) when (Map.size (Public.userClients userClients) > maxSize) $ throwStd (errorToWai @'E.TooManyClients) - API.claimLocalMultiPrekeyBundles (ProtectedUser zusr) userClients !>> clientError + lift $ liftSem $ ClientSubsystem.claimLocalMultiPrekeyBundles (ProtectedUser zusr) userClients getMultiUserPrekeyBundleHInternal :: (MonadReader Env m, MonadError HttpError m) => @@ -739,42 +736,27 @@ getMultiUserPrekeyBundleHInternal qualUserClients = do throwStd (errorToWai @'E.TooManyClients) getMultiUserPrekeyBundleHV3 :: - ( Member (Concurrency 'Unsafe) r, - Member DeleteQueue r, - Member AuthenticationSubsystem r, - Member ClientStore r - ) => + forall r. + (Member ClientSubsystem r) => UserId -> Public.QualifiedUserClients -> (Handler r) Public.QualifiedUserClientPrekeyMap getMultiUserPrekeyBundleHV3 zusr qualUserClients = do getMultiUserPrekeyBundleHInternal qualUserClients - API.claimMultiPrekeyBundlesV3 (ProtectedUser zusr) qualUserClients !>> clientError + lift $ liftSem $ ClientSubsystem.claimMultiPrekeyBundlesV3 (ProtectedUser zusr) qualUserClients getMultiUserPrekeyBundleH :: - ( Member (Concurrency 'Unsafe) r, - Member DeleteQueue r, - Member AuthenticationSubsystem r, - Member ClientStore r - ) => + forall r. + (Member ClientSubsystem r) => UserId -> Public.QualifiedUserClients -> (Handler r) Public.QualifiedUserClientPrekeyMapV4 getMultiUserPrekeyBundleH zusr qualUserClients = do getMultiUserPrekeyBundleHInternal qualUserClients - API.claimMultiPrekeyBundles (ProtectedUser zusr) qualUserClients !>> clientError + lift $ liftSem $ ClientSubsystem.claimMultiPrekeyBundles (ProtectedUser zusr) qualUserClients addClient :: - ( Member GalleyAPIAccess r, - Member DeleteQueue r, - Member NotificationSubsystem r, - Member EmailSubsystem r, - Member AuthenticationSubsystem r, - Member VerificationCodeSubsystem r, - Member Events r, - Member UserSubsystem r, - Member ClientStore r - ) => + (Member ClientSubsystem r) => Local UserId -> ConnId -> Public.NewClient -> @@ -782,59 +764,58 @@ addClient :: addClient lusr con new = do -- Users can't add legal hold clients when (Public.newClientType new == Public.LegalHoldClientType) $ - throwE (clientError ClientLegalHoldCannotBeAdded) - API.addClient lusr (Just con) new - !>> clientError + throwE (clientErrorToHttpError ClientLegalHoldCannotBeAdded) + lift $ liftSem $ ClientSubsystem.addClient lusr (Just con) new + +updateClient :: (Member ClientSubsystem r) => UserId -> ClientId -> Public.UpdateClient -> Handler r () +updateClient uid cid payload = lift $ liftSem $ ClientSubsystem.updateClient uid cid payload deleteClient :: - ( Member AuthenticationSubsystem r, - Member DeleteQueue r, - Member ClientStore r - ) => + (Member ClientSubsystem r) => UserId -> ConnId -> ClientId -> Public.RmClient -> (Handler r) () deleteClient usr con clt body = - API.rmClient usr con clt (Public.rmPassword body) !>> clientError + lift $ liftSem $ ClientSubsystem.removeClient usr con clt (Public.rmPassword body) -listClients :: (Member ClientStore r) => UserId -> (Handler r) [Public.Client] +listClients :: (Member ClientSubsystem r) => UserId -> (Handler r) [Public.Client] listClients zusr = - lift $ API.lookupLocalClients zusr + lift $ liftSem $ ClientSubsystem.lookupLocalClients zusr -getClient :: (Member ClientStore r) => UserId -> ClientId -> (Handler r) (Maybe Public.Client) -getClient zusr clientId = lift $ API.lookupLocalClient zusr clientId +getClient :: (Member ClientSubsystem r) => UserId -> ClientId -> (Handler r) (Maybe Public.Client) +getClient zusr clientId = lift $ liftSem $ ClientSubsystem.lookupLocalClient zusr clientId -getUserClientsUnqualified :: (Member ClientStore r) => UserId -> (Handler r) [Public.PubClient] +getUserClientsUnqualified :: (Member ClientSubsystem r) => UserId -> (Handler r) [Public.PubClient] getUserClientsUnqualified uid = do localdomain <- viewFederationDomain - API.lookupPubClients (Qualified uid localdomain) !>> clientError + lift $ liftSem $ ClientSubsystem.lookupPublicClients (Qualified uid localdomain) -getUserClientsQualified :: (Member ClientStore r) => Qualified UserId -> (Handler r) [Public.PubClient] -getUserClientsQualified quid = API.lookupPubClients quid !>> clientError +getUserClientsQualified :: (Member ClientSubsystem r) => Qualified UserId -> (Handler r) [Public.PubClient] +getUserClientsQualified quid = lift $ liftSem $ ClientSubsystem.lookupPublicClients quid -getUserClientUnqualified :: (Member ClientStore r) => UserId -> ClientId -> (Handler r) Public.PubClient +getUserClientUnqualified :: (Member ClientSubsystem r) => UserId -> ClientId -> (Handler r) Public.PubClient getUserClientUnqualified uid cid = do localdomain <- viewFederationDomain - x <- API.lookupPubClient (Qualified uid localdomain) cid !>> clientError + x <- lift $ liftSem $ ClientSubsystem.lookupPublicClient (Qualified uid localdomain) cid ifNothing (notFound "client not found") x -listClientsBulk :: (Member ClientStore r) => UserId -> Range 1 MaxUsersForListClientsBulk [Qualified UserId] -> (Handler r) (Public.QualifiedUserMap (Set Public.PubClient)) +listClientsBulk :: (Member ClientSubsystem r) => UserId -> Range 1 MaxUsersForListClientsBulk [Qualified UserId] -> (Handler r) (Public.QualifiedUserMap (Set Public.PubClient)) listClientsBulk _zusr limitedUids = - API.lookupPubClientsBulk (fromRange limitedUids) !>> clientError + lift $ liftSem $ ClientSubsystem.lookupPublicClientsBulk (fromRange limitedUids) -listClientsBulkV2 :: (Member ClientStore r) => UserId -> Public.LimitedQualifiedUserIdList MaxUsersForListClientsBulk -> (Handler r) (Public.WrappedQualifiedUserMap (Set Public.PubClient)) +listClientsBulkV2 :: (Member ClientSubsystem r) => UserId -> Public.LimitedQualifiedUserIdList MaxUsersForListClientsBulk -> (Handler r) (Public.WrappedQualifiedUserMap (Set Public.PubClient)) listClientsBulkV2 zusr userIds = Public.Wrapped <$> listClientsBulk zusr (Public.qualifiedUsers userIds) -getUserClientQualified :: (Member ClientStore r) => Qualified UserId -> ClientId -> (Handler r) Public.PubClient +getUserClientQualified :: (Member ClientSubsystem r) => Qualified UserId -> ClientId -> (Handler r) Public.PubClient getUserClientQualified quid cid = do - x <- API.lookupPubClient quid cid !>> clientError + x <- lift $ liftSem $ ClientSubsystem.lookupPublicClient quid cid ifNothing (notFound "client not found") x -getClientCapabilities :: (Member ClientStore r) => UserId -> ClientId -> (Handler r) Public.ClientCapabilityList +getClientCapabilities :: (Member ClientSubsystem r) => UserId -> ClientId -> (Handler r) Public.ClientCapabilityList getClientCapabilities uid cid = do - mclient <- lift (API.lookupLocalClient uid cid) + mclient <- lift $ liftSem $ ClientSubsystem.lookupLocalClient uid cid maybe (throwStd (errorToWai @'E.ClientNotFound)) (pure . Public.clientCapabilities) mclient getRichInfo :: @@ -887,7 +868,7 @@ newNonce uid cid = do lift $ wrapClient $ Nonce.insertNonce ttl uid (Id.clientToText cid) nonce pure (nonce, NoStore) -createAccessToken :: +createClientDPoPAccessToken :: forall api endpoint r. ( Member JwtTools r, Member Now r, @@ -902,9 +883,9 @@ createAccessToken :: ClientId -> Proof -> (Handler r) (DPoPAccessTokenResponse, CacheControl) -createAccessToken method luid cid proof = do +createClientDPoPAccessToken method luid cid proof = do let link = safeLink (Proxy @api) (Proxy @endpoint) cid - API.createAccessToken luid cid method link proof !>> certEnrollmentError + API.createClientDPoPAccessToken luid cid method link proof !>> certEnrollmentError upgradePersonalToTeam :: ( Member (ConnectionStore InternalPaging) r, @@ -916,7 +897,10 @@ upgradePersonalToTeam :: Member TinyLog r, Member UserSubsystem r, Member UserStore r, - Member EmailSubsystem r + Member EmailSubsystem r, + HasBrigFederationAccess m r, + Member (Error FederationError) r, + Member BackendNotificationQueueAccess r ) => Local UserId -> Public.BindingNewTeamUser -> @@ -982,7 +966,7 @@ createUser ip (Public.NewUserPublic new) = lift . runExceptT $ do for_ (liftM3 (,,) userEmail (createdUserTeam result) newUserTeam) $ \(e, ct, ut) -> sendWelcomeEmail e ct ut (Just userLocale) cok <- - Auth.toWebCookie =<< case userStatus acc of + Auth.toWebCookie =<< case Public.userStatus acc of Public.Ephemeral -> lift . liftSem $ AuthenticationSubsystem.newCookie @_ @ZAuth.U userId Nothing Public.SessionCookie newUserLabel RevokeSameLabel @@ -992,7 +976,7 @@ createUser ip (Public.NewUserPublic new) = lift . runExceptT $ do -- pure $ CreateUserResponse cok userId (Public.SelfProfile acc) pure $ Public.RegisterSuccess cok (Public.SelfProfile acc) where - sendActivationEmail :: (Member EmailSubsystem r) => Public.EmailAddress -> Public.Name -> ActivationPair -> Maybe Public.Locale -> Maybe Public.NewTeamUser -> (AppT r) () + sendActivationEmail :: (Member EmailSubsystem r) => Public.EmailAddress -> Public.Name -> Public.ActivationPair -> Maybe Public.Locale -> Maybe Public.NewTeamUser -> (AppT r) () sendActivationEmail email name (key, code) locale mTeamUser | Just teamUser <- mTeamUser, Public.NewTeamCreator creator <- teamUser, @@ -1228,8 +1212,11 @@ checkHandles _ (Public.CheckHandles hs num) = do -- 'Handle.getHandleInfo') returns UserProfile to reduce traffic between backends -- in a federated scenario. getHandleInfoUnqualifiedH :: + forall r m. ( Member UserSubsystem r, - Member UserStore r + Member UserStore r, + HasBrigFederationAccess m r, + Member (Error FederationError) r ) => UserId -> Handle -> @@ -1324,7 +1311,8 @@ createConnection :: Member UserSubsystem r, Member TinyLog r, Member (Embed HttpClientIO) r, - Member TeamSubsystem r + Member TeamSubsystem r, + HasBrigFederationAccess m r ) => UserId -> ConnId -> @@ -1358,7 +1346,8 @@ updateConnection :: Member TinyLog r, Member (Embed HttpClientIO) r, Member GalleyAPIAccess r, - Member UserStore r + Member UserStore r, + HasBrigFederationAccess m r ) => UserId -> ConnId -> @@ -1586,7 +1575,7 @@ sendVerificationCode req = do sendMail email code.codeValue (Just (Public.userLocale account)) action _ -> pure () where - getAccount :: Public.EmailAddress -> (Handler r) (Maybe User) + getAccount :: Public.EmailAddress -> (Handler r) (Maybe Public.User) getAccount email = lift . liftSem $ do mbUserId <- lookupKey $ mkEmailKey email mbLUserId <- qualifyLocal' `traverse` mbUserId @@ -1599,7 +1588,7 @@ sendVerificationCode req = do Public.Login -> sendLoginVerificationMail email value mbLocale Public.DeleteTeam -> sendTeamDeletionVerificationMail email value mbLocale - getFeatureStatus :: Maybe User -> (Handler r) Bool + getFeatureStatus :: Maybe Public.User -> (Handler r) Bool getFeatureStatus mbAccount = do mbStatusEnabled <- lift $ liftSem $ GalleyAPIAccess.getVerificationCodeEnabled `traverse` (Public.userTeam =<< mbAccount) pure $ fromMaybe False mbStatusEnabled @@ -1771,17 +1760,28 @@ createApp :: (_) => Local UserId -> TeamId -> Public.NewApp -> Handler r Public. createApp lusr tid new = lift . liftSem $ AppSubsystem.createApp lusr tid new getApp :: (_) => Local UserId -> TeamId -> UserId -> Handler r UserProfile -getApp lusr _tid uid = lift . liftSem $ do - prof <- getLocalUserProfileFiltered404 AppsOnly (qualifyAs lusr uid) +getApp lusr tid uid = lift . liftSem $ do + -- Check if requesting user is a member of the team + requestingUserTeam <- getUserTeam (tUnqualified lusr) + unless (requestingUserTeam == Just tid) $ + throw UserSubsystemProfileNotFound + + profs <- getLocalUserProfiles (qualifyAs lusr [uid]) + prof <- + note UserSubsystemProfileNotFound $ + find (\p -> p.profileType == Public.UserTypeApp && p.profileTeam == Just tid) profs if prof.profileDeleted then throw UserSubsystemProfileNotFound else pure prof getApps :: (_) => Local UserId -> TeamId -> Handler r [UserProfile] -getApps lusr tid = - lift . liftSem $ do - appIds <- AppSubsystem.getAppIds lusr tid - getLocalUserProfilesFiltered AppsOnly (qualifyAs lusr appIds) +getApps lusr tid = lift . liftSem $ do + -- Check if requesting user is a member of the team + requestingUserTeam <- getUserTeam (tUnqualified lusr) + unless (requestingUserTeam == Just tid) $ + throw UserSubsystemProfileNotFound + + getLocalAppProfiles (qualifyAs lusr tid) putApp :: (_) => Local UserId -> TeamId -> UserId -> Public.PutApp -> Handler r () putApp lusr tid uid put = lift . liftSem $ AppSubsystem.updateApp lusr tid uid put diff --git a/services/brig/src/Brig/API/Types.hs b/services/brig/src/Brig/API/Types.hs index 1936a91c644..e12d0f646d2 100644 --- a/services/brig/src/Brig/API/Types.hs +++ b/services/brig/src/Brig/API/Types.hs @@ -31,8 +31,6 @@ module Brig.API.Types where import Brig.Data.Activation (ActivationError (..)) -import Brig.Data.Client (ClientDataError (..)) -import Brig.Types.Intra import Data.Code import Data.Id import Data.Jwt.Tools (DPoPTokenGenerationError (..)) @@ -44,6 +42,7 @@ import Wire.API.Federation.Error import Wire.API.User import Wire.API.User.Activation import Wire.AuthenticationSubsystem.Error +import Wire.ClientSubsystem.Error import Wire.UserKeyStore ------------------------------------------------------------------------------- @@ -141,32 +140,11 @@ data LoginError | LoginCodeInvalid | LoginPasswordUpdateRequired -data VerificationCodeError - = VerificationCodeRequired - | VerificationCodeNoPendingCode - | VerificationCodeNoEmail - data SendActivationCodeError = InvalidRecipient EmailKey | UserKeyInUse EmailKey | ActivationBlacklistedUserKey EmailKey -data ClientError - = ClientNotFound - | ClientDataError !ClientDataError - | ClientUserNotFound !UserId - | ClientLegalHoldCannotBeRemoved - | ClientLegalHoldCannotBeAdded - | -- | this error is thrown if legalhold if incompatible with different features - -- for now, this is the case for MLS and federation - ClientLegalHoldIncompatible - | ClientFederationError FederationError - | ClientCapabilitiesCannotBeRemoved - | ClientMissingLegalholdConsentOldClients - | ClientMissingLegalholdConsent - | ClientCodeAuthenticationFailed - | ClientCodeAuthenticationRequired - data DeleteUserError = DeleteUserInvalid | DeleteUserInvalidCode diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index cccbf9f3880..4b6f1a4877c 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -75,8 +75,6 @@ import Brig.Effects.UserPendingActivationStore (UserPendingActivation (..), User import Brig.Effects.UserPendingActivationStore qualified as UserPendingActivationStore import Brig.IO.Intra qualified as Intra import Brig.Options hiding (internalEvents) -import Brig.Types.Activation (ActivationPair) -import Brig.Types.Intra import Brig.User.Auth.Cookie qualified as Auth import Cassandra hiding (Set) import Control.Error @@ -99,7 +97,7 @@ import Data.Range import Data.Time.Clock import Data.UUID.V4 (nextRandom) import Imports -import Network.Wai.Utilities +import Network.Wai.Utilities hiding (Error) import Polysemy import Polysemy.Error import Polysemy.Input @@ -110,6 +108,7 @@ import System.Logger.Message import Wire.API.Connection import Wire.API.Error import Wire.API.Error.Brig qualified as E +import Wire.API.Federation.Error import Wire.API.Routes.Internal.Galley.TeamsIntra qualified as Team import Wire.API.Team hiding (newTeam) import Wire.API.Team.Member (legalHoldStatus) @@ -122,6 +121,7 @@ import Wire.API.UserEvent import Wire.ActivationCodeStore import Wire.ActivationCodeStore qualified as ActivationCode import Wire.AuthenticationSubsystem (AuthenticationSubsystem, internalLookupPasswordResetCode) +import Wire.BackendNotificationQueueAccess import Wire.BlockListStore as BlockListStore import Wire.ClientStore (ClientStore) import Wire.ClientStore qualified as ClientStore @@ -130,6 +130,7 @@ import Wire.EmailSubsystem import Wire.Error import Wire.Events (Events) import Wire.Events qualified as Events +import Wire.FederationAPIAccess import Wire.GalleyAPIAccess as GalleyAPIAccess import Wire.HashPassword (HashPassword) import Wire.HashPassword qualified as HashPassword @@ -271,7 +272,7 @@ createUserSpar new = do pure $ CreateUserTeam tid nm upgradePersonalToTeam :: - forall r. + forall r m. ( Member GalleyAPIAccess r, Member UserStore r, Member UserSubsystem r, @@ -281,7 +282,10 @@ upgradePersonalToTeam :: Member (Input (Local ())) r, Member Now r, Member (ConnectionStore InternalPaging) r, - Member EmailSubsystem r + Member EmailSubsystem r, + HasBrigFederationAccess m r, + Member (Error FederationError) r, + Member BackendNotificationQueueAccess r ) => Local UserId -> BindingNewTeamUser -> diff --git a/services/brig/src/Brig/API/Util.hs b/services/brig/src/Brig/API/Util.hs index 81b1e79d754..d965976888f 100644 --- a/services/brig/src/Brig/API/Util.hs +++ b/services/brig/src/Brig/API/Util.hs @@ -19,8 +19,6 @@ module Brig.API.Util ( fetchUserIdentity, logInvitationCode, logEmail, - traverseConcurrentlySem, - traverseConcurrentlyWithErrors, exceptTToMaybe, ensureLocal, ) @@ -30,7 +28,6 @@ import Brig.API.Types import Brig.App import Control.Monad.Catch (throwM) import Control.Monad.Trans.Except -import Data.Bifunctor import Data.Id import Data.Maybe import Data.Text qualified as T @@ -39,8 +36,6 @@ import Imports import Polysemy import System.Logger (Msg) import System.Logger qualified as Log -import UnliftIO.Async -import UnliftIO.Exception (throwIO, try) import Util.Logging (sha256String) import Wire.API.User import Wire.UserSubsystem @@ -60,26 +55,5 @@ logEmail email = logInvitationCode :: InvitationCode -> (Msg -> Msg) logInvitationCode code = Log.field "invitation_code" (toText $ fromInvitationCode code) --- | Traverse concurrently and fail on first error. -traverseConcurrentlyWithErrors :: - (Traversable t, Exception e, MonadUnliftIO m) => - (a -> ExceptT e m b) -> - t a -> - ExceptT e m (t b) -traverseConcurrentlyWithErrors f = - ExceptT - . try - . ( traverse (either throwIO pure) - <=< pooledMapConcurrentlyN 8 (runExceptT . f) - ) - -traverseConcurrentlySem :: - (Traversable t, MonadUnliftIO m) => - (a -> ExceptT e m b) -> - t a -> - m (t (Either (a, e) b)) -traverseConcurrentlySem f = - pooledMapConcurrentlyN 8 $ \a -> first (a,) <$> runExceptT (f a) - exceptTToMaybe :: (Monad m) => ExceptT e m () -> m (Maybe e) exceptTToMaybe = (pure . either Just (const Nothing)) <=< runExceptT diff --git a/services/brig/src/Brig/Calling/API.hs b/services/brig/src/Brig/Calling/API.hs index 4da581508ea..78588a606d3 100644 --- a/services/brig/src/Brig/Calling/API.hs +++ b/services/brig/src/Brig/Calling/API.hs @@ -209,7 +209,6 @@ newConfig uid env discoveredServers sftStaticUrl mSftEnv limit listAllServers ve limitedList :: NonEmpty Public.TurnURI -> Range 1 10 Int -> NonEmpty Public.TurnURI limitedList uris lim = -- assuming limitServers is safe with respect to the length of its return value - -- (see property tests in brig-types) -- since the input is NonEmpty and limit is in Range 1 10 -- it should also be safe to assume the returning list has length >= 1 NonEmpty.nonEmpty (Public.limitServers (NonEmpty.toList uris) (fromRange lim)) diff --git a/services/brig/src/Brig/CanonicalInterpreter.hs b/services/brig/src/Brig/CanonicalInterpreter.hs index c97db46cc34..a5eb8d4f30b 100644 --- a/services/brig/src/Brig/CanonicalInterpreter.hs +++ b/services/brig/src/Brig/CanonicalInterpreter.hs @@ -28,7 +28,7 @@ import Brig.Effects.SFT (SFT, interpretSFT) import Brig.Effects.UserPendingActivationStore (UserPendingActivationStore) import Brig.Effects.UserPendingActivationStore.Cassandra (userPendingActivationStoreToCassandra) import Brig.IO.Intra (runEvents) -import Brig.Options (federationDomainConfigs, federationStrategy) +import Brig.Options (Settings (consumableNotifications), federationDomainConfigs, federationStrategy) import Brig.Options qualified as Opt import Brig.Template (InvitationUrlTemplates) import Brig.User.Search.Index (IndexEnv (..)) @@ -62,6 +62,9 @@ import Wire.AppSubsystem.Interpreter import Wire.AuthenticationSubsystem import Wire.AuthenticationSubsystem.Config import Wire.AuthenticationSubsystem.Interpreter +import Wire.BackendNotificationQueueAccess (BackendNotificationQueueAccess) +import Wire.BackendNotificationQueueAccess.RabbitMq (interpretBackendNotificationQueueAccess) +import Wire.BackendNotificationQueueAccess.RabbitMq qualified as BackendNotificationQueueAccess import Wire.BackgroundJobsPublisher (BackgroundJobsPublisher) import Wire.BackgroundJobsPublisher.RabbitMQ (interpretBackgroundJobsPublisherRabbitMQ) import Wire.BlockListStore @@ -70,6 +73,7 @@ import Wire.ClientStore (ClientStore) import Wire.ClientStore.Cassandra import Wire.ClientStore.DynamoDB (OptimisticLockEnv (..)) import Wire.ClientSubsystem +import Wire.ClientSubsystem.Error (clientErrorToHttpError) import Wire.ClientSubsystem.Interpreter import Wire.DeleteQueue import Wire.DomainRegistrationStore @@ -168,7 +172,8 @@ type NonRecursiveEffects1 = type RecursiveEffects = '[ AuthenticationSubsystem, UserSubsystem, - AppSubsystem + AppSubsystem, + ClientSubsystem ] type NonRecursiveEffects2 = @@ -178,8 +183,7 @@ type NonRecursiveEffects2 = -- | These effects have interpreters which don't depend on each other type BrigLowerLevelEffects = - '[ ClientSubsystem, - SAMLEmailSubsystem, + '[ SAMLEmailSubsystem, TeamSubsystem, TeamCollaboratorsStore, AppStore, @@ -189,6 +193,7 @@ type BrigLowerLevelEffects = DeleteQueue, Wire.Events.Events, NotificationSubsystem, + BackendNotificationQueueAccess, BackgroundJobsPublisher, RateLimit, UserGroupStore, @@ -204,7 +209,6 @@ type BrigLowerLevelEffects = Error VerificationCodeSubsystemError, Error PropertySubsystemError, Error RateLimitExceeded, - Error HttpError, Wire.FederationAPIAccess.FederationAPIAccess Wire.API.Federation.Client.FederatorClient, DomainVerificationChallengeStore, DomainRegistrationStore, @@ -229,6 +233,7 @@ type BrigLowerLevelEffects = Input (Local ()), Input (AuthenticationSubsystemConfig), Input InvitationUrlTemplates, + Input ClientSubsystemConfig, GundeckAPIAccess, FederationConfigStore, Jwk, @@ -246,9 +251,11 @@ type BrigLowerLevelEffects = Rpc, Metrics, Embed Cas.Client, + Error ClientError, Error ParseException, Error ErrorCall, Error SomeException, + Error HttpError, TinyLog, Embed HttpClientIO, Embed IO, @@ -268,17 +275,20 @@ runRecursiveEffects :: (Members NonRecursiveEffects2 r) => Sem (RecursiveEffects `Append` r) a -> Sem r a -runRecursiveEffects = runApp . runUser . runAuth +runRecursiveEffects = runClient . runApp . runUser . runAuth where runAuth :: forall r. (Members NonRecursiveEffects2 r) => InterpreterFor AuthenticationSubsystem r runAuth = interpretAuthenticationSubsystem runUser runUser :: forall r. (Members NonRecursiveEffects2 r) => InterpreterFor UserSubsystem r - runUser = runUserSubsystem runAuth runApp + runUser = runUserSubsystem runAuth runApp runClient runApp :: forall r. (Members NonRecursiveEffects2 r) => InterpreterFor AppSubsystem r runApp = runAppSubsystem runUser runAuth + runClient :: forall r. (Members NonRecursiveEffects2 r) => InterpreterFor ClientSubsystem r + runClient = runClientSubsystem runAuth runUser + runBrigToIO :: App.Env -> AppT BrigCanonicalEffects a -> IO a runBrigToIO e (AppT ma) = do let blockedDomains = @@ -359,6 +369,18 @@ runBrigToIO e (AppT ma) = do e.randomPrekeyLocalLock, casClient = e.casClient } + clientSubsystemConfig = + ClientSubsystemConfig + { userMaxPermClients = fromMaybe Opt.defUserMaxPermClients e.settings.userMaxPermClients, + consumableNotificationsEnabled = e.settings.consumableNotifications + } + backendNotificationQueueEnv = + BackendNotificationQueueAccess.Env + { channelMVar = e.rabbitmqChannel, + logger = e.appLogger, + local = localUnit, + requestId = e.requestId + } ( either throwM pure <=< ( runFinal @@ -368,9 +390,11 @@ runBrigToIO e (AppT ma) = do . embedToFinal . runEmbedded (runHttpClientIO e) . loggerToTinyLogReqId e.requestId e.appLogger + . rethrowHttpErrorIO . runError @SomeException . mapError @ErrorCall SomeException . mapError @ParseException SomeException + . mapError clientErrorToHttpError . interpretClientToIO e.casClient . runMetricsToIO . runRpcWithHttp e.httpManager e.requestId @@ -388,6 +412,7 @@ runBrigToIO e (AppT ma) = do . interpretJwk . interpretFederationDomainConfig e.casClient e.settings.federationStrategy (foldMap (remotesMapFromCfgFile . fmap (.federationDomainConfig)) e.settings.federationDomainConfigs) . runGundeckAPIAccess e.gundeckEndpoint + . runInputConst clientSubsystemConfig . runInputConst (invitationUrlTemplates e) . runInputConst authenticationSubsystemConfig . runInputConst localUnit @@ -412,7 +437,6 @@ runBrigToIO e (AppT ma) = do . interpretDomainRegistrationStoreToCassandra e.casClient . interpretDomainVerificationChallengeStoreToCassandra e.casClient e.settings.challengeTTL . interpretFederationAPIAccess federationApiAccessConfig - . rethrowHttpErrorIO . mapError rateLimitExceededToHttpError . mapError propertySubsystemErrorToHttpError . mapError verificationCodeSubsystemErrorToHttpError @@ -428,6 +452,7 @@ runBrigToIO e (AppT ma) = do . interpretUserGroupStoreToPostgres . interpretRateLimit e.rateLimitEnv . interpretBackgroundJobsPublisherRabbitMQ e.requestId e.amqpJobsPublisherChannel + . interpretBackendNotificationQueueAccess (Just backendNotificationQueueEnv) . runNotificationSubsystemGundeck (defaultNotificationSubsystemConfig e.requestId) . runEvents . runDeleteQueue e.internalEvents @@ -438,7 +463,6 @@ runBrigToIO e (AppT ma) = do . interpretTeamCollaboratorsStoreToPostgres . interpretTeamSubsystemToGalleyAPI . samlEmailSubsystemInterpreter - . runClientSubsystem . interpretTeamCollaboratorsSubsystem . runRecursiveEffects . interpretUserGroupSubsystem diff --git a/services/brig/src/Brig/Data/Activation.hs b/services/brig/src/Brig/Data/Activation.hs index e500f37922b..9c9eb1446e1 100644 --- a/services/brig/src/Brig/Data/Activation.hs +++ b/services/brig/src/Brig/Data/Activation.hs @@ -27,7 +27,6 @@ module Brig.Data.Activation where import Brig.App (AppT, liftSem, qualifyLocal, wrapClientE) -import Brig.Types.Intra import Cassandra import Control.Error import Data.Id diff --git a/services/brig/src/Brig/Data/Client.hs b/services/brig/src/Brig/Data/Client.hs deleted file mode 100644 index 274b1193c95..00000000000 --- a/services/brig/src/Brig/Data/Client.hs +++ /dev/null @@ -1,139 +0,0 @@ --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module Brig.Data.Client - ( -- * Clients - ClientDataError (..), - AuthError (..), - ReAuthError (..), - ReAuthPolicy, - reAuthForNewClients, - addClientWithReAuthPolicy, - addClient, - ) -where - -import Brig.App -import Control.Error -import Data.Id -import Data.Json.Util (toUTCTimeMillis) -import Data.Qualified -import Imports -import Polysemy (Member) -import Wire.API.User.Client hiding (UpdateClient (..)) -import Wire.API.User.Client.Prekey -import Wire.AuthenticationSubsystem (AuthenticationSubsystem) -import Wire.AuthenticationSubsystem qualified as Authentication -import Wire.AuthenticationSubsystem.Error -import Wire.ClientStore (ClientStore, DuplicateMLSPublicKey (..)) -import Wire.ClientStore qualified as ClientStore - -data ClientDataError - = TooManyClients - | ClientReAuthError !ReAuthError - | ClientMissingAuth - | MalformedPrekeys - | MLSPublicKeyDuplicate - | MLSNotEnabled - | KeyPackageDecodingError - | InvalidKeyPackageRef - --- | Re-authentication policy. --- --- For a potential new client, a policy is a function that takes as arguments --- the number of existing clients of the same type, and whether the client --- already exists, and returns whether the user should be forced to --- re-authenticate. -type ReAuthPolicy = Int -> Bool -> Bool - --- | Default re-authentication policy. --- --- Re-authenticate if there is at least one other client. -reAuthForNewClients :: ReAuthPolicy -reAuthForNewClients count upsert = count > 0 && not upsert - -addClient :: - (Member AuthenticationSubsystem r, Member ClientStore r) => - Local UserId -> - ClientId -> - NewClient -> - Int -> - Maybe ClientCapabilityList -> - ExceptT ClientDataError (AppT r) (Client, [Client], Word) -addClient = addClientWithReAuthPolicy reAuthForNewClients - -addClientWithReAuthPolicy :: - forall r. - ( MonadReader Brig.App.Env (AppT r), - Member AuthenticationSubsystem r, - Member ClientStore r - ) => - ReAuthPolicy -> - Local UserId -> - ClientId -> - NewClient -> - Int -> - Maybe ClientCapabilityList -> - ExceptT ClientDataError (AppT r) (Client, [Client], Word) -addClientWithReAuthPolicy reAuthPolicy u newId c maxPermClients caps = do - clients <- lift . liftSem $ ClientStore.lookupClients (tUnqualified u) - let typed = filter ((== newClientType c) . clientType) clients - let count = length typed - let upsert = any exists typed - when (reAuthPolicy count upsert) do - (lift . liftSem $ Authentication.reauthenticateEither (tUnqualified u) (newClientPassword c)) - >>= either (throwE . ClientReAuthError) pure - let capacity = fmap (+ (-count)) limit - unless (maybe True (> 0) capacity || upsert) $ - throwE TooManyClients - new <- insert (tUnqualified u) - let !total = fromIntegral (length clients + if upsert then 0 else 1) - let old = maybe (filter (not . exists) typed) (const []) limit - pure (new, old, total) - where - limit :: Maybe Int - limit = case newClientType c of - PermanentClientType -> Just maxPermClients - TemporaryClientType -> Nothing - LegalHoldClientType -> Nothing - - exists :: Client -> Bool - exists = (==) newId . (.clientId) - - insert :: UserId -> ExceptT ClientDataError (AppT r) Client - insert uid = do - now <- toUTCTimeMillis <$> (liftIO =<< asks (.currentTime)) - let prekeys = unpackLastPrekey (newClientLastKey c) : newClientPrekeys c - unless (all checkPrekeyBundle prekeys) $ - throwE MalformedPrekeys - mErr <- lift . liftSem $ ClientStore.upsert uid newId now (c {newClientCapabilities = caps}) - case mErr of - Just DuplicateMLSPublicKey -> throwE MLSPublicKeyDuplicate - Nothing -> - pure $! - Client - { clientId = newId, - clientType = newClientType c, - clientTime = now, - clientClass = newClientClass c, - clientLabel = newClientLabel c, - clientCookie = newClientCookie c, - clientModel = newClientModel c, - clientCapabilities = fromMaybe mempty caps, - clientMLSPublicKeys = mempty, - clientLastActive = Nothing - } diff --git a/services/brig/src/Brig/Effects/SFT.hs b/services/brig/src/Brig/Effects/SFT.hs index 04983783d5f..9eccfd3e4c5 100644 --- a/services/brig/src/Brig/Effects/SFT.hs +++ b/services/brig/src/Brig/Effects/SFT.hs @@ -80,7 +80,7 @@ newtype AllURLs = AllURLs {unAllURLs :: [HttpsUrl]} instance ToSchema AllURLs where schema = - object "AllURLs" $ + object $ AllURLs <$> unAllURLs .= field "sft_servers_all" (array schema) diff --git a/services/brig/src/Brig/Federation/Client.hs b/services/brig/src/Brig/Federation/Client.hs deleted file mode 100644 index 475e48e9adc..00000000000 --- a/services/brig/src/Brig/Federation/Client.hs +++ /dev/null @@ -1,194 +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 . - --- FUTUREWORK: Remove this module all together. -module Brig.Federation.Client where - -import Brig.App -import Control.Monad -import Control.Monad.Catch (MonadMask, throwM) -import Control.Monad.Trans.Except (ExceptT (..), throwE) -import Control.Retry -import Control.Timeout -import Data.Domain -import Data.Handle -import Data.Id -import Data.Qualified -import Data.Range (Range) -import Data.Text qualified as T -import Data.Time.Units -import Imports -import Network.AMQP qualified as Q -import System.Logger.Class qualified as Log -import Wire.API.Federation.API -import Wire.API.Federation.API.Brig as FederatedBrig -import Wire.API.Federation.BackendNotifications -import Wire.API.Federation.Client -import Wire.API.Federation.Error -import Wire.API.User -import Wire.API.User.Client -import Wire.API.User.Client.Prekey -import Wire.API.UserMap - -getUserHandleInfo :: - ( MonadReader Env m, - MonadIO m, - Log.MonadLogger m - ) => - Remote Handle -> - ExceptT FederationError m (Maybe UserProfile) -getUserHandleInfo (tUntagged -> Qualified handle domain) = do - lift $ Log.info $ Log.msg $ T.pack "Brig-federation: handle lookup call on remote backend" - runBrigFederatorClient domain $ fedClient @'Brig @"get-user-by-handle" handle - -getUsersByIds :: - ( MonadReader Env m, - MonadIO m, - Log.MonadLogger m - ) => - Domain -> - [UserId] -> - ExceptT FederationError m [UserProfile] -getUsersByIds domain uids = do - lift $ Log.info $ Log.msg ("Brig-federation: get users by ids on remote backends" :: ByteString) - runBrigFederatorClient domain $ fedClient @'Brig @"get-users-by-ids" uids - -claimPrekey :: - (MonadReader Env m, MonadIO m, Log.MonadLogger m) => - Qualified UserId -> - ClientId -> - ExceptT FederationError m (Maybe ClientPrekey) -claimPrekey (Qualified user domain) client = do - lift $ Log.info $ Log.msg @Text "Brig-federation: claiming remote prekey" - runBrigFederatorClient domain $ fedClient @'Brig @"claim-prekey" (user, client) - -claimPrekeyBundle :: - ( MonadReader Env m, - MonadIO m, - Log.MonadLogger m - ) => - Qualified UserId -> - ExceptT FederationError m PrekeyBundle -claimPrekeyBundle (Qualified user domain) = do - lift $ Log.info $ Log.msg @Text "Brig-federation: claiming remote prekey bundle" - runBrigFederatorClient domain $ fedClient @'Brig @"claim-prekey-bundle" user - -claimMultiPrekeyBundle :: - ( Log.MonadLogger m, - MonadReader Env m, - MonadIO m - ) => - Domain -> - UserClients -> - ExceptT FederationError m UserClientPrekeyMap -claimMultiPrekeyBundle domain uc = do - lift . Log.info $ Log.msg @Text "Brig-federation: claiming remote multi-user prekey bundle" - runBrigFederatorClient domain $ fedClient @'Brig @"claim-multi-prekey-bundle" uc - -getUserClients :: - ( MonadReader Env m, - MonadIO m, - Log.MonadLogger m - ) => - Domain -> - GetUserClients -> - ExceptT FederationError m (UserMap (Set PubClient)) -getUserClients domain guc = do - lift $ Log.info $ Log.msg @Text "Brig-federation: get users' clients from remote backend" - runBrigFederatorClient domain $ fedClient @'Brig @"get-user-clients" guc - -sendConnectionAction :: - (MonadReader Env m, MonadIO m, Log.MonadLogger m) => - Local UserId -> - Maybe (Local TeamId) -> - Remote UserId -> - RemoteConnectionAction -> - ExceptT FederationError m NewConnectionResponse -sendConnectionAction self mSelfTeam (tUntagged -> other) action = do - let req = - NewConnectionRequest - (tUnqualified self) - (tUnqualified <$> mSelfTeam) - (qUnqualified other) - action - lift $ Log.info $ Log.msg @Text "Brig-federation: sending connection action to remote backend" - runBrigFederatorClient (qDomain other) $ fedClient @'Brig @"send-connection-action" req - -notifyUserDeleted :: - ( MonadReader Env m, - MonadIO m, - MonadMask m, - Log.MonadLogger m - ) => - Local UserId -> - Remote (Range 1 1000 [UserId]) -> - m () -notifyUserDeleted self remotes = do - let remoteConnections = tUnqualified remotes - let notif = UserDeletedConnectionsNotification (tUnqualified self) remoteConnections - remoteDomain = tDomain remotes - - asks (.rabbitmqChannel) >>= \chanVar -> - enqueueNotification (tDomain self) remoteDomain Q.Persistent chanVar $ - fedQueueClient @'OnUserDeletedConnectionsTag notif - --- | Enqueues notifications in RabbitMQ. Retries 3 times with a delay of 1s. -enqueueNotification :: (MonadIO m, MonadMask m, Log.MonadLogger m, MonadReader Env m) => Domain -> Domain -> Q.DeliveryMode -> MVar Q.Channel -> FedQueueClient c () -> m () -enqueueNotification ownDomain remoteDomain deliveryMode chanVar action = do - let policy = limitRetries 3 <> constantDelay 1_000_000 - recovering policy [logRetries (const $ pure True) logError] (const go) - where - logError willRetry (SomeException e) status = do - rid <- asks (.requestId) - Log.err $ - Log.msg @Text "failed to enqueue notification in RabbitMQ" - . Log.field "error" (displayException e) - . Log.field "willRetry" willRetry - . Log.field "retryCount" status.rsIterNumber - . Log.field "request" rid - go = do - rid <- asks (.requestId) - mChan <- timeout (1 :: Second) (readMVar chanVar) - case mChan of - Nothing -> throwM NoRabbitMqChannel - Just chan -> liftIO $ enqueue chan rid ownDomain remoteDomain deliveryMode action - -data NoRabbitMqChannel = NoRabbitMqChannel - deriving (Show) - -instance Exception NoRabbitMqChannel - -runBrigFederatorClient :: - (MonadReader Env m, MonadIO m) => - Domain -> - FederatorClient 'Brig a -> - ExceptT FederationError m a -runBrigFederatorClient targetDomain action = do - ownDomain <- viewFederationDomain - endpoint <- asks (.federator) >>= maybe (throwE FederationNotConfigured) pure - mgr <- asks (.http2Manager) - rid <- asks (.requestId) - let env = - FederatorClientEnv - { ceOriginDomain = ownDomain, - ceTargetDomain = targetDomain, - ceFederator = endpoint, - ceHttp2Manager = mgr, - ceOriginRequestId = rid - } - liftIO (runFederatorClient env action) - >>= either (throwE . FederationCallFailure) pure diff --git a/services/brig/src/Brig/IO/Intra.hs b/services/brig/src/Brig/IO/Intra.hs index cac1765e4d2..e57b1489801 100644 --- a/services/brig/src/Brig/IO/Intra.hs +++ b/services/brig/src/Brig/IO/Intra.hs @@ -40,9 +40,6 @@ module Brig.IO.Intra -- * Account Deletion rmUser, - -- * Legalhold - guardLegalhold, - -- * Low Level API for Notifications notify, ) @@ -51,22 +48,17 @@ where import Bilge hiding (head, options, requestId) import Bilge.RPC import Brig.API.Error (internalServerError) -import Brig.API.Types import Brig.App import Brig.Data.Connection import Brig.Data.Connection qualified as Data import Brig.Effects.ConnectionStore (ConnectionStore) import Brig.Effects.ConnectionStore qualified as E -import Brig.Federation.Client (notifyUserDeleted, sendConnectionAction) import Brig.IO.Journal qualified as Journal import Brig.IO.Logging import Brig.RPC -import Control.Error (ExceptT, runExceptT) -import Control.Lens (view, (?~), (^.), (^?)) +import Control.Lens (view, (^.)) import Control.Monad.Catch -import Control.Monad.Trans.Except (throwE) import Data.Aeson -import Data.Aeson.Lens import Data.ByteString.Conversion import Data.ByteString.Lazy qualified as BL import Data.Default @@ -78,27 +70,32 @@ import Data.Proxy import Data.Qualified import Data.Range import Imports +import Network.AMQP qualified as Q import Network.HTTP.Types.Method import Network.HTTP.Types.Status import Polysemy +import Polysemy.Error import Polysemy.Input (Input, input) import Polysemy.TinyLog (TinyLog) import System.Logger.Message hiding ((.=)) +import Wire.API.Component import Wire.API.Connection import Wire.API.Conversation hiding (Member) import Wire.API.Event.Conversation (Connect (Connect)) +import Wire.API.Federation.API import Wire.API.Federation.API.Brig import Wire.API.Federation.Error import Wire.API.Push.V2 (RecipientClients (RecipientClientsAll)) import Wire.API.Push.V2 qualified as V2 import Wire.API.Routes.Internal.Galley.ConversationsIntra -import Wire.API.Routes.Internal.Galley.TeamsIntra (GuardLegalholdPolicyConflicts (GuardLegalholdPolicyConflicts)) -import Wire.API.Team.LegalHold (LegalholdProtectee) import Wire.API.Team.Member qualified as Team import Wire.API.User -import Wire.API.User.Client import Wire.API.UserEvent +import Wire.BackendNotificationQueueAccess import Wire.Events +import Wire.FederationAPIAccess +import Wire.GalleyAPIAccess (GalleyAPIAccess) +import Wire.GalleyAPIAccess qualified as GalleyAPIAccess import Wire.NotificationSubsystem import Wire.Rpc import Wire.Sem.Logger qualified as Log @@ -116,7 +113,11 @@ sendUserEvent :: Member TinyLog r, Member (Input (Local ())) r, Member Now r, - Member (ConnectionStore InternalPaging) r + Member (ConnectionStore InternalPaging) r, + HasBrigFederationAccess m r, + Member (Error FederationError) r, + Member BackendNotificationQueueAccess r, + Member GalleyAPIAccess r ) => UserId -> Maybe ConnId -> @@ -132,7 +133,11 @@ runEvents :: Member TinyLog r, Member (Input (Local ())) r, Member Now r, - Member (ConnectionStore InternalPaging) r + Member (ConnectionStore InternalPaging) r, + HasBrigFederationAccess m r, + Member (Error FederationError) r, + Member BackendNotificationQueueAccess r, + Member GalleyAPIAccess r ) => InterpreterFor Events r runEvents = interpret \case @@ -225,7 +230,11 @@ dispatchNotifications :: Member TinyLog r, Member (Input (Local ())) r, Member Now r, - Member (ConnectionStore InternalPaging) r + Member (ConnectionStore InternalPaging) r, + HasBrigFederationAccess m r, + Member (Error FederationError) r, + Member BackendNotificationQueueAccess r, + Member GalleyAPIAccess r ) => UserId -> Maybe ConnId -> @@ -309,11 +318,13 @@ notifyUserDeletionLocals deleted conn event = do connectionPages (Just (maximum (qUnqualified . ucTo <$> xs))) user pageSize notifyUserDeletionRemotes :: - forall r. - ( Member (Embed HttpClientIO) r, - Member TinyLog r, + forall r m. + ( Member TinyLog r, Member (Input (Local ())) r, - Member (ConnectionStore InternalPaging) r + Member (ConnectionStore InternalPaging) r, + HasBrigFederationAccess m r, + Member (Error FederationError) r, + Member BackendNotificationQueueAccess r ) => UserId -> Sem r () @@ -333,15 +344,21 @@ notifyUserDeletionRemotes deleted = do pure () Just rangedUcs -> do luidDeleted <- qualifyLocal' deleted - embed $ notifyUserDeleted luidDeleted (qualifyAs ucs (mapRange (qUnqualified . ucTo) rangedUcs)) + let remotes = mapRange (qUnqualified . ucTo) rangedUcs + notif = UserDeletedConnectionsNotification (tUnqualified luidDeleted) remotes + client = fedQueueClient @'OnUserDeletedConnectionsTag notif + enqueueNotification Q.Persistent ucs client -- also sent connection cancelled events to the connections that are pending let remotePendingConnections = qualifyAs ucs <$> filter ((==) Sent . ucStatus) (fromRange rangedUcs) forM_ remotePendingConnections $ sendCancelledEvent luidDeleted sendCancelledEvent :: Local UserId -> Remote UserConnection -> Sem r () sendCancelledEvent luidDeleted ruc = do - embed (runExceptT (sendConnectionAction luidDeleted Nothing (qUnqualified . ucTo <$> ruc) RemoteRescind)) >>= \case - -- should we abort the whole process if we fail to send the event to a remote backend? + let remoteUid :: Remote UserId = qUnqualified . ucTo <$> ruc + req = NewConnectionRequest (tUnqualified luidDeleted) Nothing (qUnqualified $ tUntagged remoteUid) RemoteRescind + Log.info $ msg @Text "Brig-federation: sending connection action to remote backend" + result <- runFederatedEither remoteUid $ fedClient @'Brig @"send-connection-action" req + case result of Left e -> Log.err $ field "error" (show e) @@ -391,7 +408,7 @@ notifyContacts :: forall r. ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member TinyLog r + Member GalleyAPIAccess r ) => Event -> -- | Origin user. @@ -409,7 +426,7 @@ notifyContacts event orig route conn = do contacts = embed $ lookupContactList orig teamContacts :: Sem r [UserId] - teamContacts = screenMemberList <$> getTeamContacts orig + teamContacts = screenMemberList <$> GalleyAPIAccess.getTeamContacts orig -- If we have a truncated team, we just ignore it all together to avoid very large fanouts -- screenMemberList :: Maybe Team.TeamMemberList -> [UserId] @@ -418,25 +435,6 @@ notifyContacts event orig route conn = do view Team.userId <$> mems ^. Team.teamMembers screenMemberList _ = [] -toApsData :: Event -> Maybe V2.ApsData -toApsData (ConnectionEvent (ConnectionUpdated uc name)) = - case (ucStatus uc, name) of - (MissingLegalholdConsent, _) -> Nothing - (Pending, n) -> apsConnRequest <$> n - (Accepted, n) -> apsConnAccept <$> n - (Blocked, _) -> Nothing - (Ignored, _) -> Nothing - (Sent, _) -> Nothing - (Cancelled, _) -> Nothing - where - apsConnRequest n = - V2.apsData (V2.ApsLocKey "push.notification.connection.request") [fromName n] - & V2.apsSound ?~ V2.ApsSound "new_message_apns.caf" - apsConnAccept n = - V2.apsData (V2.ApsLocKey "push.notification.connection.accepted") [fromName n] - & V2.apsSound ?~ V2.ApsSound "new_message_apns.caf" -toApsData _ = Nothing - ------------------------------------------------------------------------------- -- Conversation Management @@ -626,50 +624,3 @@ rmClient u c = do unregisterPushClient u c where expected = [status200, status204, status404] - -------------------------------------------------------------------------------- --- Team Management - --- | Only works on 'BindingTeam's! The list of members returned is potentially truncated. --- --- Calls 'Galley.API.getBindingTeamMembersH'. -getTeamContacts :: - ( Member TinyLog r, - Member (Embed HttpClientIO) r - ) => - UserId -> - Sem r (Maybe Team.TeamMemberList) -getTeamContacts u = do - Log.debug $ remote "galley" . msg (val "Get team contacts") - rs <- embed $ galleyRequest GET req - embed $ case Bilge.statusCode rs of - 200 -> Just <$> decodeBody "galley" rs - _ -> pure Nothing - where - req = - paths ["i", "users", toByteString' u, "team", "members"] - . expect [status200, status404] - -guardLegalhold :: - LegalholdProtectee -> - UserClients -> - ExceptT ClientError (AppT r) () -guardLegalhold protectee userClients = do - res <- lift . wrapHttp $ galleyRequest PUT req - case Bilge.statusCode res of - 200 -> pure () - 403 -> case Bilge.responseJsonMaybe @Value res >>= (^? key "label") of - Just "missing-legalhold-consent" -> throwE ClientMissingLegalholdConsent - Just "missing-legalhold-consent-old-clients" -> throwE ClientMissingLegalholdConsentOldClients - _ -> - -- only happens if galley misbehaves (fisx: this could also be a parse error if we - -- used a more constraining type to send back & forth between brig and galley, but - -- merging brig and galley would make this train of thought go away more naturally). - throwE ClientMissingLegalholdConsent - 404 -> pure () -- allow for galley not to be ready, so the set of valid deployment orders is non-empty. - _ -> throwM internalServerError - where - req = - paths ["i", "guard-legalhold-policy-conflicts"] - . header "Content-Type" "application/json" - . lbytes (encode $ GuardLegalholdPolicyConflicts protectee userClients) diff --git a/services/brig/src/Brig/Index/Eval.hs b/services/brig/src/Brig/Index/Eval.hs index 523582c1c70..e6196546041 100644 --- a/services/brig/src/Brig/Index/Eval.hs +++ b/services/brig/src/Brig/Index/Eval.hs @@ -55,6 +55,7 @@ import Wire.AppStore import Wire.AppStore.Postgres import Wire.BlockListStore (BlockListStore) import Wire.BlockListStore.Cassandra +import Wire.ClientSubsystem.Error (ClientError) import Wire.FederationAPIAccess import Wire.FederationAPIAccess.Interpreter (noFederationAPIAccess) import Wire.FederationConfigStore (FederationConfigStore) @@ -104,6 +105,7 @@ type BrigIndexEffectStack = Concurrency 'Unsafe, Input Pool, Error UsageError, + Error ClientError, Embed IO, Final IO ] @@ -133,6 +135,7 @@ runSem esConn cas pg galleyEndpoint logger action = do migrationIndexName = fromMaybe defaultMigrationIndexName (esMigrationIndexName esConn) runFinal . embedToFinal + . throwErrorToIOFinal @ClientError . throwErrorToIOFinal @UsageError . runInputConst pgPool . unsafelyPerformConcurrency diff --git a/services/brig/src/Brig/Options.hs b/services/brig/src/Brig/Options.hs index 91cf542e487..cd2ae315b0b 100644 --- a/services/brig/src/Brig/Options.hs +++ b/services/brig/src/Brig/Options.hs @@ -348,7 +348,7 @@ data ListAllSFTServers instance ToSchema ListAllSFTServers where schema = - enum @Text "ListSFTServers" $ + enum @Text $ mconcat [ element "enabled" ListAllSFTServers, element "disabled" HideAllSFTServers diff --git a/services/brig/src/Brig/Provider/API.hs b/services/brig/src/Brig/Provider/API.hs index 286393c5e4a..625cd27170a 100644 --- a/services/brig/src/Brig/Provider/API.hs +++ b/services/brig/src/Brig/Provider/API.hs @@ -27,12 +27,10 @@ module Brig.Provider.API ) where -import Brig.API.Client qualified as Client import Brig.API.Error import Brig.API.Handler -import Brig.API.Types (ClientDataError (..), PasswordResetError (..)) +import Brig.API.Types (PasswordResetError (..)) import Brig.App -import Brig.Data.Client qualified as User import Brig.Options (Settings (..)) import Brig.Options qualified as Opt import Brig.Provider.DB (ServiceConn (..)) @@ -124,6 +122,8 @@ import Wire.AuthenticationSubsystem.Config import Wire.AuthenticationSubsystem.ZAuth qualified as ZAuth import Wire.ClientStore (ClientStore) import Wire.ClientStore qualified as ClientStore +import Wire.ClientSubsystem as ClientSubsystem +import Wire.ClientSubsystem.Error import Wire.DeleteQueue import Wire.EmailSending (EmailSending) import Wire.Error @@ -148,9 +148,6 @@ import Wire.VerificationCodeSubsystem botAPI :: ( Member GalleyAPIAccess r, - Member (Concurrency 'Unsafe) r, - Member DeleteQueue r, - Member AuthenticationSubsystem r, Member (Input AuthenticationSubsystemConfig) r, Member Now r, Member CryptoSign r, @@ -158,7 +155,8 @@ botAPI :: Member (Embed HttpClientIO) r, Member UserSubsystem r, Member (Input (Local ())) r, - Member ClientStore r + Member ClientStore r, + Member ClientSubsystem r ) => ServerT BotAPI (Handler r) botAPI = @@ -715,10 +713,10 @@ updateServiceWhitelist :: updateServiceWhitelist uid con tid upd = do -- Preconditions guardSecondFactorDisabled (Just uid) - guardMLSNotDefault let pid = updateServiceWhitelistProvider upd sid = updateServiceWhitelistService upd newWhitelisted = updateServiceWhitelistStatus upd + when newWhitelisted guardMLSNotDefault lift . liftSem $ ensurePermissions uid tid (Set.toList serviceWhitelistPermissions) _ <- wrapClientE (DB.lookupService pid sid) >>= maybeServiceNotFound -- Add to various tables @@ -755,14 +753,13 @@ updateServiceWhitelist uid con tid upd = do addBot :: ( Member GalleyAPIAccess r, - Member AuthenticationSubsystem r, Member (Input AuthenticationSubsystemConfig) r, Member Now r, Member CryptoSign r, Member UserStore r, Member UserSubsystem r, Member (Input (Local ())) r, - Member ClientStore r + Member ClientSubsystem r ) => UserId -> ConnId -> @@ -856,19 +853,19 @@ addBot zuid zcon cid add = do { newClientPrekeys = Ext.rsNewBotPrekeys rs } lift $ liftSem $ UserStore.createUser usr (Just (cid, cnvTeam cnv)) - maxPermClients <- fromMaybe Opt.defUserMaxPermClients <$> asks (.settings.userMaxPermClients) (clt, _, _) <- do _ <- do -- if we want to protect bots against lh, 'addClient' cannot just send lh capability -- implicitly in the next line. pure $ FutureWork @'UnprotectedBot undefined lbid <- qualifyLocal (botUserId bid) - ( User.addClient - lbid - bcl - newClt - maxPermClients - (Just $ ClientCapabilityList $ Set.singleton Public.ClientSupportsLegalholdImplicitConsent) + lift + ( liftSem $ + ClientSubsystem.upsertClient + lbid + bcl + newClt + (Just $ ClientCapabilityList $ Set.singleton Public.ClientSupportsLegalholdImplicitConsent) ) !>> const (StdError $ badGatewayWith "MalformedPrekeys") @@ -948,15 +945,12 @@ botUpdatePrekeys bot upd = do Just c -> do let pks = updateBotPrekeyList upd unless (all checkPrekeyBundle pks) $ - throwE (clientDataError MalformedPrekeys) + throwE (clientDataErrorToHttpError MalformedPrekeys) lift . liftSem $ ClientStore.updatePrekeys (botUserId bot) c.clientId pks botClaimUsersPrekeys :: - ( Member (Concurrency 'Unsafe) r, - Member GalleyAPIAccess r, - Member DeleteQueue r, - Member AuthenticationSubsystem r, - Member ClientStore r + ( Member GalleyAPIAccess r, + Member ClientSubsystem r ) => BotId -> Public.UserClients -> @@ -966,7 +960,7 @@ botClaimUsersPrekeys _ body = do maxSize <- fromIntegral <$> asks (.settings.maxConvSize) when (Map.size (Public.userClients body) > maxSize) $ throwStd (errorToWai @'E.TooManyClients) - Client.claimLocalMultiPrekeyBundles UnprotectedBot body !>> clientError + lift $ liftSem $ ClientSubsystem.claimLocalMultiPrekeyBundles UnprotectedBot body botListUserProfiles :: (Member GalleyAPIAccess r, Member UserSubsystem r) => BotId -> (CommaSeparatedList UserId) -> Handler r [Public.BotUserView] botListUserProfiles _ uids = do diff --git a/services/brig/src/Brig/Provider/DB.hs b/services/brig/src/Brig/Provider/DB.hs index 5279fcd9923..fc1a828c169 100644 --- a/services/brig/src/Brig/Provider/DB.hs +++ b/services/brig/src/Brig/Provider/DB.hs @@ -17,7 +17,7 @@ module Brig.Provider.DB where -import Brig.Types.Provider.Tag +import Brig.Provider.Tag import Cassandra as C import Control.Arrow ((&&&)) import Data.Id diff --git a/libs/brig-types/src/Brig/Types/Provider/Tag.hs b/services/brig/src/Brig/Provider/Tag.hs similarity index 99% rename from libs/brig-types/src/Brig/Types/Provider/Tag.hs rename to services/brig/src/Brig/Provider/Tag.hs index 2aa2704e352..13e11eda4cb 100644 --- a/libs/brig-types/src/Brig/Types/Provider/Tag.hs +++ b/services/brig/src/Brig/Provider/Tag.hs @@ -20,7 +20,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Brig.Types.Provider.Tag +module Brig.Provider.Tag ( Bucket (..), defBucket, foldTags, diff --git a/services/brig/src/Brig/Team/API.hs b/services/brig/src/Brig/Team/API.hs index e6fb6149faa..fdde7fdf4d9 100644 --- a/services/brig/src/Brig/Team/API.hs +++ b/services/brig/src/Brig/Team/API.hs @@ -33,7 +33,6 @@ import Brig.API.Util (logEmail, logInvitationCode) import Brig.App as App import Brig.Effects.UserPendingActivationStore (UserPendingActivationStore) import Brig.Template -import Brig.Types.Team (TeamSize) import Control.Lens (view, (^.)) import Control.Monad.Trans.Except import Data.ByteString.Conversion (toByteString) @@ -68,6 +67,7 @@ import Wire.API.Team.Invitation qualified as Public import Wire.API.Team.Member (teamMembers) import Wire.API.Team.Member qualified as Teams import Wire.API.Team.Permission (Perm (AddTeamMember)) +import Wire.API.Team.Size import Wire.API.User hiding (fromEmail) import Wire.AuthenticationSubsystem import Wire.BlockListStore diff --git a/services/brig/src/Brig/User/API/Handle.hs b/services/brig/src/Brig/User/API/Handle.hs index b93fe3df3a6..4ff8f0a2b11 100644 --- a/services/brig/src/Brig/User/API/Handle.hs +++ b/services/brig/src/Brig/User/API/Handle.hs @@ -27,7 +27,6 @@ import Brig.API.Error (fedError) import Brig.API.Handler (Handler) import Brig.API.User qualified as API import Brig.App -import Brig.Federation.Client qualified as Federation import Brig.Options (searchSameTeamOnly) import Data.Handle (Handle, fromHandle) import Data.Id (UserId) @@ -35,17 +34,27 @@ import Data.Qualified import Imports import Network.Wai.Utilities ((!>>)) import Polysemy +import Polysemy.Error (Error) import System.Logger.Class qualified as Log +import Wire.API.Component +import Wire.API.Federation.API (fedClient) +import Wire.API.Federation.Error import Wire.API.User import Wire.API.User qualified as Public import Wire.API.User.Search import Wire.API.User.Search qualified as Public +import Wire.FederationAPIAccess import Wire.UserStore (UserStore) import Wire.UserStore qualified as UserStore import Wire.UserSubsystem getHandleInfo :: - (Member UserSubsystem r, Member UserStore r) => + forall r m. + ( Member UserSubsystem r, + Member UserStore r, + HasBrigFederationAccess m r, + Member (Error FederationError) r + ) => UserId -> Qualified Handle -> Handler r (Maybe Public.UserProfile) @@ -57,12 +66,20 @@ getHandleInfo self handle = do getRemoteHandleInfo handle -getRemoteHandleInfo :: Remote Handle -> Handler r (Maybe Public.UserProfile) +getRemoteHandleInfo :: + forall r m. + ( HasBrigFederationAccess m r, + Member (Error FederationError) r + ) => + Remote Handle -> + Handler r (Maybe Public.UserProfile) getRemoteHandleInfo handle = do lift . Log.info $ Log.msg (Log.val "getHandleInfo - remote lookup") . Log.field "domain" (show (tDomain handle)) - Federation.getUserHandleInfo handle !>> fedError + lift . liftSem $ + runFederated handle $ + fedClient @'Brig @"get-user-by-handle" (tUnqualified handle) getLocalHandleInfo :: (Member UserSubsystem r, Member UserStore r) => diff --git a/services/brig/src/Brig/User/Auth.hs b/services/brig/src/Brig/User/Auth.hs index 218a4a3b776..d00b6340196 100644 --- a/services/brig/src/Brig/User/Auth.hs +++ b/services/brig/src/Brig/User/Auth.hs @@ -23,7 +23,6 @@ module Brig.User.Auth renewAccess, validateTokens, revokeAccess, - verifyCode, -- * Internal ssoLogin, @@ -39,13 +38,11 @@ import Brig.API.User (changeSingleAccountStatus) import Brig.App import Brig.Budget import Brig.Options qualified as Opt -import Brig.Types.Intra import Brig.User.Auth.Cookie import Cassandra import Control.Error hiding (bool) import Data.ByteString.Conversion (toByteString) import Data.Code qualified as Code -import Data.Default import Data.Handle (Handle) import Data.Id import Data.List.NonEmpty qualified as NE @@ -63,7 +60,6 @@ import Polysemy.TinyLog qualified as Log import System.Logger (field, msg, val, (~~)) import Util.Timeout import Wire.API.Team.Feature -import Wire.API.Team.Feature qualified as Public import Wire.API.User import Wire.API.User.Auth import Wire.API.User.Auth.LegalHold @@ -73,6 +69,7 @@ import Wire.ActivationCodeStore qualified as ActivationCode import Wire.AuthenticationSubsystem import Wire.AuthenticationSubsystem qualified as Authentication import Wire.AuthenticationSubsystem.Config +import Wire.AuthenticationSubsystem.Error (VerificationCodeError (..)) import Wire.AuthenticationSubsystem.ZAuth qualified as ZAuth import Wire.ClientStore (ClientStore) import Wire.ClientStore qualified as ClientStore @@ -88,22 +85,16 @@ import Wire.UserKeyStore import Wire.UserStore import Wire.UserSubsystem (UserSubsystem) import Wire.UserSubsystem qualified as User -import Wire.VerificationCode qualified as VerificationCode -import Wire.VerificationCodeGen qualified as VerificationCodeGen -import Wire.VerificationCodeSubsystem (VerificationCodeSubsystem) -import Wire.VerificationCodeSubsystem qualified as VerificationCodeSubsystem login :: forall r. - ( Member GalleyAPIAccess r, - Member (Input (Local ())) r, + ( Member (Input (Local ())) r, Member ActivationCodeStore r, Member Events r, Member TinyLog r, Member UserKeyStore r, Member UserStore r, Member UserSubsystem r, - Member VerificationCodeSubsystem r, Member AuthenticationSubsystem r, Member (Input AuthenticationSubsystemConfig) r, Member (Concurrency Unsafe) r, @@ -133,45 +124,12 @@ login (MkLogin li pw label code) typ = do verifyLoginCode :: Maybe Code.Value -> UserId -> ExceptT LoginError (AppT r) () verifyLoginCode mbCode uid = do luid <- lift $ qualifyLocal uid - verifyCode mbCode Login luid - `catchE` \case - VerificationCodeNoPendingCode -> lift (decrRetryLimit uid) >> throwE LoginCodeInvalid - VerificationCodeRequired -> lift (decrRetryLimit uid) >> throwE LoginCodeRequired - VerificationCodeNoEmail -> lift (decrRetryLimit uid) >> throwE LoginFailed - -verifyCode :: - forall r. - (Member GalleyAPIAccess r, Member VerificationCodeSubsystem r, Member UserSubsystem r) => - Maybe Code.Value -> - VerificationAction -> - Local UserId -> - ExceptT VerificationCodeError (AppT r) () -verifyCode mbCode action luid = do - (mbEmail, mbTeamId) <- getEmailAndTeamId luid - featureEnabled <- lift $ do - mbFeatureEnabled <- liftSem $ GalleyAPIAccess.getVerificationCodeEnabled `traverse` mbTeamId - pure $ fromMaybe ((def @(Feature Public.SndFactorPasswordChallengeConfig)).status == Public.FeatureStatusEnabled) mbFeatureEnabled - account <- lift . liftSem $ User.getAccountNoFilter luid - let isSsoUser = maybe False isSamlUser account - when (featureEnabled && not isSsoUser) $ do - case (mbCode, mbEmail) of - (Just code, Just email) -> do - let key = VerificationCodeGen.mkKey email - scope = VerificationCode.scopeFromAction action - codeValid <- isJust <$> lift (liftSem $ VerificationCodeSubsystem.verifyCode key scope code) - unless codeValid $ throwE VerificationCodeNoPendingCode - (Nothing, _) -> throwE VerificationCodeRequired - (_, Nothing) -> throwE VerificationCodeNoEmail - where - getEmailAndTeamId :: - Local UserId -> - ExceptT e (AppT r) (Maybe EmailAddress, Maybe TeamId) - getEmailAndTeamId u = do - mbAccount <- lift . liftSem $ User.getAccountNoFilter u - pure - ( userEmail =<< mbAccount, - userTeam =<< mbAccount - ) + lift (liftSem $ enforceVerificationCodeEither luid mbCode Login) + >>= \case + Left VerificationCodeNoPendingCode -> lift (decrRetryLimit uid) >> throwE LoginCodeInvalid + Left VerificationCodeRequired -> lift (decrRetryLimit uid) >> throwE LoginCodeRequired + Left VerificationCodeNoEmail -> lift (decrRetryLimit uid) >> throwE LoginFailed + Right () -> pure () decrRetryLimit :: UserId -> (AppT r) () decrRetryLimit = wrapClient . withRetryLimit (\k b -> withBudget k b $ pure ()) diff --git a/services/brig/src/Brig/User/Client.hs b/services/brig/src/Brig/User/Client.hs new file mode 100644 index 00000000000..ed89f86db6d --- /dev/null +++ b/services/brig/src/Brig/User/Client.hs @@ -0,0 +1,114 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Brig.User.Client + ( createClientDPoPAccessToken, + ) +where + +import Brig.API.Types +import Brig.App +import Brig.Data.Nonce as Nonce +import Brig.Effects.JwtTools (JwtTools) +import Brig.Effects.JwtTools qualified as JwtTools +import Brig.Effects.PublicKeyBundle (PublicKeyBundle) +import Brig.Effects.PublicKeyBundle qualified as PublicKeyBundle +import Brig.Options qualified as Opt +import Control.Error +import Control.Monad.Trans.Except (except) +import Data.ByteString (toStrict) +import Data.ByteString.Conversion +import Data.HavePendingInvitations +import Data.Id (ClientId, UserId) +import Data.Qualified +import Data.Text.Encoding qualified as T +import Data.Text.Encoding.Error +import Imports hiding ((\\)) +import Network.HTTP.Types.Method (StdMethod) +import Network.Wai.Utilities hiding (Error) +import Polysemy +import Servant (Link, ToHttpApiData (toUrlPiece)) +import Wire.API.MLS.Credential (ClientIdentity (..)) +import Wire.API.MLS.Epoch (addToEpoch) +import Wire.API.Routes.Internal.Brig +import Wire.API.User +import Wire.API.User.Client.DPoPAccessToken +import Wire.Sem.FromUTC (FromUTC (fromUTCTime)) +import Wire.Sem.Now as Now +import Wire.UserSubsystem (UserSubsystem) +import Wire.UserSubsystem qualified as User + +createClientDPoPAccessToken :: + (Member JwtTools r, Member Now r, Member PublicKeyBundle r, Member UserSubsystem r) => + Local UserId -> + ClientId -> + StdMethod -> + Link -> + Proof -> + ExceptT CertEnrollmentError (AppT r) (DPoPAccessTokenResponse, CacheControl) +createClientDPoPAccessToken luid cid method link proof = do + let domain = tDomain luid + let uid = tUnqualified luid + (tid, handle, displayName) <- do + mUser <- + fmap listToMaybe + . lift + . liftSem + . User.getAccountsBy + . qualifyAs luid + $ getByNoFilters {getByUserId = [tUnqualified luid], includePendingInvitations = NoPendingInvitations} + except $ + (,,) + <$> note NotATeamUser (userTeam =<< mUser) + <*> note MissingHandle (userHandle =<< mUser) + <*> note MissingName (userDisplayName <$> mUser) + nonce <- + ExceptT $ + note NonceNotFound + <$> wrapClient + ( Nonce.lookupAndDeleteNonce + uid + (T.decodeUtf8With lenientDecode . toStrict $ toByteString cid) + ) + httpsUrl <- + except $ + note MisconfiguredRequestUrl $ + fromByteString $ + "https://" <> toByteString' domain <> "/" <> T.encodeUtf8 (toUrlPiece link) + maxSkewSeconds <- Opt.setDpopMaxSkewSecs <$> asks (.settings) + expiresIn <- Opt.dpopTokenExpirationTimeSecs <$> asks (.settings) + now <- fromUTCTime <$> lift (liftSem Now.get) + let expiresAt = now & addToEpoch expiresIn + pubKeyBundle <- do + pathToKeys <- ExceptT (note KeyBundleError <$> asks (.settings.publicKeyBundle)) + ExceptT $ note KeyBundleError <$> liftSem (PublicKeyBundle.get pathToKeys) + token <- + ExceptT $ + liftSem $ + JwtTools.generateDPoPAccessToken + proof + (ClientIdentity domain uid cid) + handle + displayName + tid + nonce + httpsUrl + method + maxSkewSeconds + expiresAt + pubKeyBundle + pure $ (DPoPAccessTokenResponse token DPoP expiresIn, NoStore) diff --git a/services/brig/test/integration/API/Calling.hs b/services/brig/test/integration/API/Calling.hs index 7b08ab42de4..1bbb92375a4 100644 --- a/services/brig/test/integration/API/Calling.hs +++ b/services/brig/test/integration/API/Calling.hs @@ -156,7 +156,7 @@ testCallsConfigMultipleV2 b turnUpdaterV2 = do toTurnURI SchemeTurn "localhost" 3478 (Just TransportTCP) :| [toTurnURI SchemeTurns "localhost" 3479 $ Just TransportTCP] modifyAndAssert b uid getTurnConfigurationV2 turnUpdaterV2 _changes _expected - -- Ensure limit=1 returns only the udp server (see brig-types/tests for other use cases involving 'limit') + -- Ensure limit=1 returns only the udp server let _changes = "turn:localhost:3478?transport=udp\nturns:localhost:3479?transport=tcp" let _expected2 = toTurnURI SchemeTurn "localhost" 3478 (Just TransportUDP) diff --git a/services/brig/test/integration/API/RichInfo/Util.hs b/services/brig/test/integration/API/RichInfo/Util.hs index 5dae93d4168..063511cc02e 100644 --- a/services/brig/test/integration/API/RichInfo/Util.hs +++ b/services/brig/test/integration/API/RichInfo/Util.hs @@ -21,11 +21,11 @@ module API.RichInfo.Util where import Bilge -import Brig.Types.User (RichInfoUpdate (RichInfoUpdate)) import Data.ByteString.Conversion import Data.Id import Imports import Util +import Wire.API.User import Wire.API.User.RichInfo getRichInfo :: diff --git a/services/brig/test/integration/API/User/Account.hs b/services/brig/test/integration/API/User/Account.hs index 18ac0d76357..796edb99a9e 100644 --- a/services/brig/test/integration/API/User/Account.hs +++ b/services/brig/test/integration/API/User/Account.hs @@ -30,8 +30,6 @@ import Bilge.Assert import Brig.AWS qualified as AWS import Brig.AWS.Types import Brig.Options qualified as Opt -import Brig.Types.Activation -import Brig.Types.Intra import Control.Arrow ((&&&)) import Control.Exception (throw) import Control.Lens (ix, preview, (^.), (^?)) diff --git a/services/brig/test/integration/Federation/End2end.hs b/services/brig/test/integration/Federation/End2end.hs index 447dfb016e2..b2b3f897c4b 100644 --- a/services/brig/test/integration/Federation/End2end.hs +++ b/services/brig/test/integration/Federation/End2end.hs @@ -21,7 +21,6 @@ import API.MLS.Util import API.User.Util import Bilge import Bilge.Assert ((!!!), ( --- --- 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 . -- for SES notifications {-# OPTIONS_GHC -fno-warn-orphans -Wno-deprecations #-} @@ -46,7 +30,6 @@ import Brig.App (Env (..)) import Brig.Calling as Calling import Brig.Options as Opt import Brig.Run qualified as Run -import Brig.Types.Activation import Control.Concurrent.Async import Control.Exception (throw) import Control.Lens ((^?), (^?!)) diff --git a/services/cargohold/src/CargoHold/S3.hs b/services/cargohold/src/CargoHold/S3.hs index 79126f484d3..e873acf3636 100644 --- a/services/cargohold/src/CargoHold/S3.hs +++ b/services/cargohold/src/CargoHold/S3.hs @@ -92,7 +92,7 @@ data AssetAuditLogMetadata = AssetAuditLogMetadata instance S.ToSchema AssetAuditLogMetadata where schema = - S.object "AssetAuditLogMetadata" $ + S.object $ AssetAuditLogMetadata <$> convId S..= S.field "convId" S.schema <*> filename S..= S.field "filename" S.schema diff --git a/services/galley/default.nix b/services/galley/default.nix index 2047f0765cd..2aff9179654 100644 --- a/services/galley/default.nix +++ b/services/galley/default.nix @@ -7,14 +7,11 @@ , aeson-qq , amazonka , amqp -, asn1-encoding -, asn1-types , async , base , base64-bytestring , bilge , binary -, brig-types , bytestring , bytestring-conversion , call-stack @@ -25,8 +22,6 @@ , conduit , containers , cookie -, crypton -, crypton-x509 , currency-codes , data-default , data-timeout @@ -132,20 +127,15 @@ mkDerivation { aeson amazonka amqp - asn1-encoding - asn1-types async base bilge - brig-types bytestring bytestring-conversion cassandra-util cassava comonad containers - crypton - crypton-x509 data-default errors exceptions @@ -168,7 +158,6 @@ mkDerivation { metrics-core metrics-wai optparse-applicative - pem polysemy polysemy-conc polysemy-plugin @@ -213,7 +202,6 @@ mkDerivation { base64-bytestring bilge binary - brig-types bytestring bytestring-conversion call-stack diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index a05868c9b2f..8f706554d45 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -139,9 +139,7 @@ library Galley.Env Galley.External.LegalHoldService Galley.External.LegalHoldService.Internal - Galley.Keys Galley.Monad - Galley.Options Galley.Queue Galley.Run Galley.Schema.Run @@ -236,20 +234,15 @@ library , aeson >=2.0.1.0 , amazonka >=1.4.5 , amqp - , asn1-encoding - , asn1-types , async >=2.0 , base >=4.6 && <5 , bilge >=0.21.1 - , brig-types >=0.73.1 , bytestring >=0.9 , bytestring-conversion >=0.2 , cassandra-util >=0.16.2 , cassava >=0.5.2 , comonad , containers >=0.5 - , crypton - , crypton-x509 , data-default , errors >=2.0 , exceptions >=0.4 @@ -272,7 +265,6 @@ library , metrics-core , metrics-wai >=0.4 , optparse-applicative - , pem , polysemy , polysemy-conc , polysemy-plugin @@ -409,7 +401,6 @@ executable galley-integration , base64-bytestring , bilge , binary - , brig-types , bytestring , bytestring-conversion , call-stack diff --git a/services/galley/src/Galley/API/Action.hs b/services/galley/src/Galley/API/Action.hs index 9348d5655c9..7a0816a0153 100644 --- a/services/galley/src/Galley/API/Action.hs +++ b/services/galley/src/Galley/API/Action.hs @@ -143,6 +143,7 @@ import Wire.TeamStore import Wire.TeamSubsystem (TeamSubsystem) import Wire.TeamSubsystem qualified as TeamSubsystem import Wire.UserList +import Wire.Util class IsConversationAction (tag :: ConversationActionTag) where type HasConversationActionEffects tag (r :: EffectRow) :: Constraint @@ -943,11 +944,21 @@ performConversationAccessData qusr lconv action = do lcnv = fmap (.id_) lconv conv = tUnqualified lconv - maybeRemoveBots :: BotsAndMembers -> Sem r BotsAndMembers + maybeRemoveBots :: (Member E.BrigAPIAccess r) => BotsAndMembers -> Sem r BotsAndMembers maybeRemoveBots bm = if Set.member ServiceAccessRole (cupAccessRoles action) then pure bm - else pure $ bm {bmBots = mempty} + else do + -- Remove bots + let bmWithoutBots = bm {bmBots = mempty} + -- Remove apps from local and remote members. Filter the original + -- local member set so users missing from `getUsers` are preserved. + localUsers <- E.getUsers (toList (bmLocals bmWithoutBots)) + let appLocals = Set.fromList [User.userId u | u <- localUsers, User.userType u == User.UserTypeApp] + -- (apps must be from the conversations home team to be + -- allowed to be in here, so we don't need to worry about + -- removing them.) + pure $ bmWithoutBots {bmLocals = Set.difference (bmLocals bmWithoutBots) appLocals} maybeRemoveGuests :: (Member E.BrigAPIAccess r) => BotsAndMembers -> Sem r BotsAndMembers maybeRemoveGuests bm = diff --git a/services/galley/src/Galley/API/Clients.hs b/services/galley/src/Galley/API/Clients.hs index 70af95788cf..7aa4c2f12e9 100644 --- a/services/galley/src/Galley/API/Clients.hs +++ b/services/galley/src/Galley/API/Clients.hs @@ -46,13 +46,13 @@ import Wire.API.Routes.MultiTablePaging import Wire.BackendNotificationQueueAccess import Wire.ConversationStore (ConversationStore, getConversation) import Wire.ConversationSubsystem qualified as ConvSubsystem -import Wire.ConversationSubsystem.Util import Wire.ExternalAccess (ExternalAccess) import Wire.NotificationSubsystem import Wire.ProposalStore (ProposalStore) import Wire.Sem.Now (Now) import Wire.Sem.Random (Random) import Wire.UserClientIndexStore qualified as E +import Wire.Util getClients :: (Member ConvSubsystem.ConversationSubsystem r) => diff --git a/services/galley/src/Galley/API/Federation/Handlers.hs b/services/galley/src/Galley/API/Federation/Handlers.hs index 1fa2540994a..b62d7ed3980 100644 --- a/services/galley/src/Galley/API/Federation/Handlers.hs +++ b/services/galley/src/Galley/API/Federation/Handlers.hs @@ -50,7 +50,6 @@ import Galley.API.MLS.Welcome import Galley.API.Mapping import Galley.API.Mapping qualified as Mapping import Galley.API.Message -import Galley.Options import Galley.Types.Conversations.One2One import Galley.Types.Error import Imports @@ -98,6 +97,7 @@ import Wire.FederationSubsystem (FederationSubsystem) import Wire.FireAndForget qualified as E import Wire.LegalHoldStore (LegalHoldStore) import Wire.NotificationSubsystem +import Wire.Options.Galley import Wire.ProposalStore (ProposalStore) import Wire.Sem.Now (Now) import Wire.Sem.Now qualified as Now @@ -109,6 +109,7 @@ import Wire.TeamStore import Wire.TeamSubsystem (TeamSubsystem) import Wire.UserClientIndexStore (UserClientIndexStore) import Wire.UserList (UserList (UserList)) +import Wire.Util onClientRemoved :: ( Member BackendNotificationQueueAccess r, diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index 67493be4915..280fc91d94b 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -52,7 +52,6 @@ import Galley.API.Teams.Features.Get import Galley.API.Update qualified as Update import Galley.App import Galley.Monad -import Galley.Options hiding (brig) import Galley.Queue qualified as Q import Galley.Types.Error import Imports hiding (head) @@ -101,6 +100,7 @@ import Wire.FederationSubsystem (getFederationStatus) import Wire.LegalHoldStore as LegalHoldStore import Wire.ListItems import Wire.NotificationSubsystem +import Wire.Options.Galley hiding (brig) import Wire.ProposalStore (ProposalStore) import Wire.Sem.Now (Now) import Wire.Sem.Now qualified as Now @@ -116,6 +116,7 @@ import Wire.TeamSubsystem (TeamSubsystem) import Wire.TeamSubsystem qualified as TeamSubsystem import Wire.UserClientIndexStore import Wire.UserList +import Wire.Util internalAPI :: API InternalAPI GalleyEffects internalAPI = @@ -348,7 +349,7 @@ getConfiguredFeatureFlags :: Sem r ConfiguredFeatureFlags getConfiguredFeatureFlags = do env <- input @Env - let flags = (env ^. Galley.App.options . Galley.Options.settings . Galley.Options.featureFlags) + let flags = (env ^. Galley.App.options . Wire.Options.Galley.settings . Wire.Options.Galley.featureFlags) pure $ ConfiguredFeatureFlags $ A.toJSON flags rmUser :: diff --git a/services/galley/src/Galley/API/LegalHold.hs b/services/galley/src/Galley/API/LegalHold.hs index c219fca6085..c3e6abcfbe4 100644 --- a/services/galley/src/Galley/API/LegalHold.hs +++ b/services/galley/src/Galley/API/LegalHold.hs @@ -30,7 +30,6 @@ module Galley.API.LegalHold ) where -import Brig.Types.Connection (UpdateConnectionsInternal (..)) import Control.Exception (assert) import Control.Lens (view, (^.)) import Data.ByteString.Conversion (toByteString) @@ -71,6 +70,7 @@ import Wire.API.Team.LegalHold qualified as Public import Wire.API.Team.LegalHold.External hiding (userId) import Wire.API.Team.LegalHold.Internal import Wire.API.Team.Member +import Wire.API.User hiding (userId) import Wire.API.User.Client.Prekey import Wire.BackendNotificationQueueAccess import Wire.BrigAPIAccess @@ -93,6 +93,7 @@ import Wire.TeamMemberStore import Wire.TeamStore import Wire.TeamSubsystem (TeamSubsystem) import Wire.TeamSubsystem qualified as TeamSubsystem +import Wire.Util createSettings :: forall r. diff --git a/services/galley/src/Galley/API/LegalHold/Conflicts.hs b/services/galley/src/Galley/API/LegalHold/Conflicts.hs index c313d399c76..23adf1c22bb 100644 --- a/services/galley/src/Galley/API/LegalHold/Conflicts.hs +++ b/services/galley/src/Galley/API/LegalHold/Conflicts.hs @@ -33,7 +33,6 @@ import Data.Map qualified as Map import Data.Misc import Data.Qualified import Data.Set qualified as Set -import Galley.Options import Imports import Polysemy import Polysemy.Error @@ -47,9 +46,10 @@ import Wire.API.Team.Member import Wire.API.User import Wire.API.User.Client as Client import Wire.BrigAPIAccess -import Wire.ConversationSubsystem.Util +import Wire.Options.Galley import Wire.TeamSubsystem (TeamSubsystem) import Wire.TeamSubsystem qualified as TeamSubsystem +import Wire.Util data LegalholdConflicts = LegalholdConflicts diff --git a/services/galley/src/Galley/API/MLS/Migration.hs b/services/galley/src/Galley/API/MLS/Migration.hs index 64bc3741ae6..1db5ce29576 100644 --- a/services/galley/src/Galley/API/MLS/Migration.hs +++ b/services/galley/src/Galley/API/MLS/Migration.hs @@ -17,7 +17,6 @@ module Galley.API.MLS.Migration where -import Brig.Types.Intra import Data.Qualified import Data.Set qualified as Set import Data.Time diff --git a/services/galley/src/Galley/API/MLS/Proposal.hs b/services/galley/src/Galley/API/MLS/Proposal.hs index 96985aa75d5..fdff658e2ad 100644 --- a/services/galley/src/Galley/API/MLS/Proposal.hs +++ b/services/galley/src/Galley/API/MLS/Proposal.hs @@ -67,7 +67,6 @@ import Wire.BackendNotificationQueueAccess import Wire.BrigAPIAccess import Wire.ConversationStore (ConversationStore) import Wire.ConversationStore.MLS.Types -import Wire.ConversationSubsystem.Util import Wire.ExternalAccess import Wire.FederationAPIAccess (FederationAPIAccess) import Wire.LegalHoldStore (LegalHoldStore) @@ -76,6 +75,7 @@ import Wire.ProposalStore import Wire.Sem.Now (Now) import Wire.TeamCollaboratorsSubsystem import Wire.TeamStore +import Wire.Util data ProposalAction = ProposalAction { paAdd :: ClientMap (LeafIndex, Maybe KeyPackage), diff --git a/services/galley/src/Galley/API/Message.hs b/services/galley/src/Galley/API/Message.hs index 502f2d53aa9..ff384a45fe9 100644 --- a/services/galley/src/Galley/API/Message.hs +++ b/services/galley/src/Galley/API/Message.hs @@ -49,7 +49,6 @@ import Data.Set qualified as Set import Data.Set.Lens import Data.Time.Clock (UTCTime) import Galley.API.LegalHold.Conflicts -import Galley.Options import Galley.Types.Clients qualified as Clients import Imports hiding (forkIO) import Network.AMQP qualified as Q @@ -82,6 +81,7 @@ import Wire.ConversationSubsystem.Util import Wire.ExternalAccess import Wire.FederationAPIAccess import Wire.NotificationSubsystem (BotMap, NotificationSubsystem, newMessagePush, runMessagePush) +import Wire.Options.Galley import Wire.Sem.Now (Now) import Wire.Sem.Now qualified as Now import Wire.StoredConversation diff --git a/services/galley/src/Galley/API/Query.hs b/services/galley/src/Galley/API/Query.hs index 777d7ab7ec7..201b7572bd3 100644 --- a/services/galley/src/Galley/API/Query.hs +++ b/services/galley/src/Galley/API/Query.hs @@ -122,6 +122,7 @@ import Wire.TeamStore import Wire.TeamSubsystem (TeamSubsystem) import Wire.TeamSubsystem qualified as TeamSubsystem import Wire.UserList +import Wire.Util getBotConversation :: ( Member ConversationStore.ConversationStore r, diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index e8ce6365e85..fbf7ed1b748 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -57,7 +57,6 @@ module Galley.API.Teams ) where -import Brig.Types.Team (TeamSize (..)) import Cassandra (PageWithState (pwsResults), pwsHasMore) import Cassandra qualified as C import Control.Lens @@ -83,7 +82,6 @@ import Galley.API.Teams.Notifications qualified as APITeamQueue import Galley.API.Update qualified as API import Galley.App import Galley.Effects.Queue qualified as E -import Galley.Options import Galley.Types.Error as Galley import Imports hiding (forkIO) import Polysemy @@ -119,7 +117,9 @@ import Wire.API.Team.Permission (Perm (..), Permissions (..), SPerm (..), copy, import Wire.API.Team.Role import Wire.API.Team.SearchVisibility import Wire.API.Team.SearchVisibility qualified as Public +import Wire.API.Team.Size import Wire.API.User qualified as U +import Wire.BrigAPIAccess import Wire.BrigAPIAccess qualified as Brig import Wire.BrigAPIAccess qualified as E import Wire.CodeStore @@ -132,6 +132,7 @@ import Wire.LegalHoldStore (LegalHoldStore) import Wire.ListItems import Wire.ListItems qualified as E import Wire.NotificationSubsystem +import Wire.Options.Galley import Wire.ProposalStore (ProposalStore) import Wire.Sem.Now import Wire.Sem.Now qualified as Now @@ -147,6 +148,7 @@ import Wire.TeamStore qualified as E import Wire.TeamSubsystem (TeamSubsystem) import Wire.TeamSubsystem qualified as TeamSubsystem import Wire.UserList +import Wire.Util getTeamH :: forall r. @@ -1152,10 +1154,11 @@ addTeamMemberInternal tid origin originConn (ntmNewTeamMember -> new) = do E.createTeamMember tid new now <- Now.get + appIds <- getAppIdsForTeam tid let e = newEvent tid now (EdMemberJoin (new ^. userId)) let recipients = case origin of - Just o -> userRecipient <$> o : filter (/= o) ((new ^. userId) : admins') - Nothing -> userRecipient <$> new ^. userId : admins' + Just o -> userRecipient <$> o : filter (/= o) ((new ^. userId) : admins' ++ appIds) + Nothing -> userRecipient <$> (new ^. userId) : admins' ++ appIds pushNotifications [ def { origin = Just (new ^. userId), diff --git a/services/galley/src/Galley/API/Teams/Features.hs b/services/galley/src/Galley/API/Teams/Features.hs index 0e702ace164..c113e394fa6 100644 --- a/services/galley/src/Galley/API/Teams/Features.hs +++ b/services/galley/src/Galley/API/Teams/Features.hs @@ -45,7 +45,6 @@ import Galley.API.LegalHold qualified as LegalHold import Galley.API.LegalHold.Team qualified as LegalHold import Galley.API.Teams.Features.Get import Galley.App -import Galley.Options import Galley.Types.Error (InternalError) import Imports import Polysemy @@ -63,8 +62,9 @@ import Wire.API.Federation.Error import Wire.API.Team.Feature import Wire.API.Team.FeatureFlags import Wire.API.Team.Member +import Wire.API.User (AccountStatus (..)) import Wire.BackendNotificationQueueAccess -import Wire.BrigAPIAccess (BrigAPIAccess, updateSearchVisibilityInbound) +import Wire.BrigAPIAccess (BrigAPIAccess, getAppIdsForTeam, setAccountStatus, updateSearchVisibilityInbound) import Wire.CodeStore import Wire.ConversationStore (ConversationStore, MLSCommitLockStore) import Wire.ConversationSubsystem @@ -78,6 +78,7 @@ import Wire.FederationSubsystem (FederationSubsystem) import Wire.FireAndForget import Wire.LegalHoldStore (LegalHoldStore) import Wire.NotificationSubsystem +import Wire.Options.Galley import Wire.ProposalStore (ProposalStore) import Wire.Sem.Now (Now) import Wire.Sem.Paging @@ -95,7 +96,8 @@ type ComputeFeatureConstraints cfg r = (Member FeaturesConfigSubsystem r) patchFeatureInternal :: forall cfg r. - ( SetFeatureConfig cfg, + ( Typeable cfg, + SetFeatureConfig cfg, ComputeFeatureConstraints cfg r, SetFeatureForTeamConstraints cfg r, Member (ErrorS 'TeamNotFound) r, @@ -132,7 +134,8 @@ patchFeatureInternal tid patch = do setFeature :: forall cfg r. - ( SetFeatureConfig cfg, + ( Typeable cfg, + SetFeatureConfig cfg, ComputeFeatureConstraints cfg r, SetFeatureForTeamConstraints cfg r, Member (ErrorS 'NotATeamMember) r, @@ -155,7 +158,8 @@ setFeature uid tid feat = do setFeatureInternal :: forall cfg r. - ( SetFeatureConfig cfg, + ( Typeable cfg, + SetFeatureConfig cfg, ComputeFeatureConstraints cfg r, SetFeatureForTeamConstraints cfg r, Member (ErrorS 'TeamNotFound) r, @@ -176,7 +180,8 @@ setFeatureInternal tid feat = do setFeatureUnchecked :: forall cfg r. - ( SetFeatureConfig cfg, + ( Typeable cfg, + SetFeatureConfig cfg, ComputeFeatureConstraints cfg r, SetFeatureForTeamConstraints cfg r, Member (Error TeamFeatureError) r, @@ -258,7 +263,8 @@ guardLockStatus = \case setFeatureForTeam :: forall cfg r. - ( SetFeatureConfig cfg, + ( Typeable cfg, + SetFeatureConfig cfg, SetFeatureForTeamConstraints cfg r, ComputeFeatureConstraints cfg r, Member P.TinyLog r, @@ -493,7 +499,28 @@ instance SetFeatureConfig ConsumableNotificationsConfig instance SetFeatureConfig ChatBubblesConfig -instance SetFeatureConfig AppsConfig +instance SetFeatureConfig AppsConfig where + type + SetFeatureForTeamConstraints AppsConfig (r :: EffectRow) = + (Member BrigAPIAccess r) + + prepareFeature tid feat = do + let newStatus = case feat.status of + FeatureStatusEnabled -> Active + FeatureStatusDisabled -> Suspended + appIds <- getAppIdsForTeam tid + -- NB: this will work as long as the only reason for suspending + -- apps is "payment plan expired", but should we ever introduce a + -- suspend button for team admins to let them temporarily disable + -- apps without deinstalling them, then we need to keep track of + -- the suspend reason and filter for the right one here. + -- + -- NB(2): this is not terribly efficient, but it's a rarely called + -- operation with usually small numbers of apps. tweak + -- opportunities: (a) only call this loop if enablement actually + -- changes; (b) do the loop over all appIds in postgres with one + -- query. + for_ appIds $ \uid -> setAccountStatus uid newStatus instance SetFeatureConfig SimplifiedUserConnectionRequestQRCodeConfig diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index b214caeee61..66a7d0030e9 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -97,7 +97,6 @@ import Galley.API.Message import Galley.API.Query qualified as Query import Galley.API.Teams.Features.Get import Galley.App -import Galley.Options import Galley.Types.Error import Imports hiding (forkIO) import Polysemy @@ -148,6 +147,7 @@ import Wire.FireAndForget import Wire.HashPassword as HashPassword import Wire.LegalHoldStore (LegalHoldStore) import Wire.NotificationSubsystem +import Wire.Options.Galley import Wire.ProposalStore (ProposalStore) import Wire.RateLimit import Wire.Sem.Now (Now) @@ -161,6 +161,7 @@ import Wire.TeamSubsystem qualified as TeamSubsystem import Wire.UserClientIndexStore qualified as E import Wire.UserGroupStore (UserGroupStore, getUserGroupsForConv) import Wire.UserList +import Wire.Util acceptConv :: ( Member ConversationStore r, diff --git a/services/galley/src/Galley/App.hs b/services/galley/src/Galley/App.hs index bfa6bbcf79f..8ee5e1e092b 100644 --- a/services/galley/src/Galley/App.hs +++ b/services/galley/src/Galley/App.hs @@ -56,10 +56,7 @@ import Galley.API.MLS.GroupInfoCheck (GroupInfoCheckEnabled (GroupInfoCheckEnabl import Galley.Effects.Queue qualified as GE import Galley.Env import Galley.External.LegalHoldService.Internal qualified as LHInternal -import Galley.Keys import Galley.Monad (runApp) -import Galley.Options hiding (brig, endpoint, federator) -import Galley.Options qualified as O import Galley.Queue import Galley.Queue qualified as Q import Galley.Types.Error @@ -142,6 +139,9 @@ import Wire.MeetingsSubsystem.Interpreter qualified as Meeting import Wire.MigrationLock import Wire.NotificationSubsystem (NotificationSubsystem) import Wire.NotificationSubsystem.Interpreter (runNotificationSubsystemGundeck) +import Wire.Options.Galley hiding (brig, endpoint, federator) +import Wire.Options.Galley qualified as O +import Wire.Options.Keys import Wire.ParseException import Wire.Postgres (PGConstraints) import Wire.ProposalStore (ProposalStore) diff --git a/services/galley/src/Galley/Env.hs b/services/galley/src/Galley/Env.hs index a7736f793fb..80de4fb949c 100644 --- a/services/galley/src/Galley/Env.hs +++ b/services/galley/src/Galley/Env.hs @@ -26,8 +26,6 @@ import Data.Id import Data.Misc (HttpsUrl) import Data.Range import Data.Time.Clock.DiffTime (millisecondsToDiffTime) -import Galley.Options -import Galley.Options qualified as O import Galley.Queue qualified as Q import HTTP2.Client.Manager (Http2Manager) import Hasql.Pool @@ -41,6 +39,8 @@ import Wire.API.Team.FeatureFlags (FanoutLimit) import Wire.AWS qualified as Aws import Wire.ExternalAccess.External import Wire.NotificationSubsystem.Interpreter +import Wire.Options.Galley +import Wire.Options.Galley qualified as O import Wire.RateLimit.Interpreter (RateLimitEnv) data DeleteItem = TeamItem TeamId UserId (Maybe ConnId) diff --git a/services/galley/src/Galley/Run.hs b/services/galley/src/Galley/Run.hs index 326d0bbfa83..be55ed36d83 100644 --- a/services/galley/src/Galley/Run.hs +++ b/services/galley/src/Galley/Run.hs @@ -44,7 +44,6 @@ import Galley.App qualified as App import Galley.Cassandra import Galley.Env import Galley.Monad -import Galley.Options import Galley.Queue qualified as Q import Imports import Network.HTTP.Media.RenderHeader qualified as HTTPMedia @@ -68,6 +67,7 @@ import Wire.API.Routes.Version import Wire.API.Routes.Version.Wai import Wire.AWS (awsEnv) import Wire.OpenTelemetry (withTracerC) +import Wire.Options.Galley import Wire.PostgresMigrations (runAllMigrations) run :: Opts -> IO () diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index e38960b67ba..7ada3332644 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -67,7 +67,6 @@ import Data.Time.Clock (getCurrentTime) import Federator.Discovery (DiscoveryFailure (..)) import Federator.MockServer hiding (status) import Galley.API.Mapping -import Galley.Options (federator, rabbitmq) import Imports hiding (id) import Imports qualified as I import Network.HTTP.Types.Status qualified as HTTP @@ -105,6 +104,7 @@ import Wire.API.Team.Member qualified as Teams import Wire.API.User import Wire.API.User.Client import Wire.API.UserMap (UserMap (..)) +import Wire.Options.Galley (federator, rabbitmq) import Wire.StoredConversation hiding (convName) tests :: IO TestSetup -> TestTree diff --git a/services/galley/test/integration/API/MLS/Util.hs b/services/galley/test/integration/API/MLS/Util.hs index cd2c7bbaf35..624505f395c 100644 --- a/services/galley/test/integration/API/MLS/Util.hs +++ b/services/galley/test/integration/API/MLS/Util.hs @@ -54,9 +54,6 @@ import Data.Text.Encoding qualified as T import Data.Time import Data.UUID qualified as UUID import Data.UUID.V4 qualified as UUIDV4 -import Galley.Keys -import Galley.Options -import Galley.Options qualified as Opts import Imports hiding (getFirst, getSymbolicLinkTarget) import Network.HTTP.Client (setQueryString) import System.FilePath @@ -88,6 +85,9 @@ import Wire.API.MLS.SubConversation import Wire.API.Routes.Public.Galley.MLS import Wire.API.User.Client import Wire.API.User.Client.Prekey +import Wire.Options.Galley +import Wire.Options.Galley qualified as Opts +import Wire.Options.Keys cid2Str :: ClientIdentity -> String cid2Str cid = diff --git a/services/galley/test/integration/API/SQS.hs b/services/galley/test/integration/API/SQS.hs index 9e8f35a6f1a..fd2f69b1c4a 100644 --- a/services/galley/test/integration/API/SQS.hs +++ b/services/galley/test/integration/API/SQS.hs @@ -28,7 +28,6 @@ import Data.Id import Data.Set qualified as Set import Data.Text (pack) import Data.UUID qualified as UUID -import Galley.Options (JournalOpts, endpoint, queueName) import Imports import Network.HTTP.Client import Network.HTTP.Client.OpenSSL @@ -41,6 +40,7 @@ import Test.Tasty.HUnit import TestSetup import Util.Test.SQS qualified as SQS import Wire.AWS qualified as Aws +import Wire.Options.Galley (JournalOpts, endpoint, queueName) withTeamEventWatcher :: (HasCallStack) => (SQS.SQSWatcher TeamEvent -> TestM ()) -> TestM () withTeamEventWatcher action = do diff --git a/services/galley/test/integration/API/Teams.hs b/services/galley/test/integration/API/Teams.hs index 2986fa37c62..04263221b24 100644 --- a/services/galley/test/integration/API/Teams.hs +++ b/services/galley/test/integration/API/Teams.hs @@ -53,7 +53,6 @@ import Data.UUID qualified as UUID import Data.UUID.Util qualified as UUID import Data.UUID.V1 qualified as UUID import Galley.Env qualified as Galley -import Galley.Options (featureFlags, maxConvSize, maxFanoutSize, settings) import Galley.Types.Conversations.Roles import Imports import Network.HTTP.Types.Status (status403) @@ -85,6 +84,7 @@ import Wire.API.Team.Role import Wire.API.Team.SearchVisibility import Wire.API.User qualified as Public import Wire.API.User qualified as U +import Wire.Options.Galley (featureFlags, maxConvSize, maxFanoutSize, settings) import Wire.StoredConversation (selfConv) tests :: IO TestSetup -> TestTree diff --git a/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs b/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs index 94e15b9e542..222c2af34bf 100644 --- a/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs +++ b/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs @@ -29,7 +29,6 @@ import API.Teams.LegalHold.Util import API.Util import Bilge hiding (accept, head, timeout, trace) import Bilge.Assert -import Brig.Types.Intra (UserSet (..)) import Control.Category ((>>>)) import Control.Concurrent.Chan import Control.Lens @@ -58,6 +57,7 @@ import Wire.API.Team.Member import Wire.API.Team.Member qualified as Team import Wire.API.Team.Permission import Wire.API.Team.Role +import Wire.API.User import Wire.API.User.Client import Wire.API.User.Client qualified as Client import Wire.LegalHoldStore.Cassandra diff --git a/services/galley/test/integration/API/Teams/LegalHold/Util.hs b/services/galley/test/integration/API/Teams/LegalHold/Util.hs index c11b38eca99..bf0195b89ad 100644 --- a/services/galley/test/integration/API/Teams/LegalHold/Util.hs +++ b/services/galley/test/integration/API/Teams/LegalHold/Util.hs @@ -48,7 +48,6 @@ import Data.Streaming.Network (bindRandomPortTCP) import Data.String.Conversions import Data.Tagged import Data.Text.Encoding (encodeUtf8) -import Galley.Options import Imports import Network.HTTP.Types.Status (status200, status400, status404) import Network.Socket (Socket) @@ -75,6 +74,7 @@ import Wire.API.Team.LegalHold import Wire.API.Team.LegalHold.External import Wire.API.User.Client import Wire.API.UserEvent qualified as Ev +import Wire.Options.Galley -------------------------------------------------------------------- -- setup helpers diff --git a/services/galley/test/integration/API/Util.hs b/services/galley/test/integration/API/Util.hs index 619a082d36e..5198b210061 100644 --- a/services/galley/test/integration/API/Util.hs +++ b/services/galley/test/integration/API/Util.hs @@ -85,7 +85,6 @@ import Data.UUID.V4 import Federator.MockServer hiding (body) import Federator.MockServer qualified as Mock import GHC.TypeNats -import Galley.Options qualified as Opts import Galley.Run qualified as Run import Galley.Types.Conversations.One2One import Imports @@ -145,6 +144,7 @@ import Wire.API.User.Auth hiding (Access) import Wire.API.User.Client import Wire.API.User.Client qualified as Client import Wire.API.User.Client.Prekey +import Wire.Options.Galley qualified as Opts import Wire.UserList ------------------------------------------------------------------------------- diff --git a/services/galley/test/integration/API/Util/TeamFeature.hs b/services/galley/test/integration/API/Util/TeamFeature.hs index 3bd3c22eefc..6ef4bc6ab39 100644 --- a/services/galley/test/integration/API/Util/TeamFeature.hs +++ b/services/galley/test/integration/API/Util/TeamFeature.hs @@ -27,11 +27,11 @@ import Bilge import Control.Lens ((%~)) import Data.ByteString.Conversion (toByteString') import Data.Id (ConvId, TeamId, UserId) -import Galley.Options (featureFlags, settings) import Imports import TestSetup import Wire.API.Team.Feature import Wire.API.Team.FeatureFlags +import Wire.Options.Galley (featureFlags, settings) withCustomSearchFeature :: FeatureDefaults SearchVisibilityAvailableConfig -> TestM () -> TestM () withCustomSearchFeature flag action = do @@ -60,6 +60,7 @@ putTeamFeatureInternal :: HasGalley m, MonadHttp m, HasCallStack, + Typeable cfg, IsFeatureConfig cfg ) => (Request -> Request) -> @@ -76,7 +77,7 @@ putTeamFeatureInternal reqmod tid status = do putTeamFeature :: forall cfg. - (HasCallStack, IsFeatureConfig cfg) => + (HasCallStack, Typeable cfg, IsFeatureConfig cfg) => UserId -> TeamId -> Feature cfg -> diff --git a/services/galley/test/integration/Federation.hs b/services/galley/test/integration/Federation.hs index 281a8fca9cb..5a7bb1e1c60 100644 --- a/services/galley/test/integration/Federation.hs +++ b/services/galley/test/integration/Federation.hs @@ -23,7 +23,6 @@ import Data.Id import Data.Qualified import Data.UUID qualified as UUID import Galley.App -import Galley.Options import Imports import Test.Tasty.HUnit import TestSetup @@ -31,6 +30,7 @@ import Wire.API.Conversation import Wire.API.Conversation.Protocol (Protocol (..)) import Wire.API.Conversation.Role (roleNameWireMember) import Wire.ConversationSubsystem.Util +import Wire.Options.Galley import Wire.StoredConversation isConvMemberLTests :: TestM () diff --git a/services/galley/test/integration/Run.hs b/services/galley/test/integration/Run.hs index 72eb745c1aa..999cc525df5 100644 --- a/services/galley/test/integration/Run.hs +++ b/services/galley/test/integration/Run.hs @@ -34,8 +34,6 @@ import Data.Text (pack) import Data.Text.Encoding (encodeUtf8) import Data.Yaml (decodeFileEither) import Federation -import Galley.Options hiding (endpoint) -import Galley.Options qualified as O import Imports hiding (local) import Network.HTTP.Client (responseTimeoutMicro) import Network.HTTP.Client.TLS (tlsManagerSettings) @@ -54,6 +52,8 @@ import Util.Options.Common import Util.Test import Util.Test.SQS qualified as SQS import Wire.AWS qualified as Aws +import Wire.Options.Galley hiding (endpoint) +import Wire.Options.Galley qualified as O newtype ServiceConfigFile = ServiceConfigFile String deriving (Eq, Ord, Typeable) diff --git a/services/galley/test/integration/TestHelpers.hs b/services/galley/test/integration/TestHelpers.hs index 66ff90fd31c..d146cd9968d 100644 --- a/services/galley/test/integration/TestHelpers.hs +++ b/services/galley/test/integration/TestHelpers.hs @@ -24,11 +24,11 @@ import Control.Monad.Catch (MonadMask) import Control.Retry import Data.Domain (Domain) import Data.Qualified -import Galley.Options (federationDomain, settings) import Imports import Test.Tasty (TestName, TestTree, testGroup) import Test.Tasty.HUnit (Assertion, testCase) import TestSetup +import Wire.Options.Galley (federationDomain, settings) test :: IO TestSetup -> TestName -> TestM a -> TestTree test s n h = testCase n runTest diff --git a/services/galley/test/integration/TestSetup.hs b/services/galley/test/integration/TestSetup.hs index da26f53f0f4..f3e09bd5f9a 100644 --- a/services/galley/test/integration/TestSetup.hs +++ b/services/galley/test/integration/TestSetup.hs @@ -55,7 +55,6 @@ import Data.ByteString.Conversion import Data.Domain import Data.Proxy import Data.Text qualified as Text -import Galley.Options (Opts) import Imports import Network.HTTP.Client qualified as HTTP import Proto.TeamEvents (TeamEvent) @@ -70,6 +69,7 @@ import Wire.API.Federation.Domain import Wire.API.Federation.Version import Wire.API.VersionInfo import Wire.AWS qualified as Aws +import Wire.Options.Galley (Opts) type GalleyR = Request -> Request diff --git a/services/restund/.gitignore b/services/restund/.gitignore deleted file mode 100644 index 4c6028d6684..00000000000 --- a/services/restund/.gitignore +++ /dev/null @@ -1,29 +0,0 @@ -# Object files -*.o - -# Libraries -*.lib -*.a - -# Shared objects (inc. Windows DLLs) -*.dll -*.so -*.dylib - -# Executables -*.exe -*.out -*.app - -# All them temporary directories and files -install -packages -src -target -.*.swp -dist -*.aci* -*.log -.vagrant -*.docker - diff --git a/services/restund/Dockerfile b/services/restund/Dockerfile deleted file mode 100644 index 4e500ae960c..00000000000 --- a/services/restund/Dockerfile +++ /dev/null @@ -1,27 +0,0 @@ -FROM ubuntu:16.04 - -ARG re_version -ARG restund_version -ARG extra_modules="zrest drain" -ARG DEBIAN_FRONTEND=noninteractive - -COPY src /build -RUN apt-get update \ - && apt-get install -y make gcc libssl-dev \ - && cd /build/re-${re_version} \ - && make RELEASE=1 \ - && make RELEASE=1 PREFIX=/usr/local install \ - && cd /build/restund-${restund_version} \ - && make RELEASE=1 EXTRA_CFLAGS="-std=gnu99" EXTRA_MODULES='${extra_modules}' \ - && make RELEASE=1 EXTRA_MODULES='${extra_modules}' PREFIX=/usr/local install \ - && ldconfig \ - && rm -rf /build \ - && apt-get remove -y make gcc \ - && apt-get autoremove -y - -RUN useradd --system --shell /bin/false -U restund - -USER restund -VOLUME /usr/local/etc/restund -#EXPOSE 1024-65000 -ENTRYPOINT ["/usr/local/sbin/restund", "-n", "-f", "/usr/local/etc/restund/restund.conf" ] diff --git a/services/restund/LICENSE b/services/restund/LICENSE deleted file mode 100644 index dba13ed2ddf..00000000000 --- a/services/restund/LICENSE +++ /dev/null @@ -1,661 +0,0 @@ - GNU AFFERO GENERAL PUBLIC LICENSE - Version 3, 19 November 2007 - - Copyright (C) 2007 Free Software Foundation, Inc. - Everyone is permitted to copy and distribute verbatim copies - of this license document, but changing it is not allowed. - - Preamble - - The GNU Affero General Public License is a free, copyleft license for -software and other kinds of works, specifically designed to ensure -cooperation with the community in the case of network server software. - - The licenses for most software and other practical works are designed -to take away your freedom to share and change the works. By contrast, -our General Public Licenses are intended to guarantee your freedom to -share and change all versions of a program--to make sure it remains free -software for all its users. - - When we speak of free software, we are referring to freedom, not -price. Our General Public Licenses are designed to make sure that you -have the freedom to distribute copies of free software (and charge for -them if you wish), that you receive source code or can get it if you -want it, that you can change the software or use pieces of it in new -free programs, and that you know you can do these things. - - Developers that use our General Public Licenses protect your rights -with two steps: (1) assert copyright on the software, and (2) offer -you this License which gives you legal permission to copy, distribute -and/or modify the software. - - A secondary benefit of defending all users' freedom is that -improvements made in alternate versions of the program, if they -receive widespread use, become available for other developers to -incorporate. Many developers of free software are heartened and -encouraged by the resulting cooperation. However, in the case of -software used on network servers, this result may fail to come about. -The GNU General Public License permits making a modified version and -letting the public access it on a server without ever releasing its -source code to the public. - - The GNU Affero General Public License is designed specifically to -ensure that, in such cases, the modified source code becomes available -to the community. It requires the operator of a network server to -provide the source code of the modified version running there to the -users of that server. Therefore, public use of a modified version, on -a publicly accessible server, gives the public access to the source -code of the modified version. - - An older license, called the Affero General Public License and -published by Affero, was designed to accomplish similar goals. This is -a different license, not a version of the Affero GPL, but Affero has -released a new version of the Affero GPL which permits relicensing under -this license. - - The precise terms and conditions for copying, distribution and -modification follow. - - TERMS AND CONDITIONS - - 0. Definitions. - - "This License" refers to version 3 of the GNU Affero General Public License. - - "Copyright" also means copyright-like laws that apply to other kinds of -works, such as semiconductor masks. - - "The Program" refers to any copyrightable work licensed under this -License. Each licensee is addressed as "you". "Licensees" and -"recipients" may be individuals or organizations. - - To "modify" a work means to copy from or adapt all or part of the work -in a fashion requiring copyright permission, other than the making of an -exact copy. The resulting work is called a "modified version" of the -earlier work or a work "based on" the earlier work. - - A "covered work" means either the unmodified Program or a work based -on the Program. - - To "propagate" a work means to do anything with it that, without -permission, would make you directly or secondarily liable for -infringement under applicable copyright law, except executing it on a -computer or modifying a private copy. Propagation includes copying, -distribution (with or without modification), making available to the -public, and in some countries other activities as well. - - To "convey" a work means any kind of propagation that enables other -parties to make or receive copies. Mere interaction with a user through -a computer network, with no transfer of a copy, is not conveying. - - An interactive user interface displays "Appropriate Legal Notices" -to the extent that it includes a convenient and prominently visible -feature that (1) displays an appropriate copyright notice, and (2) -tells the user that there is no warranty for the work (except to the -extent that warranties are provided), that licensees may convey the -work under this License, and how to view a copy of this License. If -the interface presents a list of user commands or options, such as a -menu, a prominent item in the list meets this criterion. - - 1. Source Code. - - The "source code" for a work means the preferred form of the work -for making modifications to it. "Object code" means any non-source -form of a work. - - A "Standard Interface" means an interface that either is an official -standard defined by a recognized standards body, or, in the case of -interfaces specified for a particular programming language, one that -is widely used among developers working in that language. - - The "System Libraries" of an executable work include anything, other -than the work as a whole, that (a) is included in the normal form of -packaging a Major Component, but which is not part of that Major -Component, and (b) serves only to enable use of the work with that -Major Component, or to implement a Standard Interface for which an -implementation is available to the public in source code form. A -"Major Component", in this context, means a major essential component -(kernel, window system, and so on) of the specific operating system -(if any) on which the executable work runs, or a compiler used to -produce the work, or an object code interpreter used to run it. - - The "Corresponding Source" for a work in object code form means all -the source code needed to generate, install, and (for an executable -work) run the object code and to modify the work, including scripts to -control those activities. However, it does not include the work's -System Libraries, or general-purpose tools or generally available free -programs which are used unmodified in performing those activities but -which are not part of the work. For example, Corresponding Source -includes interface definition files associated with source files for -the work, and the source code for shared libraries and dynamically -linked subprograms that the work is specifically designed to require, -such as by intimate data communication or control flow between those -subprograms and other parts of the work. - - The Corresponding Source need not include anything that users -can regenerate automatically from other parts of the Corresponding -Source. - - The Corresponding Source for a work in source code form is that -same work. - - 2. Basic Permissions. - - All rights granted under this License are granted for the term of -copyright on the Program, and are irrevocable provided the stated -conditions are met. This License explicitly affirms your unlimited -permission to run the unmodified Program. The output from running a -covered work is covered by this License only if the output, given its -content, constitutes a covered work. This License acknowledges your -rights of fair use or other equivalent, as provided by copyright law. - - You may make, run and propagate covered works that you do not -convey, without conditions so long as your license otherwise remains -in force. You may convey covered works to others for the sole purpose -of having them make modifications exclusively for you, or provide you -with facilities for running those works, provided that you comply with -the terms of this License in conveying all material for which you do -not control copyright. Those thus making or running the covered works -for you must do so exclusively on your behalf, under your direction -and control, on terms that prohibit them from making any copies of -your copyrighted material outside their relationship with you. - - Conveying under any other circumstances is permitted solely under -the conditions stated below. Sublicensing is not allowed; section 10 -makes it unnecessary. - - 3. Protecting Users' Legal Rights From Anti-Circumvention Law. - - No covered work shall be deemed part of an effective technological -measure under any applicable law fulfilling obligations under article -11 of the WIPO copyright treaty adopted on 20 December 1996, or -similar laws prohibiting or restricting circumvention of such -measures. - - When you convey a covered work, you waive any legal power to forbid -circumvention of technological measures to the extent such circumvention -is effected by exercising rights under this License with respect to -the covered work, and you disclaim any intention to limit operation or -modification of the work as a means of enforcing, against the work's -users, your or third parties' legal rights to forbid circumvention of -technological measures. - - 4. Conveying Verbatim Copies. - - You may convey verbatim copies of the Program's source code as you -receive it, in any medium, provided that you conspicuously and -appropriately publish on each copy an appropriate copyright notice; -keep intact all notices stating that this License and any -non-permissive terms added in accord with section 7 apply to the code; -keep intact all notices of the absence of any warranty; and give all -recipients a copy of this License along with the Program. - - You may charge any price or no price for each copy that you convey, -and you may offer support or warranty protection for a fee. - - 5. Conveying Modified Source Versions. - - You may convey a work based on the Program, or the modifications to -produce it from the Program, in the form of source code under the -terms of section 4, provided that you also meet all of these conditions: - - a) The work must carry prominent notices stating that you modified - it, and giving a relevant date. - - b) The work must carry prominent notices stating that it is - released under this License and any conditions added under section - 7. This requirement modifies the requirement in section 4 to - "keep intact all notices". - - c) You must license the entire work, as a whole, under this - License to anyone who comes into possession of a copy. This - License will therefore apply, along with any applicable section 7 - additional terms, to the whole of the work, and all its parts, - regardless of how they are packaged. This License gives no - permission to license the work in any other way, but it does not - invalidate such permission if you have separately received it. - - d) If the work has interactive user interfaces, each must display - Appropriate Legal Notices; however, if the Program has interactive - interfaces that do not display Appropriate Legal Notices, your - work need not make them do so. - - A compilation of a covered work with other separate and independent -works, which are not by their nature extensions of the covered work, -and which are not combined with it such as to form a larger program, -in or on a volume of a storage or distribution medium, is called an -"aggregate" if the compilation and its resulting copyright are not -used to limit the access or legal rights of the compilation's users -beyond what the individual works permit. Inclusion of a covered work -in an aggregate does not cause this License to apply to the other -parts of the aggregate. - - 6. Conveying Non-Source Forms. - - You may convey a covered work in object code form under the terms -of sections 4 and 5, provided that you also convey the -machine-readable Corresponding Source under the terms of this License, -in one of these ways: - - a) Convey the object code in, or embodied in, a physical product - (including a physical distribution medium), accompanied by the - Corresponding Source fixed on a durable physical medium - customarily used for software interchange. - - b) Convey the object code in, or embodied in, a physical product - (including a physical distribution medium), accompanied by a - written offer, valid for at least three years and valid for as - long as you offer spare parts or customer support for that product - model, to give anyone who possesses the object code either (1) a - copy of the Corresponding Source for all the software in the - product that is covered by this License, on a durable physical - medium customarily used for software interchange, for a price no - more than your reasonable cost of physically performing this - conveying of source, or (2) access to copy the - Corresponding Source from a network server at no charge. - - c) Convey individual copies of the object code with a copy of the - written offer to provide the Corresponding Source. This - alternative is allowed only occasionally and noncommercially, and - only if you received the object code with such an offer, in accord - with subsection 6b. - - d) Convey the object code by offering access from a designated - place (gratis or for a charge), and offer equivalent access to the - Corresponding Source in the same way through the same place at no - further charge. You need not require recipients to copy the - Corresponding Source along with the object code. If the place to - copy the object code is a network server, the Corresponding Source - may be on a different server (operated by you or a third party) - that supports equivalent copying facilities, provided you maintain - clear directions next to the object code saying where to find the - Corresponding Source. Regardless of what server hosts the - Corresponding Source, you remain obligated to ensure that it is - available for as long as needed to satisfy these requirements. - - e) Convey the object code using peer-to-peer transmission, provided - you inform other peers where the object code and Corresponding - Source of the work are being offered to the general public at no - charge under subsection 6d. - - A separable portion of the object code, whose source code is excluded -from the Corresponding Source as a System Library, need not be -included in conveying the object code work. - - A "User Product" is either (1) a "consumer product", which means any -tangible personal property which is normally used for personal, family, -or household purposes, or (2) anything designed or sold for incorporation -into a dwelling. In determining whether a product is a consumer product, -doubtful cases shall be resolved in favor of coverage. For a particular -product received by a particular user, "normally used" refers to a -typical or common use of that class of product, regardless of the status -of the particular user or of the way in which the particular user -actually uses, or expects or is expected to use, the product. A product -is a consumer product regardless of whether the product has substantial -commercial, industrial or non-consumer uses, unless such uses represent -the only significant mode of use of the product. - - "Installation Information" for a User Product means any methods, -procedures, authorization keys, or other information required to install -and execute modified versions of a covered work in that User Product from -a modified version of its Corresponding Source. The information must -suffice to ensure that the continued functioning of the modified object -code is in no case prevented or interfered with solely because -modification has been made. - - If you convey an object code work under this section in, or with, or -specifically for use in, a User Product, and the conveying occurs as -part of a transaction in which the right of possession and use of the -User Product is transferred to the recipient in perpetuity or for a -fixed term (regardless of how the transaction is characterized), the -Corresponding Source conveyed under this section must be accompanied -by the Installation Information. But this requirement does not apply -if neither you nor any third party retains the ability to install -modified object code on the User Product (for example, the work has -been installed in ROM). - - The requirement to provide Installation Information does not include a -requirement to continue to provide support service, warranty, or updates -for a work that has been modified or installed by the recipient, or for -the User Product in which it has been modified or installed. Access to a -network may be denied when the modification itself materially and -adversely affects the operation of the network or violates the rules and -protocols for communication across the network. - - Corresponding Source conveyed, and Installation Information provided, -in accord with this section must be in a format that is publicly -documented (and with an implementation available to the public in -source code form), and must require no special password or key for -unpacking, reading or copying. - - 7. Additional Terms. - - "Additional permissions" are terms that supplement the terms of this -License by making exceptions from one or more of its conditions. -Additional permissions that are applicable to the entire Program shall -be treated as though they were included in this License, to the extent -that they are valid under applicable law. If additional permissions -apply only to part of the Program, that part may be used separately -under those permissions, but the entire Program remains governed by -this License without regard to the additional permissions. - - When you convey a copy of a covered work, you may at your option -remove any additional permissions from that copy, or from any part of -it. (Additional permissions may be written to require their own -removal in certain cases when you modify the work.) You may place -additional permissions on material, added by you to a covered work, -for which you have or can give appropriate copyright permission. - - Notwithstanding any other provision of this License, for material you -add to a covered work, you may (if authorized by the copyright holders of -that material) supplement the terms of this License with terms: - - a) Disclaiming warranty or limiting liability differently from the - terms of sections 15 and 16 of this License; or - - b) Requiring preservation of specified reasonable legal notices or - author attributions in that material or in the Appropriate Legal - Notices displayed by works containing it; or - - c) Prohibiting misrepresentation of the origin of that material, or - requiring that modified versions of such material be marked in - reasonable ways as different from the original version; or - - d) Limiting the use for publicity purposes of names of licensors or - authors of the material; or - - e) Declining to grant rights under trademark law for use of some - trade names, trademarks, or service marks; or - - f) Requiring indemnification of licensors and authors of that - material by anyone who conveys the material (or modified versions of - it) with contractual assumptions of liability to the recipient, for - any liability that these contractual assumptions directly impose on - those licensors and authors. - - All other non-permissive additional terms are considered "further -restrictions" within the meaning of section 10. If the Program as you -received it, or any part of it, contains a notice stating that it is -governed by this License along with a term that is a further -restriction, you may remove that term. If a license document contains -a further restriction but permits relicensing or conveying under this -License, you may add to a covered work material governed by the terms -of that license document, provided that the further restriction does -not survive such relicensing or conveying. - - If you add terms to a covered work in accord with this section, you -must place, in the relevant source files, a statement of the -additional terms that apply to those files, or a notice indicating -where to find the applicable terms. - - Additional terms, permissive or non-permissive, may be stated in the -form of a separately written license, or stated as exceptions; -the above requirements apply either way. - - 8. Termination. - - You may not propagate or modify a covered work except as expressly -provided under this License. Any attempt otherwise to propagate or -modify it is void, and will automatically terminate your rights under -this License (including any patent licenses granted under the third -paragraph of section 11). - - However, if you cease all violation of this License, then your -license from a particular copyright holder is reinstated (a) -provisionally, unless and until the copyright holder explicitly and -finally terminates your license, and (b) permanently, if the copyright -holder fails to notify you of the violation by some reasonable means -prior to 60 days after the cessation. - - Moreover, your license from a particular copyright holder is -reinstated permanently if the copyright holder notifies you of the -violation by some reasonable means, this is the first time you have -received notice of violation of this License (for any work) from that -copyright holder, and you cure the violation prior to 30 days after -your receipt of the notice. - - Termination of your rights under this section does not terminate the -licenses of parties who have received copies or rights from you under -this License. If your rights have been terminated and not permanently -reinstated, you do not qualify to receive new licenses for the same -material under section 10. - - 9. Acceptance Not Required for Having Copies. - - You are not required to accept this License in order to receive or -run a copy of the Program. Ancillary propagation of a covered work -occurring solely as a consequence of using peer-to-peer transmission -to receive a copy likewise does not require acceptance. However, -nothing other than this License grants you permission to propagate or -modify any covered work. These actions infringe copyright if you do -not accept this License. Therefore, by modifying or propagating a -covered work, you indicate your acceptance of this License to do so. - - 10. Automatic Licensing of Downstream Recipients. - - Each time you convey a covered work, the recipient automatically -receives a license from the original licensors, to run, modify and -propagate that work, subject to this License. You are not responsible -for enforcing compliance by third parties with this License. - - An "entity transaction" is a transaction transferring control of an -organization, or substantially all assets of one, or subdividing an -organization, or merging organizations. If propagation of a covered -work results from an entity transaction, each party to that -transaction who receives a copy of the work also receives whatever -licenses to the work the party's predecessor in interest had or could -give under the previous paragraph, plus a right to possession of the -Corresponding Source of the work from the predecessor in interest, if -the predecessor has it or can get it with reasonable efforts. - - You may not impose any further restrictions on the exercise of the -rights granted or affirmed under this License. For example, you may -not impose a license fee, royalty, or other charge for exercise of -rights granted under this License, and you may not initiate litigation -(including a cross-claim or counterclaim in a lawsuit) alleging that -any patent claim is infringed by making, using, selling, offering for -sale, or importing the Program or any portion of it. - - 11. Patents. - - A "contributor" is a copyright holder who authorizes use under this -License of the Program or a work on which the Program is based. The -work thus licensed is called the contributor's "contributor version". - - A contributor's "essential patent claims" are all patent claims -owned or controlled by the contributor, whether already acquired or -hereafter acquired, that would be infringed by some manner, permitted -by this License, of making, using, or selling its contributor version, -but do not include claims that would be infringed only as a -consequence of further modification of the contributor version. For -purposes of this definition, "control" includes the right to grant -patent sublicenses in a manner consistent with the requirements of -this License. - - Each contributor grants you a non-exclusive, worldwide, royalty-free -patent license under the contributor's essential patent claims, to -make, use, sell, offer for sale, import and otherwise run, modify and -propagate the contents of its contributor version. - - In the following three paragraphs, a "patent license" is any express -agreement or commitment, however denominated, not to enforce a patent -(such as an express permission to practice a patent or covenant not to -sue for patent infringement). To "grant" such a patent license to a -party means to make such an agreement or commitment not to enforce a -patent against the party. - - If you convey a covered work, knowingly relying on a patent license, -and the Corresponding Source of the work is not available for anyone -to copy, free of charge and under the terms of this License, through a -publicly available network server or other readily accessible means, -then you must either (1) cause the Corresponding Source to be so -available, or (2) arrange to deprive yourself of the benefit of the -patent license for this particular work, or (3) arrange, in a manner -consistent with the requirements of this License, to extend the patent -license to downstream recipients. "Knowingly relying" means you have -actual knowledge that, but for the patent license, your conveying the -covered work in a country, or your recipient's use of the covered work -in a country, would infringe one or more identifiable patents in that -country that you have reason to believe are valid. - - If, pursuant to or in connection with a single transaction or -arrangement, you convey, or propagate by procuring conveyance of, a -covered work, and grant a patent license to some of the parties -receiving the covered work authorizing them to use, propagate, modify -or convey a specific copy of the covered work, then the patent license -you grant is automatically extended to all recipients of the covered -work and works based on it. - - A patent license is "discriminatory" if it does not include within -the scope of its coverage, prohibits the exercise of, or is -conditioned on the non-exercise of one or more of the rights that are -specifically granted under this License. You may not convey a covered -work if you are a party to an arrangement with a third party that is -in the business of distributing software, under which you make payment -to the third party based on the extent of your activity of conveying -the work, and under which the third party grants, to any of the -parties who would receive the covered work from you, a discriminatory -patent license (a) in connection with copies of the covered work -conveyed by you (or copies made from those copies), or (b) primarily -for and in connection with specific products or compilations that -contain the covered work, unless you entered into that arrangement, -or that patent license was granted, prior to 28 March 2007. - - Nothing in this License shall be construed as excluding or limiting -any implied license or other defenses to infringement that may -otherwise be available to you under applicable patent law. - - 12. No Surrender of Others' Freedom. - - If conditions are imposed on you (whether by court order, agreement or -otherwise) that contradict the conditions of this License, they do not -excuse you from the conditions of this License. If you cannot convey a -covered work so as to satisfy simultaneously your obligations under this -License and any other pertinent obligations, then as a consequence you may -not convey it at all. For example, if you agree to terms that obligate you -to collect a royalty for further conveying from those to whom you convey -the Program, the only way you could satisfy both those terms and this -License would be to refrain entirely from conveying the Program. - - 13. Remote Network Interaction; Use with the GNU General Public License. - - Notwithstanding any other provision of this License, if you modify the -Program, your modified version must prominently offer all users -interacting with it remotely through a computer network (if your version -supports such interaction) an opportunity to receive the Corresponding -Source of your version by providing access to the Corresponding Source -from a network server at no charge, through some standard or customary -means of facilitating copying of software. This Corresponding Source -shall include the Corresponding Source for any work covered by version 3 -of the GNU General Public License that is incorporated pursuant to the -following paragraph. - - Notwithstanding any other provision of this License, you have -permission to link or combine any covered work with a work licensed -under version 3 of the GNU General Public License into a single -combined work, and to convey the resulting work. The terms of this -License will continue to apply to the part which is the covered work, -but the work with which it is combined will remain governed by version -3 of the GNU General Public License. - - 14. Revised Versions of this License. - - The Free Software Foundation may publish revised and/or new versions of -the GNU Affero General Public License from time to time. Such new versions -will be similar in spirit to the present version, but may differ in detail to -address new problems or concerns. - - Each version is given a distinguishing version number. If the -Program specifies that a certain numbered version of the GNU Affero General -Public License "or any later version" applies to it, you have the -option of following the terms and conditions either of that numbered -version or of any later version published by the Free Software -Foundation. If the Program does not specify a version number of the -GNU Affero General Public License, you may choose any version ever published -by the Free Software Foundation. - - If the Program specifies that a proxy can decide which future -versions of the GNU Affero General Public License can be used, that proxy's -public statement of acceptance of a version permanently authorizes you -to choose that version for the Program. - - Later license versions may give you additional or different -permissions. However, no additional obligations are imposed on any -author or copyright holder as a result of your choosing to follow a -later version. - - 15. Disclaimer of Warranty. - - THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY -APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT -HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY -OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, -THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM -IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF -ALL NECESSARY SERVICING, REPAIR OR CORRECTION. - - 16. Limitation of Liability. - - IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING -WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS -THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY -GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE -USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF -DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD -PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), -EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF -SUCH DAMAGES. - - 17. Interpretation of Sections 15 and 16. - - If the disclaimer of warranty and limitation of liability provided -above cannot be given local legal effect according to their terms, -reviewing courts shall apply local law that most closely approximates -an absolute waiver of all civil liability in connection with the -Program, unless a warranty or assumption of liability accompanies a -copy of the Program in return for a fee. - - END OF TERMS AND CONDITIONS - - How to Apply These Terms to Your New Programs - - If you develop a new program, and you want it to be of the greatest -possible use to the public, the best way to achieve this is to make it -free software which everyone can redistribute and change under these terms. - - To do so, attach the following notices to the program. It is safest -to attach them to the start of each source file to most effectively -state the exclusion of warranty; and each file should have at least -the "copyright" line and a pointer to where the full notice is found. - - - Copyright (C) - - This program is free software: you can redistribute it and/or modify - it under the terms of the GNU Affero General Public License as published by - the Free Software Foundation, either version 3 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU Affero General Public License for more details. - - You should have received a copy of the GNU Affero General Public License - along with this program. If not, see . - -Also add information on how to contact you by electronic and paper mail. - - If your software can interact with users remotely through a computer -network, you should also make sure that it provides a way for users to -get its source. For example, if your program is a web application, its -interface could display a "Source" link that leads users to an archive -of the code. There are many ways you could offer source, and different -solutions will be better for different programs; see section 13 for the -specific requirements. - - You should also get your employer (if you work as a programmer) or school, -if any, to sign a "copyright disclaimer" for the program, if necessary. -For more information on this, and how to apply and follow the GNU AGPL, see -. diff --git a/services/restund/Makefile b/services/restund/Makefile deleted file mode 100644 index adedad7ce93..00000000000 --- a/services/restund/Makefile +++ /dev/null @@ -1,112 +0,0 @@ -LANG := en_US.UTF-8 -SHELL := /usr/bin/env bash - -BUILD_NUMBER ?= 0 - -RE_VERSION := 0.4.15 -RE_TARBALL := re-$(RE_VERSION).tar.gz -RE_SRC := src/re-$(RE_VERSION)/Makefile -RE_URL := https://github.com/creytiv/re/archive - -RESTUND_VERSION := 0.4.14 -RESTUND_TARBALL := restund-$(RESTUND_VERSION).tar.gz -RESTUND_SRC := src/restund-$(RESTUND_VERSION)/Makefile -RESTUND_URL := https://github.com/wireapp/restund/archive - -WIRE_VERSION := 7 - -EXTRA_MODULES := zrest drain - -DOCKER ?= true -DOCKER_USER ?= quay.io/wire -IMAGE_VERSION := $(RESTUND_VERSION)w$(WIRE_VERSION)b$(BUILD_NUMBER) -ACI := restund-$(IMAGE_VERSION)_linux_amd64.aci - -ACI_PORTS := udp,protocol=udp,port=1024,count=64411,socketActivated=false -ACI_PORTS += tcp,protocol=tcp,port=3478,count=1,socketActivated=false -ACI_PORTS += tls,protocol=tcp,port=5349,count=1,socketActivated=false -ACI_PORTS += http,protocol=tcp,port=8080,count=1,socketActivated=false - -space := $() $() - - -default: dist - -.PHONY: dist -dist: clean $(ACI) - -.PHONY: build -ifeq ($(DOCKER),true) -build: build-docker -else -build: $(RESTUND_SRC) $(RE_SRC) extra_modules - $(MAKE) -C src/re-$(RE_VERSION) RELEASE=1 - $(MAKE) -C src/re-$(RE_VERSION) PREFIX=/usr/local install - $(MAKE) -C src/restund-$(RESTUND_VERSION) RELEASE=1 EXTRA_MODULES='$(EXTRA_MODULES)' - $(MAKE) -C src/restund-$(RESTUND_VERSION) RELEASE=1 EXTRA_MODULES='$(EXTRA_MODULES)' PREFIX=/usr/local install - ldconfig -endif - -.PHONY: image -image: $(ACI) - -.PHONY: publish -publish: $(ACI) $(ACI).asc - -.PHONY: clean -clean: - rm -rf src - rm -f *.docker *.aci *.asc - -%.asc: - gpg --armor --yes --output $*.asc --detach-sig $* - -.PHONY: concourse -concourse: $(RESTUND_SRC) $(RE_SRC) extra_modules - printf '{"re_version":"%s","restund_version":"%s"}\n' \ - $(RE_VERSION) $(RESTUND_VERSION) > build_args.json - echo $(IMAGE_VERSION) > tag.txt - -.PHONY: build-docker -build-docker: $(RESTUND_SRC) $(RE_SRC) extra_modules - docker build -t $(DOCKER_USER)/restund:$(IMAGE_VERSION) \ - --build-arg re_version=$(RE_VERSION) \ - --build-arg restund_version=$(RESTUND_VERSION) \ - --build-arg extra_modules="$(EXTRA_MODULES)" \ - . - -$(ACI): build-docker - docker save -o restund-$(IMAGE_VERSION).docker \ - $(DOCKER_USER)/restund:$(IMAGE_VERSION) - docker2aci -debug restund-$(IMAGE_VERSION).docker - actool -debug patch-manifest -overwrite \ - --ports='$(subst $(space),:,$(ACI_PORTS))' \ - restund-$(IMAGE_VERSION).aci $(ACI) - rm restund-$(IMAGE_VERSION).aci restund-$(IMAGE_VERSION).docker - -packages: - mkdir -p packages - -packages/$(RE_TARBALL): packages - curl -sSLf $(RE_URL)/v$(RE_VERSION).tar.gz -o packages/$(RE_TARBALL) - -packages/$(RESTUND_TARBALL): packages - curl -sSLf $(RESTUND_URL)/v$(RESTUND_VERSION).tar.gz -o packages/$(RESTUND_TARBALL) - -.PHONY: tarballs -tarballs: packages/$(RE_TARBALL) packages/$(RESTUND_TARBALL) - -src: - mkdir -p src - -$(RE_SRC): packages/$(RE_TARBALL) | src - tar -C src -xmvf $(CURDIR)/packages/$(RE_TARBALL) - -$(RESTUND_SRC): packages/$(RESTUND_TARBALL) | src - tar -C src -xmvf $(CURDIR)/packages/$(RESTUND_TARBALL) - -src/restund-$(RESTUND_VERSION)/modules/%: $(RESTUND_SRC) - cp -r $(CURDIR)/modules/$* src/restund-$(RESTUND_VERSION)/modules - -.PHONY: extra_modules -extra_modules: $(addprefix src/restund-$(RESTUND_VERSION)/modules/,$(EXTRA_MODULES)) diff --git a/services/restund/README.md b/services/restund/README.md deleted file mode 100644 index 1cab623bb4f..00000000000 --- a/services/restund/README.md +++ /dev/null @@ -1,154 +0,0 @@ -# Restund - -`restund` is used for audio and video calls. - -This folder contains extra modules on top of [restund](https://github.com/wireapp/restund), as well as some build instructions. - -## License - -* The actual [restund](https://github.com/wireapp/restund) is under [BSD](https://github.com/wireapp/restund/blob/master/docs/COPYING) -* This folder's extra modules, like the rest of wire-server, are under AGPL, see [LICENSE](LICENSE) - -## Building - -The preferred way of building `restund` is via Docker, which -encodes all build- and runtime dependencies. The only prerequisites on the build -machine are thus `docker` and `make`. - -```shell -make build -``` - -It's possible to bypass `docker`, in which case the host must have all -build-time dependencies installed. - -```shell -make build DOCKER=false -``` - -## Creating ACIs for use with rkt - -If you'd like to create an [ACI](https://github.com/appc/spec/blob/master/spec/aci.md) for use with [rkt](https://github.com/rkt/rkt), -apart from`docker` and `make`, you'll need [docker2aci](https://github.com/appc/docker2aci) and -[actool](https://github.com/appc/spec/tree/master/actool) installed on the build -machine. This also implies having the Go language toolchain installed, unless -you can get hold of the binaries by some other means. Additionally, `gpg` needs to be installed and set -up in order to create signatures for the ACIs. - -```shell -export PATH=$GOPATH/bin:$PATH -go get -u github.com/appc/docker2aci -go get -u github.com/appc/spec/actool -``` - -> Note: the versions used as of this writing are: -> -> ```shell -> local:~$ docker2aci --version -> docker2aci version 0.16.0+git -> appc version 0.8.10 -> local:~$ actool version -> actool version 0.8.10+git -> ``` -> -> You may want to upgrade these tools from time to time by re-executing -> the above `go get` commands. - -Create an `.aci` and signature: - -```shell -make publish -``` - -Before releasing, you may want to increment the version(s): `restund` is -versioned according to its upstream version, plus a "wire version" set in the -Makefile. - -## Running restund on a server - -You need - -* the aci image built in the section above, or, alternatively, a natively compiled `restund` binary with all the shared libraries available. -* an adapted restund config (see below) -* (optionally) a TLS certificate chain in PEM format, including the private key - -Example config file: - -```conf -# /etc/restund/restund.conf - -# core -daemon no -debug no -realm dummy.io -syncinterval 600 -udp_listen {{ ansible_default_ipv4.address }}:3478 -udp_sockbuf_size 524288 -tcp_listen {{ ansible_default_ipv4.address }}:3478 -# tls_listen is optional, you can comment that line out. If set, you must provide a valid TLS certificate for the domain name you're advertising. -# tls_listen {{ ansible_default_ipv4.address }}:5349,/usr/local/etc/restund/restund.pem - -# modules -module_path /usr/local/lib/restund/modules -module stat.so -module drain.so -module binding.so -module turn.so -module status.so -# The auth and zrest modules are optional. If enabled, ensure the zrest_secret below is set to a value shared with the configuration in brig. -module zrest.so -module auth.so - -# auth -auth_nonce_expiry 3600 - -# turn -turn_max_allocations 64000 -turn_max_lifetime 3600 -turn_relay_addr {{ ansible_default_ipv4.address }} - -# You generally don't need to set this (only if your server is on a private network and must be reachable from other restund servers that are on another network): -# turn_public_addr is an IP which must be reachable for UDP traffic from other restund servers (and from this server itself). If unset, defaults to 'turn_relay_addr' -#turn_public_addr {{ public_ipv4 }} - -# syslog -syslog_facility 24 - -# status -status_udp_addr 127.0.0.1 -status_udp_port 33000 -status_http_addr 127.0.0.1 -status_http_port 8080 - -# zrest (shared secret shared with brig, optional) -zrest_secret {{ restund_zrest_secret }} -``` - -Adjust the above configuration: - -* Replace the `{{ variables }}` with real values (without `{{`)): - * Put your private IP of the server in place of: `{{ ansible_default_ipv4.address }}`. -* You may comment these out in case you don't want to use authentication: -``` -module zrest.so -module auth.so -zrest_secret {{ restund_zrest_secret }} -``` - - -Next, list out TURN IP and port in `services/brig/test/resources/turn/servers.txt`, and `services/brig/test/resources/turn/servers-v2.txt`, as given below: -`turn::3478` -Then run the command restund command and you'll get the live stun log in your terminal. - -Running restund with `rkt`: - -``` -/usr/bin/rkt run \ - --net=host \ - --dns=host \ - --hosts-entry=host \ - --volume volume-usr-local-etc-restund,kind=host,source=/etc/restund,readOnly=true \ - {{ aci_base_url }}/restund/restund-{{ versions.restund }}_linux_amd64.aci \ - --user=restund \ - --group=restund -``` diff --git a/services/restund/modules/drain/drain.c b/services/restund/modules/drain/drain.c deleted file mode 100644 index 7e082fe478a..00000000000 --- a/services/restund/modules/drain/drain.c +++ /dev/null @@ -1,144 +0,0 @@ -/** - * @file drain.c - * - * Copyright (c) 2018 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 . - */ - -#include -#include - - -static bool is_draining = false; - -/* - * Iff is_draining == true, prevents new allocations and denies allocation - * refresh by replying with a '508 Insufficient Capacity' message. - */ -static bool request_handler(struct restund_msgctx *ctx, int proto, void *sock, - const struct sa *src, const struct sa *dst, - const struct stun_msg *msg) -{ - int err; - struct stun_attr *lt; - - if (is_draining) { - switch (stun_msg_method(msg)) { - - case STUN_METHOD_ALLOCATE: - restund_info("received ALLOCATE request while in drain mode\n"); - goto unavailable; - - case STUN_METHOD_REFRESH: - lt = stun_msg_attr(msg, STUN_ATTR_LIFETIME); - - if (lt && lt->v.lifetime > 0) { - restund_info("received REFRESH request while in drain mode\n"); - goto unavailable; - } - - break; - - default: - break; - } - } - - return false; - - unavailable: - err = stun_ereply(proto, sock, src, 0, msg, - 508, "Draining", - NULL, 0, ctx->fp, 1, - STUN_ATTR_SOFTWARE, restund_software); - - if (err) { - restund_warning("drain reply error: %m\n", err); - } - - return true; -} - -static struct restund_stun stun = { - .reqh = request_handler -}; - -// commands - -static void drain_print(struct mbuf *mb) -{ - (void)mbuf_printf(mb, "is_draining: %d\n", is_draining); -} - -static void drain_enable(struct mbuf *mb) -{ - is_draining = true; - drain_print(mb); -} - -static void drain_disable(struct mbuf *mb) -{ - is_draining = false; - drain_print(mb); -} - -static struct restund_cmdsub cmd_drain_print = { - .cmdh = drain_print, - .cmd = "drain_state", -}; - -static struct restund_cmdsub cmd_drain_enable = { - .cmdh = drain_enable, - .cmd = "drain_enable", -}; - -static struct restund_cmdsub cmd_drain_disable = { - .cmdh = drain_disable, - .cmd = "drain_disable", -}; - - -// module - -static int module_init(void) -{ - restund_stun_register_handler(&stun); - restund_cmd_subscribe(&cmd_drain_print); - restund_cmd_subscribe(&cmd_drain_enable); - restund_cmd_subscribe(&cmd_drain_disable); - - restund_debug("drain: module loaded\n"); - - return 0; -} - -static int module_close(void) -{ - restund_cmd_unsubscribe(&cmd_drain_enable); - restund_cmd_unsubscribe(&cmd_drain_disable); - restund_cmd_unsubscribe(&cmd_drain_print); - restund_stun_unregister_handler(&stun); - - restund_debug("drain: module closed\n"); - - return 0; -} - -const struct mod_export DECL_EXPORTS(drain) = { - .name = "drain", - .type = "stun", - .init = module_init, - .close = module_close, -}; diff --git a/services/restund/modules/drain/module.mk b/services/restund/modules/drain/module.mk deleted file mode 100644 index 940cfd05cb8..00000000000 --- a/services/restund/modules/drain/module.mk +++ /dev/null @@ -1,23 +0,0 @@ -# -# module.mk -# -# Copyright (c) 2018 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 . -# -MOD := drain -$(MOD)_SRCS += drain.c -$(MOD)_LFLAGS += - -include mk/mod.mk diff --git a/services/restund/modules/zrest/module.mk b/services/restund/modules/zrest/module.mk deleted file mode 100644 index 1f65af5a364..00000000000 --- a/services/restund/modules/zrest/module.mk +++ /dev/null @@ -1,23 +0,0 @@ -# -# module.mk -# -# Copyright (c) 2018 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 . - -MOD := zrest -$(MOD)_SRCS += zrest.c -$(MOD)_LFLAGS += - -include mk/mod.mk diff --git a/services/restund/modules/zrest/zrest.c b/services/restund/modules/zrest/zrest.c deleted file mode 100644 index 66ce8a47a9d..00000000000 --- a/services/restund/modules/zrest/zrest.c +++ /dev/null @@ -1,283 +0,0 @@ -/** - * @file zrest.c Zeta REST-based authentication - * - * Copyright (c) 2018 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 . - */ - -#include -#include -#include -#include -#include -#include -#include - - -/* - * This module implements a REST-based authentication mechanism - * using ephemeral (i.e. time-limited) credentials. - * - * A shared secret must be configured in the config file, and can then - * be shared with a HTTP REST-based service. - * - * Format: - * - * username = .s. - * password = HMAC_SHA512(secret, username) - */ - - -static struct { - char secret[256]; - size_t secret_len; - - struct http_sock *http_sock; /* optional */ -} zrest; - - -#if 0 -static void generate_username_v0(char *user, size_t sz, uint32_t ttl) -{ - char x[42]; - time_t now = time(NULL); - - rand_str(x, sizeof(x)); - - re_snprintf(user, sz, - "%llu.s.%s", (uint64_t)(now + ttl), x); -} -#endif - - -static void generate_username_v1(char *user, size_t sz, uint32_t ttl) -{ - char x[42]; - time_t now = time(NULL); - - rand_str(x, sizeof(x)); - - re_snprintf(user, sz, - "d=%llu.v=1.k=0.t=s.r=%s", - (uint64_t)(now + ttl), x); -} - - -static int generate_password(char *pass, size_t *passlen, const char *user) -{ - uint8_t digest[SHA512_DIGEST_LENGTH]; - unsigned int md_len = sizeof(digest); - int err; - - if (!HMAC(EVP_sha512(), - zrest.secret, (int)zrest.secret_len, - (void *)user, (int)strlen(user), - digest, &md_len)) { - - restund_warning("zrest: HMAC failed\n"); - ERR_clear_error(); - return EINVAL; - } - - err = base64_encode(digest, sizeof(digest), pass, passlen); - if (err) - return err; - - return 0; -} - - -static int auth_handler(const char *user, uint8_t *ha1) -{ - struct pl expires; - time_t expi; - char pass[256]; - size_t passlen = sizeof(pass); - struct pl pl_keyindex; - uint32_t keyindex = 0; - int err; - - if (0 == re_regex(user, strlen(user), - "d=[0-9]+.v=1.k=[0-9]+.t=s.r=[a-z0-9]*", - &expires, &pl_keyindex, NULL)) { - - keyindex = pl_u32(&pl_keyindex); - - restund_debug("zrest: auth version 1 (keyindex=%u)\n", - keyindex); - } - else if (0 == re_regex(user, strlen(user), - "[0-9]+.s.[0-9]*", &expires, NULL)) { - - restund_info("zrest: auth version 0\n"); - } - else { - restund_info("zrest: could not parse username (%s)\n", user); - return EPROTO; - } - - expi = (time_t)pl_u64(&expires); - if (expi < time(NULL)) { - restund_debug("zrest: username expired %lli seconds ago\n", - time(NULL) - pl_u64(&expires)); - return ETIMEDOUT; - } - - err = generate_password(pass, &passlen, user); - if (err) { - restund_warning("zrest: failed to generated password (%m)\n", - err); - return err; - } - - restund_debug("zrest: VALID username token :)\n"); - - return md5_printf(ha1, "%s:%s:%b", - user, restund_realm(), pass, passlen); -} - - -static void http_req_handler(struct http_conn *conn, - const struct http_msg *msg, void *arg) -{ - struct pl username; - char tsuser[256]; - uint32_t ttl = 86400; - char pass[256]; - size_t passlen = sizeof(pass); - int err; - (void)arg; - struct sa stun_addr; - - if (re_regex(msg->prm.p, msg->prm.l, "username=[^&]+", &username)) { - - restund_warning("zrest: missing username parameter\n"); - http_ereply(conn, 400, "Bad Request"); - return; - } - - generate_username_v1(tsuser, sizeof(tsuser), ttl); - - err = generate_password(pass, &passlen, tsuser); - if (err) { - restund_warning("zrest: could not generate password" - " for use '%s' (%m)\n", tsuser, err); - http_ereply(conn, 500, "Server Error"); - } - - restund_udp_socket(&stun_addr, NULL, false, false); - - http_creply(conn, 200, "OK", "application/json", - - "{\r\n" - " \"username\" : \"%s\",\r\n" - " \"password\" : \"%b\",\r\n" - " \"ttl\" : %u,\r\n" - " \"uris\" : [\r\n" - " \"turn:%J?transport=udp\",\r\n" - " ]\r\n" - "}\r\n" - , - tsuser, - pass, passlen, - ttl, - &stun_addr - ); -} - - -static int module_init(void) -{ - char addr[64]; - int err; - - err = conf_get_str(restund_conf(), "zrest_secret", zrest.secret, - sizeof(zrest.secret)); - if (err) { - restund_error("zrest: missing config 'rest_secret'\n"); - return err; - } - - zrest.secret_len = strlen(zrest.secret); - if (zrest.secret_len == 0) { - restund_error("zrest: config 'zrest_secret' is empty\n"); - return EINVAL; - } - - restund_db_set_auth_handler(auth_handler); - - /* selftest */ - if (1) { - char user[256], pass[256]; - size_t passlen = sizeof(pass); - generate_username_v1(user, sizeof(user), 60); - err = generate_password(pass, &passlen, user); - if (err) { - restund_error("zrest: failed to generate password" - " for user='%s' (%m)\n", user, err); - return err; - } - - restund_info("zrest: selftest passed (pass=%b)\n", - pass, passlen); - } - - if (0 == conf_get_str(restund_conf(), "zrest_listen", - addr, sizeof(addr))) { - - struct sa http_addr; - - err = sa_set_str(&http_addr, addr, 8000); - if (err) { - restund_warning("zrest: invalid address (%s)\n", addr); - return err; - } - - err = http_listen(&zrest.http_sock, &http_addr, - http_req_handler, NULL); - if (err) { - restund_warning("zrest: failed to listen on %J (%m)\n", - &http_addr, err); - return err; - } - - restund_info("zrest: HTTP server listening on %J\n", - &http_addr); - } - - restund_debug("zrest: module loaded\n"); - - return 0; -} - - -static int module_close(void) -{ - zrest.http_sock = mem_deref(zrest.http_sock); - - restund_db_set_auth_handler(NULL); - - restund_debug("zrest: module closed\n"); - - return 0; -} - - -const struct mod_export exports = { - .name = "zrest", - .type = "auth", - .init = module_init, - .close = module_close -}; diff --git a/services/spar/default.nix b/services/spar/default.nix index b59feaf3aa6..315c3c5d75a 100644 --- a/services/spar/default.nix +++ b/services/spar/default.nix @@ -9,7 +9,6 @@ , base , base64-bytestring , bilge -, brig-types , bytestring , bytestring-conversion , case-insensitive @@ -75,7 +74,6 @@ , wai-extra , wai-middleware-gunzip , wai-utilities -, warp , wire-api , wire-subsystems , xml-conduit @@ -93,7 +91,6 @@ mkDerivation { base base64-bytestring bilge - brig-types bytestring bytestring-conversion case-insensitive @@ -135,7 +132,6 @@ mkDerivation { wai wai-middleware-gunzip wai-utilities - warp wire-api wire-subsystems yaml @@ -147,7 +143,6 @@ mkDerivation { base base64-bytestring bilge - brig-types bytestring bytestring-conversion case-insensitive @@ -210,7 +205,6 @@ mkDerivation { aeson aeson-qq base - brig-types bytestring-conversion containers cookie diff --git a/services/spar/spar.cabal b/services/spar/spar.cabal index 233edf320ba..42885b16c33 100644 --- a/services/spar/spar.cabal +++ b/services/spar/spar.cabal @@ -163,7 +163,6 @@ library , base , base64-bytestring , bilge - , brig-types , bytestring , bytestring-conversion , case-insensitive @@ -205,7 +204,6 @@ library , wai , wai-middleware-gunzip , wai-utilities - , warp , wire-api , wire-subsystems , yaml @@ -356,7 +354,6 @@ executable spar-integration , base , base64-bytestring , bilge - , brig-types , bytestring , bytestring-conversion , case-insensitive @@ -630,7 +627,6 @@ test-suite spec aeson , aeson-qq , base - , brig-types , bytestring-conversion , containers , cookie diff --git a/services/spar/src/Spar/API.hs b/services/spar/src/Spar/API.hs index c5e62375b9f..bd8e285b66a 100644 --- a/services/spar/src/Spar/API.hs +++ b/services/spar/src/Spar/API.hs @@ -54,7 +54,6 @@ module Spar.API ) where -import Brig.Types.Intra import Cassandra as Cas import Control.Lens hiding ((.=)) import qualified Data.ByteString as SBS diff --git a/services/spar/src/Spar/CanonicalInterpreter.hs b/services/spar/src/Spar/CanonicalInterpreter.hs index c6d3681b526..884a534b4d1 100644 --- a/services/spar/src/Spar/CanonicalInterpreter.hs +++ b/services/spar/src/Spar/CanonicalInterpreter.hs @@ -71,6 +71,7 @@ import Wire.API.Routes.Version (expandVersionExp) import Wire.API.User.Saml (TTLError) import Wire.BrigAPIAccess (BrigAPIAccess) import Wire.BrigAPIAccess.Rpc (interpretBrigAccess) +import Wire.ClientSubsystem.Error (ClientError, clientErrorToHttpError) import Wire.GalleyAPIAccess (GalleyAPIAccess) import Wire.GalleyAPIAccess.Rpc (interpretGalleyAPIAccessToRpc) import Wire.IdPConfigStore (IdPConfigStore) @@ -100,6 +101,7 @@ type LowerLevelCanonicalEffs = AReqIDStore, VerdictFormatStore, Error ParseException, + Error ClientError, Rpc, Input ScimSubsystemConfig, Error IdPSubsystemError, @@ -156,6 +158,7 @@ runSparToIO ctx = . mapIdPSubsystemErrors . runInputConst (ctx.sparCtxScimSubsystemConfig) . runRpcWithHttp ctx.sparCtxHttpManager ctx.sparCtxRequestId + . iClientException . iParseException . verdictFormatStoreToCassandra . aReqIDStoreToCassandra @@ -172,6 +175,9 @@ runSparToIO ctx = iParseException :: (Member (Error SparError) r) => InterpreterFor (Error ParseException) r iParseException = Polysemy.Error.mapError (httpErrorToSparError . parseExceptionToHttpError) +iClientException :: (Member (Error SparError) r) => InterpreterFor (Error ClientError) r +iClientException = Polysemy.Error.mapError (httpErrorToSparError . clientErrorToHttpError) + runSparToHandler :: Env -> Sem CanonicalEffs a -> Handler a runSparToHandler ctx spar = do liftIO (runSparToIO ctx spar) >>= \case diff --git a/services/spar/src/Spar/Intra/Brig.hs b/services/spar/src/Spar/Intra/Brig.hs index be8a6acf904..fef947f5c28 100644 --- a/services/spar/src/Spar/Intra/Brig.hs +++ b/services/spar/src/Spar/Intra/Brig.hs @@ -48,8 +48,6 @@ module Spar.Intra.Brig where import Bilge -import Brig.Types.Intra -import Brig.Types.User import Control.Monad.Except import Data.ByteString.Conversion import Data.Code as Code diff --git a/services/spar/src/Spar/Intra/BrigApp.hs b/services/spar/src/Spar/Intra/BrigApp.hs index 08bc096ee87..c1729747b3a 100644 --- a/services/spar/src/Spar/Intra/BrigApp.hs +++ b/services/spar/src/Spar/Intra/BrigApp.hs @@ -39,7 +39,6 @@ module Spar.Intra.BrigApp ) where -import Brig.Types.Intra import Control.Lens import Control.Monad.Except import Data.ByteString.Conversion diff --git a/services/spar/src/Spar/Options.hs b/services/spar/src/Spar/Options.hs index 9811cb85390..ee54660c2c6 100644 --- a/services/spar/src/Spar/Options.hs +++ b/services/spar/src/Spar/Options.hs @@ -50,7 +50,7 @@ data Opts = Opts maxttlAuthresp :: !(TTL "authresp"), -- | The maximum number of SCIM tokens that we will allow teams to have. maxScimTokens :: !Int, - -- | The maximum size of rich info. Should be in sync with 'Brig.Types.richInfoLimit'. + -- | The maximum size of rich info. richInfoLimit :: !Int, -- | Wire/AWS specific; optional; used to discover Cassandra instance -- IPs using describe-instances. diff --git a/services/spar/src/Spar/Run.hs b/services/spar/src/Spar/Run.hs index d14e1842b1d..36482a10abf 100644 --- a/services/spar/src/Spar/Run.hs +++ b/services/spar/src/Spar/Run.hs @@ -42,7 +42,6 @@ import Imports import Network.URI import Network.Wai (Application) import qualified Network.Wai as Wai -import qualified Network.Wai.Handler.Warp as Warp import qualified Network.Wai.Middleware.Gunzip as GZip import Network.Wai.Utilities.Server import qualified Network.Wai.Utilities.Server as WU @@ -54,7 +53,6 @@ import Spar.Data.Instances () import Spar.Options as Opt import Spar.Orphans () import System.Logger (Logger) -import qualified System.Logger as Log import qualified System.Logger.Extended as Log import qualified URI.ByteString as URI import Util.Options @@ -78,16 +76,13 @@ initCassandra opts lgr = ---------------------------------------------------------------------- -- servant / wai / warp --- | FUTUREWORK: figure out how to call 'Network.Wai.Utilities.Server.newSettings' here. For once, --- this would create the "Listening on..." log message there, but it may also have other benefits. runServer :: Opts -> IO () runServer sparCtxOpts = do - let settings = Warp.defaultSettings & Warp.setHost (fromString shost) . Warp.setPort sport - shost :: String = sparCtxOpts ^. to saml . SAML.cfgSPHost + let shost :: String = sparCtxOpts ^. to saml . SAML.cfgSPHost sport :: Int = sparCtxOpts ^. to saml . SAML.cfgSPPort (wrappedApp, ctxOpts) <- mkApp sparCtxOpts let logger = sparCtxLogger ctxOpts - Log.info logger . Log.msg $ "Listening on " <> shost <> ":" <> show sport + let settings = newSettings $ defaultServer shost (fromIntegral sport) logger WU.runSettingsWithShutdown settings wrappedApp Nothing mkApp :: Opts -> IO (Application, Env) diff --git a/services/spar/src/Spar/Sem/BrigAccess.hs b/services/spar/src/Spar/Sem/BrigAccess.hs index 27629e7a926..b8765965f32 100644 --- a/services/spar/src/Spar/Sem/BrigAccess.hs +++ b/services/spar/src/Spar/Sem/BrigAccess.hs @@ -45,7 +45,6 @@ module Spar.Sem.BrigAccess ) where -import Brig.Types.Intra import Data.Code as Code import Data.Handle (Handle) import Data.HavePendingInvitations diff --git a/services/spar/test-integration/Util/Email.hs b/services/spar/test-integration/Util/Email.hs index b9bf4761eed..0a05b2f0245 100644 --- a/services/spar/test-integration/Util/Email.hs +++ b/services/spar/test-integration/Util/Email.hs @@ -23,7 +23,6 @@ module Util.Email where import Bilge hiding (accept, timeout) import Bilge.Assert -import Brig.Types.Activation import Control.Lens (view) import Control.Monad.Catch (MonadCatch) import Data.ByteString.Conversion diff --git a/services/spar/test/Test/Spar/Scim/UserSpec.hs b/services/spar/test/Test/Spar/Scim/UserSpec.hs index a67ff176890..f28ed144925 100644 --- a/services/spar/test/Test/Spar/Scim/UserSpec.hs +++ b/services/spar/test/Test/Spar/Scim/UserSpec.hs @@ -18,7 +18,6 @@ module Test.Spar.Scim.UserSpec where import Arbitrary () -import Brig.Types.Intra import Control.Monad.Except (runExceptT) import Data.Handle (parseHandle) import Data.HavePendingInvitations diff --git a/tools/db/mls-users/src/MlsUsers/Lib.hs b/tools/db/mls-users/src/MlsUsers/Lib.hs index e5e5acfffb5..58a612d6b46 100644 --- a/tools/db/mls-users/src/MlsUsers/Lib.hs +++ b/tools/db/mls-users/src/MlsUsers/Lib.hs @@ -42,7 +42,7 @@ getUserResult logger brigClient ur = do andM [ pure ur.activated, pure $ ur.status == Just Active, - pure $ Set.notMember BaseProtocolMLSTag ur.supportedProtocols, + pure $ Set.notMember BaseProtocolMLSTag (fold ur.supportedProtocols), -- check that the user has at least one active client do now <- getCurrentTime diff --git a/tools/db/mls-users/src/MlsUsers/Types.hs b/tools/db/mls-users/src/MlsUsers/Types.hs index 49f219afd55..6f2fee89eb1 100644 --- a/tools/db/mls-users/src/MlsUsers/Types.hs +++ b/tools/db/mls-users/src/MlsUsers/Types.hs @@ -36,7 +36,7 @@ data UserRow = UserRow { userId :: UserId, activated :: Bool, status :: Maybe AccountStatus, - supportedProtocols :: Set BaseProtocolTag + supportedProtocols :: Maybe (Set BaseProtocolTag) } deriving (Generic) diff --git a/tools/rex/.ormolu b/tools/rex/.ormolu deleted file mode 120000 index 157b212d7cd..00000000000 --- a/tools/rex/.ormolu +++ /dev/null @@ -1 +0,0 @@ -../../.ormolu \ No newline at end of file diff --git a/tools/rex/LICENSE b/tools/rex/LICENSE deleted file mode 100644 index dba13ed2ddf..00000000000 --- a/tools/rex/LICENSE +++ /dev/null @@ -1,661 +0,0 @@ - GNU AFFERO GENERAL PUBLIC LICENSE - Version 3, 19 November 2007 - - Copyright (C) 2007 Free Software Foundation, Inc. - Everyone is permitted to copy and distribute verbatim copies - of this license document, but changing it is not allowed. - - Preamble - - The GNU Affero General Public License is a free, copyleft license for -software and other kinds of works, specifically designed to ensure -cooperation with the community in the case of network server software. - - The licenses for most software and other practical works are designed -to take away your freedom to share and change the works. By contrast, -our General Public Licenses are intended to guarantee your freedom to -share and change all versions of a program--to make sure it remains free -software for all its users. - - When we speak of free software, we are referring to freedom, not -price. Our General Public Licenses are designed to make sure that you -have the freedom to distribute copies of free software (and charge for -them if you wish), that you receive source code or can get it if you -want it, that you can change the software or use pieces of it in new -free programs, and that you know you can do these things. - - Developers that use our General Public Licenses protect your rights -with two steps: (1) assert copyright on the software, and (2) offer -you this License which gives you legal permission to copy, distribute -and/or modify the software. - - A secondary benefit of defending all users' freedom is that -improvements made in alternate versions of the program, if they -receive widespread use, become available for other developers to -incorporate. Many developers of free software are heartened and -encouraged by the resulting cooperation. However, in the case of -software used on network servers, this result may fail to come about. -The GNU General Public License permits making a modified version and -letting the public access it on a server without ever releasing its -source code to the public. - - The GNU Affero General Public License is designed specifically to -ensure that, in such cases, the modified source code becomes available -to the community. It requires the operator of a network server to -provide the source code of the modified version running there to the -users of that server. Therefore, public use of a modified version, on -a publicly accessible server, gives the public access to the source -code of the modified version. - - An older license, called the Affero General Public License and -published by Affero, was designed to accomplish similar goals. This is -a different license, not a version of the Affero GPL, but Affero has -released a new version of the Affero GPL which permits relicensing under -this license. - - The precise terms and conditions for copying, distribution and -modification follow. - - TERMS AND CONDITIONS - - 0. Definitions. - - "This License" refers to version 3 of the GNU Affero General Public License. - - "Copyright" also means copyright-like laws that apply to other kinds of -works, such as semiconductor masks. - - "The Program" refers to any copyrightable work licensed under this -License. Each licensee is addressed as "you". "Licensees" and -"recipients" may be individuals or organizations. - - To "modify" a work means to copy from or adapt all or part of the work -in a fashion requiring copyright permission, other than the making of an -exact copy. The resulting work is called a "modified version" of the -earlier work or a work "based on" the earlier work. - - A "covered work" means either the unmodified Program or a work based -on the Program. - - To "propagate" a work means to do anything with it that, without -permission, would make you directly or secondarily liable for -infringement under applicable copyright law, except executing it on a -computer or modifying a private copy. Propagation includes copying, -distribution (with or without modification), making available to the -public, and in some countries other activities as well. - - To "convey" a work means any kind of propagation that enables other -parties to make or receive copies. Mere interaction with a user through -a computer network, with no transfer of a copy, is not conveying. - - An interactive user interface displays "Appropriate Legal Notices" -to the extent that it includes a convenient and prominently visible -feature that (1) displays an appropriate copyright notice, and (2) -tells the user that there is no warranty for the work (except to the -extent that warranties are provided), that licensees may convey the -work under this License, and how to view a copy of this License. If -the interface presents a list of user commands or options, such as a -menu, a prominent item in the list meets this criterion. - - 1. Source Code. - - The "source code" for a work means the preferred form of the work -for making modifications to it. "Object code" means any non-source -form of a work. - - A "Standard Interface" means an interface that either is an official -standard defined by a recognized standards body, or, in the case of -interfaces specified for a particular programming language, one that -is widely used among developers working in that language. - - The "System Libraries" of an executable work include anything, other -than the work as a whole, that (a) is included in the normal form of -packaging a Major Component, but which is not part of that Major -Component, and (b) serves only to enable use of the work with that -Major Component, or to implement a Standard Interface for which an -implementation is available to the public in source code form. A -"Major Component", in this context, means a major essential component -(kernel, window system, and so on) of the specific operating system -(if any) on which the executable work runs, or a compiler used to -produce the work, or an object code interpreter used to run it. - - The "Corresponding Source" for a work in object code form means all -the source code needed to generate, install, and (for an executable -work) run the object code and to modify the work, including scripts to -control those activities. However, it does not include the work's -System Libraries, or general-purpose tools or generally available free -programs which are used unmodified in performing those activities but -which are not part of the work. For example, Corresponding Source -includes interface definition files associated with source files for -the work, and the source code for shared libraries and dynamically -linked subprograms that the work is specifically designed to require, -such as by intimate data communication or control flow between those -subprograms and other parts of the work. - - The Corresponding Source need not include anything that users -can regenerate automatically from other parts of the Corresponding -Source. - - The Corresponding Source for a work in source code form is that -same work. - - 2. Basic Permissions. - - All rights granted under this License are granted for the term of -copyright on the Program, and are irrevocable provided the stated -conditions are met. This License explicitly affirms your unlimited -permission to run the unmodified Program. The output from running a -covered work is covered by this License only if the output, given its -content, constitutes a covered work. This License acknowledges your -rights of fair use or other equivalent, as provided by copyright law. - - You may make, run and propagate covered works that you do not -convey, without conditions so long as your license otherwise remains -in force. You may convey covered works to others for the sole purpose -of having them make modifications exclusively for you, or provide you -with facilities for running those works, provided that you comply with -the terms of this License in conveying all material for which you do -not control copyright. Those thus making or running the covered works -for you must do so exclusively on your behalf, under your direction -and control, on terms that prohibit them from making any copies of -your copyrighted material outside their relationship with you. - - Conveying under any other circumstances is permitted solely under -the conditions stated below. Sublicensing is not allowed; section 10 -makes it unnecessary. - - 3. Protecting Users' Legal Rights From Anti-Circumvention Law. - - No covered work shall be deemed part of an effective technological -measure under any applicable law fulfilling obligations under article -11 of the WIPO copyright treaty adopted on 20 December 1996, or -similar laws prohibiting or restricting circumvention of such -measures. - - When you convey a covered work, you waive any legal power to forbid -circumvention of technological measures to the extent such circumvention -is effected by exercising rights under this License with respect to -the covered work, and you disclaim any intention to limit operation or -modification of the work as a means of enforcing, against the work's -users, your or third parties' legal rights to forbid circumvention of -technological measures. - - 4. Conveying Verbatim Copies. - - You may convey verbatim copies of the Program's source code as you -receive it, in any medium, provided that you conspicuously and -appropriately publish on each copy an appropriate copyright notice; -keep intact all notices stating that this License and any -non-permissive terms added in accord with section 7 apply to the code; -keep intact all notices of the absence of any warranty; and give all -recipients a copy of this License along with the Program. - - You may charge any price or no price for each copy that you convey, -and you may offer support or warranty protection for a fee. - - 5. Conveying Modified Source Versions. - - You may convey a work based on the Program, or the modifications to -produce it from the Program, in the form of source code under the -terms of section 4, provided that you also meet all of these conditions: - - a) The work must carry prominent notices stating that you modified - it, and giving a relevant date. - - b) The work must carry prominent notices stating that it is - released under this License and any conditions added under section - 7. This requirement modifies the requirement in section 4 to - "keep intact all notices". - - c) You must license the entire work, as a whole, under this - License to anyone who comes into possession of a copy. This - License will therefore apply, along with any applicable section 7 - additional terms, to the whole of the work, and all its parts, - regardless of how they are packaged. This License gives no - permission to license the work in any other way, but it does not - invalidate such permission if you have separately received it. - - d) If the work has interactive user interfaces, each must display - Appropriate Legal Notices; however, if the Program has interactive - interfaces that do not display Appropriate Legal Notices, your - work need not make them do so. - - A compilation of a covered work with other separate and independent -works, which are not by their nature extensions of the covered work, -and which are not combined with it such as to form a larger program, -in or on a volume of a storage or distribution medium, is called an -"aggregate" if the compilation and its resulting copyright are not -used to limit the access or legal rights of the compilation's users -beyond what the individual works permit. Inclusion of a covered work -in an aggregate does not cause this License to apply to the other -parts of the aggregate. - - 6. Conveying Non-Source Forms. - - You may convey a covered work in object code form under the terms -of sections 4 and 5, provided that you also convey the -machine-readable Corresponding Source under the terms of this License, -in one of these ways: - - a) Convey the object code in, or embodied in, a physical product - (including a physical distribution medium), accompanied by the - Corresponding Source fixed on a durable physical medium - customarily used for software interchange. - - b) Convey the object code in, or embodied in, a physical product - (including a physical distribution medium), accompanied by a - written offer, valid for at least three years and valid for as - long as you offer spare parts or customer support for that product - model, to give anyone who possesses the object code either (1) a - copy of the Corresponding Source for all the software in the - product that is covered by this License, on a durable physical - medium customarily used for software interchange, for a price no - more than your reasonable cost of physically performing this - conveying of source, or (2) access to copy the - Corresponding Source from a network server at no charge. - - c) Convey individual copies of the object code with a copy of the - written offer to provide the Corresponding Source. This - alternative is allowed only occasionally and noncommercially, and - only if you received the object code with such an offer, in accord - with subsection 6b. - - d) Convey the object code by offering access from a designated - place (gratis or for a charge), and offer equivalent access to the - Corresponding Source in the same way through the same place at no - further charge. You need not require recipients to copy the - Corresponding Source along with the object code. If the place to - copy the object code is a network server, the Corresponding Source - may be on a different server (operated by you or a third party) - that supports equivalent copying facilities, provided you maintain - clear directions next to the object code saying where to find the - Corresponding Source. Regardless of what server hosts the - Corresponding Source, you remain obligated to ensure that it is - available for as long as needed to satisfy these requirements. - - e) Convey the object code using peer-to-peer transmission, provided - you inform other peers where the object code and Corresponding - Source of the work are being offered to the general public at no - charge under subsection 6d. - - A separable portion of the object code, whose source code is excluded -from the Corresponding Source as a System Library, need not be -included in conveying the object code work. - - A "User Product" is either (1) a "consumer product", which means any -tangible personal property which is normally used for personal, family, -or household purposes, or (2) anything designed or sold for incorporation -into a dwelling. In determining whether a product is a consumer product, -doubtful cases shall be resolved in favor of coverage. For a particular -product received by a particular user, "normally used" refers to a -typical or common use of that class of product, regardless of the status -of the particular user or of the way in which the particular user -actually uses, or expects or is expected to use, the product. A product -is a consumer product regardless of whether the product has substantial -commercial, industrial or non-consumer uses, unless such uses represent -the only significant mode of use of the product. - - "Installation Information" for a User Product means any methods, -procedures, authorization keys, or other information required to install -and execute modified versions of a covered work in that User Product from -a modified version of its Corresponding Source. The information must -suffice to ensure that the continued functioning of the modified object -code is in no case prevented or interfered with solely because -modification has been made. - - If you convey an object code work under this section in, or with, or -specifically for use in, a User Product, and the conveying occurs as -part of a transaction in which the right of possession and use of the -User Product is transferred to the recipient in perpetuity or for a -fixed term (regardless of how the transaction is characterized), the -Corresponding Source conveyed under this section must be accompanied -by the Installation Information. But this requirement does not apply -if neither you nor any third party retains the ability to install -modified object code on the User Product (for example, the work has -been installed in ROM). - - The requirement to provide Installation Information does not include a -requirement to continue to provide support service, warranty, or updates -for a work that has been modified or installed by the recipient, or for -the User Product in which it has been modified or installed. Access to a -network may be denied when the modification itself materially and -adversely affects the operation of the network or violates the rules and -protocols for communication across the network. - - Corresponding Source conveyed, and Installation Information provided, -in accord with this section must be in a format that is publicly -documented (and with an implementation available to the public in -source code form), and must require no special password or key for -unpacking, reading or copying. - - 7. Additional Terms. - - "Additional permissions" are terms that supplement the terms of this -License by making exceptions from one or more of its conditions. -Additional permissions that are applicable to the entire Program shall -be treated as though they were included in this License, to the extent -that they are valid under applicable law. If additional permissions -apply only to part of the Program, that part may be used separately -under those permissions, but the entire Program remains governed by -this License without regard to the additional permissions. - - When you convey a copy of a covered work, you may at your option -remove any additional permissions from that copy, or from any part of -it. (Additional permissions may be written to require their own -removal in certain cases when you modify the work.) You may place -additional permissions on material, added by you to a covered work, -for which you have or can give appropriate copyright permission. - - Notwithstanding any other provision of this License, for material you -add to a covered work, you may (if authorized by the copyright holders of -that material) supplement the terms of this License with terms: - - a) Disclaiming warranty or limiting liability differently from the - terms of sections 15 and 16 of this License; or - - b) Requiring preservation of specified reasonable legal notices or - author attributions in that material or in the Appropriate Legal - Notices displayed by works containing it; or - - c) Prohibiting misrepresentation of the origin of that material, or - requiring that modified versions of such material be marked in - reasonable ways as different from the original version; or - - d) Limiting the use for publicity purposes of names of licensors or - authors of the material; or - - e) Declining to grant rights under trademark law for use of some - trade names, trademarks, or service marks; or - - f) Requiring indemnification of licensors and authors of that - material by anyone who conveys the material (or modified versions of - it) with contractual assumptions of liability to the recipient, for - any liability that these contractual assumptions directly impose on - those licensors and authors. - - All other non-permissive additional terms are considered "further -restrictions" within the meaning of section 10. If the Program as you -received it, or any part of it, contains a notice stating that it is -governed by this License along with a term that is a further -restriction, you may remove that term. If a license document contains -a further restriction but permits relicensing or conveying under this -License, you may add to a covered work material governed by the terms -of that license document, provided that the further restriction does -not survive such relicensing or conveying. - - If you add terms to a covered work in accord with this section, you -must place, in the relevant source files, a statement of the -additional terms that apply to those files, or a notice indicating -where to find the applicable terms. - - Additional terms, permissive or non-permissive, may be stated in the -form of a separately written license, or stated as exceptions; -the above requirements apply either way. - - 8. Termination. - - You may not propagate or modify a covered work except as expressly -provided under this License. Any attempt otherwise to propagate or -modify it is void, and will automatically terminate your rights under -this License (including any patent licenses granted under the third -paragraph of section 11). - - However, if you cease all violation of this License, then your -license from a particular copyright holder is reinstated (a) -provisionally, unless and until the copyright holder explicitly and -finally terminates your license, and (b) permanently, if the copyright -holder fails to notify you of the violation by some reasonable means -prior to 60 days after the cessation. - - Moreover, your license from a particular copyright holder is -reinstated permanently if the copyright holder notifies you of the -violation by some reasonable means, this is the first time you have -received notice of violation of this License (for any work) from that -copyright holder, and you cure the violation prior to 30 days after -your receipt of the notice. - - Termination of your rights under this section does not terminate the -licenses of parties who have received copies or rights from you under -this License. If your rights have been terminated and not permanently -reinstated, you do not qualify to receive new licenses for the same -material under section 10. - - 9. Acceptance Not Required for Having Copies. - - You are not required to accept this License in order to receive or -run a copy of the Program. Ancillary propagation of a covered work -occurring solely as a consequence of using peer-to-peer transmission -to receive a copy likewise does not require acceptance. However, -nothing other than this License grants you permission to propagate or -modify any covered work. These actions infringe copyright if you do -not accept this License. Therefore, by modifying or propagating a -covered work, you indicate your acceptance of this License to do so. - - 10. Automatic Licensing of Downstream Recipients. - - Each time you convey a covered work, the recipient automatically -receives a license from the original licensors, to run, modify and -propagate that work, subject to this License. You are not responsible -for enforcing compliance by third parties with this License. - - An "entity transaction" is a transaction transferring control of an -organization, or substantially all assets of one, or subdividing an -organization, or merging organizations. If propagation of a covered -work results from an entity transaction, each party to that -transaction who receives a copy of the work also receives whatever -licenses to the work the party's predecessor in interest had or could -give under the previous paragraph, plus a right to possession of the -Corresponding Source of the work from the predecessor in interest, if -the predecessor has it or can get it with reasonable efforts. - - You may not impose any further restrictions on the exercise of the -rights granted or affirmed under this License. For example, you may -not impose a license fee, royalty, or other charge for exercise of -rights granted under this License, and you may not initiate litigation -(including a cross-claim or counterclaim in a lawsuit) alleging that -any patent claim is infringed by making, using, selling, offering for -sale, or importing the Program or any portion of it. - - 11. Patents. - - A "contributor" is a copyright holder who authorizes use under this -License of the Program or a work on which the Program is based. The -work thus licensed is called the contributor's "contributor version". - - A contributor's "essential patent claims" are all patent claims -owned or controlled by the contributor, whether already acquired or -hereafter acquired, that would be infringed by some manner, permitted -by this License, of making, using, or selling its contributor version, -but do not include claims that would be infringed only as a -consequence of further modification of the contributor version. For -purposes of this definition, "control" includes the right to grant -patent sublicenses in a manner consistent with the requirements of -this License. - - Each contributor grants you a non-exclusive, worldwide, royalty-free -patent license under the contributor's essential patent claims, to -make, use, sell, offer for sale, import and otherwise run, modify and -propagate the contents of its contributor version. - - In the following three paragraphs, a "patent license" is any express -agreement or commitment, however denominated, not to enforce a patent -(such as an express permission to practice a patent or covenant not to -sue for patent infringement). To "grant" such a patent license to a -party means to make such an agreement or commitment not to enforce a -patent against the party. - - If you convey a covered work, knowingly relying on a patent license, -and the Corresponding Source of the work is not available for anyone -to copy, free of charge and under the terms of this License, through a -publicly available network server or other readily accessible means, -then you must either (1) cause the Corresponding Source to be so -available, or (2) arrange to deprive yourself of the benefit of the -patent license for this particular work, or (3) arrange, in a manner -consistent with the requirements of this License, to extend the patent -license to downstream recipients. "Knowingly relying" means you have -actual knowledge that, but for the patent license, your conveying the -covered work in a country, or your recipient's use of the covered work -in a country, would infringe one or more identifiable patents in that -country that you have reason to believe are valid. - - If, pursuant to or in connection with a single transaction or -arrangement, you convey, or propagate by procuring conveyance of, a -covered work, and grant a patent license to some of the parties -receiving the covered work authorizing them to use, propagate, modify -or convey a specific copy of the covered work, then the patent license -you grant is automatically extended to all recipients of the covered -work and works based on it. - - A patent license is "discriminatory" if it does not include within -the scope of its coverage, prohibits the exercise of, or is -conditioned on the non-exercise of one or more of the rights that are -specifically granted under this License. You may not convey a covered -work if you are a party to an arrangement with a third party that is -in the business of distributing software, under which you make payment -to the third party based on the extent of your activity of conveying -the work, and under which the third party grants, to any of the -parties who would receive the covered work from you, a discriminatory -patent license (a) in connection with copies of the covered work -conveyed by you (or copies made from those copies), or (b) primarily -for and in connection with specific products or compilations that -contain the covered work, unless you entered into that arrangement, -or that patent license was granted, prior to 28 March 2007. - - Nothing in this License shall be construed as excluding or limiting -any implied license or other defenses to infringement that may -otherwise be available to you under applicable patent law. - - 12. No Surrender of Others' Freedom. - - If conditions are imposed on you (whether by court order, agreement or -otherwise) that contradict the conditions of this License, they do not -excuse you from the conditions of this License. If you cannot convey a -covered work so as to satisfy simultaneously your obligations under this -License and any other pertinent obligations, then as a consequence you may -not convey it at all. For example, if you agree to terms that obligate you -to collect a royalty for further conveying from those to whom you convey -the Program, the only way you could satisfy both those terms and this -License would be to refrain entirely from conveying the Program. - - 13. Remote Network Interaction; Use with the GNU General Public License. - - Notwithstanding any other provision of this License, if you modify the -Program, your modified version must prominently offer all users -interacting with it remotely through a computer network (if your version -supports such interaction) an opportunity to receive the Corresponding -Source of your version by providing access to the Corresponding Source -from a network server at no charge, through some standard or customary -means of facilitating copying of software. This Corresponding Source -shall include the Corresponding Source for any work covered by version 3 -of the GNU General Public License that is incorporated pursuant to the -following paragraph. - - Notwithstanding any other provision of this License, you have -permission to link or combine any covered work with a work licensed -under version 3 of the GNU General Public License into a single -combined work, and to convey the resulting work. The terms of this -License will continue to apply to the part which is the covered work, -but the work with which it is combined will remain governed by version -3 of the GNU General Public License. - - 14. Revised Versions of this License. - - The Free Software Foundation may publish revised and/or new versions of -the GNU Affero General Public License from time to time. Such new versions -will be similar in spirit to the present version, but may differ in detail to -address new problems or concerns. - - Each version is given a distinguishing version number. If the -Program specifies that a certain numbered version of the GNU Affero General -Public License "or any later version" applies to it, you have the -option of following the terms and conditions either of that numbered -version or of any later version published by the Free Software -Foundation. If the Program does not specify a version number of the -GNU Affero General Public License, you may choose any version ever published -by the Free Software Foundation. - - If the Program specifies that a proxy can decide which future -versions of the GNU Affero General Public License can be used, that proxy's -public statement of acceptance of a version permanently authorizes you -to choose that version for the Program. - - Later license versions may give you additional or different -permissions. However, no additional obligations are imposed on any -author or copyright holder as a result of your choosing to follow a -later version. - - 15. Disclaimer of Warranty. - - THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY -APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT -HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY -OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, -THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM -IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF -ALL NECESSARY SERVICING, REPAIR OR CORRECTION. - - 16. Limitation of Liability. - - IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING -WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS -THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY -GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE -USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF -DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD -PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), -EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF -SUCH DAMAGES. - - 17. Interpretation of Sections 15 and 16. - - If the disclaimer of warranty and limitation of liability provided -above cannot be given local legal effect according to their terms, -reviewing courts shall apply local law that most closely approximates -an absolute waiver of all civil liability in connection with the -Program, unless a warranty or assumption of liability accompanies a -copy of the Program in return for a fee. - - END OF TERMS AND CONDITIONS - - How to Apply These Terms to Your New Programs - - If you develop a new program, and you want it to be of the greatest -possible use to the public, the best way to achieve this is to make it -free software which everyone can redistribute and change under these terms. - - To do so, attach the following notices to the program. It is safest -to attach them to the start of each source file to most effectively -state the exclusion of warranty; and each file should have at least -the "copyright" line and a pointer to where the full notice is found. - - - Copyright (C) - - This program is free software: you can redistribute it and/or modify - it under the terms of the GNU Affero General Public License as published by - the Free Software Foundation, either version 3 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU Affero General Public License for more details. - - You should have received a copy of the GNU Affero General Public License - along with this program. If not, see . - -Also add information on how to contact you by electronic and paper mail. - - If your software can interact with users remotely through a computer -network, you should also make sure that it provides a way for users to -get its source. For example, if your program is a web application, its -interface could display a "Source" link that leads users to an archive -of the code. There are many ways you could offer source, and different -solutions will be better for different programs; see section 13 for the -specific requirements. - - You should also get your employer (if you work as a programmer) or school, -if any, to sign a "copyright disclaimer" for the program, if necessary. -For more information on this, and how to apply and follow the GNU AGPL, see -. diff --git a/tools/rex/Main.hs b/tools/rex/Main.hs deleted file mode 100644 index 34401a8037e..00000000000 --- a/tools/rex/Main.hs +++ /dev/null @@ -1,376 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} -{-# OPTIONS_GHC -Wno-incomplete-patterns #-} -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} - -{-# HLINT ignore "Use shutdown" #-} - --- 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 Main (main) where - -import Control.Concurrent.Async -import Control.Monad.Catch -import Control.Monad.Trans -import qualified Data.Attoparsec.ByteString.Char8 as Parser -import Data.Bifunctor -import Data.Bitraversable -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as ByteString -import Data.Foldable -import Data.Functor (($>)) -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap -import Data.IP -import Data.Maybe -import Data.Text (Text) -import qualified Data.Text as Text -import Data.Text.Encoding (decodeUtf8, encodeUtf8) -import qualified Data.Text.IO as Text -import qualified Data.Text.Read as Text -import Data.Traversable -import Data.Word -import Network.DNS hiding (header) -import Network.HTTP.Types -import Network.Socket -import Network.Socket.ByteString -import Network.Wai -import Network.Wai.Handler.Warp -import Options.Applicative -import System.Clock -import qualified System.Logger as Log -import System.Logger.Message (msg, val) -import System.Metrics.Prometheus.Concurrent.RegistryT -- this library sucks -import System.Metrics.Prometheus.Encode.Text -import qualified System.Metrics.Prometheus.Metric.Counter as Counter -import System.Metrics.Prometheus.Metric.Gauge (Gauge) -import qualified System.Metrics.Prometheus.Metric.Gauge as Gauge -import qualified System.Metrics.Prometheus.Metric.Histogram as Histo -import System.Metrics.Prometheus.MetricId -import System.Metrics.Prometheus.Registry (RegistrySample) -import System.Timeout (timeout) - -data Opts = Opts - { optExposePort :: !Word16, - optRestundUDPStatusPort :: !Word16, - optRestundUDPListenPort :: !Word16, - optTier :: !Text, - optZone :: !ByteString - } - deriving (Show) - -parseOpts :: ParserInfo Opts -parseOpts = info (helper <*> parser) desc - where - desc = header "restund Metrics Exporter" <> fullDesc - - parser = - Opts - <$> option - auto - ( short 'p' - <> long "port" - <> metavar "PORT" - <> help "Expose metrics on this port" - <> value 9200 - <> showDefault - ) - <*> option - auto - ( long "restund-udp-status-port" - <> metavar "PORT" - <> help "UDP Status Port" - <> value 33000 - <> showDefault - ) - <*> option - auto - ( long "restund-udp-listen-port" - <> metavar "PORT" - <> help "UDP Listen Port (aka STUN port aka Management port)" - <> value 3478 - <> showDefault - ) - <*> option - txt - ( long "tier" - <> help "Deployment Tier" - ) - <*> option - bs - ( long "zone" - <> value "wire.com" - <> help "Deployment Zone" - <> showDefault - ) - - txt = Text.pack <$> str - bs = ByteString.pack <$> str - -main :: IO () -main = withSocketsDo $ do - opts <- execParser parseOpts - lgr <- Log.new Log.defSettings - rlv <- makeResolvSeed defaultResolvConf - - let labels = - fromList - [ ("tier", optTier opts), - ("app", "restund"), - ("srv", "rex") - ] - dns = - mconcat - [ "_turn._tcp.", - encodeUtf8 (optTier opts), - ".", - optZone opts, - "." - ] - - runRegistryT $ do - known <- knownStats labels - unknown <- registerCounter "UNKNOWN" labels - rxq <- registerGauge "recv_queue" labels - txq <- registerGauge "send_queue" labels - drp <- registerGauge "packet_drops" labels - peers <- registerGauge "known_peers" labels - rpeers <- registerGauge "reachable_peers" labels - - timing <- - registerHistogram - "scrape_timing_ns" - labels - [ 500000, -- .5 ms - 1000000, -- 1 ms - 5000000 -- 5 ms - ] - - sampleIO <- sample - - liftIO . serveIO opts $ do - Log.info lgr $ msg (val "Scraping ...") - start <- getTime Monotonic - - (!_, !_, !_) <- - runConcurrently $ - (,,) - <$> Concurrently - ( do - sockStats <- getSocketStats (optRestundUDPListenPort opts) - Log.trace lgr $ msg (show sockStats) - for_ sockStats $ \SocketStats {..} -> do - Gauge.set (fromIntegral rxQueue) rxq - Gauge.set (fromIntegral txQueue) txq - Gauge.set (fromIntegral drops) drp - ) - <*> Concurrently - ( withSocket $ \ssock -> do - appStats <- getAppStats lgr (statusAddr opts) ssock - Log.trace lgr $ msg (show appStats) - for_ appStats $ \(k, v) -> - maybe - (Counter.inc unknown) - (Gauge.set v) - (HashMap.lookup k known) - ) - <*> Concurrently - ( do - peerStats <- getPeerConnectivityStats lgr rlv dns - Log.trace lgr $ msg (show peerStats) - Gauge.set (fromIntegral (peersDiscovered peerStats)) peers - Gauge.set (fromIntegral (peersReachable peerStats)) rpeers - ) - - !took <- toNanoSecs . (`diffTimeSpec` start) <$> getTime Monotonic - Log.info lgr $ msg ("Done scaping in " <> show took <> "ns") - Histo.observe (fromIntegral took) timing - - sampleIO - where - localhost = tupleToHostAddress (127, 0, 0, 1) - - statusAddr Opts {optRestundUDPStatusPort = p} = - SockAddrInet (fromIntegral p) localhost - - withSocket = - bracket - (socket AF_INET Datagram defaultProtocol) - close - -data SocketStats = SocketStats - { lPort :: !Word16, - rxQueue :: Word64, - txQueue :: Word64, - drops :: Word64 - } - deriving (Show) - --- nb. that this requires restund and rex to run in the same network namespace --- (ie. either both run with --net=host, or both run in the same pod) -getSocketStats :: Word16 -> IO (Maybe SocketStats) -getSocketStats port = do - pnu <- Text.readFile "/proc/net/udp" - pure - . find ((== port) . lPort) - . map (mk . Text.words) - . drop 1 - $ Text.lines pnu - where - -- sl local_address rem_address st tx_queue:rx_queue tr:tm->when retrnsmt uid timeout inode ref pointer drops - mk [_, la, _, _, qs, _, _, _, _, _, _, _, ds] = - let p = hex . snd . Text.breakOnEnd ":" $ la - (rx, tx) = bimap hex hex . Text.breakOn ":" $ qs - d = either (const 0) fst . Text.decimal $ ds - in SocketStats p rx tx d - - hex :: (Integral a, Bounded a) => Text -> a - hex = either (const minBound) fst . Text.hexadecimal - -getAppStats :: Log.Logger -> SockAddr -> Socket -> IO [(Text, Double)] -getAppStats lgr addr sock = fmap mconcat . for cmds $ \cmd -> do - sendAllTo sock cmd addr - (reply, _) <- recvFrom sock 1024 - Log.trace lgr $ msg (ByteString.intercalate "\n" (ByteString.lines reply)) - pure $ - parseAppStats reply - where - cmds = ["stat", "turnstats", "turnreply", "tcpstats", "authstats"] - -parseAppStats :: ByteString -> [(Text, Double)] -parseAppStats = - mapMaybe - ( bitraverse Just id - . bimap - decodeUtf8 - ( either (const Nothing) Just - . Parser.parseOnly - (Parser.skipWhile Parser.isSpace *> Parser.double) - ) - . ByteString.break (== ' ') - ) - . ByteString.lines - -knownStats :: Labels -> RegistryT IO (HashMap Text Gauge) -knownStats def = - HashMap.fromList - <$> traverse - (mk def) - [ -- stat - "binding_req", - "allocate_req", - "refresh_req", - "createperm_req", - "chanbind_req", - "unknown_req", - -- turnstats - "allocs_cur", - "allocs_tot", - "bytes_tx", - "bytes_rx", - "bytes_tot", - -- turnreply - "scode_400", - "scode_420", - "scode_437", - "scode_440", - "scode_441", - "scode_442", - "scode_443", - "scode_500", - "scode_508", - -- tcpstats - "tcp_connections", - "tls_connections", - -- authstats - "auth_req_mi", - "auth_req_no_mi" - ] - where - mk :: Labels -> Name -> RegistryT IO (Text, Gauge) - mk labels name = do - g <- registerGauge name labels - pure (unName name, g) - -data PeerConnectivityStats = PeerConnectivityStats - { peersDiscovered :: Int, - peersReachable :: Int - } - deriving (Show) - -getPeerConnectivityStats :: - Log.Logger -> - ResolvSeed -> - Domain -> - IO PeerConnectivityStats -getPeerConnectivityStats lgr seed dom = do - addrs <- disco - reach <- length . catMaybes <$> mapConcurrently shakehands addrs - pure - PeerConnectivityStats - { peersDiscovered = length addrs, - peersReachable = reach - } - where - disco = withResolver seed $ \rlv -> - lookupSRV rlv dom - >>= either - (const $ pure []) - ( \xs -> - concatMap mkAddr . zip xs - <$> traverse (lookupA rlv . _4) xs - ) - - shakehands (addr, port) = - handleIOError (\e -> logUnreachable addr port e $> Nothing) - . timeout (5 * 1000000) - $ bracket - (socket AF_INET Stream defaultProtocol) - close - (`connect` SockAddrInet (fromIntegral port) (toHostAddress addr)) - - mkAddr (_, Left _) = mempty - mkAddr (rr, Right ips) = (,_3 rr) <$> ips - - _4 (_, _, _, x) = x - _3 (_, _, x, _) = x - - logUnreachable addr port e = - Log.warn lgr . msg $ - "Peer " <> show addr <> ":" <> show port <> " unreachable: " <> show e - -serveIO :: (MonadIO m) => Opts -> IO RegistrySample -> m () -serveIO opts runSample = - liftIO $ - runSettings - ( setPort (fromIntegral (optExposePort opts)) - . setHost "127.0.0.1" - $ defaultSettings - ) - (app runSample) - -app :: IO RegistrySample -> Application -app runSample req respond = case pathInfo req of - ("metrics" : _) -> runSample >>= respond . r200 - _ -> respond r404 - where - r200 = responseBuilder status200 hdrs . encodeMetrics - r404 = responseLBS status404 hdrs mempty - hdrs = [(hContentType, "text/plain")] diff --git a/tools/rex/README.md b/tools/rex/README.md deleted file mode 100644 index 99a36f71115..00000000000 --- a/tools/rex/README.md +++ /dev/null @@ -1,11 +0,0 @@ -# Rex - -Restund-exporer: A service scraping metrics from `restund` and exposing them in a format understood by the `prometheus` monitoring system. - -For instance it can show the number of current allocations (ongoing calls): - -``` -curl -s localhost:9200/metrics | grep allocs_cur -# TYPE allocs_cur gauge -allocs_cur{app="restund",srv="rex",tier="staging"} 15.0 -``` diff --git a/tools/rex/default.nix b/tools/rex/default.nix deleted file mode 100644 index 02d05d765d4..00000000000 --- a/tools/rex/default.nix +++ /dev/null @@ -1,56 +0,0 @@ -# WARNING: GENERATED FILE, DO NOT EDIT. -# This file is generated by running hack/bin/generate-local-nix-packages.sh and -# must be regenerated whenever local packages are added or removed, or -# dependencies are added or removed. -{ mkDerivation -, async -, attoparsec -, base -, bytestring -, clock -, dns -, exceptions -, gitignoreSource -, http-types -, iproute -, lib -, mtl -, network -, optparse-applicative -, prometheus -, text -, tinylog -, unordered-containers -, wai -, warp -}: -mkDerivation { - pname = "rex"; - version = "0.3.0"; - src = gitignoreSource ./.; - isLibrary = false; - isExecutable = true; - executableHaskellDepends = [ - async - attoparsec - base - bytestring - clock - dns - exceptions - http-types - iproute - mtl - network - optparse-applicative - prometheus - text - tinylog - unordered-containers - wai - warp - ]; - description = "Scrape and expose restund metrics for prometheus"; - license = lib.licenses.agpl3Only; - mainProgram = "rex"; -} diff --git a/tools/rex/rex.cabal b/tools/rex/rex.cabal deleted file mode 100644 index d317815b3f6..00000000000 --- a/tools/rex/rex.cabal +++ /dev/null @@ -1,46 +0,0 @@ -cabal-version: >=1.10 -name: rex -version: 0.3.0 -synopsis: Scrape and expose restund metrics for prometheus -description: @rex@ = @restund-exporter@ in prometheus jargon -category: Network -author: Wire Swiss GmbH -maintainer: Wire Swiss GmbH -license: AGPL-3 -license-file: LICENSE -build-type: Simple - -flag static - description: Enable static linking - default: False - -executable rex - main-is: Main.hs - build-depends: - async - , attoparsec - , base >=4 && <5 - , bytestring - , clock - , dns >=2.0.8 - , exceptions - , http-types - , iproute - , mtl - , network - , optparse-applicative - , prometheus - , text - , tinylog - , unordered-containers - , wai - , warp - - ghc-options: - -Wall -O1 -funbox-small-strict-fields -Wredundant-constraints - -Wunused-packages - - if flag(static) - ld-options: -static - - default-language: Haskell2010 diff --git a/tools/stern/default.nix b/tools/stern/default.nix index 628a2a3a1d9..753c3bfd50d 100644 --- a/tools/stern/default.nix +++ b/tools/stern/default.nix @@ -6,7 +6,6 @@ , aeson , base , bilge -, brig-types , bytestring , bytestring-conversion , containers @@ -64,7 +63,6 @@ mkDerivation { aeson base bilge - brig-types bytestring bytestring-conversion containers @@ -99,7 +97,6 @@ mkDerivation { aeson base bilge - brig-types bytestring-conversion containers cookie diff --git a/tools/stern/src/Stern/API.hs b/tools/stern/src/Stern/API.hs index dd1b104d67a..8c37c89071a 100644 --- a/tools/stern/src/Stern/API.hs +++ b/tools/stern/src/Stern/API.hs @@ -27,7 +27,6 @@ module Stern.API ) where -import Brig.Types.Intra import Control.Error import Control.Lens ((.~)) import Control.Monad.Except @@ -362,7 +361,7 @@ mkFeatureGetRoute = Intra.getTeamFeatureFlag @cfg mkFeaturePutRoute :: forall cfg. - (IsFeatureConfig cfg) => + (Typeable cfg, IsFeatureConfig cfg) => TeamId -> Feature cfg -> Handler NoContent diff --git a/tools/stern/src/Stern/API/Routes.hs b/tools/stern/src/Stern/API/Routes.hs index d3152fe4158..21c89c56b04 100644 --- a/tools/stern/src/Stern/API/Routes.hs +++ b/tools/stern/src/Stern/API/Routes.hs @@ -515,7 +515,7 @@ data UserConnectionGroups = UserConnectionGroups instance Schema.ToSchema UserConnectionGroups where schema = - Schema.object "UserConnectionGroups" $ + Schema.object $ UserConnectionGroups <$> ucgAccepted Schema..= Schema.field "ucgAccepted" Schema.schema <*> ucgSent Schema..= Schema.field "ucgSent" Schema.schema diff --git a/tools/stern/src/Stern/Intra.hs b/tools/stern/src/Stern/Intra.hs index 6daee4beffe..f508adc3542 100644 --- a/tools/stern/src/Stern/Intra.hs +++ b/tools/stern/src/Stern/Intra.hs @@ -74,7 +74,6 @@ where import Bilge hiding (head, options, patch, path, paths, requestId) import Bilge qualified import Bilge.RPC -import Brig.Types.Intra import Control.Error import Control.Lens (view, (^.)) import Data.Aeson hiding (Error) @@ -529,7 +528,7 @@ getTeamFeatureFlag tid = do setTeamFeatureFlag :: forall cfg. - (IsFeatureConfig cfg) => + (Typeable cfg, IsFeatureConfig cfg) => TeamId -> Public.Feature cfg -> Handler () @@ -543,7 +542,7 @@ setTeamFeatureFlag tid status = do patchTeamFeatureFlag :: forall cfg. - (IsFeatureConfig cfg) => + (Typeable cfg, IsFeatureConfig cfg) => TeamId -> Public.LockableFeaturePatch cfg -> Handler () @@ -1064,7 +1063,13 @@ runClientToHandler :: SC.ClientM a -> Handler a runClientToHandler client = do clientEnv <- asks (.brigServantClientEnv) res <- liftIO $ SC.runClientM client clientEnv - either (throwE . mkError status400 "servant-client-error" . LT.pack . displayExceptionNoBacktrace) pure res + either throwError pure res + where + throwError ce = + throwE . mkError (errorStatus ce) "servant-client-error" . LT.pack . displayExceptionNoBacktrace $ ce + + errorStatus (SC.FailureResponse _ resp) = resp.responseStatusCode + errorStatus _ = status400 domRegLock :: Domain -> SC.ClientM NoContent domRegUnlock :: Domain -> SC.ClientM NoContent diff --git a/tools/stern/src/Stern/Types.hs b/tools/stern/src/Stern/Types.hs index 24dde504caa..ccbf19cedd4 100644 --- a/tools/stern/src/Stern/Types.hs +++ b/tools/stern/src/Stern/Types.hs @@ -47,7 +47,7 @@ newtype TeamMemberInfo = TeamMemberInfo {tm :: TeamMember} instance S.ToSchema TeamMemberInfo where schema = - S.object "TeamMemberInfo" $ + S.object $ TeamMemberInfo <$> tm S..= teamMemberObjectSchema <* ((`hasPermission` SetBilling) . tm) S..= S.field "can_update_billing" S.schema @@ -62,7 +62,7 @@ data TeamInfo = TeamInfo instance S.ToSchema TeamInfo where schema = - S.object "TeamInfo" $ + S.object $ TeamInfo <$> tiData S..= S.field "info" S.schema <*> tiMembers S..= S.field "members" (S.array S.schema) @@ -78,7 +78,7 @@ data TeamAdminInfo = TeamAdminInfo instance S.ToSchema TeamAdminInfo where schema = - S.object "TeamAdminInfo" $ + S.object $ TeamAdminInfo <$> taData S..= S.field "data" S.schema <*> taOwners S..= S.field "owners" (S.array S.schema) @@ -193,7 +193,7 @@ data TeamBillingInfo = TeamBillingInfo instance S.ToSchema TeamBillingInfo where schema = - S.object "TeamBillingInfo" $ + S.object $ TeamBillingInfo <$> tbiFirstname S..= S.field "firstname" S.schema <*> tbiLastname S..= S.field "lastname" S.schema @@ -219,7 +219,7 @@ data TeamBillingInfoUpdate = TeamBillingInfoUpdate instance S.ToSchema TeamBillingInfoUpdate where schema = - S.object "TeamBillingInfoUpdate" $ + S.object $ TeamBillingInfoUpdate <$> tbiuFirstname S..= tbiuField "firstname" <*> tbiuLastname S..= tbiuField "lastname" diff --git a/tools/stern/stern.cabal b/tools/stern/stern.cabal index 65d327b1ad8..137a8c81a7a 100644 --- a/tools/stern/stern.cabal +++ b/tools/stern/stern.cabal @@ -76,7 +76,6 @@ library aeson , base , bilge - , brig-types , bytestring , bytestring-conversion , containers @@ -245,7 +244,6 @@ executable stern-integration aeson , base , bilge - , brig-types , bytestring-conversion , containers , cookie diff --git a/tools/stern/test/integration/API.hs b/tools/stern/test/integration/API.hs index 942e2e6bc2a..6a29dce2e04 100644 --- a/tools/stern/test/integration/API.hs +++ b/tools/stern/test/integration/API.hs @@ -24,7 +24,6 @@ module API (tests) where import Bilge import Bilge.Assert -import Brig.Types.Intra import Control.Applicative import Control.Lens hiding ((.=)) import Data.Aeson (ToJSON, Value) @@ -949,7 +948,7 @@ testDomainRegistration = do void $ post (s . paths ["domain-registration", dom, "preauthorize"] . expect2xx) void $ post (s . paths ["domain-registration", dom, "unauthorize"] . expect2xx) void $ delete (s . paths ["domain-registration", dom] . expect2xx) - void $ get (s . paths ["domain-registration", dom] . expect4xx) + void $ get (s . paths ["domain-registration", dom] . expectStatus ((==) 404)) let upd = DomainRegistrationUpdate NoRegistration Allowed void $ put (s . paths ["domain-registration", dom] . json upd . expect2xx) void $ get (s . paths ["domain-registration", dom] . expect2xx) diff --git a/treefmt.toml b/treefmt.toml index 1cd7408a8ff..949295a0b4c 100644 --- a/treefmt.toml +++ b/treefmt.toml @@ -17,5 +17,4 @@ includes = ["*.sh"] excludes = [ "dist-newstyle/", "services/nginz/third_party/*", - "services/restund/*", ]