diff --git a/.envrc b/.envrc new file mode 100644 index 0000000000..4543636416 --- /dev/null +++ b/.envrc @@ -0,0 +1,5 @@ +env=$(nix-build --no-out-link "$PWD/direnv.nix") +PATH_add "${env}/bin" + +# allow local .envrc overrides +[[ -f .envrc.local ]] && source_env .envrc.local diff --git a/.gitignore b/.gitignore index c8af0964ef..8e9a7a3b4c 100644 --- a/.gitignore +++ b/.gitignore @@ -33,7 +33,6 @@ TAGS .stack-docker-profile .metadata *.tix -*.pem .DS_Store services/nginz/src services/.env @@ -99,4 +98,4 @@ i.yaml b.yaml telepresence.log -/.ghci \ No newline at end of file +/.ghci diff --git a/CHANGELOG.md b/CHANGELOG.md index cf1a2d9807..0497d809de 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,67 @@ +# [2021-10-29] + +## Release notes + +* Upgrade SFT to 2.1.15 (#1849) +* Upgrade team settings to Release: [v4.2.0](https://github.com/wireapp/wire-team-settings/releases/tag/v4.2.0) and image tag: 4.2.0-v0.28.28-1e2ef7 (#1856) +* Upgrade Webapp to image tag: 20021-10-28-federation-m1 (#1856) + +## API changes + +* Remove `POST /list-conversations` endpoint. (#1840) +* The member.self ID in conversation endpoints is qualified and available as + "qualified_id". The old unqualified "id" is still available. (#1866) + +## Features + +* Allow configuring nginz so it serve the deeplink for apps to discover the backend (#1889) +* SFT: allow using TURN discovery using 'turnDiscoveryEnabled' (#1519) + +## Bug fixes and other updates + +* Fix an issue related to installing the SFT helm chart as a sub chart to the wire-server chart. (#1677) +* SAML columns (Issuer, NameID) in CSV files with team members. (#1828) + +## Internal changes + +* Add a 'make flake-PATTERN' target to run a subset of tests multiple times to trigger a failure case in flaky tests (#1875) +* Avoid a flaky test to fail related to phone updates and improve failure output. (#1874) +* Brig: Delete deprecated `GET /i/users/connections-status` endpoint. (#1842) +* Replace shell.nix with direnv + nixpkgs.buildEnv based setup (#1876) +* Make connection DB functions work with Qualified IDs (#1819) +* Fix more Swagger validation errors. (#1841) +* Turn `Galley` into a polysemy monad stack. (#1881) +* Internal CI tooling improvement: decrease integration setup time by using helmfile. (#1805) +* Depend on hs-certificate master instead of our fork (#1822) +* Add internal endpoint to insert or update a 1-1 conversation. This is to be used by brig when updating the status of a connection. (#1825) +* Update helm to 3.6.3 in developer tooling (nix-shell) (#1862) +* Improve the `Qualified` abstraction and make local/remote tagging safer (#1839) +* Add some new Spar effects, completely isolating us from saml2-web-sso interface (#1827) +* Convert legacy POST conversations/:cnv/members endpoint to Servant (#1838) +* Simplify mock federator interface by removing unnecessary arguments. (#1870) +* Replace the `Spar` newtype, instead using `Sem` directly. (#1833) + +## Federation changes + +* Remove remote guests as well as local ones when "Guests and services" is disabled in a group conversation, and propagate removal to remote members. (#1854) +* Check connections when adding remote users to a local conversation and local users to remote conversations. (#1842) +* Check connections when creating group and team conversations with remote members. (#1870) +* Server certificates without the "serverAuth" extended usage flag are now rejected when connecting to a remote federator. (#1855) +* Close GRPC client after making a request to a remote federator. (#1865) +* Support deleting conversations with federated users (#1861) +* Ensure that the conversation creator is included only once in notifications sent to remote users (#1879) +* Allow connecting to remote users. One to one conversations are not created yet. (#1824) +* Make federator's default log level Info (#1882) +* The creator of a conversation now appears as a member when the conversation is fetched from a remote backend (#1842) +* Include remote connections in the response to `POST /list-connections` (#1826) +* When a user gets deleted, notify remotes about conversations and connections in chunks of 1000 (#1872, #1883) +* Make federated requests to multiple backends in parallel. (#1860) +* Make conversation ID of `RemoteConversation` unqualified and move it out of the metadata record. (#1839) +* Make the conversation creator field in the `on-conversation-created` RPC unqualified. (#1858) +* Update One2One conversation when connection status changes (#1850) + # [2021-10-01] ## Release notes diff --git a/Makefile b/Makefile index 3dc1142568..980fffa320 100644 --- a/Makefile +++ b/Makefile @@ -234,7 +234,7 @@ libzauth: .PHONY: hie.yaml hie.yaml: stack-dev.yaml stack build implicit-hie - stack exec gen-hie | nix-shell --command 'yq "{cradle: {stack: {stackYaml: \"./stack-dev.yaml\", components: .cradle.stack}}}" > hie.yaml' + stack exec gen-hie | yq "{cradle: {stack: {stackYaml: \"./stack-dev.yaml\", components: .cradle.stack}}}" > hie.yaml .PHONY: stack-dev.yaml stack-dev.yaml: @@ -311,7 +311,7 @@ release-chart-%: .PHONY: guard-tag guard-tag: @if [ "${DOCKER_TAG}" = "${USER}" ]; then \ - echo "Environment variable DOCKER_TAG not set to non-default value. Re-run with DOCKER_TAG=. Try using 'make latest-brig-tag' for latest develop docker image tag";\ + echo "Environment variable DOCKER_TAG not set to non-default value. Re-run with DOCKER_TAG=. Try using 'make latest-tag' for latest develop docker image tag";\ exit 1; \ fi @@ -403,6 +403,7 @@ kind-reset: kind-delete kind-cluster .local/kind-kubeconfig: mkdir -p $(CURDIR)/.local kind get kubeconfig --name $(KIND_CLUSTER_NAME) > $(CURDIR)/.local/kind-kubeconfig + chmod 0600 $(CURDIR)/.local/kind-kubeconfig # This guard is a fail-early way to save needing to debug nginz container not # starting up in the second namespace of the kind cluster in some cases. Error @@ -429,11 +430,11 @@ guard-inotify: .PHONY: kind-integration-setup kind-integration-setup: guard-inotify .local/kind-kubeconfig - ENABLE_KIND_VALUES="1" KUBECONFIG=$(CURDIR)/.local/kind-kubeconfig make kube-integration-setup + HELMFILE_ENV="kind" KUBECONFIG=$(CURDIR)/.local/kind-kubeconfig make kube-integration-setup .PHONY: kind-integration-test kind-integration-test: .local/kind-kubeconfig - ENABLE_KIND_VALUES="1" KUBECONFIG=$(CURDIR)/.local/kind-kubeconfig make kube-integration-test + HELMFILE_ENV="kind" KUBECONFIG=$(CURDIR)/.local/kind-kubeconfig make kube-integration-test kind-integration-e2e: .local/kind-kubeconfig cd services/brig && KUBECONFIG=$(CURDIR)/.local/kind-kubeconfig ./federation-tests.sh $(NAMESPACE) diff --git a/README.md b/README.md index 992c2e3074..f5d86ab3e7 100644 --- a/README.md +++ b/README.md @@ -63,8 +63,8 @@ It also contains - **build**: Build scripts and Dockerfiles for some platforms - **deploy**: (Work-in-progress) - how to run wire-server in an ephemeral, in-memory demo mode - **doc**: Documentation -- **hack**: scripts and configuration for kubernetes helm chart development/releases mainly used by CI -- **charts**: kubernetes helm charts +- **hack**: scripts and configuration for kuberentes helm chart development/releases mainly used by CI +- **charts**: Kubernetes Helm charts. The charts are mirroed to S3 and can be used with `helm repo add wire https://s3-eu-west-1.amazonaws.com/public.wire.com/charts`. See the [Administrator's Guide](https://docs.wire.com) for more info. ## Architecture Overview diff --git a/changelog.d/mk-changelog.sh b/changelog.d/mk-changelog.sh index da6998647d..550e024738 100755 --- a/changelog.d/mk-changelog.sh +++ b/changelog.d/mk-changelog.sh @@ -13,10 +13,14 @@ getPRNumber() { for d in "$DIR"/*; do if [[ ! -d "$d" ]]; then continue; fi + entries=("$d"/*[^~]) + + if [[ ${#entries[@]} -eq 0 ]]; then continue; fi + echo -n "## " sed '$ a\' "$d/.title" echo "" - for f in "$d"/*[^~]; do + for f in "${entries[@]}"; do pr=$(getPRNumber $f) sed -r ' # create a bullet point on the first line diff --git a/charts/fake-aws-s3/values.yaml b/charts/fake-aws-s3/values.yaml index 4f995011dd..2e0d458235 100644 --- a/charts/fake-aws-s3/values.yaml +++ b/charts/fake-aws-s3/values.yaml @@ -7,6 +7,8 @@ minio: enabled: false environment: MINIO_BROWSER: "off" + defaultBucket: + name: dummy-bucket buckets: - name: dummy-bucket purge: true diff --git a/charts/federator/values.yaml b/charts/federator/values.yaml index 3184c8983c..9e0439e596 100644 --- a/charts/federator/values.yaml +++ b/charts/federator/values.yaml @@ -23,7 +23,7 @@ resources: memory: "512Mi" cpu: "500m" config: - logLevel: Debug + logLevel: Info logFormat: JSON optSettings: # Defaults to using system CA store in the federator image for making diff --git a/charts/nginz/templates/conf/_deeplink.html.tpl b/charts/nginz/templates/conf/_deeplink.html.tpl new file mode 100644 index 0000000000..4e9b458def --- /dev/null +++ b/charts/nginz/templates/conf/_deeplink.html.tpl @@ -0,0 +1,15 @@ +{{- define "nginz_deeplink.html" }} +{{/* See https://docs.wire.com/how-to/associate/deeplink.html + (or search for "deeplink" on docs.wire.com) + for details on use of the deeplink*/}} + + + + {{- if hasKey .Values.nginx_conf "deeplink" }} + Click here for access + {{- else }} + No Deep Link. + {{- end }} + + +{{- end }} diff --git a/charts/nginz/templates/conf/_deeplink.json.tpl b/charts/nginz/templates/conf/_deeplink.json.tpl new file mode 100644 index 0000000000..da5ddb19a6 --- /dev/null +++ b/charts/nginz/templates/conf/_deeplink.json.tpl @@ -0,0 +1,24 @@ +{{- define "nginz_deeplink.json" }} +{{- if hasKey .Values.nginx_conf "deeplink" }} +{{- with .Values.nginx_conf.deeplink }} +{{/* See https://docs.wire.com/how-to/associate/deeplink.html + (or search for "deeplink" on docs.wire.com) + for details on use of the deeplink*/}} +{ + "endpoints" : { + {{- with .endpoints }} + "backendURL" : {{ .backendURL | quote }}, + "backendWSURL": {{ .backendWSURL | quote }}, + "blackListURL": {{ .blackListURL | quote }}, + "teamsURL": {{ .teamsURL | quote }}, + "accountsURL": {{ .accountsURL | quote }}, + "websiteURL": {{ .websiteURL | quote }} + {{- end }} + }, + "title" : {{ .title | quote }} +} +{{- end }} +{{- else }} +{} +{{- end }} +{{- end }} diff --git a/charts/nginz/templates/conf/_nginx.conf.tpl b/charts/nginz/templates/conf/_nginx.conf.tpl index d5f888b2b7..1e3d993704 100644 --- a/charts/nginz/templates/conf/_nginx.conf.tpl +++ b/charts/nginz/templates/conf/_nginx.conf.tpl @@ -344,6 +344,25 @@ http { image/png png; } } + + {{- if hasKey .Values.nginx_conf "deeplink" }} + location ~* ^/deeplink.(json|html)$ { + zauth off; + root /etc/wire/nginz/conf/; + types { + application/json json; + text/html html; + } + if ($request_method = 'OPTIONS') { + add_header 'Access-Control-Allow-Methods' "GET, OPTIONS"; + add_header 'Access-Control-Allow-Headers' "$http_access_control_request_headers, DNT,X-Mx-ReqToken,Keep-Alive,User-Agent,X-Requested-With,If-Modified-Since,Cache-Control,Content-Type"; + add_header 'Content-Type' 'text/plain; charset=UTF-8'; + add_header 'Content-Length' 0; + return 204; + } + more_set_headers 'Access-Control-Allow-Origin: $http_origin'; + } + {{- end }} } } {{- end }} diff --git a/charts/nginz/templates/configmap.yaml b/charts/nginz/templates/configmap.yaml index b14e4042ec..cb57148817 100644 --- a/charts/nginz/templates/configmap.yaml +++ b/charts/nginz/templates/configmap.yaml @@ -6,6 +6,10 @@ data: {{- include "nginz_upstreams.txt" . | indent 4 }} zwagger-config.js: |2 {{- include "nginz_zwagger-config.js" . | indent 4 }} + deeplink.json: |2 +{{- include "nginz_deeplink.json" . | indent 4 }} + deeplink.html: |2 +{{- include "nginz_deeplink.html" . | indent 4 }} {{ (.Files.Glob "conf/static/*").AsConfig | indent 2 }} kind: ConfigMap metadata: diff --git a/charts/nginz/values.yaml b/charts/nginz/values.yaml index 3773dd2aed..5c0f7ebd81 100644 --- a/charts/nginz/values.yaml +++ b/charts/nginz/values.yaml @@ -32,6 +32,15 @@ nginx_conf: worker_rlimit_nofile: 131072 worker_connections: 65536 swagger_root: /var/www/swagger + # deeplink: + # endpoints: + # backendURL: "https://prod-nginz-https.wire.com" + # backendWSURL: "https://prod-nginz-ssl.wire.com" + # blackListURL: "https://clientblacklist.wire.com/prod" + # teamsURL: "https://teams.wire.com" + # accountsURL: "https://accounts.wire.com" + # websiteURL: "https://wire.com" + # title: "Production" disabled_paths: - /conversations/last-events - ~* ^/conversations/([^/]*)/knock @@ -304,9 +313,6 @@ nginx_conf: envs: - all doc: true - - path: ~* ^/list-conversations$ - envs: - - all - path: ~* ^/teams$ envs: - all diff --git a/charts/sftd/Chart.yaml b/charts/sftd/Chart.yaml index bd8b66f802..c619f35d92 100644 --- a/charts/sftd/Chart.yaml +++ b/charts/sftd/Chart.yaml @@ -11,4 +11,4 @@ version: 0.0.42 # This is the version number of the application being deployed. This version number should be # incremented each time you make changes to the application. Versions are not expected to # follow Semantic Versioning. They should reflect the version the application is using. -appVersion: 2.0.127 +appVersion: 2.1.15 diff --git a/charts/sftd/README.md b/charts/sftd/README.md index c785f58009..2d0fa74a07 100644 --- a/charts/sftd/README.md +++ b/charts/sftd/README.md @@ -111,6 +111,32 @@ able to reach the restund servers on their public IPs. More exotic setups _are_ possible but are currently *not* officially supported. Please contact us if you have different constraints. +### No public IP on default interface + +Often on-prem or at certain cloud providers your nodes will not have directly routable public IP addresses +but are deployed in 1:1 NAT. This chart is able to auto-detect this scenario if your cloud providers adds +an `ExternalIP` field to your kubernetes node objects. + +On on-prem you should set an `wire.com/external-ip` annotation on your kubernetes nodes so that sftd is aware +of its external IP when it gets scheduled on a node. + +If you use our kubespray playbooks to bootstrap kubernetes, you simply have to +set the `external_ip` field in your `group_vars` +```yaml +# inventory/group_vars/k8s-cluster +node_annotations: + wire.com/external-ip: {{ external_ip }} +``` +And the `external_ip` is set in the inventory per node: +``` +node0 ansible_host=.... ip=... external_ip=aaa.xxx.yyy.zzz +``` + +If you are hosting Kubernetes through other means you can annotate your nodes manually: +``` +$ kubectl annotate node $HOSTNAME wire.com/external-ip=$EXTERNAL_IP +``` + ## Rollout Kubernetes will shut down pods and start new ones when rolling out a release. Any calls @@ -193,31 +219,6 @@ helm install wire-prod charts/wire-server --set 'nodeSelector.wire\.com/role=sft helm install wire-staging charts/wire-server --set 'nodeSelector.wire\.com/role=sftd-staging' ...other-flags ``` -## No public IP on default interface - -Often on-prem or at certain cloud providers your nodes will not have directly routable public IP addresses -but are deployed in 1:1 NAT. This chart is able to auto-detect this scenario if your cloud providers adds -an `ExternalIP` field to your kubernetes node objects. - -On on-prem you should set an `wire.com/external-ip` annotation on your kubernetes nodes so that sftd is aware -of its external IP when it gets scheduled on a node. - -If you use our kubespray playbooks to bootstrap kubernetes, you simply have to -set the `external_ip` field in your `group_vars` -```yaml -# inventory/group_vars/k8s-cluster -node_annotations: - wire.com/external-ip: {{ external_ip }} -``` -And the `external_ip` is set in the inventory per node: -``` -node0 ansible_host=.... ip=... external_ip=aaa.xxx.yyy.zzz -``` - -If you are hosting Kubernetes through other means you can annotate your nodes manually: -``` -$ kubectl annotate node $HOSTNAME wire.com/external-ip=$EXTERNAL_IP -``` ## Port conflicts and `hostNetwork` diff --git a/charts/sftd/templates/configmap-join-call.yaml b/charts/sftd/templates/configmap-join-call.yaml index 6388574146..fd4ec86717 100644 --- a/charts/sftd/templates/configmap-join-call.yaml +++ b/charts/sftd/templates/configmap-join-call.yaml @@ -14,7 +14,7 @@ data: location /healthz { return 204; } location ~ ^/sfts/([a-z0-9\-]+)/(.*) { - proxy_pass http://$1.sftd.${POD_NAMESPACE}.svc.cluster.local:8585/$2; + proxy_pass http://$1.{{ include "sftd.fullname" . }}.${POD_NAMESPACE}.svc.cluster.local:8585/$2; } } diff --git a/charts/sftd/templates/statefulset.yaml b/charts/sftd/templates/statefulset.yaml index cfdf064a83..391931b1a0 100644 --- a/charts/sftd/templates/statefulset.yaml +++ b/charts/sftd/templates/statefulset.yaml @@ -83,7 +83,12 @@ spec: else ACCESS_ARGS="-A ${EXTERNAL_IP}" fi - exec sftd -I "${POD_IP}" -M "${POD_IP}" ${ACCESS_ARGS} -u "https://{{ required "must specify host" .Values.host }}/sfts/${POD_NAME}" + exec sftd \ + -I "${POD_IP}" \ + -M "${POD_IP}" \ + ${ACCESS_ARGS} \ + {{ if .Values.turnDiscoveryEnabled }}-T{{ end }} \ + -u "https://{{ required "must specify host" .Values.host }}/sfts/${POD_NAME}" ports: - name: sft containerPort: 8585 diff --git a/charts/sftd/values.yaml b/charts/sftd/values.yaml index 4a186e8ee9..6c889fc629 100644 --- a/charts/sftd/values.yaml +++ b/charts/sftd/values.yaml @@ -81,3 +81,7 @@ joinCall: # Overrides the image tag whose default is the chart appVersion. tag: "1.19.5" +# Allow SFT instances to choose/consider using a TURN server for themselves as a proxy when +# trying to establish a connection to clients +# DOCS: https://docs.wire.com/understand/sft.html#prerequisites +turnDiscoveryEnabled: false diff --git a/charts/team-settings/values.yaml b/charts/team-settings/values.yaml index 61f8968d85..9e70266351 100644 --- a/charts/team-settings/values.yaml +++ b/charts/team-settings/values.yaml @@ -9,7 +9,7 @@ resources: cpu: "1" image: repository: quay.io/wire/team-settings - tag: "4.0.0-v0.28.21-b92fca-2" + tag: "4.2.0-v0.28.28-1e2ef7" service: https: externalPort: 443 diff --git a/charts/webapp/values.yaml b/charts/webapp/values.yaml index fe21eb3aac..80def91676 100644 --- a/charts/webapp/values.yaml +++ b/charts/webapp/values.yaml @@ -9,7 +9,7 @@ resources: cpu: "1" image: repository: quay.io/wire/webapp - tag: 2021-09-06-staging.3-v0.28.24-e6e306b + tag: "2021-10-28-federation-M1" service: https: externalPort: 443 diff --git a/deploy/services-demo/conf/nginz/nginx-docker.conf b/deploy/services-demo/conf/nginz/nginx-docker.conf index c674cdd4ac..9fdd32baf8 100644 --- a/deploy/services-demo/conf/nginz/nginx-docker.conf +++ b/deploy/services-demo/conf/nginz/nginx-docker.conf @@ -253,11 +253,6 @@ http { proxy_pass http://galley; } - location /list-conversations { - include common_response_with_zauth.conf; - proxy_pass http://galley; - } - location ~* ^/conversations/([^/]*)/otr/messages { include common_response_with_zauth.conf; proxy_pass http://galley; diff --git a/deploy/services-demo/conf/nginz/nginx.conf b/deploy/services-demo/conf/nginz/nginx.conf index 5d577caed6..543dc2d8c3 100644 --- a/deploy/services-demo/conf/nginz/nginx.conf +++ b/deploy/services-demo/conf/nginz/nginx.conf @@ -313,11 +313,6 @@ http { proxy_pass http://galley; } - location /list-conversations { - include common_response_with_zauth.conf; - proxy_pass http://galley; - } - location ~* ^/conversations/([^/]*)/otr/messages { include common_response_with_zauth.conf; proxy_pass http://galley; diff --git a/shell.nix b/direnv.nix similarity index 50% rename from shell.nix rename to direnv.nix index 1057866883..c29ac40da5 100644 --- a/shell.nix +++ b/direnv.nix @@ -20,6 +20,30 @@ let cp ${binPath} $out/bin ''; }; + + staticBinary = { pname, version, linuxAmd64Url, linuxAmd64Sha256, darwinAmd64Url, darwinAmd64Sha256, binPath ? pname }: + pkgs.stdenv.mkDerivation { + inherit pname version; + + src = + if pkgs.stdenv.isDarwin + then pkgs.fetchurl { + url = darwinAmd64Url; + sha256 = darwinAmd64Sha256; + } + else pkgs.fetchurl { + url = linuxAmd64Url; + sha256 = linuxAmd64Sha256; + }; + phases = ["installPhase" "patchPhase"]; + + installPhase = '' + mkdir -p $out/bin + cp $src $out/bin/${binPath} + chmod +x $out/bin/${binPath} + ''; + }; + pinned = { stack = staticBinaryInTarball { pname = "stack"; @@ -34,13 +58,24 @@ let helm = staticBinaryInTarball { pname = "helm"; - version = "3.1.1"; + version = "3.6.3"; - darwinAmd64Url = "https://get.helm.sh/helm-v3.1.1-darwin-amd64.tar.gz"; - darwinAmd64Sha256 = "2ce00e6c44ba18fbcbec21c493476e919128710d480789bb35bd228ae695cd66"; + darwinAmd64Url = "https://get.helm.sh/helm-v3.6.3-darwin-amd64.tar.gz"; + darwinAmd64Sha256 = "0djjvgla8cw27h8s4y6jby19f74j58byb2vfv590cd03vlbzz8c4"; - linuxAmd64Url = "https://get.helm.sh/helm-v3.1.1-linux-amd64.tar.gz"; - linuxAmd64Sha256 = "cdd7ad304e2615c583dde0ffb0cb38fc1336cd7ce8ff3b5f237434dcadb28c98"; + linuxAmd64Url = "https://get.helm.sh/helm-v3.6.3-linux-amd64.tar.gz"; + linuxAmd64Sha256 = "0qp28fq137b07haz4vsdbc5biagh60dcs29jj70ksqi5k6201h87"; + }; + + helmfile = staticBinary { + pname = "helmfile"; + version = "0.141.0"; + + darwinAmd64Url = "https://github.com/roboll/helmfile/releases/download/v0.141.0/helmfile_darwin_amd64"; + darwinAmd64Sha256 = "0szfd3vy6fzd5657079hz5vii86f9xkg3bdzp3g4knkcw5x1kpxy"; + + linuxAmd64Url = "https://github.com/roboll/helmfile/releases/download/v0.141.0/helmfile_linux_amd64"; + linuxAmd64Sha256 = "0f5d9w3qjvwip4qn79hsigwp8nbjpj58p289hww503j43wjyxx8r"; }; kubectl = staticBinaryInTarball { @@ -55,11 +90,21 @@ let binPath = "client/bin/kubectl"; }; + + kind = staticBinary { + pname = "kind"; + version = "0.11.0"; + + darwinAmd64Url = "https://github.com/kubernetes-sigs/kind/releases/download/v0.11.1/kind-darwin-amd64"; + darwinAmd64Sha256 = "432bef555a70e9360b44661c759658265b9eaaf7f75f1beec4c4d1e6bbf97ce3"; + + linuxAmd64Url = "https://github.com/kubernetes-sigs/kind/releases/download/v0.11.1/kind-linux-amd64"; + linuxAmd64Sha256 = "949f81b3c30ca03a3d4effdecda04f100fa3edc07a28b19400f72ede7c5f0491"; + }; }; -in pkgs.mkShell { - name = "shell"; - LOCALE_ARCHIVE = "${pkgs.glibcLocales}/lib/locale/locale-archive"; # works around https://github.com/tweag/ormolu/issues/38 - buildInputs = [ +in pkgs.buildEnv { + name = "wire-server-direnv"; + paths = [ pkgs.docker-compose pkgs.gnumake pkgs.haskell-language-server @@ -72,10 +117,12 @@ in pkgs.mkShell { # To actually run buildah on nixos, I had to follow this: https://gist.github.com/alexhrescale/474d55635154e6b2cd6362c3bb403faf pkgs.buildah - pkgs.kind pinned.stack pinned.helm + pinned.helmfile pinned.kubectl + pinned.kind ]; } + diff --git a/docs/developer/dependencies.md b/docs/developer/dependencies.md index be011c84df..3cd670834e 100644 --- a/docs/developer/dependencies.md +++ b/docs/developer/dependencies.md @@ -174,11 +174,12 @@ docker login --username= * [Install docker](https://docker.com) * [Install docker-compose](https://docs.docker.com/compose/install/) -## Nix +## Nix + Direnv Using Stack's [Nix integration](https://docs.haskellstack.org/en/stable/nix_integration/), Stack will take care of installing any system dependencies automatically - including `cryptobox-c`. If new system dependencies are needed, add them to the `stack-deps.nix` file in the project root. -Just type `$ nix-shell` and you will automatically have `make`, `docker-compose` and `stack` in `PATH`. + +If you have `direnv` and `nix`, you will automatically have `make`, `docker-compose` and `stack` in `PATH` once you `cd` into the project root and `direnv allow`. You can then run all the builds, and the native dependencies will be automatically present. ## Telepresence @@ -225,4 +226,4 @@ See `make buildah-docker` for an entry point here. ## Helm chart development, integration tests in kubernetes -You need `kubectl`, `helm`, and a valid kubernetes context. Refer to https://docs.wire.com for details. +You need `kubectl`, `helm`, `helmfile`, and a valid kubernetes context. Refer to https://docs.wire.com for details. diff --git a/docs/developer/editor-setup.md b/docs/developer/editor-setup.md index 99509513fe..e21d59025b 100644 --- a/docs/developer/editor-setup.md +++ b/docs/developer/editor-setup.md @@ -57,6 +57,16 @@ Install the [projectile][] package for Emacs and do `M-x projectile-add-known-pr ad-do-it))) ``` +### Haskell Language Server + +To use HLS bundled in direnv setup, here is a sample `.dir-locals.el` that can +be put in the root directory of the project: +```el +((haskell-mode . ((haskell-completion-backend . lsp) + (lsp-haskell-server-path . "/home/haskeller/code/wire-server/hack/bin/nix-hls.sh") + ))) +``` + ### Ormolu integration There are make targets `format`, `formatf`, `formatc` to re-format diff --git a/docs/developer/federation-api-conventions.md b/docs/developer/federation-api-conventions.md index 6971d4b042..5703ffe3af 100644 --- a/docs/developer/federation-api-conventions.md +++ b/docs/developer/federation-api-conventions.md @@ -3,12 +3,14 @@ # Federation API Conventions - All endpoints must start with `/federation/` -- All endpoints must have exactly one path segment after federation, so - `/federation/foo` is valid `/fedeartion/foo/bar` is not. The path segments - must be in kebab-case. The name of the field in this record must be the - same name in camelCase. +- All path segments must be in kebab-case. The name the field in the record must + be the same name in camelCase. +- There can be either one or two path segments after `/federation/`, so + `/federation/foo` is valid, `/fedeartion/foo/bar` is valid, but + `/federation/foo/bar/baz` is not. - All endpoints must be `POST`. -- No query query params, all information that needs to go must go in body. +- No query query params or captured path params, all information that needs to + go must go in body. - All responses must be `200 OK`, domain specific failures (e.g. the conversation doesn't exist) must be indicated as a Sum type. Unhandled failures can be 5xx, an endpoint not being implemented will of course @@ -16,9 +18,11 @@ - Accept only json, respond with only json. Maybe we can think of changing this in future. But as of now, the federator hardcodes application/json as the content type of the body. -- Name of the last path segment must be either `-` or - `on--`, e.g. `get-conversations` or - `on-conversation-created`. +- Ensure that paths don't collide between brig and galley federation API, this + will be very helpful when we merge brig and galley. +- Name of the first path segment after `/federation/` must be either + `-` or `on--`, e.g. + `get-conversations` or `on-conversation-created`. How to decide which one to use: - If the request is supposed to ask for information/change from another @@ -29,3 +33,9 @@ this request has authority on, like a conversation got created, or a message is sent, then use the second format like `on-conversation-created` or `on-message-sent` +- Path segment number 3 (so `/federation/not-this/but-this-one`), must only be + used in exceptional circumstances, like when there needs to be the same path + in brig and galley, e.g. `on-user-deleted`. In this case use the third segment + to express the difference. For `on-user-deleted` we came up with + `on-user-deleted/connections`for brig and `on-user-deleted/conversations` for + galley. diff --git a/hack/bin/helm_overrides.sh b/hack/bin/helm_overrides.sh new file mode 100644 index 0000000000..6349897831 --- /dev/null +++ b/hack/bin/helm_overrides.sh @@ -0,0 +1,15 @@ +#!/usr/bin/env bash + +# Helm (v3) writes into XDG folders only these days. They don't honor HELM_ vars +# anymore. +# Derive a helm-specific folder inside the wire-server/.local to avoid polluting +# ~. + +DIR="$(cd "$(dirname "${BASH_SOURCE[0]}")" && pwd)" +TOP_LEVEL="$DIR/../.." +LOCAL_HELM_FOLDER="$TOP_LEVEL/.local/helm" + +[[ -e $LOCAL_HELM_FOLDER ]] || mkdir -p "$LOCAL_HELM_FOLDER" +export XDG_CACHE_HOME=${LOCAL_HELM_FOLDER}/cache +export XDG_CONFIG_HOME=${LOCAL_HELM_FOLDER}/config +export XDG_DATA_HOME=${LOCAL_HELM_FOLDER}/data diff --git a/hack/bin/integration-setup-federation.sh b/hack/bin/integration-setup-federation.sh index d703586777..a8f0290497 100755 --- a/hack/bin/integration-setup-federation.sh +++ b/hack/bin/integration-setup-federation.sh @@ -1,19 +1,57 @@ #!/usr/bin/env bash -USAGE="Usage: $0" +set -euo pipefail -set -e - -DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )" +DIR="$(cd "$(dirname "${BASH_SOURCE[0]}")" && pwd)" TOP_LEVEL="$DIR/../.." - export NAMESPACE=${NAMESPACE:-test-integration} +HELMFILE_ENV=${HELMFILE_ENV:-default} +CHARTS_DIR="${TOP_LEVEL}/.local/charts" + +. "$DIR/helm_overrides.sh" +${DIR}/integration-cleanup.sh + +# FUTUREWORK explore: have helmfile do the interpolation (and skip the "make charts" step) https://wearezeta.atlassian.net/browse/SQPIT-722 +# +# FUTUREWORK: get rid of wrapper charts, use helmfile for pinning. Then we may not need the recursive update hack anymore: https://wearezeta.atlassian.net/browse/SQPIT-721 +# +# Sadly, even with helmfile, we still need to use use this recursive update +# script beforehand on all relevant charts to download the nested dependencies +# (e.g. cassandra from underneath databases-ephemeral) +echo "updating recursive dependencies ..." +charts=(fake-aws databases-ephemeral wire-server nginx-ingress-controller nginx-ingress-services) +for chart in "${charts[@]}"; do + "$DIR/update.sh" "$CHARTS_DIR/$chart" +done + +# FUTUREWORK: use helm functions instead, see https://wearezeta.atlassian.net/browse/SQPIT-723 +echo "Generating self-signed certificates..." + +export NAMESPACE_1="$NAMESPACE" +export FEDERATION_DOMAIN_BASE="$NAMESPACE_1.svc.cluster.local" +export FEDERATION_DOMAIN_1="federation-test-helper.$FEDERATION_DOMAIN_BASE" +"$DIR/selfsigned-kubernetes.sh" namespace1 + +export NAMESPACE_2="$NAMESPACE-fed2" +export FEDERATION_DOMAIN_BASE="$NAMESPACE_2.svc.cluster.local" +export FEDERATION_DOMAIN_2="federation-test-helper.$FEDERATION_DOMAIN_BASE" +"$DIR/selfsigned-kubernetes.sh" namespace2 + +echo "Installing charts..." + +helmfile --environment "$HELMFILE_ENV" --file "${TOP_LEVEL}/hack/helmfile.yaml" sync -$DIR/integration-setup.sh +# wait for fakeSNS to create resources. TODO, cleaner: make initiate-fake-aws-sns a post hook. See cassandra-migrations chart for an example. +resourcesReady() { + SNS_POD=$(kubectl -n "${NAMESPACE_1}" get pods | grep fake-aws-sns | grep Running | awk '{print $1}') + kubectl -n "${NAMESPACE_1}" logs "$SNS_POD" -c initiate-fake-aws-sns | grep created -# The suffix '-fed2' must be kept in sync with configuration inside -# charts/brig/templates/tests/configmap.yaml and -# hack/bin/integration-teardown-federation.sh -export NAMESPACE=${NAMESPACE}-fed2 + SNS_POD=$(kubectl -n "${NAMESPACE_2}" get pods | grep fake-aws-sns | grep Running | awk '{print $1}') + kubectl -n "${NAMESPACE_2}" logs "$SNS_POD" -c initiate-fake-aws-sns | grep created +} +until resourcesReady; do + echo 'waiting for SNS resources' + sleep 1 +done -$DIR/integration-setup.sh +echo "done" diff --git a/hack/bin/integration-setup.sh b/hack/bin/integration-setup.sh index 1f917dfc24..991efc4345 100755 --- a/hack/bin/integration-setup.sh +++ b/hack/bin/integration-setup.sh @@ -1,84 +1,31 @@ #!/usr/bin/env bash -USAGE="Usage: $0" - -set -e +set -euo pipefail DIR="$(cd "$(dirname "${BASH_SOURCE[0]}")" && pwd)" TOP_LEVEL="$DIR/../.." +export NAMESPACE=${NAMESPACE:-test-integration} +HELMFILE_ENV=${HELMFILE_ENV:-default} CHARTS_DIR="${TOP_LEVEL}/.local/charts" -NAMESPACE=${NAMESPACE:-test-integration} -ENABLE_KIND_VALUES=${ENABLE_KIND_VALUES:-0} - -kubectl create namespace "${NAMESPACE}" >/dev/null 2>&1 || true +. "$DIR/helm_overrides.sh" -${DIR}/integration-cleanup.sh - -charts=(fake-aws databases-ephemeral wire-server nginx-ingress-controller nginx-ingress-services) +"${DIR}/integration-cleanup.sh" echo "updating recursive dependencies ..." +charts=(fake-aws databases-ephemeral wire-server nginx-ingress-controller nginx-ingress-services) for chart in "${charts[@]}"; do "$DIR/update.sh" "$CHARTS_DIR/$chart" done -echo "Installing charts..." - -function printLogs() { - echo "---- a command failed, attempting to print useful debug information..." - echo "-------------------------------" - echo "-------------------------------" - echo "-------------------------------" - echo "" - kubectl -n ${NAMESPACE} get pods - kubectl -n ${NAMESPACE} get pods | grep -v Running | grep -v Pending | grep -v Completed | grep -v STATUS | grep -v ContainerCreating | awk '{print $1}' | xargs -n 1 -I{} bash -c "printf '\n\n----LOGS FROM {}:\n'; kubectl -n ${NAMESPACE} logs --tail=30 {}" || true - kubectl -n ${NAMESPACE} get pods | grep Pending | awk '{print $1}' | xargs -n 1 -I{} bash -c "printf '\n\n----DESCRIBE 'pending' {}:\n'; kubectl -n ${NAMESPACE} describe pod {}" || true -} - -trap printLogs ERR - +echo "Generating self-signed certificates..." export FEDERATION_DOMAIN_BASE="$NAMESPACE.svc.cluster.local" -FEDERATION_DOMAIN="federation-test-helper.$FEDERATION_DOMAIN_BASE" -"$DIR/selfsigned-kubernetes.sh" - -for chart in "${charts[@]}"; do - kubectl -n ${NAMESPACE} get pods - valuesfile="${DIR}/../helm_vars/${chart}/values.yaml" - kindValuesfile="${DIR}/../helm_vars/${chart}/kind-values.yaml" - certificatesValuesfile="${DIR}/../helm_vars/${chart}/certificates.yaml" - - declare -a options=() - - if [ -f "$valuesfile" ]; then - options+=(-f "$valuesfile") - fi +export FEDERATION_DOMAIN="federation-test-helper.$FEDERATION_DOMAIN_BASE" +"$DIR/selfsigned-kubernetes.sh" namespace1 - if [ -f "$certificatesValuesfile" ]; then - options+=(-f "$certificatesValuesfile") - fi - - if [[ "$chart" == "nginx-ingress-services" ]]; then - # Federation domain is also the SRV record created by the - # federation-test-helper service. Maybe we can find a way to make these - # differ, so we don't make any silly assumptions in the code. - options+=("--set" "config.dns.federator=$FEDERATION_DOMAIN") - fi - - if [[ "$ENABLE_KIND_VALUES" == "1" ]] && [[ -f "$kindValuesfile" ]]; then - options+=(-f "$kindValuesfile") - fi +echo "Installing charts..." - # default is 5m but may not be enough on a fresh install including cassandra migrations - TIMEOUT=10m - set -x - helm upgrade --install --namespace "${NAMESPACE}" "${NAMESPACE}-${chart}" "${CHARTS_DIR}/${chart}" \ - ${options[*]} \ - --set brig.config.optSettings.setFederationDomain="$FEDERATION_DOMAIN" \ - --set galley.config.settings.federationDomain="$FEDERATION_DOMAIN" \ - --wait \ - --timeout "$TIMEOUT" - set +x -done +helmfile --environment "$HELMFILE_ENV" --file "${TOP_LEVEL}/hack/helmfile-single.yaml" sync # wait for fakeSNS to create resources. TODO, cleaner: make initiate-fake-aws-sns a post hook. See cassandra-migrations chart for an example. resourcesReady() { @@ -90,6 +37,6 @@ until resourcesReady; do sleep 1 done -kubectl -n ${NAMESPACE} get pods +kubectl -n "${NAMESPACE}" get pods echo "done" diff --git a/hack/bin/integration-teardown-federation.sh b/hack/bin/integration-teardown-federation.sh index 7c652171ef..76633f3c6a 100755 --- a/hack/bin/integration-teardown-federation.sh +++ b/hack/bin/integration-teardown-federation.sh @@ -1,16 +1,16 @@ #!/usr/bin/env bash -set -e +DIR="$(cd "$(dirname "${BASH_SOURCE[0]}")" && pwd)" +TOP_LEVEL="$DIR/../.." -DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )" +set -ex -export NAMESPACE=${NAMESPACE:-test-integration} +NAMESPACE=${NAMESPACE:-test-integration} +export NAMESPACE_1="$NAMESPACE" +export NAMESPACE_2="$NAMESPACE-fed2" +# these don't matter for destruction but have to be set. +export FEDERATION_DOMAIN_1="." +export FEDERATION_DOMAIN_2="." -$DIR/integration-teardown.sh - -# The suffix '-fed2' must be kept in sync with configuration inside -# charts/brig/templates/tests/configmap.yaml and -# hack/bin/integration-setup-federation.sh -export NAMESPACE=${NAMESPACE}-fed2 - -$DIR/integration-teardown.sh +. "$DIR/helm_overrides.sh" +helmfile --file "${TOP_LEVEL}/hack/helmfile.yaml" destroy diff --git a/hack/bin/integration-teardown.sh b/hack/bin/integration-teardown.sh index f09dff597b..cd82194c2b 100755 --- a/hack/bin/integration-teardown.sh +++ b/hack/bin/integration-teardown.sh @@ -1,15 +1,13 @@ #!/usr/bin/env bash -DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )/.." +DIR="$(cd "$(dirname "${BASH_SOURCE[0]}")" && pwd)" +TOP_LEVEL="$DIR/../.." NAMESPACE=${NAMESPACE:-test-integration} +# doesn't matter for destruction but needs to be set +export FEDERATION_DOMAIN="." set -ex -echo "NAMESPACE = $NAMESPACE" - -helm ls --all --namespace ${NAMESPACE} | grep -v NAME | awk '{print $1}' | xargs -n 1 helm -n "$NAMESPACE" delete - -sleep 10 - -kubectl delete namespace ${NAMESPACE} +. "$DIR/helm_overrides.sh" +helmfile --file "${TOP_LEVEL}/hack/helmfile-single.yaml" destroy diff --git a/hack/bin/nix-hls.sh b/hack/bin/nix-hls.sh new file mode 100755 index 0000000000..488cc122e6 --- /dev/null +++ b/hack/bin/nix-hls.sh @@ -0,0 +1,10 @@ +#!/usr/bin/env bash + +set -euo pipefail + +DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )" +TOP_LEVEL="$(cd "$DIR/../.." && pwd)" + +env=$(nix-build --no-out-link "$PWD/direnv.nix") +export PATH="$env/bin:$PATH" +haskell-language-server-wrapper "$@" diff --git a/hack/bin/selfsigned-kubernetes.sh b/hack/bin/selfsigned-kubernetes.sh index 73b9776231..d0023cce0f 100755 --- a/hack/bin/selfsigned-kubernetes.sh +++ b/hack/bin/selfsigned-kubernetes.sh @@ -5,7 +5,8 @@ # These certificates are only meant for integration tests. # (The CA certificates are assumed to be re-used across the domains A and B for end2end integration tests.) -set -ex +set -e +SUFFIX=${1:?"need suffix argument"} TEMP=${TEMP:-/tmp} CSR="$TEMP/csr.json" OUTPUTNAME_CA="integration-ca" @@ -13,8 +14,8 @@ OUTPUTNAME_LEAF_CERT="integration-leaf" OUTPUTNAME_CLIENT_CERT="integration-client" DIR="$(cd "$(dirname "${BASH_SOURCE[0]}")" && pwd)" TOP_LEVEL="$DIR/../.." -OUTPUT_CONFIG_FEDERATOR="$TOP_LEVEL/hack/helm_vars/wire-server/certificates.yaml" -OUTPUT_CONFIG_INGRESS="$TOP_LEVEL/hack/helm_vars/nginx-ingress-services/certificates.yaml" +OUTPUT_CONFIG_FEDERATOR="$TOP_LEVEL/hack/helm_vars/wire-server/certificates-$SUFFIX.yaml" +OUTPUT_CONFIG_INGRESS="$TOP_LEVEL/hack/helm_vars/nginx-ingress-services/certificates-$SUFFIX.yaml" command -v cfssl >/dev/null 2>&1 || { echo >&2 "cfssl is not installed, aborting. See https://github.com/cloudflare/cfssl" @@ -70,7 +71,7 @@ cfssl gencert -ca "$OUTPUTNAME_CA.pem" -ca-key "$OUTPUTNAME_CA-key.pem" -hostnam sed -e 's/^/ /' $OUTPUTNAME_LEAF_CERT-key.pem echo " tlsClientCA: |" sed -e 's/^/ /' $OUTPUTNAME_CA.pem -} | tee "$OUTPUT_CONFIG_INGRESS" +} >"$OUTPUT_CONFIG_INGRESS" # the following yaml override file is needed as an override to # the wire-server (federator) helm chart @@ -85,7 +86,7 @@ cfssl gencert -ca "$OUTPUTNAME_CA.pem" -ca-key "$OUTPUTNAME_CA-key.pem" -hostnam sed -e 's/^/ /' $OUTPUTNAME_CLIENT_CERT.pem echo " clientPrivateKeyContents: |" sed -e 's/^/ /' $OUTPUTNAME_CLIENT_CERT-key.pem -} | tee "$OUTPUT_CONFIG_FEDERATOR" +} >"$OUTPUT_CONFIG_FEDERATOR" # cleanup unneeded files rm "$OUTPUTNAME_LEAF_CERT.csr" diff --git a/hack/helm_vars/.gitignore b/hack/helm_vars/.gitignore index 9849d951a0..38a7ff397a 100644 --- a/hack/helm_vars/.gitignore +++ b/hack/helm_vars/.gitignore @@ -1 +1,3 @@ certificates.yaml +certificates-namespace1.yaml +certificates-namespace2.yaml diff --git a/hack/helm_vars/wire-server/kind-values.yaml b/hack/helm_vars/wire-server/kind-values.yaml deleted file mode 100644 index b2c077854e..0000000000 --- a/hack/helm_vars/wire-server/kind-values.yaml +++ /dev/null @@ -1,22 +0,0 @@ -cassandra-migrations: - imagePullPolicy: Never -elasticsearch-index: - imagePullPolicy: Never -brig: - imagePullPolicy: Never -cannon: - imagePullPolicy: Never -cargohold: - imagePullPolicy: Never -galley: - imagePullPolicy: Never -gundeck: - imagePullPolicy: Never -nginz: - imagePullPolicy: Never -proxy: - imagePullPolicy: Never -spar: - imagePullPolicy: Never -federator: - imagePullPolicy: Never diff --git a/hack/helm_vars/wire-server/values.yaml b/hack/helm_vars/wire-server/values.yaml.gotmpl similarity index 92% rename from hack/helm_vars/wire-server/values.yaml rename to hack/helm_vars/wire-server/values.yaml.gotmpl index 7a9fc90a53..c872b4c04a 100644 --- a/hack/helm_vars/wire-server/values.yaml +++ b/hack/helm_vars/wire-server/values.yaml.gotmpl @@ -15,12 +15,12 @@ tags: sftd: false cassandra-migrations: - imagePullPolicy: Always + imagePullPolicy: {{ .Values.imagePullPolicy }} cassandra: host: cassandra-ephemeral replicaCount: 1 elasticsearch-index: - imagePullPolicy: Always + imagePullPolicy: {{ .Values.imagePullPolicy }} elasticsearch: host: elasticsearch-ephemeral index: directory_test @@ -29,7 +29,7 @@ elasticsearch-index: brig: replicaCount: 1 - imagePullPolicy: Always + imagePullPolicy: {{ .Values.imagePullPolicy }} resources: requests: {} limits: @@ -106,7 +106,7 @@ brig: enableFederationTests: true cannon: replicaCount: 2 - imagePullPolicy: Always + imagePullPolicy: {{ .Values.imagePullPolicy }} resources: requests: {} limits: @@ -115,7 +115,7 @@ cannon: drainTimeout: 0 cargohold: replicaCount: 1 - imagePullPolicy: Always + imagePullPolicy: {{ .Values.imagePullPolicy }} resources: requests: {} limits: @@ -130,7 +130,7 @@ cargohold: awsSecretKey: dummysecret galley: replicaCount: 1 - imagePullPolicy: Always + imagePullPolicy: {{ .Values.imagePullPolicy }} config: cassandra: host: cassandra-ephemeral @@ -160,7 +160,7 @@ galley: awsSecretKey: dummysecret gundeck: replicaCount: 1 - imagePullPolicy: Always + imagePullPolicy: {{ .Values.imagePullPolicy }} resources: requests: {} limits: @@ -188,7 +188,7 @@ gundeck: awsSecretKey: dummysecret nginz: replicaCount: 1 - imagePullPolicy: Always + imagePullPolicy: {{ .Values.imagePullPolicy }} nginx_conf: env: staging external_env_domain: zinfra.io @@ -199,7 +199,7 @@ nginz: publicKeys: 0UW38se1yeoc5bVNEvf5LyrHWGZkyvcGTVilK2geGdU= proxy: replicaCount: 1 - imagePullPolicy: Always + imagePullPolicy: {{ .Values.imagePullPolicy }} secrets: proxy_config: |- secrets { @@ -211,7 +211,7 @@ proxy: } spar: replicaCount: 1 - imagePullPolicy: Always + imagePullPolicy: {{ .Values.imagePullPolicy }} resources: requests: {} limits: @@ -237,7 +237,7 @@ federator: replicaCount: 1 resources: requests: {} - imagePullPolicy: Always + imagePullPolicy: {{ .Values.imagePullPolicy }} config: optSettings: federationStrategy: diff --git a/hack/helmfile-single.yaml b/hack/helmfile-single.yaml new file mode 100644 index 0000000000..8d5c81a041 --- /dev/null +++ b/hack/helmfile-single.yaml @@ -0,0 +1,65 @@ +# This helmfile is similar to the 'helmfile.yaml', but only spawns up components for a single backend. +# In some situations (when not testing anything federation specific), use of a single backend is sufficient. +# +# The 'make kube-integration-setup-sans-federation' target uses this helmfile. + +helmDefaults: + wait: true + timeout: 600 + devel: true + +environments: + default: + values: + - namespace: {{ requiredEnv "NAMESPACE" }} + - federationDomain: {{ requiredEnv "FEDERATION_DOMAIN" }} + +repositories: + - name: stable + url: 'https://charts.helm.sh/stable' + +releases: + - name: '{{ .Values.namespace }}-fake-aws' + namespace: '{{ .Values.namespace }}' + chart: '../.local/charts/fake-aws' + values: + - './helm_vars/fake-aws/values.yaml' + + - name: '{{ .Values.namespace }}-databases-ephemeral' + namespace: '{{ .Values.namespace }}' + chart: '../.local/charts/databases-ephemeral' + + - name: '{{ .Values.namespace }}-nginx-ingress-controller' + namespace: '{{ .Values.namespace }}' + chart: '../.local/charts/nginx-ingress-controller' + values: + - './helm_vars/nginx-ingress-controller/values.yaml' + + - name: '{{ .Values.namespace }}-nginx-ingress-services' + namespace: '{{ .Values.namespace }}' + chart: '../.local/charts/nginx-ingress-services' + values: + - './helm_vars/nginx-ingress-services/values.yaml' + - './helm_vars/nginx-ingress-services/certificates-namespace1.yaml' + set: + # Federation domain is also the SRV record created by the + # federation-test-helper service. Maybe we can find a way to make these + # differ, so we don't make any silly assumptions in the code. + - name: config.dns.federator + value: {{ .Values.federationDomain }} + + # Note that wire-server depends on databases-ephemeral being up; and in some + # cases on nginx-ingress also being up. If installing helm charts in a + # parallel way, it's expected to see some wire-server pods (namely the + # cassandra-migration one) fail and get restarted a few times) + - name: '{{ .Values.namespace }}-wire-server' + namespace: '{{ .Values.namespace }}' + chart: '../.local/charts/wire-server' + values: + - './helm_vars/wire-server/values.yaml.gotmpl' + - './helm_vars/wire-server/certificates-namespace1.yaml' + set: + - name: brig.config.optSettings.setFederationDomain + value: {{ .Values.federationDomain }} + - name: galley.config.settings.federationDomain + value: {{ .Values.federationDomain }} diff --git a/hack/helmfile.yaml b/hack/helmfile.yaml new file mode 100644 index 0000000000..578cef0d9a --- /dev/null +++ b/hack/helmfile.yaml @@ -0,0 +1,122 @@ +# This helfile is used for the setup of two ephemeral backends on kubernetes +# during integration testing (including federation integration tests spanning +# over 2 backends) +# This helmfile is used via the './hack/bin/integration-setup-federation.sh' via +# 'make kube-integration-setup', which set environment variables required here +# and generate some keys. + +helmDefaults: + wait: true + timeout: 600 + devel: true + createNamespace: true + +environments: + default: + values: + - namespace: {{ requiredEnv "NAMESPACE_1" }} + - federationDomain: {{ requiredEnv "FEDERATION_DOMAIN_1" }} + - namespaceFed2: {{ requiredEnv "NAMESPACE_2" }} + - federationDomainFed2: {{ requiredEnv "FEDERATION_DOMAIN_2" }} + - imagePullPolicy: Always + kind: + values: + - namespace: {{ requiredEnv "NAMESPACE_1" }} + - federationDomain: {{ requiredEnv "FEDERATION_DOMAIN_1" }} + - namespaceFed2: {{ requiredEnv "NAMESPACE_2" }} + - federationDomainFed2: {{ requiredEnv "FEDERATION_DOMAIN_2" }} + - imagePullPolicy: Never + +repositories: + - name: stable + url: 'https://charts.helm.sh/stable' + +releases: + - name: '{{ .Values.namespace }}-fake-aws' + namespace: '{{ .Values.namespace }}' + chart: '../.local/charts/fake-aws' + values: + - './helm_vars/fake-aws/values.yaml' + + - name: '{{ .Values.namespace }}-fake-aws-2' + namespace: '{{ .Values.namespaceFed2 }}' + chart: '../.local/charts/fake-aws' + values: + - './helm_vars/fake-aws/values.yaml' + + - name: '{{ .Values.namespace }}-databases-ephemeral' + namespace: '{{ .Values.namespace }}' + chart: '../.local/charts/databases-ephemeral' + + - name: '{{ .Values.namespace }}-databases-ephemeral-2' + namespace: '{{ .Values.namespaceFed2 }}' + chart: '../.local/charts/databases-ephemeral' + + - name: '{{ .Values.namespace }}-nginx-ingress-controller' + namespace: '{{ .Values.namespace }}' + chart: '../.local/charts/nginx-ingress-controller' + values: + - './helm_vars/nginx-ingress-controller/values.yaml' + + - name: '{{ .Values.namespace }}-nginx-ingress-controller-2' + namespace: '{{ .Values.namespaceFed2 }}' + chart: '../.local/charts/nginx-ingress-controller' + values: + - './helm_vars/nginx-ingress-controller/values.yaml' + + - name: '{{ .Values.namespace }}-nginx-ingress-services' + namespace: '{{ .Values.namespace }}' + chart: '../.local/charts/nginx-ingress-services' + values: + - './helm_vars/nginx-ingress-services/values.yaml' + - './helm_vars/nginx-ingress-services/certificates-namespace1.yaml' + set: + # Federation domain is also the SRV record created by the + # federation-test-helper service. Maybe we can find a way to make these + # differ, so we don't make any silly assumptions in the code. + - name: config.dns.federator + value: {{ .Values.federationDomain }} + + - name: '{{ .Values.namespace }}-nginx-ingress-services-2' + namespace: '{{ .Values.namespaceFed2 }}' + chart: '../.local/charts/nginx-ingress-services' + values: + - './helm_vars/nginx-ingress-services/values.yaml' + - './helm_vars/nginx-ingress-services/certificates-namespace2.yaml' + set: + # Federation domain is also the SRV record created by the + # federation-test-helper service. Maybe we can find a way to make these + # differ, so we don't make any silly assumptions in the code. + - name: config.dns.federator + value: {{ .Values.federationDomainFed2 }} + + #--------------------------------------------- + # + # Note that wire-server depends on databases-ephemeral being up; and in some + # cases on nginx-ingress also being up. If installing helm charts in a + # parallel way, it's expected to see some wire-server pods (namely the + # cassandra-migration one) fail and get restarted a few times) + + - name: '{{ .Values.namespace }}-wire-server' + namespace: '{{ .Values.namespace }}' + chart: '../.local/charts/wire-server' + values: + - './helm_vars/wire-server/values.yaml.gotmpl' + - './helm_vars/wire-server/certificates-namespace1.yaml' + set: + - name: brig.config.optSettings.setFederationDomain + value: {{ .Values.federationDomain }} + - name: galley.config.settings.federationDomain + value: {{ .Values.federationDomain }} + + - name: '{{ .Values.namespace }}-wire-server-2' + namespace: '{{ .Values.namespaceFed2 }}' + chart: '../.local/charts/wire-server' + values: + - './helm_vars/wire-server/values.yaml.gotmpl' + - './helm_vars/wire-server/certificates-namespace2.yaml' + set: + - name: brig.config.optSettings.setFederationDomain + value: {{ .Values.federationDomainFed2 }} + - name: galley.config.settings.federationDomain + value: {{ .Values.federationDomainFed2 }} diff --git a/libs/api-bot/src/Network/Wire/Bot/Assert.hs b/libs/api-bot/src/Network/Wire/Bot/Assert.hs index 4140b3ff33..b94a1367c8 100644 --- a/libs/api-bot/src/Network/Wire/Bot/Assert.hs +++ b/libs/api-bot/src/Network/Wire/Bot/Assert.hs @@ -21,7 +21,7 @@ module Network.Wire.Bot.Assert where import Data.Id (ConvId, UserId) -import Data.Qualified (qUnqualified) +import Data.Qualified (Local, QualifiedWithTag (qUntagged), qUnqualified, qualifyAs) import qualified Data.Set as Set import Imports import Network.Wire.Bot.Monad @@ -31,7 +31,7 @@ import Network.Wire.Client.API.User assertConvCreated :: (HasCallStack, MonadBotNet m) => - ConvId -> + Local ConvId -> -- | The creator of the conversation. Bot -> -- | The other users in the conversation. @@ -41,14 +41,14 @@ assertConvCreated c b bs = do let everyone = b : bs forM_ bs $ \u -> let others = Set.fromList . filter (/= botId u) . map botId $ everyone - in assertEvent u TConvCreate (convCreate (botId u) others) + in assertEvent u TConvCreate (convCreate (qUntagged . qualifyAs c . botId $ u) others) where convCreate self others = \case EConvCreate e -> let cnv = convEvtData e mems = cnvMembers cnv omems = Set.fromList (map (qUnqualified . omQualifiedId) (cmOthers mems)) - in (qUnqualified . cnvQualifiedId $ cnv) == c + in cnvQualifiedId cnv == qUntagged c && convEvtFrom e == botId b && cnvType cnv == RegularConv && memId (cmSelf mems) == self diff --git a/libs/api-bot/src/Network/Wire/Bot/Monad.hs b/libs/api-bot/src/Network/Wire/Bot/Monad.hs index 5c78e8b851..45f65c4e3d 100644 --- a/libs/api-bot/src/Network/Wire/Bot/Monad.hs +++ b/libs/api-bot/src/Network/Wire/Bot/Monad.hs @@ -88,6 +88,7 @@ module Network.Wire.Bot.Monad BotNetException (..), BotNetFailure (..), try, + qualifyLocal, ) where @@ -104,6 +105,7 @@ import Data.Id import Data.Metrics (Metrics) import qualified Data.Metrics as Metrics import Data.Misc (PlainTextPassword (..)) +import Data.Qualified (Local, toLocalUnsafe) import Data.Text (pack, unpack) import Data.Time.Clock import Data.Time.Format (defaultTimeLocale, formatTime, parseTimeOrError) @@ -525,6 +527,9 @@ withCachedBot t f = do viewFederationDomain :: MonadBotNet m => m Domain viewFederationDomain = liftBotNet . BotNet $ asks botNetDomain +qualifyLocal :: MonadBotNet m => a -> m (Local a) +qualifyLocal a = toLocalUnsafe <$> viewFederationDomain <*> pure a + ------------------------------------------------------------------------------- -- Assertions diff --git a/libs/bilge/src/Bilge/RPC.hs b/libs/bilge/src/Bilge/RPC.hs index 50d8a6507b..04cb232ec3 100644 --- a/libs/bilge/src/Bilge/RPC.hs +++ b/libs/bilge/src/Bilge/RPC.hs @@ -33,7 +33,7 @@ import Bilge.IO import Bilge.Request import Bilge.Response import Control.Error hiding (err) -import Control.Monad.Catch (MonadThrow (..)) +import Control.Monad.Catch (MonadCatch, MonadThrow (..), try) import Control.Monad.Except import Data.Aeson (FromJSON, eitherDecode') import Data.CaseInsensitive (original) @@ -41,7 +41,6 @@ import Data.Text.Lazy (pack) import Imports hiding (log) import qualified Network.HTTP.Client as HTTP import System.Logger.Class -import UnliftIO.Exception (try) class HasRequestId m where getRequestId :: m RequestId @@ -69,7 +68,7 @@ instance Show RPCException where . showString "}" rpc :: - (MonadUnliftIO m, MonadHttp m, HasRequestId m, MonadLogger m, MonadThrow m) => + (MonadIO m, MonadCatch m, MonadHttp m, HasRequestId m) => LText -> (Request -> Request) -> m (Response (Maybe LByteString)) @@ -81,7 +80,7 @@ rpc sys = rpc' sys empty -- Note: 'syncIO' is wrapped around the IO action performing the request -- and any exceptions caught are re-thrown in an 'RPCException'. rpc' :: - (MonadUnliftIO m, MonadHttp m, HasRequestId m, MonadThrow m) => + (MonadIO m, MonadCatch m, MonadHttp m, HasRequestId m) => -- | A label for the remote system in case of 'RPCException's. LText -> Request -> diff --git a/libs/brig-types/src/Brig/Types/Connection.hs b/libs/brig-types/src/Brig/Types/Connection.hs index dc80c88c75..73bb4a802a 100644 --- a/libs/brig-types/src/Brig/Types/Connection.hs +++ b/libs/brig-types/src/Brig/Types/Connection.hs @@ -25,7 +25,6 @@ module Brig.Types.Connection ( module C, UserIds (..), - ConnectionsStatusRequest (..), UpdateConnectionsInternal (..), -- * re-exports @@ -40,6 +39,7 @@ where import Brig.Types.Common as C import Data.Aeson import Data.Id (UserId) +import Data.Qualified import Imports import Wire.API.Arbitrary import Wire.API.Connection @@ -51,13 +51,6 @@ data UserIds = UserIds {cUsers :: [UserId]} deriving (Eq, Show, Generic) --- | Data that is passed to the @\/i\/users\/connections-status@ endpoint. -data ConnectionsStatusRequest = ConnectionsStatusRequest - { csrFrom :: ![UserId], - csrTo :: !(Maybe [UserId]) - } - deriving (Eq, Show, Generic) - -- FUTUREWORK: This needs to get Qualified IDs when implementing -- Legalhold + Federation, as it's used in the internal -- putConnectionInternal / galley->Brig "/i/users/connections-status" @@ -67,6 +60,8 @@ data ConnectionsStatusRequest = ConnectionsStatusRequest data UpdateConnectionsInternal = BlockForMissingLHConsent UserId [UserId] | RemoveLHBlocksInvolving UserId + | -- | This must only be used by tests + CreateConnectionForTest UserId (Qualified UserId) deriving (Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform UpdateConnectionsInternal) @@ -86,16 +81,3 @@ instance ToJSON UserIds where toJSON (UserIds us) = object ["ids" .= us] - -instance FromJSON ConnectionsStatusRequest where - parseJSON = withObject "ConnectionsStatusRequest" $ \o -> do - csrFrom <- o .: "from" - csrTo <- o .: "to" - pure ConnectionsStatusRequest {..} - -instance ToJSON ConnectionsStatusRequest where - toJSON ConnectionsStatusRequest {csrFrom, csrTo} = - object - [ "from" .= csrFrom, - "to" .= csrTo - ] diff --git a/libs/brig-types/src/Brig/Types/Intra.hs b/libs/brig-types/src/Brig/Types/Intra.hs index 7093688a1a..1a29afb02f 100644 --- a/libs/brig-types/src/Brig/Types/Intra.hs +++ b/libs/brig-types/src/Brig/Types/Intra.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} -- This file is part of the Wire Server implementation. @@ -24,7 +23,6 @@ module Brig.Types.Intra ( AccountStatus (..), AccountStatusUpdate (..), AccountStatusResp (..), - ConnectionStatus (..), UserAccount (..), NewUserScimInvitation (..), UserSet (..), @@ -91,30 +89,6 @@ instance FromJSON AccountStatusUpdate where instance ToJSON AccountStatusUpdate where toJSON s = object ["status" .= suStatus s] -------------------------------------------------------------------------------- --- ConnectionStatus - -data ConnectionStatus = ConnectionStatus - { csFrom :: !UserId, - csTo :: !UserId, - csStatus :: !Relation - } - deriving (Eq, Show, Generic) - -instance FromJSON ConnectionStatus where - parseJSON = withObject "connection-status" $ \o -> - ConnectionStatus <$> o .: "from" - <*> o .: "to" - <*> o .: "status" - -instance ToJSON ConnectionStatus where - toJSON cs = - object - [ "from" .= csFrom cs, - "to" .= csTo cs, - "status" .= csStatus cs - ] - ------------------------------------------------------------------------------- -- UserAccount diff --git a/libs/brig-types/src/Brig/Types/User/Event.hs b/libs/brig-types/src/Brig/Types/User/Event.hs index efe7c991f8..382eae7af5 100644 --- a/libs/brig-types/src/Brig/Types/User/Event.hs +++ b/libs/brig-types/src/Brig/Types/User/Event.hs @@ -23,7 +23,7 @@ import Brig.Types import Data.ByteString.Conversion import Data.Handle (Handle) import Data.Id -import Data.Qualified (Qualified (Qualified)) +import Data.Qualified import Imports import System.Logger.Class @@ -44,7 +44,7 @@ data UserEvent -- has been restored. UserResumed !UserId | -- | The user account has been deleted. - UserDeleted !UserId + UserDeleted !(Qualified UserId) | UserUpdated !UserUpdatedData | UserIdentityUpdated !UserIdentityUpdatedData | UserIdentityRemoved !UserIdentityRemovedData @@ -162,19 +162,6 @@ emptyUserUpdatedData u = connEventUserId :: ConnectionEvent -> UserId connEventUserId ConnectionUpdated {..} = ucFrom ucConn -userEventUserId :: UserEvent -> UserId -userEventUserId (UserCreated u) = userId u -userEventUserId (UserActivated u) = userId u -userEventUserId (UserSuspended u) = u -userEventUserId (UserResumed u) = u -userEventUserId (UserDeleted u) = u -userEventUserId (UserUpdated u) = eupId u -userEventUserId (UserIdentityUpdated u) = eiuId u -userEventUserId (UserIdentityRemoved u) = eirId u -userEventUserId (UserLegalHoldDisabled uid) = uid -userEventUserId (UserLegalHoldEnabled uid) = uid -userEventUserId (LegalHoldClientRequested dat) = lhcTargetUser dat - propEventUserId :: PropertyEvent -> UserId propEventUserId (PropertySet u _ _) = u propEventUserId (PropertyDeleted u _) = u @@ -198,16 +185,16 @@ instance ToBytes Event where bytes (ClientEvent e) = bytes e instance ToBytes UserEvent where - bytes e@UserCreated {} = val "user.new: " +++ toByteString (userEventUserId e) - bytes e@UserActivated {} = val "user.activate: " +++ toByteString (userEventUserId e) - bytes e@UserUpdated {} = val "user.update: " +++ toByteString (userEventUserId e) - bytes e@UserIdentityUpdated {} = val "user.update: " +++ toByteString (userEventUserId e) - bytes e@UserIdentityRemoved {} = val "user.identity-remove: " +++ toByteString (userEventUserId e) - bytes e@UserSuspended {} = val "user.suspend: " +++ toByteString (userEventUserId e) - bytes e@UserResumed {} = val "user.resume: " +++ toByteString (userEventUserId e) - bytes e@UserDeleted {} = val "user.delete: " +++ toByteString (userEventUserId e) - bytes e@UserLegalHoldDisabled {} = val "user.legalhold-disable: " +++ toByteString (userEventUserId e) - bytes e@UserLegalHoldEnabled {} = val "user.legalhold-enable: " +++ toByteString (userEventUserId e) + bytes (UserCreated u) = val "user.new: " +++ toByteString (userId u) + bytes (UserActivated u) = val "user.activate: " +++ toByteString (userId u) + bytes (UserUpdated u) = val "user.update: " +++ toByteString (eupId u) + bytes (UserIdentityUpdated u) = val "user.update: " +++ toByteString (eiuId u) + bytes (UserIdentityRemoved u) = val "user.identity-remove: " +++ toByteString (eirId u) + bytes (UserSuspended u) = val "user.suspend: " +++ toByteString u + bytes (UserResumed u) = val "user.resume: " +++ toByteString u + bytes (UserDeleted u) = val "user.delete: " +++ toByteString (qUnqualified u) +++ val "@" +++ toByteString (qDomain u) + bytes (UserLegalHoldDisabled u) = val "user.legalhold-disable: " +++ toByteString u + bytes (UserLegalHoldEnabled u) = val "user.legalhold-enable: " +++ toByteString u bytes (LegalHoldClientRequested payload) = val "user.legalhold-request: " +++ show payload instance ToBytes ConnectionEvent where diff --git a/libs/galley-types/galley-types.cabal b/libs/galley-types/galley-types.cabal index 891555cac7..60a176f4a1 100644 --- a/libs/galley-types/galley-types.cabal +++ b/libs/galley-types/galley-types.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 8d07ea070b6384ec247f4473abb198bbb9639f72543920cbe46f561df96963ca +-- hash: ccecf8384a3050034fc05928ae9bd039006f4479289f73de11832052791a691f name: galley-types version: 0.81.0 @@ -22,7 +22,9 @@ library Galley.Types Galley.Types.Bot Galley.Types.Bot.Service + Galley.Types.Conversations.Intra Galley.Types.Conversations.Members + Galley.Types.Conversations.One2One Galley.Types.Conversations.Roles Galley.Types.Teams Galley.Types.Teams.Intra @@ -37,16 +39,23 @@ library QuickCheck , aeson >=0.6 , base >=4 && <5 + , bytestring + , bytestring-conversion , containers >=0.5 + , cryptonite , currency-codes >=2.0 + , errors , exceptions >=0.10.0 , imports , lens >=4.12 + , memory + , schema-profunctor , string-conversions , tagged , text >=0.11 , time >=1.4 , types-common >=0.16 + , uuid , wire-api default-language: Haskell2010 diff --git a/libs/galley-types/package.yaml b/libs/galley-types/package.yaml index 3c8971ad0a..d692a08ae4 100644 --- a/libs/galley-types/package.yaml +++ b/libs/galley-types/package.yaml @@ -16,16 +16,23 @@ library: dependencies: - aeson >=0.6 - base >=4 && <5 + - bytestring + - bytestring-conversion - containers >=0.5 + - cryptonite - currency-codes >=2.0 + - errors - exceptions >=0.10.0 - lens >=4.12 + - memory - QuickCheck + - schema-profunctor - string-conversions - tagged - text >=0.11 - time >=1.4 - types-common >=0.16 + - uuid tests: galley-types-tests: main: Main.hs diff --git a/libs/galley-types/src/Galley/Types.hs b/libs/galley-types/src/Galley/Types.hs index 6b0a86f099..e9f69bbb43 100644 --- a/libs/galley-types/src/Galley/Types.hs +++ b/libs/galley-types/src/Galley/Types.hs @@ -24,7 +24,6 @@ module Galley.Types -- * re-exports ConversationMetadata (..), Conversation (..), - cnvQualifiedId, cnvType, cnvCreator, cnvAccess, diff --git a/libs/galley-types/src/Galley/Types/Conversations/Intra.hs b/libs/galley-types/src/Galley/Types/Conversations/Intra.hs new file mode 100644 index 0000000000..0cb0ba9afd --- /dev/null +++ b/libs/galley-types/src/Galley/Types/Conversations/Intra.hs @@ -0,0 +1,87 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Types.Conversations.Intra + ( DesiredMembership (..), + Actor (..), + UpsertOne2OneConversationRequest (..), + UpsertOne2OneConversationResponse (..), + ) +where + +import qualified Data.Aeson as A +import Data.Aeson.Types (FromJSON, ToJSON) +import Data.Id (ConvId, UserId) +import Data.Qualified +import Data.Schema +import Imports + +data DesiredMembership = Included | Excluded + deriving (Show, Eq, Generic) + deriving (FromJSON, ToJSON) via Schema DesiredMembership + +instance ToSchema DesiredMembership where + schema = + enum @Text "DesiredMembership" $ + mconcat + [ element "included" Included, + element "excluded" Excluded + ] + +data Actor = LocalActor | RemoteActor + deriving (Show, Eq, Generic) + deriving (FromJSON, ToJSON) via Schema Actor + +instance ToSchema Actor where + schema = + enum @Text "Actor" $ + mconcat + [ element "local_actor" LocalActor, + element "remote_actor" RemoteActor + ] + +data UpsertOne2OneConversationRequest = UpsertOne2OneConversationRequest + { uooLocalUser :: Local UserId, + uooRemoteUser :: Remote UserId, + uooActor :: Actor, + uooActorDesiredMembership :: DesiredMembership, + uooConvId :: Maybe (Qualified ConvId) + } + deriving (Show, Generic) + deriving (FromJSON, ToJSON) via Schema UpsertOne2OneConversationRequest + +instance ToSchema UpsertOne2OneConversationRequest where + schema = + object "UpsertOne2OneConversationRequest" $ + UpsertOne2OneConversationRequest + <$> (qUntagged . uooLocalUser) .= field "local_user" (qTagUnsafe <$> schema) + <*> (qUntagged . uooRemoteUser) .= field "remote_user" (qTagUnsafe <$> schema) + <*> uooActor .= field "actor" schema + <*> uooActorDesiredMembership .= field "actor_desired_membership" schema + <*> uooConvId .= field "conversation_id" (optWithDefault A.Null schema) + +newtype UpsertOne2OneConversationResponse = UpsertOne2OneConversationResponse + { uuorConvId :: Qualified ConvId + } + deriving (Show, Generic) + deriving (FromJSON, ToJSON) via Schema UpsertOne2OneConversationResponse + +instance ToSchema UpsertOne2OneConversationResponse where + schema = + object "UpsertOne2OneConversationResponse" $ + UpsertOne2OneConversationResponse + <$> uuorConvId .= field "conversation_id" schema diff --git a/libs/galley-types/src/Galley/Types/Conversations/Members.hs b/libs/galley-types/src/Galley/Types/Conversations/Members.hs index 7e6a88c6db..42a3fb9dda 100644 --- a/libs/galley-types/src/Galley/Types/Conversations/Members.hs +++ b/libs/galley-types/src/Galley/Types/Conversations/Members.hs @@ -30,7 +30,6 @@ where import Data.Domain import Data.Id as Id import Data.Qualified -import Data.Tagged import Imports import Wire.API.Conversation import Wire.API.Conversation.Role (RoleName) @@ -46,7 +45,7 @@ data RemoteMember = RemoteMember remoteMemberToOther :: RemoteMember -> OtherMember remoteMemberToOther x = OtherMember - { omQualifiedId = unTagged (rmId x), + { omQualifiedId = qUntagged (rmId x), omService = Nothing, omConvRoleName = rmConvRoleName x } diff --git a/libs/galley-types/src/Galley/Types/Conversations/One2One.hs b/libs/galley-types/src/Galley/Types/Conversations/One2One.hs new file mode 100644 index 0000000000..bc608b70da --- /dev/null +++ b/libs/galley-types/src/Galley/Types/Conversations/One2One.hs @@ -0,0 +1,116 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Types.Conversations.One2One (one2OneConvId) where + +import Control.Error (atMay) +import qualified Crypto.Hash as Crypto +import Data.Bits +import Data.ByteArray (convert) +import qualified Data.ByteString as B +import Data.ByteString.Conversion +import qualified Data.ByteString.Lazy as L +import Data.Id +import Data.Qualified +import Data.UUID (UUID) +import qualified Data.UUID as UUID +import qualified Data.UUID.Tagged as U +import Imports + +-- | The hash function used to obtain the 1-1 conversation ID for a pair of users. +-- +-- /Note/: the hash function must always return byte strings of length > 16. +hash :: ByteString -> ByteString +hash = convert . Crypto.hash @ByteString @Crypto.SHA256 + +-- | A randomly-generated UUID to use as a namespace for the UUIDv5 of 1-1 +-- conversation IDs +namespace :: UUID +namespace = UUID.fromWords 0x9a51edb8 0x060c0d9a 0x0c2950a8 0x5d152982 + +compareDomains :: Ord a => Qualified a -> Qualified a -> Ordering +compareDomains (Qualified a1 dom1) (Qualified a2 dom2) = + compare (dom1, a1) (dom2, a2) + +quidToByteString :: Qualified UserId -> ByteString +quidToByteString (Qualified uid domain) = toByteString' uid <> toByteString' domain + +-- | This function returns the 1-1 conversation for a given pair of users. +-- +-- Let A, B denote the (not necessarily distinct) backends of the two users, +-- with the domain of A less or equal than the domain of B in the lexicographic +-- ordering of their ascii encodings. Given users a@A and b@B, the UUID and +-- owning domain of the unique 1-1 conversation between a and b shall be a +-- deterministic function of the input data, plus some fixed parameters, as +-- described below. +-- +-- __Parameters__ +-- +-- * A (collision-resistant) hash function h with N bits of output, where N +-- s a multiple of 8 strictly larger than 128; this is set to SHA256. +-- * A "namespace" UUID n. +-- +-- __Algorithm__ +-- +-- First, in the special case where A and B are the same backend, assume that +-- the UUID of a is lower than that of b. If that is not the case, swap a +-- and b in the following. This is necessary to ensure that the function we +-- describe below is symmetric in its arguments. +-- Let c be the bytestring obtained as the concatenation of the following 5 +-- components: +-- +-- * the 16 bytes of the namespace n +-- * the 16 bytes of the UUID of a +-- * the ascii encoding of the domain of A +-- * the 16 bytes of the UUID of b +-- * the ascii encoding of the domain of B, +-- +-- and let x = h(c) be its hashed value. The UUID of the 1-1 conversation +-- between a and b is obtained by converting the first 128 bits of x to a UUID +-- V5. Note that our use of V5 here is not strictly compliant with RFC 4122, +-- since we are using a custom hash and not necessarily SHA1. +-- +-- The owning domain for the conversation is set to be A if bit 128 of x (i.e. +-- the most significant bit of the octet at index 16) is 0, and B otherwise. +-- This is well-defined, because we assumed the number of bits of x to be +-- strictly larger than 128. +one2OneConvId :: Qualified UserId -> Qualified UserId -> Qualified ConvId +one2OneConvId a b = case compareDomains a b of + GT -> one2OneConvId b a + _ -> + let c = + mconcat + [ L.toStrict (UUID.toByteString namespace), + quidToByteString a, + quidToByteString b + ] + x = hash c + result = + U.toUUID . U.mk @U.V5 + . fromMaybe UUID.nil + -- fromByteString only returns 'Nothing' when the input is not + -- exactly 16 bytes long, here this should not be a case since + -- 'hash' is supposed to return atleast 16 bytes and we use 'B.take + -- 16' to truncate it + . UUID.fromByteString + . L.fromStrict + . B.take 16 + $ x + domain + | fromMaybe 0 (atMay (B.unpack x) 16) .&. 0x80 == 0 = qDomain a + | otherwise = qDomain b + in Qualified (Id result) domain diff --git a/libs/types-common/src/Data/Id.hs b/libs/types-common/src/Data/Id.hs index c06c897b7b..60f418eba1 100644 --- a/libs/types-common/src/Data/Id.hs +++ b/libs/types-common/src/Data/Id.hs @@ -1,5 +1,4 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -22,7 +21,36 @@ -- for UUID instances -module Data.Id where +module Data.Id + ( -- * Tagged IDs + Id (..), + IdTag, + KnownIdTag (..), + idTagName, + randomId, + AssetId, + InvitationId, + ConvId, + UserId, + ProviderId, + ServiceId, + TeamId, + ScimTokenId, + parseIdFromText, + idToText, + IdObject (..), + + -- * Client IDs + ClientId (..), + newClientId, + + -- * Other IDs + ConnId (..), + RequestId (..), + BotId (..), + NoId, + ) +where import Cassandra hiding (S) import Control.Lens ((?~)) @@ -56,39 +84,54 @@ import Servant (FromHttpApiData (..), ToHttpApiData (..)) import Test.QuickCheck import Test.QuickCheck.Instances () -data A +data IdTag = A | C | I | U | P | S | T | STo -data C +idTagName :: IdTag -> Text +idTagName A = "Asset" +idTagName C = "Conv" +idTagName I = "Invitation" +idTagName U = "User" +idTagName P = "Provider" +idTagName S = "Service" +idTagName T = "Team" +idTagName STo = "ScimToken" -data I +class KnownIdTag (t :: IdTag) where + idTagValue :: IdTag -data U +instance KnownIdTag 'A where idTagValue = A -data P +instance KnownIdTag 'C where idTagValue = C -data S +instance KnownIdTag 'I where idTagValue = I -data T +instance KnownIdTag 'U where idTagValue = U -data STo +instance KnownIdTag 'P where idTagValue = P -type AssetId = Id A +instance KnownIdTag 'S where idTagValue = S -type InvitationId = Id I +instance KnownIdTag 'T where idTagValue = T + +instance KnownIdTag 'STo where idTagValue = STo + +type AssetId = Id 'A + +type InvitationId = Id 'I -- | A local conversation ID -type ConvId = Id C +type ConvId = Id 'C -- | A local user ID -type UserId = Id U +type UserId = Id 'U -type ProviderId = Id P +type ProviderId = Id 'P -type ServiceId = Id S +type ServiceId = Id 'S -type TeamId = Id T +type TeamId = Id 'T -type ScimTokenId = Id STo +type ScimTokenId = Id 'STo -- Id ------------------------------------------------------------------------- diff --git a/libs/types-common/src/Data/Misc.hs b/libs/types-common/src/Data/Misc.hs index cb0214a710..2f731095dd 100644 --- a/libs/types-common/src/Data/Misc.hs +++ b/libs/types-common/src/Data/Misc.hs @@ -350,5 +350,5 @@ instance Arbitrary PlainTextPassword where -- -- Example: -- >>> let (FutureWork @'LegalholdPlusFederationNotImplemented -> _remoteUsers, localUsers) --- >>> = partitionRemoteOrLocalIds domain qualifiedUids +-- >>> = partitionQualified domain qualifiedUids newtype FutureWork label payload = FutureWork payload diff --git a/libs/types-common/src/Data/Qualified.hs b/libs/types-common/src/Data/Qualified.hs index 6a01d6d10a..4bce70e078 100644 --- a/libs/types-common/src/Data/Qualified.hs +++ b/libs/types-common/src/Data/Qualified.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE StrictData #-} @@ -21,35 +22,37 @@ module Data.Qualified ( -- * Qualified Qualified (..), + qToPair, + QualifiedWithTag, + tUnqualified, + tUnqualifiedL, + tDomain, + qUntagged, + qTagUnsafe, Remote, - toRemote, + toRemoteUnsafe, Local, - toLocal, - lUnqualified, - lDomain, + toLocalUnsafe, qualifyAs, foldQualified, - renderQualifiedId, - partitionRemoteOrLocalIds, - partitionRemoteOrLocalIds', partitionQualified, + partitionQualifiedAndTag, + indexQualified, + bucketQualified, + bucketRemote, deprecatedSchema, - partitionRemote, ) where -import Control.Lens ((?~)) +import Control.Lens (Lens, lens, (?~)) import Data.Aeson (FromJSON (..), ToJSON (..)) import Data.Bifunctor (first) -import Data.Domain (Domain, domainText) +import Data.Domain (Domain) import Data.Handle (Handle (..)) -import Data.Id (Id (toUUID)) +import Data.Id import qualified Data.Map as Map import Data.Schema -import Data.String.Conversions (cs) import qualified Data.Swagger as S -import Data.Tagged -import qualified Data.UUID as UUID import Imports hiding (local) import Test.QuickCheck (Arbitrary (arbitrary)) @@ -62,71 +65,96 @@ data Qualified a = Qualified } deriving stock (Eq, Ord, Show, Generic, Functor, Foldable, Traversable) --- | A type to differentiate between generally Qualified values, and values --- where it is known if they are coming from a Remote backend or not. --- Use 'toRemote' or 'partitionRemoteOrLocalIds\'' to get Remote values and use --- 'unTagged' to convert from a Remote value back to a plain Qualified one. -type Remote a = Tagged "remote" (Qualified a) +qToPair :: Qualified a -> (Domain, a) +qToPair (Qualified x dom) = (dom, x) --- | Convert a Qualified something to a Remote something. -toRemote :: Qualified a -> Remote a -toRemote = Tagged +data QTag = QLocal | QRemote + deriving (Eq, Show) --- | A type representing a Qualified value where the domain is guaranteed to be --- the local one. -type Local a = Tagged "local" (Qualified a) +-- | A type to differentiate between generally 'Qualified' values, and "tagged" values, +-- for which it is known whether they are coming from a remote or local backend. +-- Use 'foldQualified', 'partitionQualified' or 'qualifyLocal' to get tagged values and use +-- 'qUntagged' to convert from a tagged value back to a plain 'Qualified' one. +newtype QualifiedWithTag (t :: QTag) a = QualifiedWithTag {qUntagged :: Qualified a} + deriving stock (Eq, Ord, Show, Functor, Foldable, Traversable) + deriving newtype (Arbitrary) -toLocal :: Qualified a -> Local a -toLocal = Tagged +qTagUnsafe :: forall t a. Qualified a -> QualifiedWithTag t a +qTagUnsafe = QualifiedWithTag -lUnqualified :: Local a -> a -lUnqualified = qUnqualified . unTagged +tUnqualified :: QualifiedWithTag t a -> a +tUnqualified = qUnqualified . qUntagged -lDomain :: Local a -> Domain -lDomain = qDomain . unTagged +tDomain :: QualifiedWithTag t a -> Domain +tDomain = qDomain . qUntagged + +tUnqualifiedL :: Lens (QualifiedWithTag t a) (QualifiedWithTag t b) a b +tUnqualifiedL = lens tUnqualified qualifyAs + +-- | A type representing a 'Qualified' value where the domain is guaranteed to +-- be remote. +type Remote = QualifiedWithTag 'QRemote + +-- | Convert a 'Domain' and an @a@ to a 'Remote' value. This is only safe if we +-- already know that the domain is remote. +toRemoteUnsafe :: Domain -> a -> Remote a +toRemoteUnsafe d a = qTagUnsafe $ Qualified a d + +-- | A type representing a 'Qualified' value where the domain is guaranteed to +-- be local. +type Local = QualifiedWithTag 'QLocal + +-- | Convert a 'Domain' and an @a@ to a 'Local' value. This is only safe if we +-- already know that the domain is local. +toLocalUnsafe :: Domain -> a -> Local a +toLocalUnsafe d a = qTagUnsafe $ Qualified a d -- | Convert an unqualified value to a qualified one, with the same tag as the -- given tagged qualified value. -qualifyAs :: Tagged t (Qualified x) -> a -> Tagged t (Qualified a) -qualifyAs (Tagged q) x = Tagged (q $> x) +qualifyAs :: QualifiedWithTag t x -> a -> QualifiedWithTag t a +qualifyAs = ($>) foldQualified :: Local x -> (Local a -> b) -> (Remote a -> b) -> Qualified a -> b foldQualified loc f g q - | lDomain loc == qDomain q = - f (toLocal q) + | tDomain loc == qDomain q = + f (qTagUnsafe q) | otherwise = - g (toRemote q) - --- | FUTUREWORK: Maybe delete this, it is only used in printing federation not --- implemented errors -renderQualified :: (a -> Text) -> Qualified a -> Text -renderQualified renderLocal (Qualified localPart domain) = - renderLocal localPart <> "@" <> domainText domain - --- FUTUREWORK: we probably want to use the primed function everywhere. Refactor these two functions to only have one. -partitionRemoteOrLocalIds :: Foldable f => Domain -> f (Qualified a) -> ([Qualified a], [a]) -partitionRemoteOrLocalIds localDomain = foldMap $ \qualifiedId -> - if qDomain qualifiedId == localDomain - then (mempty, [qUnqualified qualifiedId]) - else ([qualifiedId], mempty) - -partitionRemoteOrLocalIds' :: Foldable f => Domain -> f (Qualified a) -> ([Remote a], [a]) -partitionRemoteOrLocalIds' localDomain xs = first (fmap toRemote) $ partitionRemoteOrLocalIds localDomain xs - --- | Index a list of qualified values by domain -partitionQualified :: Foldable f => f (Qualified a) -> Map Domain [a] -partitionQualified = foldr add mempty + g (qTagUnsafe q) + +-- Partition a collection of qualified values into locals and remotes. +-- +-- Note that the local values are returned as unqualified values, as a (probably +-- insignificant) optimisation. Use 'partitionQualifiedAndTag' to get them as +-- 'Local' values. +partitionQualified :: Foldable f => Local x -> f (Qualified a) -> ([a], [Remote a]) +partitionQualified loc = + foldMap $ + foldQualified loc (\l -> ([tUnqualified l], mempty)) (\r -> (mempty, [r])) + +partitionQualifiedAndTag :: Foldable f => Local x -> f (Qualified a) -> ([Local a], [Remote a]) +partitionQualifiedAndTag loc = + first (map (qualifyAs loc)) + . partitionQualified loc + +-- | Index a list of qualified values by domain. +indexQualified :: Foldable f => f (Qualified a) -> Map Domain [a] +indexQualified = foldr add mempty where add :: Qualified a -> Map Domain [a] -> Map Domain [a] add (Qualified x domain) = Map.insertWith (<>) domain [x] -partitionRemote :: (Functor f, Foldable f) => f (Remote a) -> [(Domain, [a])] -partitionRemote remotes = Map.assocs $ partitionQualified (unTagged <$> remotes) +-- | Bucket a list of qualified values by domain. +bucketQualified :: Foldable f => f (Qualified a) -> [Qualified [a]] +bucketQualified = map (\(d, a) -> Qualified a d) . Map.assocs . indexQualified ----------------------------------------------------------------------- +bucketRemote :: (Functor f, Foldable f) => f (Remote a) -> [Remote [a]] +bucketRemote = + map (uncurry toRemoteUnsafe) + . Map.assocs + . indexQualified + . fmap qUntagged -renderQualifiedId :: Qualified (Id a) -> Text -renderQualifiedId = renderQualified (cs . UUID.toString . toUUID) +---------------------------------------------------------------------- deprecatedSchema :: S.HasDescription doc (Maybe Text) => Text -> ValueSchema doc a -> ValueSchema doc a deprecatedSchema new = doc . description ?~ ("Deprecated, use " <> new) @@ -142,19 +170,19 @@ qualifiedSchema name fieldName sch = <$> qUnqualified .= field fieldName sch <*> qDomain .= field "domain" schema -instance ToSchema (Qualified (Id a)) where - schema = qualifiedSchema "UserId" "id" schema +instance KnownIdTag t => ToSchema (Qualified (Id t)) where + schema = qualifiedSchema (idTagName (idTagValue @t) <> "Id") "id" schema instance ToSchema (Qualified Handle) where schema = qualifiedSchema "Handle" "handle" schema -instance ToJSON (Qualified (Id a)) where +instance KnownIdTag t => ToJSON (Qualified (Id t)) where toJSON = schemaToJSON -instance FromJSON (Qualified (Id a)) where +instance KnownIdTag t => FromJSON (Qualified (Id t)) where parseJSON = schemaParseJSON -instance S.ToSchema (Qualified (Id a)) where +instance KnownIdTag t => S.ToSchema (Qualified (Id t)) where declareNamedSchema = schemaToSwagger instance ToJSON (Qualified Handle) where diff --git a/libs/types-common/src/Data/Range.hs b/libs/types-common/src/Data/Range.hs index 832746ccc1..d244a6fa65 100644 --- a/libs/types-common/src/Data/Range.hs +++ b/libs/types-common/src/Data/Range.hs @@ -30,6 +30,7 @@ module Data.Range checked, checkedEither, checkedEitherMsg, + rangedChunks, errorMsg, unsafeRange, fromRange, @@ -286,6 +287,14 @@ checkedEither x = do Nothing -> Left (errorMsg (fromSing sn) (fromSing sm) "") Just r -> Right r +rangedChunks :: forall a n. (Within [a] 1 n, KnownNat n) => [a] -> [Range 1 n [a]] +rangedChunks xs = + let (headPart, tailPart) = splitAt (fromIntegral (natVal (Proxy @n))) xs + in -- Since n >= 1, headPart being empty can only be when 'xs' was empty. + case headPart of + [] -> [] + _ -> Range headPart : rangedChunks tailPart + unsafeRange :: (Show a, Within a n m) => a -> Range n m a unsafeRange x = fromMaybe (msg sing sing) (checked x) where diff --git a/libs/types-common/src/Data/UUID/Tagged.hs b/libs/types-common/src/Data/UUID/Tagged.hs index cd822e7d04..e3552f0b0b 100644 --- a/libs/types-common/src/Data/UUID/Tagged.hs +++ b/libs/types-common/src/Data/UUID/Tagged.hs @@ -17,12 +17,16 @@ module Data.UUID.Tagged ( UUID, + toUUID, V4, + V5, Version (..), version, variant, addv4, unpack, + create, + mk, ) where @@ -30,35 +34,43 @@ import Data.Bits import qualified Data.UUID as D import qualified Data.UUID.V4 as D4 import Imports -import Test.QuickCheck (Arbitrary, arbitrary) -- | Versioned UUID. -newtype UUID v = UUID D.UUID deriving (Eq, Ord, Show) +newtype UUID v = UUID {toUUID :: D.UUID} + deriving (Eq, Ord, Show) instance NFData (UUID v) where rnf (UUID a) = seq a () class Version v where - -- | Create a fresh versioned UUID. - create :: IO (UUID v) - -- | Try to turn a plain UUID into a versioned UUID. fromUUID :: D.UUID -> Maybe (UUID v) + fromUUID u = guard (version u == versionValue @v) $> UUID u + + versionValue :: Word32 data V4 instance Version V4 where - create = UUID <$> D4.nextRandom - fromUUID u = case version u of - 4 -> Just (UUID u) - _ -> Nothing - -instance Arbitrary (UUID V4) where - arbitrary = do - a <- arbitrary - b <- retainVersion 4 <$> arbitrary - c <- retainVariant 2 <$> arbitrary - d <- arbitrary - pure $ UUID $ D.fromWords a b c d + versionValue = 4 + +data V5 + +instance Version V5 where + versionValue = 5 + +mk :: forall v. Version v => D.UUID -> UUID v +mk u = UUID $ + case D.toWords u of + (x0, x1, x2, x3) -> + D.fromWords + x0 + (retainVersion (versionValue @v) x1) + (retainVariant 2 x2) + x3 + +-- | Create a fresh UUIDv4. +create :: IO (UUID V4) +create = UUID <$> D4.nextRandom -- | Extract the 'D.UUID' from a versioned UUID. unpack :: UUID v -> D.UUID diff --git a/libs/types-common/test/Test/Qualified.hs b/libs/types-common/test/Test/Qualified.hs index 8e11f79103..1787d475a9 100644 --- a/libs/types-common/test/Test/Qualified.hs +++ b/libs/types-common/test/Test/Qualified.hs @@ -22,14 +22,11 @@ where import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON)) import qualified Data.Aeson.Types as Aeson -import Data.Domain (Domain (..)) import Data.Handle (Handle) -import Data.Id (Id (..), UserId) -import Data.Qualified (Qualified (..), renderQualifiedId) -import qualified Data.UUID as UUID +import Data.Id (UserId) +import Data.Qualified (Qualified (..)) import Imports import Test.Tasty -import Test.Tasty.HUnit import Test.Tasty.QuickCheck import Type.Reflection (typeRep) @@ -42,13 +39,7 @@ tests = testQualifiedSerialization :: [TestTree] testQualifiedSerialization = - [ testCase "render 61a73a52-e526-4892-82a9-3d638d77629f@example.com" $ do - uuid <- - maybe (assertFailure "invalid UUID") pure $ - UUID.fromString "61a73a52-e526-4892-82a9-3d638d77629f" - assertEqual "" "61a73a52-e526-4892-82a9-3d638d77629f@example.com" $ - (renderQualifiedId (Qualified (Id uuid) (Domain "example.com"))), - jsonRoundtrip @(Qualified Handle), + [ jsonRoundtrip @(Qualified Handle), jsonRoundtrip @(Qualified UserId) ] diff --git a/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs b/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs index e2181ca099..8986d39e89 100644 --- a/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs +++ b/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs @@ -170,7 +170,7 @@ compile routes = Route.prepare (Route.renderer predicateError >> routes) messageStr (Just t) = char7 ':' <> char7 ' ' <> byteString t messageStr Nothing = mempty -route :: (MonadCatch m, MonadIO m) => Tree (App m) -> Request -> Continue IO -> m ResponseReceived +route :: MonadIO m => Tree (App m) -> Request -> Continue IO -> m ResponseReceived route rt rq k = Route.routeWith (Route.Config $ errorRs' noEndpoint) rt rq (liftIO . k) where noEndpoint = Wai.mkError status404 "no-endpoint" "The requested endpoint does not exist" diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API/Brig.hs b/libs/wire-api-federation/src/Wire/API/Federation/API/Brig.hs index 1e714c58c0..ba8bf3f1a9 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/API/Brig.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/API/Brig.hs @@ -18,16 +18,19 @@ module Wire.API.Federation.API.Brig where import Control.Monad.Except (MonadError (..)) -import Data.Aeson (FromJSON, ToJSON) +import Data.Aeson import Data.Handle (Handle) -import Data.Id (ClientId, UserId) +import Data.Id +import Data.Range import Imports import Servant.API import Servant.API.Generic import Servant.Client.Generic (AsClientT, genericClient) import Test.QuickCheck (Arbitrary) import Wire.API.Arbitrary (GenericUniform (..)) +import Wire.API.Federation.API.Common import Wire.API.Federation.Client (FederationClientFailure, FederatorClient) +import Wire.API.Federation.Domain (OriginDomainHeader) import qualified Wire.API.Federation.GRPC.Types as Proto import Wire.API.Message (UserClients) import Wire.API.User (UserProfile) @@ -92,7 +95,22 @@ data Api routes = Api :- "federation" :> "get-user-clients" :> ReqBody '[JSON] GetUserClients - :> Post '[JSON] (UserMap (Set PubClient)) + :> Post '[JSON] (UserMap (Set PubClient)), + sendConnectionAction :: + routes + :- "federation" + :> "send-connection-action" + :> OriginDomainHeader + :> ReqBody '[JSON] NewConnectionRequest + :> Post '[JSON] NewConnectionResponse, + onUserDeleted :: + routes + :- "federation" + :> "on-user-deleted" + :> "connections" + :> OriginDomainHeader + :> ReqBody '[JSON] UserDeletedConnectionsNotification + :> Post '[JSON] EmptyResponse } deriving (Generic) @@ -102,5 +120,58 @@ newtype GetUserClients = GetUserClients deriving stock (Eq, Show, Generic) deriving (ToJSON, FromJSON) via (CustomEncoded GetUserClients) +-- NOTE: ConversationId for remote connections +-- +-- The plan is to model the connect/one2one conversationId as deterministically derived from +-- the combination of both userIds and both domains. It may be in the domain +-- of the sending OR the receiving backend (with a 50/50 probability). +-- However at the level of the federation API, we are only concerned about +-- the question of which backend has the authority over the conversationId. +-- +-- (Backend A should not prescribe backend B to use a certain UUID for its +-- conversation; as that could lead to a potential malicious override of an +-- existing conversation) +-- +-- The deterministic conversation Id should be seen as a 'best effort' +-- attempt only. (we cannot guarantee a backend won't change the code in the +-- future) + +data NewConnectionRequest = NewConnectionRequest + { -- | The 'from' userId is understood to always have the domain of the backend making the connection request + ncrFrom :: UserId, + -- | The 'to' userId is understood to always have the domain of the receiving backend. + ncrTo :: UserId, + ncrAction :: RemoteConnectionAction + } + deriving stock (Eq, Show, Generic) + deriving (Arbitrary) via (GenericUniform NewConnectionRequest) + deriving (FromJSON, ToJSON) via (CustomEncoded NewConnectionRequest) + +data RemoteConnectionAction + = RemoteConnect + | RemoteRescind + deriving stock (Eq, Show, Generic) + deriving (Arbitrary) via (GenericUniform RemoteConnectionAction) + deriving (FromJSON, ToJSON) via (CustomEncoded RemoteConnectionAction) + +data NewConnectionResponse + = NewConnectionResponseUserNotActivated + | NewConnectionResponseOk (Maybe RemoteConnectionAction) + deriving stock (Eq, Show, Generic) + deriving (Arbitrary) via (GenericUniform NewConnectionResponse) + deriving (FromJSON, ToJSON) via (CustomEncoded NewConnectionResponse) + +type UserDeletedNotificationMaxConnections = 1000 + +data UserDeletedConnectionsNotification = UserDeletedConnectionsNotification + { -- | This is qualified implicitly by the origin domain + udcnUser :: UserId, + -- | These are qualified implicitly by the target domain + udcnConnections :: Range 1 UserDeletedNotificationMaxConnections [UserId] + } + deriving stock (Eq, Show, Generic) + deriving (Arbitrary) via (GenericUniform UserDeletedConnectionsNotification) + deriving (FromJSON, ToJSON) via (CustomEncoded UserDeletedConnectionsNotification) + clientRoutes :: (MonadError FederationClientFailure m, MonadIO m) => Api (AsClientT (FederatorClient 'Proto.Brig m)) clientRoutes = genericClient diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API/Common.hs b/libs/wire-api-federation/src/Wire/API/Federation/API/Common.hs new file mode 100644 index 0000000000..0df3432e3f --- /dev/null +++ b/libs/wire-api-federation/src/Wire/API/Federation/API/Common.hs @@ -0,0 +1,35 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2020 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Wire.API.Federation.API.Common where + +import Data.Aeson +import Imports +import Test.QuickCheck +import Wire.API.Arbitrary + +-- | This is equivalent to '()', but JSONifies to an empty object instead of an +-- empty array. +data EmptyResponse = EmptyResponse + deriving stock (Eq, Show, Generic) + deriving (Arbitrary) via (GenericUniform EmptyResponse) + +instance FromJSON EmptyResponse where + parseJSON = withObject "EmptyResponse" . const $ pure EmptyResponse + +instance ToJSON EmptyResponse where + toJSON EmptyResponse = object [] diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs b/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs index f3524abfb8..6e258cc242 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs @@ -22,7 +22,8 @@ import Data.Aeson (FromJSON, ToJSON) import Data.Id (ClientId, ConvId, UserId) import Data.Json.Util (Base64ByteString) import Data.Misc (Milliseconds) -import Data.Qualified (Qualified) +import Data.Qualified +import Data.Range import Data.Time.Clock (UTCTime) import Imports import Servant.API (JSON, Post, ReqBody, Summary, (:>)) @@ -39,6 +40,7 @@ import Wire.API.Conversation import Wire.API.Conversation.Action import Wire.API.Conversation.Member (OtherMember) import Wire.API.Conversation.Role (RoleName) +import Wire.API.Federation.API.Common import Wire.API.Federation.Client (FederationClientFailure, FederatorClient) import Wire.API.Federation.Domain (OriginDomainHeader) import qualified Wire.API.Federation.GRPC.Types as Proto @@ -102,7 +104,15 @@ data Api routes = Api :> "send-message" :> OriginDomainHeader :> ReqBody '[JSON] MessageSendRequest - :> Post '[JSON] MessageSendResponse + :> Post '[JSON] MessageSendResponse, + onUserDeleted :: + routes + :- "federation" + :> "on-user-deleted" + :> "conversations" + :> OriginDomainHeader + :> ReqBody '[JSON] UserDeletedConversationsNotification + :> Post '[JSON] EmptyResponse } deriving (Generic) @@ -127,7 +137,10 @@ data RemoteConvMembers = RemoteConvMembers -- fields (muted/archived/hidden) are omitted, since they are not known by the -- remote backend. data RemoteConversation = RemoteConversation - { rcnvMetadata :: ConversationMetadata, + { -- | Id of the conversation, implicitly qualified with the domain of the + -- backend that created this value. + rcnvId :: ConvId, + rcnvMetadata :: ConversationMetadata, rcnvMembers :: RemoteConvMembers } deriving stock (Eq, Show, Generic) @@ -148,8 +161,10 @@ newtype GetConversationsResponse = GetConversationsResponse data NewRemoteConversation conv = NewRemoteConversation { -- | The time when the conversation was created rcTime :: UTCTime, - -- | The user that created the conversation - rcOrigUserId :: Qualified UserId, + -- | The user that created the conversation. This is implicitly qualified + -- by the requesting domain, since it is impossible to create a regular/group + -- conversation on a remote backend. + rcOrigUserId :: UserId, -- | The conversation ID, local to the backend invoking the RPC rcCnvId :: conv, -- | The conversation type @@ -158,14 +173,17 @@ data NewRemoteConversation conv = NewRemoteConversation rcCnvAccessRole :: AccessRole, -- | The conversation name, rcCnvName :: Maybe Text, - -- | Members of the conversation - rcMembers :: Set OtherMember, + -- | Members of the conversation apart from the creator + rcNonCreatorMembers :: Set OtherMember, rcMessageTimer :: Maybe Milliseconds, rcReceiptMode :: Maybe ReceiptMode } deriving stock (Eq, Show, Generic, Functor) deriving (ToJSON, FromJSON) via (CustomEncoded (NewRemoteConversation conv)) +rcRemoteOrigUserId :: NewRemoteConversation (Remote ConvId) -> Remote UserId +rcRemoteOrigUserId rc = qualifyAs (rcCnvId rc) (rcOrigUserId rc) + data ConversationUpdate = ConversationUpdate { cuTime :: UTCTime, cuOrigUserId :: Qualified UserId, @@ -245,5 +263,17 @@ newtype LeaveConversationResponse = LeaveConversationResponse (ToJSON, FromJSON) via (Either (CustomEncoded RemoveFromConversationError) ()) +type UserDeletedNotificationMaxConvs = 1000 + +data UserDeletedConversationsNotification = UserDeletedConversationsNotification + { -- | This is qualified implicitly by the origin domain + udcnUser :: UserId, + -- | These are qualified implicitly by the target domain + udcnConversations :: Range 1 UserDeletedNotificationMaxConvs [ConvId] + } + deriving stock (Eq, Show, Generic) + deriving (Arbitrary) via (GenericUniform UserDeletedConversationsNotification) + deriving (FromJSON, ToJSON) via (CustomEncoded UserDeletedConversationsNotification) + clientRoutes :: (MonadError FederationClientFailure m, MonadIO m) => Api (AsClientT (FederatorClient 'Proto.Galley m)) clientRoutes = genericClient diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Client.hs b/libs/wire-api-federation/src/Wire/API/Federation/Client.hs index ee39c5ed59..423c7788a5 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/Client.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/Client.hs @@ -123,14 +123,16 @@ data FederationError | FederationNotImplemented | FederationNotConfigured | FederationCallFailure FederationClientFailure - deriving (Show, Eq) + deriving (Show, Eq, Typeable) + +instance Exception FederationError data FederationClientFailure = FederationClientFailure { fedFailDomain :: Domain, fedFailPath :: ByteString, fedFailError :: FederationClientError } - deriving (Show, Eq) + deriving (Show, Eq, Typeable) data FederationClientError = FederationClientInvalidMethod HTTP.Method @@ -139,7 +141,7 @@ data FederationClientError | FederationClientOutwardError Proto.OutwardError | FederationClientInwardError Proto.InwardError | FederationClientServantError Servant.ClientError - deriving (Show, Eq) + deriving (Show, Eq, Typeable) callRemote :: MonadIO m => GrpcClient -> Proto.ValidatedFederatedRequest -> m (GRpcReply Proto.OutwardResponse) callRemote fedClient call = liftIO $ gRpcCall @'MsgProtoBuf @Proto.Outward @"Outward" @"call" fedClient (Proto.validatedFederatedRequestToFederatedRequest call) diff --git a/libs/wire-api-federation/src/Wire/API/Federation/GRPC/Client.hs b/libs/wire-api-federation/src/Wire/API/Federation/GRPC/Client.hs index 805fea7f84..ec6a2aa44c 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/GRPC/Client.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/GRPC/Client.hs @@ -15,7 +15,12 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Wire.API.Federation.GRPC.Client where +module Wire.API.Federation.GRPC.Client + ( GrpcClientErr (..), + createGrpcClient, + grpcClientError, + ) +where import Control.Exception import qualified Data.Text as T @@ -32,11 +37,15 @@ createGrpcClient :: MonadIO m => GrpcClientConfig -> m (Either GrpcClientErr Grp createGrpcClient cfg = do res <- liftIO $ try @IOException $ setupGrpcClient' cfg pure $ case res of - Left err -> Left (GrpcClientErr (T.pack (show err <> errorInfo))) - Right (Left err) -> Left (GrpcClientErr (T.pack (show err <> errorInfo))) + Left err -> Left (grpcClientError (Just cfg) err) + Right (Left err) -> Left (grpcClientError (Just cfg) err) Right (Right client) -> Right client - where - errorInfo = addressToErrInfo $ _grpcClientConfigAddress cfg + +grpcClientError :: Exception e => Maybe GrpcClientConfig -> e -> GrpcClientErr +grpcClientError mcfg err = + GrpcClientErr . T.pack $ + displayException err + <> maybe "" (\cfg -> " " <> addressToErrInfo (_grpcClientConfigAddress cfg)) mcfg addressToErrInfo :: Address -> String addressToErrInfo = \case diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Mock.hs b/libs/wire-api-federation/src/Wire/API/Federation/Mock.hs index 54c0257329..f3afde0400 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/Mock.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/Mock.hs @@ -87,7 +87,7 @@ stopMockFederator ref = flushState :: IORef MockState -> IO () flushState = flip modifyIORef $ \s -> s {receivedRequests = [], effectfulResponse = error "No mock response provided"} -initState :: Domain -> Domain -> MockState +initState :: Domain -> MockState initState = MockState [] (error "No mock response provided") (error "server not started") (error "No port selected yet") -- | Run an action with access to a mock federator. @@ -113,15 +113,16 @@ withMockFederator ref resp action = do withMockFederatorClient :: (MonadIO m, MonadMask m) => + Domain -> IORef MockState -> (FederatedRequest -> ServerErrorIO OutwardResponse) -> FederatorClient component (ExceptT e m) a -> ExceptT String m (Either e a, ReceivedRequests) -withMockFederatorClient ref resp action = withMockFederator ref resp $ \st -> do +withMockFederatorClient target ref resp action = withMockFederator ref resp $ \st -> do let cfg = grpcClientConfigSimple "127.0.0.1" (fromInteger (serverPort st)) False client <- fmapLT (Text.unpack . reason) (ExceptT (createGrpcClient cfg)) lift . runExceptT $ - runFederatorClientWith client (stateTarget st) (stateOrigin st) action + runFederatorClientWith client target (stateOrigin st) action -- | Like 'withMockFederator', but spawn a new instance of the mock federator -- just for this action. @@ -157,7 +158,6 @@ data MockState = MockState effectfulResponse :: FederatedRequest -> ServerErrorIO OutwardResponse, serverThread :: Async.Async (), serverPort :: Integer, - stateTarget :: Domain, stateOrigin :: Domain } diff --git a/libs/wire-api-federation/test/Test/Wire/API/Federation/ClientSpec.hs b/libs/wire-api-federation/test/Test/Wire/API/Federation/ClientSpec.hs index 4dd1e784ab..8ea3f3e1cf 100644 --- a/libs/wire-api-federation/test/Test/Wire/API/Federation/ClientSpec.hs +++ b/libs/wire-api-federation/test/Test/Wire/API/Federation/ClientSpec.hs @@ -38,9 +38,10 @@ import Wire.API.User (UserProfile) spec :: Spec spec = do + let target = Domain "target.example.com" stateRef <- runIO . newIORef $ - initState (Domain "target.example.com") (Domain "origin.example.com") + initState (Domain "origin.example.com") beforeAll (assertRightT (startMockFederator stateRef)) . afterAll_ (stopMockFederator stateRef) . before_ (flushState stateRef) @@ -50,7 +51,7 @@ spec = do expectedResponse :: Maybe UserProfile <- generate arbitrary (actualResponse, sentRequests) <- - assertRightT . withMockFederatorClient stateRef (const (mkSuccessResponse expectedResponse)) $ + assertRightT . withMockFederatorClient target stateRef (const (mkSuccessResponse expectedResponse)) $ Brig.getUserByHandle Brig.clientRoutes handle sentRequests `shouldBe` [FederatedRequest "target.example.com" (Just $ Request Brig "/federation/get-user-by-handle" (LBS.toStrict (Aeson.encode handle)) "origin.example.com")] @@ -61,7 +62,7 @@ spec = do someErr <- generate arbitrary (actualResponse, _) <- - assertRightT . withMockFederatorClient stateRef (const (mkErrorResponse someErr)) $ + assertRightT . withMockFederatorClient target stateRef (const (mkErrorResponse someErr)) $ Brig.getUserByHandle Brig.clientRoutes handle first fedFailError actualResponse @@ -71,7 +72,7 @@ spec = do handle <- generate arbitrary (actualResponse, _) <- - assertRightT . withMockFederatorClient stateRef (error "some IO error!") $ + assertRightT . withMockFederatorClient target stateRef (error "some IO error!") $ Brig.getUserByHandle Brig.clientRoutes handle case actualResponse of @@ -86,7 +87,7 @@ spec = do handle <- generate arbitrary (actualResponse, _) <- - assertRightT . withMockFederatorClient stateRef (const (throwError $ Mu.ServerError Mu.NotFound "Just testing")) $ + assertRightT . withMockFederatorClient target stateRef (const (throwError $ Mu.ServerError Mu.NotFound "Just testing")) $ Brig.getUserByHandle Brig.clientRoutes handle first fedFailError actualResponse diff --git a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/ConversationUpdate.hs b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/ConversationUpdate.hs index 1535c7c458..e73413673e 100644 --- a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/ConversationUpdate.hs +++ b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/ConversationUpdate.hs @@ -70,5 +70,5 @@ testObject_ConversationUpdate2 = cuConvId = Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000006")), cuAlreadyPresentUsers = [chad, dee], - cuAction = ConversationActionRemoveMember (qAlice) + cuAction = ConversationActionRemoveMembers (pure qAlice) } diff --git a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/GoldenSpec.hs b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/GoldenSpec.hs index eb9fded308..5cac536c68 100644 --- a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/GoldenSpec.hs +++ b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/GoldenSpec.hs @@ -23,6 +23,9 @@ import qualified Test.Wire.API.Federation.Golden.ConversationUpdate as Conversat import qualified Test.Wire.API.Federation.Golden.LeaveConversationRequest as LeaveConversationRequest import qualified Test.Wire.API.Federation.Golden.LeaveConversationResponse as LeaveConversationResponse import qualified Test.Wire.API.Federation.Golden.MessageSendResponse as MessageSendResponse +import qualified Test.Wire.API.Federation.Golden.NewConnectionRequest as NewConnectionRequest +import qualified Test.Wire.API.Federation.Golden.NewConnectionResponse as NewConnectionResponse +import qualified Test.Wire.API.Federation.Golden.NewRemoteConversation as NewRemoteConversation import Test.Wire.API.Federation.Golden.Runner (testObjects) spec :: Spec @@ -50,3 +53,17 @@ spec = (LeaveConversationResponse.testObject_LeaveConversationResponse7, "testObject_LeaveConversationResponse7.json"), (LeaveConversationResponse.testObject_LeaveConversationResponse8, "testObject_LeaveConversationResponse8.json") ] + testObjects + [ (NewConnectionRequest.testObject_NewConnectionRequest1, "testObject_NewConnectionRequest1.json"), + (NewConnectionRequest.testObject_NewConnectionRequest2, "testObject_NewConnectionRequest2.json") + ] + testObjects + [ (NewConnectionResponse.testObject_NewConnectionResponse1, "testObject_NewConnectionResponse1.json"), + (NewConnectionResponse.testObject_NewConnectionResponse2, "testObject_NewConnectionResponse2.json"), + (NewConnectionResponse.testObject_NewConnectionResponse3, "testObject_NewConnectionResponse3.json"), + (NewConnectionResponse.testObject_NewConnectionResponse4, "testObject_NewConnectionResponse4.json") + ] + testObjects + [ (NewRemoteConversation.testObject_NewRemoteConversation1, "testObject_NewRemoteConversation1.json"), + (NewRemoteConversation.testObject_NewRemoteConversation2, "testObject_NewRemoteConversation2.json") + ] diff --git a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/NewConnectionRequest.hs b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/NewConnectionRequest.hs new file mode 100644 index 0000000000..07a4d0306f --- /dev/null +++ b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/NewConnectionRequest.hs @@ -0,0 +1,39 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Test.Wire.API.Federation.Golden.NewConnectionRequest where + +import Data.Id +import qualified Data.UUID as UUID +import Imports +import Wire.API.Federation.API.Brig + +testObject_NewConnectionRequest1 :: NewConnectionRequest +testObject_NewConnectionRequest1 = + NewConnectionRequest + { ncrFrom = Id (fromJust (UUID.fromString "69f66843-6cf1-48fb-8c05-1cf58c23566a")), + ncrTo = Id (fromJust (UUID.fromString "1669240c-c510-43e0-bf1a-33378fa4ba55")), + ncrAction = RemoteConnect + } + +testObject_NewConnectionRequest2 :: NewConnectionRequest +testObject_NewConnectionRequest2 = + NewConnectionRequest + { ncrFrom = Id (fromJust (UUID.fromString "69f66843-6cf1-48fb-8c05-1cf58c23566a")), + ncrTo = Id (fromJust (UUID.fromString "1669240c-c510-43e0-bf1a-33378fa4ba55")), + ncrAction = RemoteRescind + } diff --git a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/NewConnectionResponse.hs b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/NewConnectionResponse.hs new file mode 100644 index 0000000000..23c8833459 --- /dev/null +++ b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/NewConnectionResponse.hs @@ -0,0 +1,33 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Test.Wire.API.Federation.Golden.NewConnectionResponse where + +import Imports +import Wire.API.Federation.API.Brig + +testObject_NewConnectionResponse1 :: NewConnectionResponse +testObject_NewConnectionResponse1 = NewConnectionResponseOk Nothing + +testObject_NewConnectionResponse2 :: NewConnectionResponse +testObject_NewConnectionResponse2 = NewConnectionResponseOk (Just RemoteConnect) + +testObject_NewConnectionResponse3 :: NewConnectionResponse +testObject_NewConnectionResponse3 = NewConnectionResponseOk (Just RemoteRescind) + +testObject_NewConnectionResponse4 :: NewConnectionResponse +testObject_NewConnectionResponse4 = NewConnectionResponseUserNotActivated diff --git a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/NewRemoteConversation.hs b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/NewRemoteConversation.hs new file mode 100644 index 0000000000..9fcb503ea5 --- /dev/null +++ b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/NewRemoteConversation.hs @@ -0,0 +1,67 @@ +module Test.Wire.API.Federation.Golden.NewRemoteConversation where + +import Data.Domain +import Data.Id +import Data.Misc +import Data.Qualified +import qualified Data.Set as Set +import qualified Data.UUID as UUID +import Imports +import Wire.API.Conversation +import Wire.API.Conversation.Role +import Wire.API.Federation.API.Galley +import Wire.API.Provider.Service + +testObject_NewRemoteConversation1 :: NewRemoteConversation ConvId +testObject_NewRemoteConversation1 = + NewRemoteConversation + { rcTime = read "1864-04-12 12:22:43.673 UTC", + rcOrigUserId = Id (fromJust (UUID.fromString "eed9dea3-5468-45f8-b562-7ad5de2587d0")), + rcCnvId = Id (fromJust (UUID.fromString "d13dbe58-d4e3-450f-9c0c-1e632f548740")), + rcCnvType = RegularConv, + rcCnvAccess = [InviteAccess, CodeAccess], + rcCnvAccessRole = ActivatedAccessRole, + rcCnvName = Just "gossip", + rcNonCreatorMembers = + Set.fromList + [ OtherMember + { omQualifiedId = + Qualified + (read "50e6fff1-ffbd-4235-bc73-19c093433beb") + (Domain "golden.example.com"), + omService = Nothing, + omConvRoleName = roleNameWireAdmin + }, + OtherMember + { omQualifiedId = + Qualified + (read "6801e49b-918c-4eef-baed-f18522152fca") + (Domain "golden.example.com"), + omService = + Just + ( ServiceRef + { _serviceRefId = read "abfe2452-ed22-4f94-b4d4-765b989d7dbb", + _serviceRefProvider = read "11b91f61-917e-489b-a268-60b881d08f06" + } + ), + omConvRoleName = roleNameWireMember + } + ], + rcMessageTimer = Just (Ms 1000), + rcReceiptMode = Just (ReceiptMode 42) + } + +testObject_NewRemoteConversation2 :: NewRemoteConversation ConvId +testObject_NewRemoteConversation2 = + NewRemoteConversation + { rcTime = read "1864-04-12 12:22:43.673 UTC", + rcOrigUserId = Id (fromJust (UUID.fromString "eed9dea3-5468-45f8-b562-7ad5de2587d0")), + rcCnvId = Id (fromJust (UUID.fromString "d13dbe58-d4e3-450f-9c0c-1e632f548740")), + rcCnvType = One2OneConv, + rcCnvAccess = [], + rcCnvAccessRole = ActivatedAccessRole, + rcCnvName = Nothing, + rcNonCreatorMembers = Set.fromList [], + rcMessageTimer = Nothing, + rcReceiptMode = Nothing + } diff --git a/libs/wire-api-federation/test/golden/testObject_ConversationUpdate2.json b/libs/wire-api-federation/test/golden/testObject_ConversationUpdate2.json index 3a0490a253..e398d32ebc 100644 --- a/libs/wire-api-federation/test/golden/testObject_ConversationUpdate2.json +++ b/libs/wire-api-federation/test/golden/testObject_ConversationUpdate2.json @@ -9,11 +9,13 @@ ], "time": "1864-04-12T12:22:43.673Z", "action": { - "tag": "ConversationActionRemoveMember", - "contents": { - "domain": "golden.example.com", - "id": "00000000-0000-0000-0000-000100004007" - } + "tag": "ConversationActionRemoveMembers", + "contents": [ + { + "domain": "golden.example.com", + "id": "00000000-0000-0000-0000-000100004007" + } + ] }, "conv_id": "00000000-0000-0000-0000-000100000006" } \ No newline at end of file diff --git a/libs/wire-api-federation/test/golden/testObject_NewConnectionRequest1.json b/libs/wire-api-federation/test/golden/testObject_NewConnectionRequest1.json new file mode 100644 index 0000000000..cebe1dfa47 --- /dev/null +++ b/libs/wire-api-federation/test/golden/testObject_NewConnectionRequest1.json @@ -0,0 +1,5 @@ +{ + "to": "1669240c-c510-43e0-bf1a-33378fa4ba55", + "from": "69f66843-6cf1-48fb-8c05-1cf58c23566a", + "action": "RemoteConnect" +} \ No newline at end of file diff --git a/libs/wire-api-federation/test/golden/testObject_NewConnectionRequest2.json b/libs/wire-api-federation/test/golden/testObject_NewConnectionRequest2.json new file mode 100644 index 0000000000..4610970610 --- /dev/null +++ b/libs/wire-api-federation/test/golden/testObject_NewConnectionRequest2.json @@ -0,0 +1,5 @@ +{ + "to": "1669240c-c510-43e0-bf1a-33378fa4ba55", + "from": "69f66843-6cf1-48fb-8c05-1cf58c23566a", + "action": "RemoteRescind" +} \ No newline at end of file diff --git a/libs/wire-api-federation/test/golden/testObject_NewConnectionResponse1.json b/libs/wire-api-federation/test/golden/testObject_NewConnectionResponse1.json new file mode 100644 index 0000000000..61c94bf0db --- /dev/null +++ b/libs/wire-api-federation/test/golden/testObject_NewConnectionResponse1.json @@ -0,0 +1,4 @@ +{ + "tag": "NewConnectionResponseOk", + "contents": null +} \ No newline at end of file diff --git a/libs/wire-api-federation/test/golden/testObject_NewConnectionResponse2.json b/libs/wire-api-federation/test/golden/testObject_NewConnectionResponse2.json new file mode 100644 index 0000000000..84fa71d736 --- /dev/null +++ b/libs/wire-api-federation/test/golden/testObject_NewConnectionResponse2.json @@ -0,0 +1,4 @@ +{ + "tag": "NewConnectionResponseOk", + "contents": "RemoteConnect" +} \ No newline at end of file diff --git a/libs/wire-api-federation/test/golden/testObject_NewConnectionResponse3.json b/libs/wire-api-federation/test/golden/testObject_NewConnectionResponse3.json new file mode 100644 index 0000000000..aeee3a6db9 --- /dev/null +++ b/libs/wire-api-federation/test/golden/testObject_NewConnectionResponse3.json @@ -0,0 +1,4 @@ +{ + "tag": "NewConnectionResponseOk", + "contents": "RemoteRescind" +} \ No newline at end of file diff --git a/libs/wire-api-federation/test/golden/testObject_NewConnectionResponse4.json b/libs/wire-api-federation/test/golden/testObject_NewConnectionResponse4.json new file mode 100644 index 0000000000..06b6310771 --- /dev/null +++ b/libs/wire-api-federation/test/golden/testObject_NewConnectionResponse4.json @@ -0,0 +1,3 @@ +{ + "tag": "NewConnectionResponseUserNotActivated" +} \ No newline at end of file diff --git a/libs/wire-api-federation/test/golden/testObject_NewRemoteConversation1.json b/libs/wire-api-federation/test/golden/testObject_NewRemoteConversation1.json new file mode 100644 index 0000000000..f1716f8bb1 --- /dev/null +++ b/libs/wire-api-federation/test/golden/testObject_NewRemoteConversation1.json @@ -0,0 +1,38 @@ +{ + "orig_user_id": "eed9dea3-5468-45f8-b562-7ad5de2587d0", + "time": "1864-04-12T12:22:43.673Z", + "cnv_access": [ + "invite", + "code" + ], + "non_creator_members": [ + { + "status": 0, + "conversation_role": "wire_admin", + "qualified_id": { + "domain": "golden.example.com", + "id": "50e6fff1-ffbd-4235-bc73-19c093433beb" + }, + "id": "50e6fff1-ffbd-4235-bc73-19c093433beb" + }, + { + "status": 0, + "service": { + "id": "abfe2452-ed22-4f94-b4d4-765b989d7dbb", + "provider": "11b91f61-917e-489b-a268-60b881d08f06" + }, + "conversation_role": "wire_member", + "qualified_id": { + "domain": "golden.example.com", + "id": "6801e49b-918c-4eef-baed-f18522152fca" + }, + "id": "6801e49b-918c-4eef-baed-f18522152fca" + } + ], + "cnv_access_role": "activated", + "cnv_type": 0, + "receipt_mode": 42, + "message_timer": 1000, + "cnv_name": "gossip", + "cnv_id": "d13dbe58-d4e3-450f-9c0c-1e632f548740" +} \ No newline at end of file diff --git a/libs/wire-api-federation/test/golden/testObject_NewRemoteConversation2.json b/libs/wire-api-federation/test/golden/testObject_NewRemoteConversation2.json new file mode 100644 index 0000000000..bb4bcfc755 --- /dev/null +++ b/libs/wire-api-federation/test/golden/testObject_NewRemoteConversation2.json @@ -0,0 +1,12 @@ +{ + "orig_user_id": "eed9dea3-5468-45f8-b562-7ad5de2587d0", + "time": "1864-04-12T12:22:43.673Z", + "cnv_access": [], + "non_creator_members": [], + "cnv_access_role": "activated", + "cnv_type": 2, + "receipt_mode": null, + "message_timer": null, + "cnv_name": null, + "cnv_id": "d13dbe58-d4e3-450f-9c0c-1e632f548740" +} \ No newline at end of file diff --git a/libs/wire-api-federation/wire-api-federation.cabal b/libs/wire-api-federation/wire-api-federation.cabal index 5fada7cdf1..a48cc3d774 100644 --- a/libs/wire-api-federation/wire-api-federation.cabal +++ b/libs/wire-api-federation/wire-api-federation.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 8106f61fbca587df7a82a89effeec838bb9d9326c84bd7af8f615502cedc152f +-- hash: 502683f56cc0fbb11b75807669858c1d4fdf146afa8a016fa18daec9f6a72e7a name: wire-api-federation version: 0.1.0 @@ -23,6 +23,7 @@ extra-source-files: library exposed-modules: Wire.API.Federation.API.Brig + Wire.API.Federation.API.Common Wire.API.Federation.API.Galley Wire.API.Federation.Client Wire.API.Federation.Domain @@ -82,6 +83,9 @@ test-suite spec Test.Wire.API.Federation.Golden.LeaveConversationRequest Test.Wire.API.Federation.Golden.LeaveConversationResponse Test.Wire.API.Federation.Golden.MessageSendResponse + Test.Wire.API.Federation.Golden.NewConnectionRequest + Test.Wire.API.Federation.Golden.NewConnectionResponse + Test.Wire.API.Federation.Golden.NewRemoteConversation Test.Wire.API.Federation.Golden.Runner Test.Wire.API.Federation.GRPC.TypesSpec Paths_wire_api_federation diff --git a/libs/wire-api/package.yaml b/libs/wire-api/package.yaml index b08c802a5a..9d813db174 100644 --- a/libs/wire-api/package.yaml +++ b/libs/wire-api/package.yaml @@ -16,6 +16,8 @@ dependencies: - servant-swagger-ui - case-insensitive - hscim +- saml2-web-sso +- filepath library: source-dirs: src dependencies: @@ -28,6 +30,7 @@ library: - cassandra-util - cassava >= 0.5 - cereal + - comonad - cookie - cryptonite - currency-codes >=2.0 @@ -59,7 +62,6 @@ library: - QuickCheck >=2.14 - quickcheck-instances >=0.3.16 - resourcet - - saml2-web-sso - servant - servant-client - servant-client-core diff --git a/libs/wire-api/src/Wire/API/Connection.hs b/libs/wire-api/src/Wire/API/Connection.hs index 73e60c5028..612c867f26 100644 --- a/libs/wire-api/src/Wire/API/Connection.hs +++ b/libs/wire-api/src/Wire/API/Connection.hs @@ -31,6 +31,7 @@ module Wire.API.Connection Relation (..), RelationWithHistory (..), relationDropHistory, + relationWithHistory, -- * Requests ConnectionRequest (..), @@ -47,17 +48,16 @@ where import Control.Applicative (optional) import Control.Lens ((?~)) import Data.Aeson as Aeson -import Data.Attoparsec.ByteString (takeByteString) -import Data.ByteString.Conversion import Data.Id import Data.Json.Util (UTCTimeMillis) import Data.Qualified (Qualified (qUnqualified), deprecatedSchema) import Data.Range import qualified Data.Schema as P +import Data.Swagger as S import qualified Data.Swagger.Build.Api as Doc -import Data.Swagger.Schema as S import Data.Text as Text import Imports +import Servant.API import Wire.API.Arbitrary (Arbitrary (..), GenericUniform (..)) import Wire.API.Routes.MultiTablePaging @@ -172,6 +172,9 @@ data Relation deriving (Arbitrary) via (GenericUniform Relation) deriving (FromJSON, ToJSON, S.ToSchema) via (P.Schema Relation) +instance S.ToParamSchema Relation where + toParamSchema _ = mempty & S.type_ ?~ S.SwaggerString + -- | 'updateConnectionInternal', requires knowledge of the previous state (before -- 'MissingLegalholdConsent'), but the clients don't need that information. To avoid having -- to change the API, we introduce an internal variant of 'Relation' with surjective mapping @@ -192,6 +195,17 @@ data RelationWithHistory deriving stock (Eq, Ord, Show, Generic) deriving (Arbitrary) via (GenericUniform RelationWithHistory) +-- | Convert a 'Relation' to 'RelationWithHistory'. This is to be used only if +-- the MissingLegalholdConsent case does not need to be supported. +relationWithHistory :: Relation -> RelationWithHistory +relationWithHistory Accepted = AcceptedWithHistory +relationWithHistory Blocked = BlockedWithHistory +relationWithHistory Pending = PendingWithHistory +relationWithHistory Ignored = IgnoredWithHistory +relationWithHistory Sent = SentWithHistory +relationWithHistory Cancelled = CancelledWithHistory +relationWithHistory MissingLegalholdConsent = MissingLegalholdConsentFromCancelled + relationDropHistory :: RelationWithHistory -> Relation relationDropHistory = \case AcceptedWithHistory -> Accepted @@ -233,20 +247,19 @@ instance P.ToSchema Relation where P.element "missing-legalhold-consent" MissingLegalholdConsent ] -instance FromByteString Relation where - parser = - takeByteString >>= \case - "accepted" -> return Accepted - "blocked" -> return Blocked - "pending" -> return Pending - "ignored" -> return Ignored - "sent" -> return Sent - "cancelled" -> return Cancelled - "missing-legalhold-consent" -> return MissingLegalholdConsent - x -> fail $ "Invalid relation-type " <> show x - -instance ToByteString Relation where - builder = \case +instance FromHttpApiData Relation where + parseQueryParam = \case + "accepted" -> return Accepted + "blocked" -> return Blocked + "pending" -> return Pending + "ignored" -> return Ignored + "sent" -> return Sent + "cancelled" -> return Cancelled + "missing-legalhold-consent" -> return MissingLegalholdConsent + x -> Left $ "Invalid relation-type " <> x + +instance ToHttpApiData Relation where + toQueryParam = \case Accepted -> "accepted" Blocked -> "blocked" Pending -> "pending" @@ -255,7 +268,7 @@ instance ToByteString Relation where Cancelled -> "cancelled" MissingLegalholdConsent -> "missing-legalhold-consent" --------------------------------------------------------------------------------- +---------------- -- Requests -- | Payload type for a connection request from one user to another. diff --git a/libs/wire-api/src/Wire/API/Conversation.hs b/libs/wire-api/src/Wire/API/Conversation.hs index 17d2fb21a3..49412c9d85 100644 --- a/libs/wire-api/src/Wire/API/Conversation.hs +++ b/libs/wire-api/src/Wire/API/Conversation.hs @@ -25,7 +25,6 @@ module Wire.API.Conversation ConversationMetadata (..), Conversation (..), mkConversation, - cnvQualifiedId, cnvType, cnvCreator, cnvAccess, @@ -37,7 +36,6 @@ module Wire.API.Conversation ConversationCoverView (..), ConversationList (..), ListConversations (..), - ListConversationsV2 (..), GetPaginatedConversationIds, pattern GetPaginatedConversationIds, ConvIdsPage, @@ -117,9 +115,7 @@ import Wire.API.Routes.MultiTablePaging -- Conversation data ConversationMetadata = ConversationMetadata - { -- | A qualified conversation ID - cnvmQualifiedId :: Qualified ConvId, - cnvmType :: ConvType, + { cnvmType :: ConvType, -- FUTUREWORK: Make this a qualified user ID. cnvmCreator :: UserId, cnvmAccess :: [Access], @@ -144,10 +140,7 @@ conversationMetadataObjectSchema :: ConversationMetadata conversationMetadataObjectSchema = ConversationMetadata - <$> cnvmQualifiedId .= field "qualified_id" schema - <* (qUnqualified . cnvmQualifiedId) - .= optional (field "id" (deprecatedSchema "qualified_id" schema)) - <*> cnvmType .= field "type" schema + <$> cnvmType .= field "type" schema <*> cnvmCreator .= fieldWithDocModifier "creator" @@ -178,7 +171,9 @@ instance ToSchema ConversationMetadata where -- Can be produced from the internal one ('Galley.Data.Types.Conversation') -- by using 'Galley.API.Mapping.conversationView'. data Conversation = Conversation - { cnvMetadata :: ConversationMetadata, + { -- | A qualified conversation ID + cnvQualifiedId :: Qualified ConvId, + cnvMetadata :: ConversationMetadata, cnvMembers :: ConvMembers } deriving stock (Eq, Show, Generic) @@ -198,10 +193,7 @@ mkConversation :: Maybe ReceiptMode -> Conversation mkConversation qid ty uid acc role name mems tid ms rm = - Conversation (ConversationMetadata qid ty uid acc role name tid ms rm) mems - -cnvQualifiedId :: Conversation -> Qualified ConvId -cnvQualifiedId = cnvmQualifiedId . cnvMetadata + Conversation qid (ConversationMetadata ty uid acc role name tid ms rm) mems cnvType :: Conversation -> ConvType cnvType = cnvmType . cnvMetadata @@ -233,7 +225,10 @@ instance ToSchema Conversation where "Conversation" (description ?~ "A conversation object as returned from the server") $ Conversation - <$> cnvMetadata .= conversationMetadataObjectSchema + <$> cnvQualifiedId .= field "qualified_id" schema + <* (qUnqualified . cnvQualifiedId) + .= optional (field "id" (deprecatedSchema "qualified_id" schema)) + <*> cnvMetadata .= conversationMetadataObjectSchema <*> cnvMembers .= field "members" schema modelConversation :: Doc.Model @@ -359,37 +354,19 @@ type GetPaginatedConversationIds = GetMultiTablePageRequest ConversationPagingNa pattern GetPaginatedConversationIds :: Maybe (MultiTablePagingState name tables) -> Range 1 max Int32 -> GetMultiTablePageRequest name tables max def pattern GetPaginatedConversationIds state size = GetMultiTablePageRequest size state -data ListConversations = ListConversations - { lQualifiedIds :: Maybe (NonEmpty (Qualified ConvId)), - lStartId :: Maybe (Qualified ConvId), - lSize :: Maybe (Range 1 500 Int32) - } - deriving stock (Eq, Show, Generic) - deriving (FromJSON, ToJSON, S.ToSchema) via Schema ListConversations - -instance ToSchema ListConversations where - schema = - objectWithDocModifier - "ListConversations" - (description ?~ "A request to list some or all of a user's conversations, including remote ones") - $ ListConversations - <$> lQualifiedIds .= optField "qualified_ids" Nothing (nonEmptyArray schema) - <*> lStartId .= optField "start_id" Nothing schema - <*> lSize .= optField "size" Nothing schema - -- | Used on the POST /conversations/list/v2 endpoint -newtype ListConversationsV2 = ListConversationsV2 +newtype ListConversations = ListConversations { lcQualifiedIds :: Range 1 1000 [Qualified ConvId] } deriving stock (Eq, Show, Generic) - deriving (FromJSON, ToJSON, S.ToSchema) via Schema ListConversationsV2 + deriving (FromJSON, ToJSON, S.ToSchema) via Schema ListConversations -instance ToSchema ListConversationsV2 where +instance ToSchema ListConversations where schema = objectWithDocModifier "ListConversations" (description ?~ "A request to list some of a user's conversations, including remote ones. Maximum 1000 qualified conversation IDs") - $ ListConversationsV2 + $ ListConversations <$> (fromRange . lcQualifiedIds) .= field "qualified_ids" (rangedSchema sing sing (array schema)) data ConversationsResponse = ConversationsResponse @@ -726,6 +703,18 @@ data Invite = Invite -- Deprecated, use InviteQualified (and maybe rename?) } deriving stock (Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform Invite) + deriving (FromJSON, ToJSON, S.ToSchema) via (Schema Invite) + +instance ToSchema Invite where + schema = + object "Invite" $ + Invite + <$> (toNonEmpty . invUsers) + .= fmap List1 (field "users" (nonEmptyArray schema)) + <*> (Just . invRoleName) + .= fmap + (fromMaybe roleNameWireAdmin) + (optField "conversation_role" Nothing schema) data InviteQualified = InviteQualified { invQUsers :: NonEmpty (Qualified UserId), @@ -741,7 +730,10 @@ instance ToSchema InviteQualified where object "InviteQualified" $ InviteQualified <$> invQUsers .= field "qualified_users" (nonEmptyArray schema) - <*> invQRoleName .= (field "conversation_role" schema <|> pure roleNameWireAdmin) + <*> (Just . invQRoleName) + .= fmap + (fromMaybe roleNameWireAdmin) + (optField "conversation_role" Nothing schema) newInvite :: List1 UserId -> Invite newInvite us = Invite us roleNameWireAdmin @@ -752,17 +744,6 @@ modelInvite = Doc.defineModel "Invite" $ do Doc.property "users" (Doc.unique $ Doc.array Doc.bytes') $ Doc.description "List of user IDs to add to a conversation" -instance ToJSON Invite where - toJSON i = - A.object - [ "users" A..= invUsers i, - "conversation_role" A..= invRoleName i - ] - -instance FromJSON Invite where - parseJSON = A.withObject "invite object" $ \o -> - Invite <$> o A..: "users" <*> o A..:? "conversation_role" A..!= roleNameWireAdmin - -------------------------------------------------------------------------------- -- update diff --git a/libs/wire-api/src/Wire/API/Conversation/Action.hs b/libs/wire-api/src/Wire/API/Conversation/Action.hs index c96a77bc3e..a7bf22c23b 100644 --- a/libs/wire-api/src/Wire/API/Conversation/Action.hs +++ b/libs/wire-api/src/Wire/API/Conversation/Action.hs @@ -38,12 +38,13 @@ import Wire.API.Util.Aeson (CustomEncoded (..)) -- Used to send notifications to users and to remote backends. data ConversationAction = ConversationActionAddMembers (NonEmpty (Qualified UserId)) RoleName - | ConversationActionRemoveMember (Qualified UserId) + | ConversationActionRemoveMembers (NonEmpty (Qualified UserId)) | ConversationActionRename ConversationRename | ConversationActionMessageTimerUpdate ConversationMessageTimerUpdate | ConversationActionReceiptModeUpdate ConversationReceiptModeUpdate | ConversationActionMemberUpdate (Qualified UserId) OtherMemberUpdate | ConversationActionAccessUpdate ConversationAccessData + | ConversationActionDelete deriving stock (Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform ConversationAction) deriving (ToJSON, FromJSON) via (CustomEncoded ConversationAction) @@ -57,9 +58,9 @@ conversationActionToEvent :: conversationActionToEvent now quid qcnv (ConversationActionAddMembers newMembers role) = Event MemberJoin qcnv quid now $ EdMembersJoin $ SimpleMembers (map (`SimpleMember` role) (toList newMembers)) -conversationActionToEvent now quid qcnv (ConversationActionRemoveMember removedMember) = +conversationActionToEvent now quid qcnv (ConversationActionRemoveMembers removedMembers) = Event MemberLeave qcnv quid now $ - EdMembersLeave (QualifiedUserIdList [removedMember]) + EdMembersLeave (QualifiedUserIdList (toList removedMembers)) conversationActionToEvent now quid qcnv (ConversationActionRename rename) = Event ConvRename qcnv quid now (EdConvRename rename) conversationActionToEvent now quid qcnv (ConversationActionMessageTimerUpdate update) = @@ -71,14 +72,17 @@ conversationActionToEvent now quid qcnv (ConversationActionMemberUpdate target ( in Event MemberStateUpdate qcnv quid now (EdMemberUpdate update) conversationActionToEvent now quid qcnv (ConversationActionAccessUpdate update) = Event ConvAccessUpdate qcnv quid now (EdConvAccessUpdate update) +conversationActionToEvent now quid qcnv ConversationActionDelete = + Event ConvDelete qcnv quid now EdConvDelete conversationActionTag :: Qualified UserId -> ConversationAction -> Action conversationActionTag _ (ConversationActionAddMembers _ _) = AddConversationMember -conversationActionTag qusr (ConversationActionRemoveMember victim) - | qusr == victim = LeaveConversation +conversationActionTag qusr (ConversationActionRemoveMembers victims) + | pure qusr == victims = LeaveConversation | otherwise = RemoveConversationMember conversationActionTag _ (ConversationActionRename _) = ModifyConversationName conversationActionTag _ (ConversationActionMessageTimerUpdate _) = ModifyConversationMessageTimer conversationActionTag _ (ConversationActionReceiptModeUpdate _) = ModifyConversationReceiptMode conversationActionTag _ (ConversationActionMemberUpdate _ _) = ModifyOtherConversationMember conversationActionTag _ (ConversationActionAccessUpdate _) = ModifyConversationAccess +conversationActionTag _ ConversationActionDelete = DeleteConversation diff --git a/libs/wire-api/src/Wire/API/Conversation/Member.hs b/libs/wire-api/src/Wire/API/Conversation/Member.hs index 7b1a570ff0..e2abc40d06 100644 --- a/libs/wire-api/src/Wire/API/Conversation/Member.hs +++ b/libs/wire-api/src/Wire/API/Conversation/Member.hs @@ -89,9 +89,8 @@ modelConversationMembers = Doc.defineModel "ConversationMembers" $ do -------------------------------------------------------------------------------- -- Members --- FUTUREWORK: Add a qualified Id here. data Member = Member - { memId :: UserId, + { memId :: Qualified UserId, memService :: Maybe ServiceRef, memOtrMutedStatus :: Maybe MutedStatus, memOtrMutedRef :: Maybe Text, @@ -109,7 +108,9 @@ instance ToSchema Member where schema = object "Member" $ Member - <$> memId .= field "id" schema + <$> memId .= field "qualified_id" schema + <* (qUnqualified . memId) + .= optional (field "id" (deprecatedSchema "qualified_id" schema)) <*> memService .= lax (field "service" (optWithDefault A.Null schema)) -- Remove ... <* const () .= optional (field "status" (c (0 :: Int))) diff --git a/libs/wire-api/src/Wire/API/Event/Conversation.hs b/libs/wire-api/src/Wire/API/Event/Conversation.hs index 0cc3da6702..d681659225 100644 --- a/libs/wire-api/src/Wire/API/Event/Conversation.hs +++ b/libs/wire-api/src/Wire/API/Event/Conversation.hs @@ -352,7 +352,7 @@ instance ToSchema SimpleMember where .= (field "conversation_role" schema <|> pure roleNameWireAdmin) data Connect = Connect - { cRecipient :: UserId, + { cRecipient :: Qualified UserId, -- FUTUREWORK: As a follow-up from -- https://github.com/wireapp/wire-server/pull/1726, the message field can -- be removed from this event. @@ -370,7 +370,8 @@ instance ToSchema Connect where connectObjectSchema :: ObjectSchema SwaggerDoc Connect connectObjectSchema = Connect - <$> cRecipient .= field "recipient" schema + <$> cRecipient .= field "qualified_recipient" schema + <* (Just . qUnqualified . cRecipient) .= optField "recipient" Nothing schema <*> cMessage .= lax (field "message" (optWithDefault A.Null schema)) <*> cName .= lax (field "name" (optWithDefault A.Null schema)) <*> cEmail .= lax (field "email" (optWithDefault A.Null 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 ed89cf2c5e..51e34b18d4 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs @@ -36,6 +36,8 @@ import qualified Servant import Servant.Swagger (HasSwagger (toSwagger)) import Servant.Swagger.Internal.Orphans () import Servant.Swagger.UI +import Wire.API.Connection +import Wire.API.Routes.Internal.Brig.Connection import Wire.API.Routes.Internal.Brig.EJPD import qualified Wire.API.Team.Feature as ApiFt @@ -85,12 +87,36 @@ type DeleteAccountFeatureConfig = :> "conferenceCalling" :> Delete '[Servant.JSON] NoContent +type GetAllConnectionsUnqualified = + Summary "Get all connections of a given user" + :> "users" + :> "connections-status" + :> ReqBody '[Servant.JSON] ConnectionsStatusRequest + :> QueryParam' + [ Optional, + Strict, + Description "Only returns connections with the given relation, if omitted, returns all connections" + ] + "filter" + Relation + :> Post '[Servant.JSON] [ConnectionStatus] + +type GetAllConnections = + Summary "Get all connections of a given user" + :> "users" + :> "connections-status" + :> "v2" + :> ReqBody '[Servant.JSON] ConnectionsStatusRequestV2 + :> Post '[Servant.JSON] [ConnectionStatusV2] + type API = "i" :> ( EJPDRequest :<|> GetAccountFeatureConfig :<|> PutAccountFeatureConfig :<|> DeleteAccountFeatureConfig + :<|> GetAllConnectionsUnqualified + :<|> GetAllConnections ) type SwaggerDocsAPI = "api" :> "internal" :> SwaggerSchemaUI "swagger-ui" "swagger.json" 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 new file mode 100644 index 0000000000..1132c6f920 --- /dev/null +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Brig/Connection.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE RecordWildCards #-} + +module Wire.API.Routes.Internal.Brig.Connection where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Id +import Data.Qualified +import Data.Schema +import qualified Data.Swagger as S +import Imports +import Wire.API.Connection + +data ConnectionsStatusRequest = ConnectionsStatusRequest + { csrFrom :: ![UserId], + csrTo :: !(Maybe [UserId]) + } + deriving (Eq, Show, Generic) + deriving (ToJSON, FromJSON, S.ToSchema) via (Schema ConnectionsStatusRequest) + +instance ToSchema ConnectionsStatusRequest where + schema = + object "ConnectionsStatusRequest" $ + ConnectionsStatusRequest + <$> csrFrom .= field "from" (array schema) + <*> csrTo .= optField "to" Nothing (array schema) + +data ConnectionsStatusRequestV2 = ConnectionsStatusRequestV2 + { csrv2From :: ![UserId], + csrv2To :: !(Maybe [Qualified UserId]), + csrv2Relation :: !(Maybe Relation) + } + deriving (Eq, Show, Generic) + deriving (ToJSON, FromJSON, S.ToSchema) via (Schema ConnectionsStatusRequestV2) + +instance ToSchema ConnectionsStatusRequestV2 where + schema = + object "ConnectionsStatusRequestV2" $ + ConnectionsStatusRequestV2 + <$> csrv2From .= field "from" (array schema) + <*> csrv2To .= optField "to" Nothing (array schema) + <*> csrv2Relation .= optField "relation" Nothing schema + +data ConnectionStatus = ConnectionStatus + { csFrom :: !UserId, + csTo :: !UserId, + csStatus :: !Relation + } + deriving (Eq, Show, Generic) + deriving (ToJSON, FromJSON, S.ToSchema) via (Schema ConnectionStatus) + +instance ToSchema ConnectionStatus where + schema = + object "ConnectionStatus" $ + ConnectionStatus + <$> csFrom .= field "from" schema + <*> csTo .= field "to" schema + <*> csStatus .= field "status" schema + +data ConnectionStatusV2 = ConnectionStatusV2 + { csv2From :: !UserId, + csv2To :: !(Qualified UserId), + csv2Status :: !Relation + } + deriving (Eq, Show, Generic) + deriving (ToJSON, FromJSON, S.ToSchema) via (Schema ConnectionStatusV2) + +instance ToSchema ConnectionStatusV2 where + schema = + object "ConnectionStatusV2" $ + ConnectionStatusV2 + <$> csv2From .= field "from" schema + <*> csv2To .= field "qualified_to" schema + <*> csv2Status .= field "status" 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 d275ad368c..abeb005178 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs @@ -117,7 +117,6 @@ data Api routes = Api -- - MemberLeave event to members for all conversations the user was in (via galley) deleteSelf :: routes - -- TODO: Add custom AsUnion :- Summary "Initiate account deletion." :> Description "if the account has a verified identity, a verification \ diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs b/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs index 7fd3202e1d..41cd9d2ae1 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs @@ -141,7 +141,10 @@ data Api routes = Api getConversations :: routes :- Summary "Get all *local* conversations." - :> Description "Will not return remote conversations (will eventually be deprecated in favour of list-conversations)" + :> Description + "Will not return remote conversations.\n\n\ + \Use `POST /conversations/list-ids` followed by \ + \`POST /conversations/list/v2` instead." :> ZUser :> "conversations" :> QueryParam' @@ -167,25 +170,13 @@ data Api routes = Api (Range 1 500 Int32) :> Get '[Servant.JSON] (ConversationList Conversation), listConversations :: - routes - :- Summary "[deprecated] Get all conversations (also returns remote conversations)" - :> Description - "Like GET /conversations, but allows specifying a list of remote conversations in its request body. \ - \Will return all or the requested qualified conversations, including remote ones. \ - \Size parameter is not yet honoured for remote conversations.\n\ - \**NOTE** This endpoint will soon be removed." - :> ZUser - :> "list-conversations" - :> ReqBody '[Servant.JSON] ListConversations - :> Post '[Servant.JSON] (ConversationList Conversation), - listConversationsV2 :: routes :- Summary "Get conversation metadata for a list of conversation ids" :> ZUser :> "conversations" :> "list" :> "v2" - :> ReqBody '[Servant.JSON] ListConversationsV2 + :> ReqBody '[Servant.JSON] ListConversations :> Post '[Servant.JSON] ConversationsResponse, -- This endpoint can lead to the following events being sent: -- - ConvCreate event to members @@ -233,7 +224,23 @@ data Api routes = Api :> "one2one" :> ReqBody '[Servant.JSON] NewConvUnmanaged :> ConversationVerb, - addMembersToConversationV2 :: + -- This endpoint can lead to the following events being sent: + -- - MemberJoin event to members + addMembersToConversationUnqualified :: + routes + :- Summary "Add members to an existing conversation (deprecated)" + :> CanThrow ConvNotFound + :> CanThrow NotConnected + :> CanThrow ConvAccessDenied + :> CanThrow (InvalidOp "Invalid operation") + :> ZUser + :> ZConn + :> "conversations" + :> Capture "cnv" ConvId + :> "members" + :> ReqBody '[JSON] Invite + :> MultiVerb 'POST '[JSON] ConvUpdateResponses (UpdateResult Event), + addMembersToConversation :: routes :- Summary "Add qualified members to an existing conversation." :> ZUser diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Util.hs b/libs/wire-api/src/Wire/API/Routes/Public/Util.hs index a2479de2af..3779cdad36 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Util.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Util.hs @@ -20,8 +20,8 @@ module Wire.API.Routes.Public.Util where +import Control.Comonad import Data.SOP (I (..), NS (..)) -import Imports import Servant import Servant.Swagger.Internal.Orphans () import Wire.API.Routes.MultiVerb @@ -45,6 +45,13 @@ data ResponseForExistedCreated a | Created !a deriving (Functor) +instance Comonad ResponseForExistedCreated where + extract (Existed x) = x + extract (Created x) = x + + duplicate r@(Existed _) = Existed r + duplicate r@(Created _) = Created r + type ResponsesForExistedCreated eDesc cDesc a = '[ Respond 200 eDesc a, Respond 201 cDesc a diff --git a/libs/wire-api/src/Wire/API/Team/LegalHold.hs b/libs/wire-api/src/Wire/API/Team/LegalHold.hs index b03769225e..7dd7fc7099 100644 --- a/libs/wire-api/src/Wire/API/Team/LegalHold.hs +++ b/libs/wire-api/src/Wire/API/Team/LegalHold.hs @@ -350,7 +350,7 @@ data LegalholdProtectee | -- | add UserId here if you want to protect bots as well (or just remove and use -- 'ProtectedUser', but then you'll loose the user type information). UnprotectedBot - | -- | FUTUREWORK: protection against legalhold when looking up prekeys accross federated + | -- | FUTUREWORK: protection against legalhold when looking up prekeys across federated -- instances. LegalholdPlusFederationNotImplemented deriving (Show, Eq, Ord, Generic) diff --git a/libs/wire-api/src/Wire/API/User.hs b/libs/wire-api/src/Wire/API/User.hs index 07ab1e05df..7a98a355eb 100644 --- a/libs/wire-api/src/Wire/API/User.hs +++ b/libs/wire-api/src/Wire/API/User.hs @@ -120,7 +120,6 @@ import Data.Schema import qualified Data.Swagger as S import qualified Data.Swagger.Build.Api as Doc import Data.Text.Ascii -import qualified Data.Text.Lazy as TL import Data.UUID (UUID, nil) import qualified Data.UUID as UUID import Deriving.Swagger @@ -412,12 +411,12 @@ userSCIMExternalId :: User -> Maybe Text userSCIMExternalId usr = userSSOId >=> ssoIdExtId $ usr where ssoIdExtId :: UserSSOId -> Maybe Text - ssoIdExtId (UserSSOId _ nameIdXML) = case userManagedBy usr of + ssoIdExtId (UserSSOId (SAML.UserRef _ nameIdXML)) = case userManagedBy usr of ManagedByWire -> Nothing ManagedByScim -> - -- FUTUREWORK: keep the CI value, store the original in the database, but always use - -- the CI value for processing. - CI.original . SAML.unsafeShowNameID <$> either (const Nothing) pure (SAML.decodeElem (TL.fromStrict nameIdXML)) + -- FUTUREWORK: this is only ignoring case in the email format, and emails should be + -- handled case-insensitively. https://wearezeta.atlassian.net/browse/SQSERVICES-909 + Just . CI.original . SAML.unsafeShowNameID $ nameIdXML ssoIdExtId (UserScimExternalId extId) = pure extId connectedProfile :: User -> UserLegalHoldStatus -> UserProfile diff --git a/libs/wire-api/src/Wire/API/User/Client.hs b/libs/wire-api/src/Wire/API/User/Client.hs index 58f3b573d2..6e601ecbb8 100644 --- a/libs/wire-api/src/Wire/API/User/Client.hs +++ b/libs/wire-api/src/Wire/API/User/Client.hs @@ -30,6 +30,7 @@ module Wire.API.User.Client QualifiedUserClientMap (..), QualifiedUserClientPrekeyMap (..), mkQualifiedUserClientPrekeyMap, + qualifiedUserClientPrekeyMapFromList, UserClientsFull (..), userClientsFullToUserClients, UserClients (..), @@ -84,6 +85,7 @@ import Data.Id import Data.Json.Util import qualified Data.Map.Strict as Map import Data.Misc (Latitude (..), Location, Longitude (..), PlainTextPassword (..), latitude, location, longitude, modelLocation) +import Data.Qualified import Data.Schema import qualified Data.Semigroup as Semigroup import qualified Data.Set as Set @@ -308,6 +310,12 @@ instance ToSchema QualifiedUserClientPrekeyMap where mkQualifiedUserClientPrekeyMap :: Map Domain UserClientPrekeyMap -> QualifiedUserClientPrekeyMap mkQualifiedUserClientPrekeyMap = coerce +qualifiedUserClientPrekeyMapFromList :: + [Qualified UserClientPrekeyMap] -> + QualifiedUserClientPrekeyMap +qualifiedUserClientPrekeyMapFromList = + mkQualifiedUserClientPrekeyMap . Map.fromList . map qToPair + -------------------------------------------------------------------------------- -- UserClients diff --git a/libs/wire-api/src/Wire/API/User/Identity.hs b/libs/wire-api/src/Wire/API/User/Identity.hs index f70575cd1a..55584f1eba 100644 --- a/libs/wire-api/src/Wire/API/User/Identity.hs +++ b/libs/wire-api/src/Wire/API/User/Identity.hs @@ -40,28 +40,43 @@ module Wire.API.User.Identity -- * UserSSOId UserSSOId (..), - - -- * Swagger + emailFromSAML, + emailToSAML, + emailToSAMLNameID, + emailFromSAMLNameID, + mkSampleUref, + mkSimpleSampleUref, ) where import Control.Applicative (optional) -import Control.Lens ((.~), (?~)) +import Control.Lens ((.~), (?~), (^.)) import Data.Aeson (FromJSON (..), ToJSON (..)) import qualified Data.Aeson as A +import qualified Data.Aeson.Types as A import Data.Attoparsec.Text -import Data.Bifunctor (first) +import Data.Bifunctor (first, second) import Data.ByteString.Conversion +import qualified Data.CaseInsensitive as CI import Data.Proxy (Proxy (..)) import Data.Schema +import Data.String.Conversions (cs) import qualified Data.Swagger as S import qualified Data.Text as Text import Data.Text.Encoding (decodeUtf8', encodeUtf8) import Data.Time.Clock import Imports +import SAML2.WebSSO.Test.Arbitrary () +import qualified SAML2.WebSSO.Types as SAML +import qualified SAML2.WebSSO.Types.Email as SAMLEmail +import qualified SAML2.WebSSO.XML as SAML +import System.FilePath (()) import qualified Test.QuickCheck as QC import qualified Text.Email.Validate as Email.V +import qualified URI.ByteString as URI +import URI.ByteString.QQ (uri) import Wire.API.Arbitrary (Arbitrary (arbitrary), GenericUniform (..)) +import Wire.API.User.Profile (fromName, mkName) -------------------------------------------------------------------------------- -- UserIdentity @@ -267,30 +282,27 @@ isValidPhone = either (const False) (const True) . parseOnly e164 -- | User's external identity. -- --- Morally this is the same thing as 'SAML.UserRef', but we forget the --- structure -- i.e. we just store XML-encoded SAML blobs. If the structure --- of those blobs changes, Brig won't have to deal with it, only Spar will. +-- NB: this type is serialized to the full xml encoding of the `SAML.UserRef` components, but +-- deserialiation is more lenient: it also allows for the `Issuer` to be a plain URL (without +-- xml around it), and the `NameID` to be an email address (=> format "email") or an arbitrary +-- text (=> format "unspecified"). This is for backwards compatibility and general +-- robustness. -- --- FUTUREWORK: rename the data type to @UserSparId@ (not the two constructors, those are ok). +-- FUTUREWORK: we should probably drop this entirely and store saml and scim data in separate +-- database columns. data UserSSOId - = UserSSOId - -- An XML blob pointing to the identity provider that can confirm - -- user's identity. - Text - -- An XML blob specifying the user's ID on the identity provider's side. - Text - | UserScimExternalId - Text + = UserSSOId SAML.UserRef + | UserScimExternalId Text deriving stock (Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform UserSSOId) --- FUTUREWORK: This schema should ideally be a choice of either tenant+subject, or scim_external_id +-- | FUTUREWORK: This schema should ideally be a choice of either tenant+subject, or scim_external_id -- but this is currently not possible to derive in swagger2 -- Maybe this becomes possible with swagger 3? instance S.ToSchema UserSSOId where declareNamedSchema _ = do - tenantSchema <- S.declareSchemaRef (Proxy @Text) - subjectSchema <- S.declareSchemaRef (Proxy @Text) + tenantSchema <- S.declareSchemaRef (Proxy @Text) -- FUTUREWORK: 'Issuer' + subjectSchema <- S.declareSchemaRef (Proxy @Text) -- FUTUREWORK: 'NameID' scimSchema <- S.declareSchemaRef (Proxy @Text) return $ S.NamedSchema (Just "UserSSOId") $ @@ -304,16 +316,16 @@ instance S.ToSchema UserSSOId where instance ToJSON UserSSOId where toJSON = \case - UserSSOId tenant subject -> A.object ["tenant" A..= tenant, "subject" A..= subject] + UserSSOId (SAML.UserRef tenant subject) -> A.object ["tenant" A..= SAML.encodeElem tenant, "subject" A..= SAML.encodeElem subject] UserScimExternalId eid -> A.object ["scim_external_id" A..= eid] instance FromJSON UserSSOId where parseJSON = A.withObject "UserSSOId" $ \obj -> do - mtenant <- obj A..:? "tenant" - msubject <- obj A..:? "subject" + mtenant <- lenientlyParseSAMLIssuer =<< (obj A..:? "tenant") + msubject <- lenientlyParseSAMLNameID =<< (obj A..:? "subject") meid <- obj A..:? "scim_external_id" case (mtenant, msubject, meid) of - (Just tenant, Just subject, Nothing) -> pure $ UserSSOId tenant subject + (Just tenant, Just subject, Nothing) -> pure $ UserSSOId (SAML.UserRef tenant subject) (Nothing, Nothing, Just eid) -> pure $ UserScimExternalId eid _ -> fail "either need tenant and subject, or scim_external_id, but not both" @@ -331,3 +343,78 @@ instance FromJSON PhoneBudgetTimeout where instance ToJSON PhoneBudgetTimeout where toJSON (PhoneBudgetTimeout t) = A.object ["expires_in" A..= t] + +lenientlyParseSAMLIssuer :: Maybe LText -> A.Parser (Maybe SAML.Issuer) +lenientlyParseSAMLIssuer mbtxt = forM mbtxt $ \txt -> do + let asxml :: Either String SAML.Issuer + asxml = SAML.decodeElem txt + + asurl :: Either String SAML.Issuer + asurl = + first show + . second SAML.Issuer + $ URI.parseURI URI.laxURIParserOptions (cs txt) + + err :: String + err = "lenientlyParseSAMLIssuer: " <> show (asxml, asurl, mbtxt) + + either (const $ fail err) pure $ asxml <|> asurl + +lenientlyParseSAMLNameID :: Maybe LText -> A.Parser (Maybe SAML.NameID) +lenientlyParseSAMLNameID Nothing = pure Nothing +lenientlyParseSAMLNameID (Just txt) = do + let asxml :: Either String SAML.NameID + asxml = SAML.decodeElem txt + + asemail :: Either String SAML.NameID + asemail = + maybe + (Left "not an email") + (fmap emailToSAMLNameID . validateEmail) + (parseEmail (cs txt)) + + astxt :: Either String SAML.NameID + astxt = do + nm <- mkName (cs txt) + SAML.mkNameID (SAML.mkUNameIDUnspecified (fromName nm)) Nothing Nothing Nothing + + err :: String + err = "lenientlyParseSAMLNameID: " <> show (asxml, asemail, astxt, txt) + + either + (const $ fail err) + (pure . Just) + (asxml <|> asemail <|> astxt) + +emailFromSAML :: HasCallStack => SAMLEmail.Email -> Email +emailFromSAML = fromJust . parseEmail . SAMLEmail.render + +emailToSAML :: HasCallStack => Email -> SAMLEmail.Email +emailToSAML = CI.original . fromRight (error "emailToSAML") . SAMLEmail.validate . toByteString + +-- | FUTUREWORK(fisx): if saml2-web-sso exported the 'NameID' constructor, we could make this +-- function total without all that praying and hoping. +emailToSAMLNameID :: HasCallStack => Email -> SAML.NameID +emailToSAMLNameID = fromRight (error "impossible") . SAML.emailNameID . fromEmail + +emailFromSAMLNameID :: HasCallStack => SAML.NameID -> Maybe Email +emailFromSAMLNameID nid = case nid ^. SAML.nameID of + SAML.UNameIDEmail email -> Just . emailFromSAML . CI.original $ email + _ -> Nothing + +-- | For testing. Create a sample 'SAML.UserRef' value with random seeds to make 'Issuer' and +-- 'NameID' unique. FUTUREWORK: move to saml2-web-sso. +mkSampleUref :: Text -> Text -> SAML.UserRef +mkSampleUref iseed nseed = SAML.UserRef issuer nameid + where + issuer :: SAML.Issuer + issuer = SAML.Issuer ([uri|http://example.com/|] & URI.pathL .~ cs ("/" cs iseed)) + + nameid :: SAML.NameID + nameid = fromRight (error "impossible") $ do + unqualified <- SAML.mkUNameIDEmail $ "me" <> nseed <> "@example.com" + SAML.mkNameID unqualified Nothing Nothing Nothing + +-- | @mkSampleUref "" ""@ +mkSimpleSampleUref :: SAML.UserRef +mkSimpleSampleUref = mkSampleUref "" "" diff --git a/libs/wire-api/test/golden/fromJSON/testObject_NewUserPublic_user_1-1.json b/libs/wire-api/test/golden/fromJSON/testObject_NewUserPublic_user_1-1.json deleted file mode 100644 index 1f1c81c450..0000000000 --- a/libs/wire-api/test/golden/fromJSON/testObject_NewUserPublic_user_1-1.json +++ /dev/null @@ -1,32 +0,0 @@ -{ - "accent_id": 39125, - "assets": [ - { - "key": "", - "size": "complete", - "type": "image" - }, - { - "key": "(󼊊\u001bp󳢼u]'􅄻", - "type": "image" - }, - { - "key": "􁿐f", - "size": "preview", - "type": "image" - } - ], - "email_code": "cfTQLlhl6H6sYloQXsghILggxWoGhM2WGbxjzm0=", - "label": ">>Mp१𤘇9:󺰽􋼒\u0010D1j󾮢􂊠;􄆇󳸪f#]", - "locale": "so", - "managed_by": "wire", - "name": "\\sY4]u󼛸\u0010󺲻\u001c\u0003 \u001f\u0017􄚐dw;}􆃪@𭂿\r8", - "password": "dX󹊒赲󶻎ht𘙏󴰏\u0007>\u0018\u000bO95\u0015\n(𩝙󻞌嶝f]_𪀮\u00002FQbNS=6g󿷼P𢲾􃨫󰧽􅤹M\u001e7\u0016~\u0017m󽎭\u0006\u0001\u000bkgmBp\u0017w悬𩓯f󹼮%Q\u0004𢔶kP|G𥬅\u0017B-\nJWH(8)4$󱠶<7𭨖\u001cI\u0008A\u0010\r?󹀊\u0008\u00085\u0006󶟨d \u00166􍉶G\u0018\u0008\t=qG􃁰 D\u0002vV\tYpg󸋮吝q\n \u0017L􁼛-􏕋\u0013󺃝F7Q􊔜]揃i?\r\u0010\u001b{=􎕻_?e􇢹%\u000eR󱆼\u001b+\u000ef\u0017q:g\\Rk馍𪝞[l\u0015􉜀VK\njwp\u00043TJྏEj\u0002R7d83ON\u0017q獿\u0019𮣜N8\n\u000f󻦼u:GꓻFZ\u001c<\u0015揤7􉖬tH󿳸;hbS{ꮯ\u001csMs󲷒9B4􀷾35c(~CUc󸇪\\V_XD3me@example.com", + "tenant": "http://example.com/" } } diff --git a/libs/wire-api/test/golden/testObject_ActivationResponse_user_19.json b/libs/wire-api/test/golden/testObject_ActivationResponse_user_19.json index f4ad262a30..caf5540093 100644 --- a/libs/wire-api/test/golden/testObject_ActivationResponse_user_19.json +++ b/libs/wire-api/test/golden/testObject_ActivationResponse_user_19.json @@ -2,7 +2,7 @@ "email": "R@K", "first": false, "sso_id": { - "subject": "", - "tenant": "" + "subject": "me@example.com", + "tenant": "http://example.com/" } } diff --git a/libs/wire-api/test/golden/testObject_Connect_user_1.json b/libs/wire-api/test/golden/testObject_Connect_user_1.json index 551cb7d2b1..63d654e666 100644 --- a/libs/wire-api/test/golden/testObject_Connect_user_1.json +++ b/libs/wire-api/test/golden/testObject_Connect_user_1.json @@ -2,5 +2,9 @@ "email": "test email", "message": "E", "name": ".🝊]G", + "qualified_recipient": { + "domain": "foo.example.com", + "id": "00000002-0000-0001-0000-000400000004" + }, "recipient": "00000002-0000-0001-0000-000400000004" } diff --git a/libs/wire-api/test/golden/testObject_Connect_user_2.json b/libs/wire-api/test/golden/testObject_Connect_user_2.json index 8ce9a35dd4..76257ece7c 100644 --- a/libs/wire-api/test/golden/testObject_Connect_user_2.json +++ b/libs/wire-api/test/golden/testObject_Connect_user_2.json @@ -2,5 +2,9 @@ "email": null, "message": null, "name": null, + "qualified_recipient": { + "domain": "bar.example.com", + "id": "00000005-0000-0007-0000-000200000008" + }, "recipient": "00000005-0000-0007-0000-000200000008" } diff --git a/libs/wire-api/test/golden/testObject_ConvMembers_user_1.json b/libs/wire-api/test/golden/testObject_ConvMembers_user_1.json index 67711be729..8c5765489d 100644 --- a/libs/wire-api/test/golden/testObject_ConvMembers_user_1.json +++ b/libs/wire-api/test/golden/testObject_ConvMembers_user_1.json @@ -23,6 +23,10 @@ "otr_archived_ref": "", "otr_muted_ref": "", "otr_muted_status": null, + "qualified_id": { + "domain": "golden.example.com", + "id": "00000000-0000-0001-0000-000100000001" + }, "service": { "id": "00000001-0000-0000-0000-000000000000", "provider": "00000000-0000-0000-0000-000000000000" diff --git a/libs/wire-api/test/golden/testObject_ConvMembers_user_2.json b/libs/wire-api/test/golden/testObject_ConvMembers_user_2.json index 97ecd589b7..050ea4b53a 100644 --- a/libs/wire-api/test/golden/testObject_ConvMembers_user_2.json +++ b/libs/wire-api/test/golden/testObject_ConvMembers_user_2.json @@ -9,6 +9,10 @@ "otr_archived_ref": null, "otr_muted_ref": "", "otr_muted_status": null, + "qualified_id": { + "domain": "golden.example.com", + "id": "00000000-0000-0000-0000-000000000000" + }, "service": { "id": "00000001-0000-0001-0000-000100000001", "provider": "00000001-0000-0001-0000-000000000001" diff --git a/libs/wire-api/test/golden/testObject_ConversationList_20Conversation_user_1.json b/libs/wire-api/test/golden/testObject_ConversationList_20Conversation_user_1.json index 326adbbcda..ceccfb14fc 100644 --- a/libs/wire-api/test/golden/testObject_ConversationList_20Conversation_user_1.json +++ b/libs/wire-api/test/golden/testObject_ConversationList_20Conversation_user_1.json @@ -18,6 +18,10 @@ "otr_archived_ref": null, "otr_muted_ref": "", "otr_muted_status": 0, + "qualified_id": { + "domain": "golden.example.com", + "id": "00000000-0000-0000-0000-000100000000" + }, "service": null, "status": 0, "status_ref": "0.0", diff --git a/libs/wire-api/test/golden/testObject_Conversation_user_1.json b/libs/wire-api/test/golden/testObject_Conversation_user_1.json index 5ac0de117e..22dcd63af6 100644 --- a/libs/wire-api/test/golden/testObject_Conversation_user_1.json +++ b/libs/wire-api/test/golden/testObject_Conversation_user_1.json @@ -16,6 +16,10 @@ "otr_archived_ref": "", "otr_muted_ref": null, "otr_muted_status": null, + "qualified_id": { + "domain": "golden.example.com", + "id": "00000001-0000-0001-0000-000100000000" + }, "service": null, "status": 0, "status_ref": "0.0", diff --git a/libs/wire-api/test/golden/testObject_Conversation_user_2.json b/libs/wire-api/test/golden/testObject_Conversation_user_2.json index 6b60594110..7c2362da23 100644 --- a/libs/wire-api/test/golden/testObject_Conversation_user_2.json +++ b/libs/wire-api/test/golden/testObject_Conversation_user_2.json @@ -43,6 +43,10 @@ "otr_archived_ref": null, "otr_muted_ref": null, "otr_muted_status": -1, + "qualified_id": { + "domain": "golden.example.com", + "id": "00000000-0000-0001-0000-000100000001" + }, "service": null, "status": 0, "status_ref": "0.0", diff --git a/libs/wire-api/test/golden/testObject_ConversationsResponse_1.json b/libs/wire-api/test/golden/testObject_ConversationsResponse_1.json index f33bf1205e..db6807e12d 100644 --- a/libs/wire-api/test/golden/testObject_ConversationsResponse_1.json +++ b/libs/wire-api/test/golden/testObject_ConversationsResponse_1.json @@ -28,6 +28,10 @@ "otr_archived_ref": "", "otr_muted_ref": null, "otr_muted_status": null, + "qualified_id": { + "domain": "golden.example.com", + "id": "00000001-0000-0001-0000-000100000000" + }, "service": null, "status": 0, "status_ref": "0.0", @@ -75,6 +79,10 @@ "otr_archived_ref": null, "otr_muted_ref": null, "otr_muted_status": -1, + "qualified_id": { + "domain": "golden.example.com", + "id": "00000000-0000-0001-0000-000100000001" + }, "service": null, "status": 0, "status_ref": "0.0", diff --git a/libs/wire-api/test/golden/testObject_Event_user_10.json b/libs/wire-api/test/golden/testObject_Event_user_10.json index 3ec9ea0854..7a1f9dcd99 100644 --- a/libs/wire-api/test/golden/testObject_Event_user_10.json +++ b/libs/wire-api/test/golden/testObject_Event_user_10.json @@ -4,6 +4,10 @@ "email": "󲛚", "message": "L", "name": "fq", + "qualified_recipient": { + "domain": "faraway.example.com", + "id": "00000008-0000-0000-0000-000600000001" + }, "recipient": "00000008-0000-0000-0000-000600000001" }, "from": "00007f28-0000-40b1-0000-56ab0000748d", diff --git a/libs/wire-api/test/golden/testObject_Event_user_8.json b/libs/wire-api/test/golden/testObject_Event_user_8.json index bf7fab7331..ecfc1b3da8 100644 --- a/libs/wire-api/test/golden/testObject_Event_user_8.json +++ b/libs/wire-api/test/golden/testObject_Event_user_8.json @@ -36,6 +36,10 @@ "otr_archived_ref": "", "otr_muted_ref": "", "otr_muted_status": 0, + "qualified_id": { + "domain": "golden.example.com", + "id": "00000001-0000-0000-0000-000000000001" + }, "service": { "id": "00000001-0000-0000-0000-000000000001", "provider": "00000000-0000-0000-0000-000100000001" diff --git a/libs/wire-api/test/golden/testObject_ListConversationsV2_1.json b/libs/wire-api/test/golden/testObject_ListConversations_1.json similarity index 100% rename from libs/wire-api/test/golden/testObject_ListConversationsV2_1.json rename to libs/wire-api/test/golden/testObject_ListConversations_1.json diff --git a/libs/wire-api/test/golden/testObject_Member_user_1.json b/libs/wire-api/test/golden/testObject_Member_user_1.json index 76d176b1be..16fad76423 100644 --- a/libs/wire-api/test/golden/testObject_Member_user_1.json +++ b/libs/wire-api/test/golden/testObject_Member_user_1.json @@ -7,6 +7,10 @@ "otr_archived_ref": "𢖖", "otr_muted_ref": "ref", "otr_muted_status": -2, + "qualified_id": { + "domain": "golden.example.com", + "id": "00000002-0000-0001-0000-000100000000" + }, "service": { "id": "00000000-0000-0000-0000-000000000001", "provider": "00000000-0000-0001-0000-000000000001" diff --git a/libs/wire-api/test/golden/testObject_Member_user_2.json b/libs/wire-api/test/golden/testObject_Member_user_2.json index e6f6fd61ce..4415044d05 100644 --- a/libs/wire-api/test/golden/testObject_Member_user_2.json +++ b/libs/wire-api/test/golden/testObject_Member_user_2.json @@ -7,6 +7,10 @@ "otr_archived_ref": null, "otr_muted_ref": null, "otr_muted_status": null, + "qualified_id": { + "domain": "golden.example.com", + "id": "00000000-0000-0001-0000-000100000002" + }, "service": null, "status": 0, "status_ref": "0.0", diff --git a/libs/wire-api/test/golden/testObject_NewUser_user_6.json b/libs/wire-api/test/golden/testObject_NewUser_user_6.json index 9302c14469..158591955d 100644 --- a/libs/wire-api/test/golden/testObject_NewUser_user_6.json +++ b/libs/wire-api/test/golden/testObject_NewUser_user_6.json @@ -2,8 +2,8 @@ "assets": [], "name": "test name", "sso_id": { - "subject": "thing", - "tenant": "some" + "subject": "me@example.com", + "tenant": "http://example.com/" }, "team_id": "00007b0e-0000-3489-0000-075c00005be7" } diff --git a/libs/wire-api/test/golden/testObject_UserIdentity_user_16.json b/libs/wire-api/test/golden/testObject_UserIdentity_user_16.json index 56073c95ac..156ade504d 100644 --- a/libs/wire-api/test/golden/testObject_UserIdentity_user_16.json +++ b/libs/wire-api/test/golden/testObject_UserIdentity_user_16.json @@ -2,7 +2,7 @@ "email": "%x\u0013􀔑\u0004.@G빯t.6", "phone": "+298116118047", "sso_id": { - "subject": "\u0013\u001c", - "tenant": "a\u001c" + "subject": "me@example.com", + "tenant": "http://example.com" } } diff --git a/libs/wire-api/test/golden/testObject_UserIdentity_user_5.json b/libs/wire-api/test/golden/testObject_UserIdentity_user_5.json index 68bd2291d2..902e47fbe8 100644 --- a/libs/wire-api/test/golden/testObject_UserIdentity_user_5.json +++ b/libs/wire-api/test/golden/testObject_UserIdentity_user_5.json @@ -2,7 +2,7 @@ "email": null, "phone": "+49198172826", "sso_id": { - "subject": "󴤰", - "tenant": ">􋲗􎚆󾪂" + "subject": "me@example.com", + "tenant": "http://example.com" } } diff --git a/libs/wire-api/test/golden/testObject_UserIdentity_user_8.json b/libs/wire-api/test/golden/testObject_UserIdentity_user_8.json index 5e01fb0c2b..f9a46004b6 100644 --- a/libs/wire-api/test/golden/testObject_UserIdentity_user_8.json +++ b/libs/wire-api/test/golden/testObject_UserIdentity_user_8.json @@ -2,7 +2,7 @@ "email": null, "phone": "+149548802116267", "sso_id": { - "subject": "", - "tenant": "" + "subject": "me@example.com", + "tenant": "http://example.com" } } diff --git a/libs/wire-api/test/golden/testObject_UserSSOId_user_2.json b/libs/wire-api/test/golden/testObject_UserSSOId_user_2.json index 6de1296422..431a302354 100644 --- a/libs/wire-api/test/golden/testObject_UserSSOId_user_2.json +++ b/libs/wire-api/test/golden/testObject_UserSSOId_user_2.json @@ -1,3 +1,4 @@ { - "scim_external_id": "퀶\u001a\u0002\u000bf\u0008-󿰣qA􄚨\u0005 >jJ" + "subject": "me@example.com", + "tenant": "http://example.com/" } diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/FromJSON.hs b/libs/wire-api/test/unit/Test/Wire/API/Golden/FromJSON.hs index f0bdbc0320..5c0485a279 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Golden/FromJSON.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Golden/FromJSON.hs @@ -94,25 +94,13 @@ tests = testFromJSONFailureWithMsg @NewUser (Just "all team users must set a password on creation") "testObject_NewUser_user_5-2.json", - testCase "testObject_NewUser_user_6-2.json" $ - testFromJSONFailureWithMsg @NewUser - (Just "sso_id, team_id must be either both present or both absent.") - "testObject_NewUser_user_6-2.json", testCase "testObject_NewUser_user_6-3.json" $ testFromJSONFailureWithMsg @NewUser (Just "sso_id, team_id must be either both present or both absent.") - "testObject_NewUser_user_6-3.json", - testCase "testObject_NewUser_user_6-4.json" $ - testFromJSONFailureWithMsg @NewUser - (Just "team_code, team, invitation_code, sso_id, and the pair (sso_id, team_id) are mutually exclusive") - "testObject_NewUser_user_6-4.json" + "testObject_NewUser_user_6-3.json" ], testGroup "NewUserPublic: failure" $ - [ testCase "testObject_NewUserPublic_user_1-1.json" $ - testFromJSONFailureWithMsg @NewUserPublic - (Just "SSO-managed users are not allowed here.") - "testObject_NewUserPublic_user_1-1.json", - testCase "testObject_NewUserPublic_user_1-2.json" $ + [ testCase "testObject_NewUserPublic_user_1-2.json" $ testFromJSONFailureWithMsg @NewUserPublic (Just "it is not allowed to provide a UUID for the users here.") "testObject_NewUserPublic_user_1-2.json", diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated.hs b/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated.hs index 5c2c181d66..7eacbb74d2 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated.hs @@ -1059,9 +1059,9 @@ tests = testGroup "Golden: Phone_user" $ testObjects [(Test.Wire.API.Golden.Generated.Phone_user.testObject_Phone_user_1, "testObject_Phone_user_1.json"), (Test.Wire.API.Golden.Generated.Phone_user.testObject_Phone_user_2, "testObject_Phone_user_2.json"), (Test.Wire.API.Golden.Generated.Phone_user.testObject_Phone_user_3, "testObject_Phone_user_3.json"), (Test.Wire.API.Golden.Generated.Phone_user.testObject_Phone_user_4, "testObject_Phone_user_4.json"), (Test.Wire.API.Golden.Generated.Phone_user.testObject_Phone_user_5, "testObject_Phone_user_5.json"), (Test.Wire.API.Golden.Generated.Phone_user.testObject_Phone_user_6, "testObject_Phone_user_6.json"), (Test.Wire.API.Golden.Generated.Phone_user.testObject_Phone_user_7, "testObject_Phone_user_7.json"), (Test.Wire.API.Golden.Generated.Phone_user.testObject_Phone_user_8, "testObject_Phone_user_8.json"), (Test.Wire.API.Golden.Generated.Phone_user.testObject_Phone_user_9, "testObject_Phone_user_9.json"), (Test.Wire.API.Golden.Generated.Phone_user.testObject_Phone_user_10, "testObject_Phone_user_10.json"), (Test.Wire.API.Golden.Generated.Phone_user.testObject_Phone_user_11, "testObject_Phone_user_11.json"), (Test.Wire.API.Golden.Generated.Phone_user.testObject_Phone_user_12, "testObject_Phone_user_12.json"), (Test.Wire.API.Golden.Generated.Phone_user.testObject_Phone_user_13, "testObject_Phone_user_13.json"), (Test.Wire.API.Golden.Generated.Phone_user.testObject_Phone_user_14, "testObject_Phone_user_14.json"), (Test.Wire.API.Golden.Generated.Phone_user.testObject_Phone_user_15, "testObject_Phone_user_15.json"), (Test.Wire.API.Golden.Generated.Phone_user.testObject_Phone_user_16, "testObject_Phone_user_16.json"), (Test.Wire.API.Golden.Generated.Phone_user.testObject_Phone_user_17, "testObject_Phone_user_17.json"), (Test.Wire.API.Golden.Generated.Phone_user.testObject_Phone_user_18, "testObject_Phone_user_18.json"), (Test.Wire.API.Golden.Generated.Phone_user.testObject_Phone_user_19, "testObject_Phone_user_19.json"), (Test.Wire.API.Golden.Generated.Phone_user.testObject_Phone_user_20, "testObject_Phone_user_20.json")], testGroup "Golden: UserSSOId_user" $ - testObjects [(Test.Wire.API.Golden.Generated.UserSSOId_user.testObject_UserSSOId_user_1, "testObject_UserSSOId_user_1.json"), (Test.Wire.API.Golden.Generated.UserSSOId_user.testObject_UserSSOId_user_2, "testObject_UserSSOId_user_2.json"), (Test.Wire.API.Golden.Generated.UserSSOId_user.testObject_UserSSOId_user_3, "testObject_UserSSOId_user_3.json"), (Test.Wire.API.Golden.Generated.UserSSOId_user.testObject_UserSSOId_user_4, "testObject_UserSSOId_user_4.json"), (Test.Wire.API.Golden.Generated.UserSSOId_user.testObject_UserSSOId_user_5, "testObject_UserSSOId_user_5.json"), (Test.Wire.API.Golden.Generated.UserSSOId_user.testObject_UserSSOId_user_6, "testObject_UserSSOId_user_6.json"), (Test.Wire.API.Golden.Generated.UserSSOId_user.testObject_UserSSOId_user_7, "testObject_UserSSOId_user_7.json"), (Test.Wire.API.Golden.Generated.UserSSOId_user.testObject_UserSSOId_user_8, "testObject_UserSSOId_user_8.json"), (Test.Wire.API.Golden.Generated.UserSSOId_user.testObject_UserSSOId_user_9, "testObject_UserSSOId_user_9.json"), (Test.Wire.API.Golden.Generated.UserSSOId_user.testObject_UserSSOId_user_10, "testObject_UserSSOId_user_10.json"), (Test.Wire.API.Golden.Generated.UserSSOId_user.testObject_UserSSOId_user_11, "testObject_UserSSOId_user_11.json"), (Test.Wire.API.Golden.Generated.UserSSOId_user.testObject_UserSSOId_user_12, "testObject_UserSSOId_user_12.json"), (Test.Wire.API.Golden.Generated.UserSSOId_user.testObject_UserSSOId_user_13, "testObject_UserSSOId_user_13.json"), (Test.Wire.API.Golden.Generated.UserSSOId_user.testObject_UserSSOId_user_14, "testObject_UserSSOId_user_14.json"), (Test.Wire.API.Golden.Generated.UserSSOId_user.testObject_UserSSOId_user_15, "testObject_UserSSOId_user_15.json"), (Test.Wire.API.Golden.Generated.UserSSOId_user.testObject_UserSSOId_user_16, "testObject_UserSSOId_user_16.json"), (Test.Wire.API.Golden.Generated.UserSSOId_user.testObject_UserSSOId_user_17, "testObject_UserSSOId_user_17.json"), (Test.Wire.API.Golden.Generated.UserSSOId_user.testObject_UserSSOId_user_18, "testObject_UserSSOId_user_18.json"), (Test.Wire.API.Golden.Generated.UserSSOId_user.testObject_UserSSOId_user_19, "testObject_UserSSOId_user_19.json"), (Test.Wire.API.Golden.Generated.UserSSOId_user.testObject_UserSSOId_user_20, "testObject_UserSSOId_user_20.json")], + testObjects [(Test.Wire.API.Golden.Generated.UserSSOId_user.testObject_UserSSOId_user_2, "testObject_UserSSOId_user_2.json"), (Test.Wire.API.Golden.Generated.UserSSOId_user.testObject_UserSSOId_user_9, "testObject_UserSSOId_user_9.json"), (Test.Wire.API.Golden.Generated.UserSSOId_user.testObject_UserSSOId_user_13, "testObject_UserSSOId_user_13.json")], testGroup "Golden: UserIdentity_user" $ - testObjects [(Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_1, "testObject_UserIdentity_user_1.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_2, "testObject_UserIdentity_user_2.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_3, "testObject_UserIdentity_user_3.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_4, "testObject_UserIdentity_user_4.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_5, "testObject_UserIdentity_user_5.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_6, "testObject_UserIdentity_user_6.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_7, "testObject_UserIdentity_user_7.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_8, "testObject_UserIdentity_user_8.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_9, "testObject_UserIdentity_user_9.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_10, "testObject_UserIdentity_user_10.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_11, "testObject_UserIdentity_user_11.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_12, "testObject_UserIdentity_user_12.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_13, "testObject_UserIdentity_user_13.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_14, "testObject_UserIdentity_user_14.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_15, "testObject_UserIdentity_user_15.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_16, "testObject_UserIdentity_user_16.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_17, "testObject_UserIdentity_user_17.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_18, "testObject_UserIdentity_user_18.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_19, "testObject_UserIdentity_user_19.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_20, "testObject_UserIdentity_user_20.json")], + testObjects [(Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_1, "testObject_UserIdentity_user_1.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_2, "testObject_UserIdentity_user_2.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_3, "testObject_UserIdentity_user_3.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_4, "testObject_UserIdentity_user_4.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_6, "testObject_UserIdentity_user_6.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_7, "testObject_UserIdentity_user_7.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_9, "testObject_UserIdentity_user_9.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_10, "testObject_UserIdentity_user_10.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_11, "testObject_UserIdentity_user_11.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_12, "testObject_UserIdentity_user_12.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_13, "testObject_UserIdentity_user_13.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_14, "testObject_UserIdentity_user_14.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_15, "testObject_UserIdentity_user_15.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_17, "testObject_UserIdentity_user_17.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_18, "testObject_UserIdentity_user_18.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_19, "testObject_UserIdentity_user_19.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_20, "testObject_UserIdentity_user_20.json")], testGroup "Golden: NewPasswordReset_user" $ testObjects [(Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_1, "testObject_NewPasswordReset_user_1.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_2, "testObject_NewPasswordReset_user_2.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_3, "testObject_NewPasswordReset_user_3.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_4, "testObject_NewPasswordReset_user_4.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_5, "testObject_NewPasswordReset_user_5.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_6, "testObject_NewPasswordReset_user_6.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_7, "testObject_NewPasswordReset_user_7.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_8, "testObject_NewPasswordReset_user_8.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_9, "testObject_NewPasswordReset_user_9.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_10, "testObject_NewPasswordReset_user_10.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_11, "testObject_NewPasswordReset_user_11.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_12, "testObject_NewPasswordReset_user_12.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_13, "testObject_NewPasswordReset_user_13.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_14, "testObject_NewPasswordReset_user_14.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_15, "testObject_NewPasswordReset_user_15.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_16, "testObject_NewPasswordReset_user_16.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_17, "testObject_NewPasswordReset_user_17.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_18, "testObject_NewPasswordReset_user_18.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_19, "testObject_NewPasswordReset_user_19.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_20, "testObject_NewPasswordReset_user_20.json")], testGroup "Golden: PasswordResetKey_user" $ diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ActivationResponse_user.hs b/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ActivationResponse_user.hs index 0b0bfc8cbb..0b0cdf459e 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ActivationResponse_user.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ActivationResponse_user.hs @@ -31,13 +31,14 @@ import Wire.API.User UserSSOId (UserSSOId, UserScimExternalId), ) import Wire.API.User.Activation (ActivationResponse (..)) +import Wire.API.User.Identity (mkSimpleSampleUref) testObject_ActivationResponse_user_1 :: ActivationResponse testObject_ActivationResponse_user_1 = ActivationResponse { activatedIdentity = SSOIdentity - (UserSSOId "" "\RS") + (UserSSOId mkSimpleSampleUref) (Just (Email {emailLocal = "\165918\rZ\a\ESC", emailDomain = "p\131777\62344"})) Nothing, activatedFirst = False @@ -169,7 +170,7 @@ testObject_ActivationResponse_user_18 = testObject_ActivationResponse_user_19 :: ActivationResponse testObject_ActivationResponse_user_19 = ActivationResponse - { activatedIdentity = SSOIdentity (UserSSOId "" "") (Just (Email {emailLocal = "R", emailDomain = "K"})) Nothing, + { activatedIdentity = SSOIdentity (UserSSOId mkSimpleSampleUref) (Just (Email {emailLocal = "R", emailDomain = "K"})) Nothing, activatedFirst = False } diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Connect_user.hs b/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Connect_user.hs index ad3dcd121d..2e40212058 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Connect_user.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Connect_user.hs @@ -16,7 +16,9 @@ -- with this program. If not, see . module Test.Wire.API.Golden.Generated.Connect_user where +import Data.Domain import Data.Id (Id (Id)) +import Data.Qualified import qualified Data.UUID as UUID (fromString) import Imports (Maybe (Just, Nothing), fromJust) import Wire.API.Event.Conversation (Connect (..)) @@ -24,7 +26,10 @@ import Wire.API.Event.Conversation (Connect (..)) testObject_Connect_user_1 :: Connect testObject_Connect_user_1 = Connect - { cRecipient = Id (fromJust (UUID.fromString "00000002-0000-0001-0000-000400000004")), + { cRecipient = + Qualified + (Id (fromJust (UUID.fromString "00000002-0000-0001-0000-000400000004"))) + (Domain "foo.example.com"), cMessage = Just "E", cName = Just ".\128842]G", cEmail = Just "test email" @@ -33,7 +38,10 @@ testObject_Connect_user_1 = testObject_Connect_user_2 :: Connect testObject_Connect_user_2 = Connect - { cRecipient = Id (fromJust (UUID.fromString "00000005-0000-0007-0000-000200000008")), + { cRecipient = + Qualified + (Id (fromJust (UUID.fromString "00000005-0000-0007-0000-000200000008"))) + (Domain "bar.example.com"), cMessage = Nothing, cName = Nothing, cEmail = Nothing diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ConvMembers_user.hs b/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ConvMembers_user.hs index c0e49460fa..2666cd2061 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ConvMembers_user.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ConvMembers_user.hs @@ -50,7 +50,7 @@ testObject_ConvMembers_user_1 = ConvMembers { cmSelf = Member - { memId = Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000001")), + { memId = Qualified (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000001"))) domain, memService = Just ( ServiceRef @@ -92,7 +92,7 @@ testObject_ConvMembers_user_2 = ConvMembers { cmSelf = Member - { memId = Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000")), + { memId = Qualified (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000"))) domain, memService = Just ( ServiceRef diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ConversationList_20Conversation_user.hs b/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ConversationList_20Conversation_user.hs index d23b8022f3..e51e664e48 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ConversationList_20Conversation_user.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ConversationList_20Conversation_user.hs @@ -27,15 +27,18 @@ import Imports (Bool (False, True), Maybe (Just, Nothing), fromJust) import Wire.API.Conversation import Wire.API.Conversation.Role (parseRoleName) +domain :: Domain +domain = Domain "golden.example.com" + testObject_ConversationList_20Conversation_user_1 :: ConversationList Conversation testObject_ConversationList_20Conversation_user_1 = ConversationList { convList = [ Conversation - { cnvMetadata = + { cnvQualifiedId = Qualified (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000000"))) (Domain "golden.example.com"), + cnvMetadata = ConversationMetadata - { cnvmQualifiedId = Qualified (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000000"))) (Domain "golden.example.com"), - cnvmType = RegularConv, + { cnvmType = RegularConv, cnvmCreator = Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000001")), cnvmAccess = [], cnvmAccessRole = PrivateAccessRole, @@ -48,7 +51,7 @@ testObject_ConversationList_20Conversation_user_1 = ConvMembers { cmSelf = Member - { memId = Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000000")), + { memId = Qualified (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000000"))) domain, memService = Nothing, memOtrMutedStatus = Just (MutedStatus {fromMutedStatus = 0}), memOtrMutedRef = Just "", diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Conversation_user.hs b/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Conversation_user.hs index 0ea5ad8e86..688f856d43 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Conversation_user.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Conversation_user.hs @@ -34,10 +34,10 @@ domain = Domain "golden.example.com" testObject_Conversation_user_1 :: Conversation testObject_Conversation_user_1 = Conversation - { cnvMetadata = + { cnvQualifiedId = Qualified (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000000"))) domain, + cnvMetadata = ConversationMetadata - { cnvmQualifiedId = Qualified (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000000"))) (Domain "golden.example.com"), - cnvmType = One2OneConv, + { cnvmType = One2OneConv, cnvmCreator = Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000200000001")), cnvmAccess = [], cnvmAccessRole = PrivateAccessRole, @@ -50,7 +50,7 @@ testObject_Conversation_user_1 = ConvMembers { cmSelf = Member - { memId = Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000000")), + { memId = Qualified (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000000"))) domain, memService = Nothing, memOtrMutedStatus = Nothing, memOtrMutedRef = Nothing, @@ -67,10 +67,10 @@ testObject_Conversation_user_1 = testObject_Conversation_user_2 :: Conversation testObject_Conversation_user_2 = Conversation - { cnvMetadata = + { cnvQualifiedId = Qualified (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000002"))) domain, + cnvMetadata = ConversationMetadata - { cnvmQualifiedId = Qualified (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000002"))) (Domain "golden.example.com"), - cnvmType = SelfConv, + { cnvmType = SelfConv, cnvmCreator = Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000200000001")), cnvmAccess = [ InviteAccess, @@ -96,7 +96,7 @@ testObject_Conversation_user_2 = ConvMembers { cmSelf = Member - { memId = Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000001")), + { memId = Qualified (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000001"))) domain, memService = Nothing, memOtrMutedStatus = Just (MutedStatus {fromMutedStatus = -1}), memOtrMutedRef = Nothing, diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Event_user.hs b/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Event_user.hs index 8ec156d909..93e7d7dbfe 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Event_user.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Event_user.hs @@ -142,10 +142,10 @@ testObject_Event_user_8 = (read "1864-05-29 19:31:31.226 UTC") ( EdConversation ( Conversation - { cnvMetadata = + { cnvQualifiedId = Qualified (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000001"))) (Domain "golden.example.com"), + cnvMetadata = ConversationMetadata - { cnvmQualifiedId = Qualified (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000001"))) (Domain "golden.example.com"), - cnvmType = RegularConv, + { cnvmType = RegularConv, cnvmCreator = Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000200000001")), cnvmAccess = [InviteAccess, PrivateAccess, LinkAccess, InviteAccess, InviteAccess, InviteAccess, LinkAccess], @@ -159,7 +159,7 @@ testObject_Event_user_8 = ConvMembers { cmSelf = Member - { memId = Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000001")), + { memId = Qualified (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000001"))) (Domain "golden.example.com"), memService = Just ( ServiceRef @@ -214,7 +214,10 @@ testObject_Event_user_10 = (read "1864-05-25 01:31:49.802 UTC") ( EdConnect ( Connect - { cRecipient = Id (fromJust (UUID.fromString "00000008-0000-0000-0000-000600000001")), + { cRecipient = + Qualified + (Id (fromJust (UUID.fromString "00000008-0000-0000-0000-000600000001"))) + (Domain "faraway.example.com"), cMessage = Just "L", cName = Just "fq", cEmail = Just "\992986" diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Member_user.hs b/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Member_user.hs index 5621b21169..bbac8ae66a 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Member_user.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Member_user.hs @@ -16,17 +16,22 @@ -- with this program. If not, see . module Test.Wire.API.Golden.Generated.Member_user where +import Data.Domain (Domain (..)) import Data.Id (Id (Id)) +import Data.Qualified (Qualified (..)) import qualified Data.UUID as UUID (fromString) import Imports (Bool (False, True), Maybe (Just, Nothing), fromJust) import Wire.API.Conversation (Member (..), MutedStatus (MutedStatus, fromMutedStatus)) import Wire.API.Conversation.Role (parseRoleName) import Wire.API.Provider.Service (ServiceRef (ServiceRef, _serviceRefId, _serviceRefProvider)) +domain :: Domain +domain = Domain "golden.example.com" + testObject_Member_user_1 :: Member testObject_Member_user_1 = Member - { memId = Id (fromJust (UUID.fromString "00000002-0000-0001-0000-000100000000")), + { memId = Qualified (Id (fromJust (UUID.fromString "00000002-0000-0001-0000-000100000000"))) domain, memService = Just ( ServiceRef @@ -47,7 +52,7 @@ testObject_Member_user_1 = testObject_Member_user_2 :: Member testObject_Member_user_2 = Member - { memId = Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000002")), + { memId = Qualified (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000002"))) domain, memService = Nothing, memOtrMutedStatus = Nothing, memOtrMutedRef = Nothing, diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/NewUser_user.hs b/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/NewUser_user.hs index d197d6bad0..68039b8ac3 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/NewUser_user.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/NewUser_user.hs @@ -61,7 +61,7 @@ import Wire.API.User ) import Wire.API.User.Activation (ActivationCode (ActivationCode, fromActivationCode)) import Wire.API.User.Auth (CookieLabel (CookieLabel, cookieLabelText)) -import Wire.API.User.Identity (Phone (..), UserSSOId (UserSSOId)) +import Wire.API.User.Identity (Phone (..), UserSSOId (UserSSOId), mkSimpleSampleUref) testObject_NewUser_user_1 :: NewUser testObject_NewUser_user_1 = @@ -140,7 +140,7 @@ testObject_NewUser_user_6 = (Name {fromName = "test name"}) ) { newUserOrigin = Just (NewUserOriginTeamUser (NewTeamMemberSSO tid)), - newUserIdentity = Just (SSOIdentity (UserSSOId "some" "thing") Nothing Nothing) + newUserIdentity = Just (SSOIdentity (UserSSOId mkSimpleSampleUref) Nothing Nothing) } where tid = Id (fromJust (UUID.fromString "00007b0e-0000-3489-0000-075c00005be7")) diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/UserIdentity_user.hs b/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/UserIdentity_user.hs index 0345304768..19d70db470 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/UserIdentity_user.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/UserIdentity_user.hs @@ -25,6 +25,7 @@ import Wire.API.User UserIdentity (..), UserSSOId (UserSSOId, UserScimExternalId), ) +import Wire.API.User.Identity (mkSimpleSampleUref) testObject_UserIdentity_user_1 :: UserIdentity testObject_UserIdentity_user_1 = @@ -56,7 +57,7 @@ testObject_UserIdentity_user_4 = testObject_UserIdentity_user_5 :: UserIdentity testObject_UserIdentity_user_5 = - SSOIdentity (UserSSOId ">\1096855\1107590\1043074" "\1001776") Nothing (Just (Phone {fromPhone = "+49198172826"})) + SSOIdentity (UserSSOId mkSimpleSampleUref) Nothing (Just (Phone {fromPhone = "+49198172826"})) testObject_UserIdentity_user_6 :: UserIdentity testObject_UserIdentity_user_6 = PhoneIdentity (Phone {fromPhone = "+03038459796465"}) @@ -65,7 +66,7 @@ testObject_UserIdentity_user_7 :: UserIdentity testObject_UserIdentity_user_7 = PhoneIdentity (Phone {fromPhone = "+805676294"}) testObject_UserIdentity_user_8 :: UserIdentity -testObject_UserIdentity_user_8 = SSOIdentity (UserSSOId "" "") Nothing (Just (Phone {fromPhone = "+149548802116267"})) +testObject_UserIdentity_user_8 = SSOIdentity (UserSSOId mkSimpleSampleUref) Nothing (Just (Phone {fromPhone = "+149548802116267"})) testObject_UserIdentity_user_9 :: UserIdentity testObject_UserIdentity_user_9 = @@ -114,7 +115,7 @@ testObject_UserIdentity_user_15 = PhoneIdentity (Phone {fromPhone = "+0923809422 testObject_UserIdentity_user_16 :: UserIdentity testObject_UserIdentity_user_16 = SSOIdentity - (UserSSOId "a\FS" "\DC3\FS") + (UserSSOId mkSimpleSampleUref) (Just (Email {emailLocal = "%x\DC3\1049873\EOT.", emailDomain = "G\48751t.6"})) (Just (Phone {fromPhone = "+298116118047"})) diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/UserSSOId_user.hs b/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/UserSSOId_user.hs index 5f01be95f0..51d29bcd37 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/UserSSOId_user.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/UserSSOId_user.hs @@ -19,65 +19,13 @@ module Test.Wire.API.Golden.Generated.UserSSOId_user where import Wire.API.User (UserSSOId (..)) - -testObject_UserSSOId_user_1 :: UserSSOId -testObject_UserSSOId_user_1 = UserSSOId "#ph\1052492" "\121009\1055837S\ACK\\\ETB\\" +import Wire.API.User.Identity (mkSimpleSampleUref) testObject_UserSSOId_user_2 :: UserSSOId -testObject_UserSSOId_user_2 = UserScimExternalId "\53302\SUB\STX\vf\b\58777-\1047587qA\1066664\ENQ >jJ" - -testObject_UserSSOId_user_3 :: UserSSOId -testObject_UserSSOId_user_3 = UserSSOId "i\DEL\\\EOT\r\99405\NAK\992986\51508Vi" "\164492\&4X\EM" - -testObject_UserSSOId_user_4 :: UserSSOId -testObject_UserSSOId_user_4 = UserSSOId "0\1078858hK\150460Rc;/[Q9s{" "\1089121\&0\ESC\183599. -module Test.Wire.API.Golden.Manual.ListConversationsV2 where +module Test.Wire.API.Golden.Manual.ListConversations where import Data.Domain (Domain (Domain)) import Data.Id (Id (Id)) @@ -23,11 +23,11 @@ import Data.Qualified (Qualified (Qualified)) import Data.Range (unsafeRange) import qualified Data.UUID as UUID import Imports -import Wire.API.Conversation (ListConversationsV2 (..)) +import Wire.API.Conversation (ListConversations (..)) -testObject_ListConversationsV2_1 :: ListConversationsV2 -testObject_ListConversationsV2_1 = - ListConversationsV2 +testObject_ListConversations_1 :: ListConversations +testObject_ListConversations_1 = + ListConversations ( unsafeRange [ Qualified (Id (fromJust (UUID.fromString "00000018-0000-0020-0000-000e00000002"))) (Domain "domain.example.com"), Qualified (Id (fromJust (UUID.fromString "00000018-0000-0020-0000-111111111112"))) (Domain "domain2.example.com") diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Manual/UserClientPrekeyMap.hs b/libs/wire-api/test/unit/Test/Wire/API/Golden/Manual/UserClientPrekeyMap.hs index 1a095aaf33..c1751973c2 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Golden/Manual/UserClientPrekeyMap.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Golden/Manual/UserClientPrekeyMap.hs @@ -19,7 +19,7 @@ module Test.Wire.API.Golden.Manual.UserClientPrekeyMap where -import Data.Id (ClientId (ClientId, client), Id (Id)) +import Data.Id import qualified Data.UUID as UUID (fromString) import GHC.Exts (IsList (fromList)) import Imports diff --git a/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/ByteString.hs b/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/ByteString.hs index d79ed2a670..58a2e1c27b 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/ByteString.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/ByteString.hs @@ -26,7 +26,6 @@ import qualified Wire.API.Arbitrary as Arbitrary () import qualified Wire.API.Asset.V3 as Asset.V3 import qualified Wire.API.Asset.V3.Resumable as Asset.V3.Resumable import qualified Wire.API.Call.Config as Call.Config -import qualified Wire.API.Connection as Connection import qualified Wire.API.Conversation.Code as Conversation.Code import qualified Wire.API.Conversation.Role as Conversation.Role import qualified Wire.API.Properties as Properties @@ -58,7 +57,6 @@ tests = testRoundTrip @Call.Config.Transport, testRoundTrip @Call.Config.TurnHost, testRoundTrip @Call.Config.TurnURI, - testRoundTrip @Connection.Relation, testRoundTrip @Conversation.Code.Key, testRoundTrip @Conversation.Code.Value, testRoundTrip @Conversation.Role.RoleName, diff --git a/libs/wire-api/test/unit/Test/Wire/API/User.hs b/libs/wire-api/test/unit/Test/Wire/API/User.hs index 66707271b6..86c4a0687f 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/User.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/User.hs @@ -85,5 +85,5 @@ parseIdentityTests = hphone = Phone "+493012345678" phone = ("phone", "+493012345678") badphone = ("phone", "__@@") - hssoid = UserSSOId "nil" "nil" + hssoid = UserSSOId mkSimpleSampleUref ssoid = ("sso_id", toJSON hssoid) diff --git a/libs/wire-api/wire-api.cabal b/libs/wire-api/wire-api.cabal index b85340b9ba..623fa0c173 100644 --- a/libs/wire-api/wire-api.cabal +++ b/libs/wire-api/wire-api.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 4ba12caf3f3efd379bd7183a7661ac527d4da4072b7d92dd240af982bdab27de +-- hash: 2d17ec32d1990b4f59c918291cd7a1286d20e5c54ad921ecd5eb9d01b4b9f1c8 name: wire-api version: 0.1.0 @@ -50,6 +50,7 @@ library Wire.API.Push.Token Wire.API.Push.V2.Token Wire.API.Routes.Internal.Brig + Wire.API.Routes.Internal.Brig.Connection Wire.API.Routes.Internal.Brig.EJPD Wire.API.Routes.MultiTablePaging Wire.API.Routes.MultiTablePaging.State @@ -113,6 +114,7 @@ library , cassandra-util , cassava >=0.5 , cereal + , comonad , containers >=0.5 , cookie , cryptonite @@ -123,6 +125,7 @@ library , errors , extended , extra + , filepath , generic-random >=1.2 , generics-sop , ghc-prim @@ -412,7 +415,7 @@ test-suite wire-api-tests Test.Wire.API.Golden.Manual.ConvIdsPage Test.Wire.API.Golden.Manual.FeatureConfigEvent Test.Wire.API.Golden.Manual.GetPaginatedConversationIds - Test.Wire.API.Golden.Manual.ListConversationsV2 + Test.Wire.API.Golden.Manual.ListConversations Test.Wire.API.Golden.Manual.QualifiedUserClientPrekeyMap Test.Wire.API.Golden.Manual.UserClientPrekeyMap Test.Wire.API.Golden.Manual.UserIdList @@ -444,6 +447,7 @@ test-suite wire-api-tests , containers >=0.5 , currency-codes , directory + , filepath , hscim , imports , iso3166-country-codes @@ -453,6 +457,7 @@ test-suite wire-api-tests , pem , pretty , proto-lens + , saml2-web-sso , servant-swagger-ui , string-conversions , swagger2 diff --git a/services/brig/Makefile b/services/brig/Makefile index 6b40a02f6e..c8acd90884 100644 --- a/services/brig/Makefile +++ b/services/brig/Makefile @@ -103,6 +103,19 @@ i-list: i-%: INTEGRATION_USE_NGINZ=$(INTEGRATION_USE_NGINZ) ../integration.sh $(EXE_IT) -s $(NAME).integration.yaml -i ../integration.yaml -p "$*" $(WIRE_INTEGRATION_TEST_OPTIONS) + +# Like integration-%, but starts services only once then runs a given test pattern $FLAKE_AMOUNT times until a failure is seen +FLAKE_FILE ?= /tmp/flake.sh +FLAKE_AMOUNT ?= 1000 +flake-%: fast + echo 'set -ex' > $(FLAKE_FILE) + chmod +x $(FLAKE_FILE) + for i in $$(seq $(FLAKE_AMOUNT)); do \ + echo "echo $$i" >> $(FLAKE_FILE); \ + echo '$(EXE_IT) -s $(NAME).integration.yaml -i ../integration.yaml -p "$*" $(WIRE_INTEGRATION_TEST_OPTIONS)' >> $(FLAKE_FILE); \ + done + INTEGRATION_USE_NGINZ=$(INTEGRATION_USE_NGINZ) ../integration.sh $(FLAKE_FILE) + .PHONY: integration integration: fast i diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal index 7aff982fc2..0b10a5456a 100644 --- a/services/brig/brig.cabal +++ b/services/brig/brig.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: d5382afdfc45e225067c7848e99d40349897ddd6eeb69be59038373e57ada716 +-- hash: 3f6cdbdd5b65f096b8f3e838b1009c4a1a0dd5e295304d123a4ad90ebcdf2057 name: brig version: 1.35.0 @@ -22,6 +22,8 @@ library Brig.API Brig.API.Client Brig.API.Connection + Brig.API.Connection.Remote + Brig.API.Connection.Util Brig.API.Error Brig.API.Federation Brig.API.Handler @@ -137,6 +139,7 @@ library , bytestring >=0.10 , bytestring-conversion >=0.2 , cassandra-util >=0.16.2 + , comonad , conduit >=1.2.8 , containers >=0.5 , cookie >=0.4 @@ -173,6 +176,7 @@ library , metrics-wai >=0.3 , mime , mime-mail >=0.4 + , mmorph , mtl >=2.1 , mu-grpc-client , multihash >=0.1.3 @@ -207,6 +211,7 @@ library , string-conversions , swagger >=0.1 , swagger2 + , tagged , template >=0.2 , text >=0.11 , text-icu-translit >=0.1 @@ -336,6 +341,7 @@ executable brig-integration , lens-aeson , metrics-wai , mime >=0.4 + , mtl , mu-grpc-server , mu-rpc , network diff --git a/services/brig/package.yaml b/services/brig/package.yaml index 7a78afb759..0fb6928ca1 100644 --- a/services/brig/package.yaml +++ b/services/brig/package.yaml @@ -31,6 +31,7 @@ library: - bytestring >=0.10 - bytestring-conversion >=0.2 - cassandra-util >=0.16.2 + - comonad - conduit >=1.2.8 - containers >=0.5 - cookie >=0.4 @@ -72,6 +73,7 @@ library: - mime - mime-mail >=0.4 - MonadRandom >=0.5 + - mmorph - mtl >=2.1 - mu-grpc-client - multihash >=0.1.3 @@ -106,6 +108,7 @@ library: - string-conversions - swagger >=0.1 - swagger2 + - tagged - template >=0.2 - text >=0.11 - text-icu-translit >=0.1 @@ -218,6 +221,7 @@ executables: - metrics-wai - mime >=0.4 - MonadRandom >= 0.5 + - mtl - mu-grpc-server - mu-rpc - network diff --git a/services/brig/src/Brig/API/Client.hs b/services/brig/src/Brig/API/Client.hs index c0a51bd18b..e601a81ecf 100644 --- a/services/brig/src/Brig/API/Client.hs +++ b/services/brig/src/Brig/API/Client.hs @@ -45,6 +45,7 @@ module Brig.API.Client where import Brig.API.Types +import Brig.API.Util import Brig.App import qualified Brig.Data.Client as Data import qualified Brig.Data.User as Data @@ -69,19 +70,18 @@ import Data.List.Split (chunksOf) import Data.Map.Strict (traverseWithKey) import qualified Data.Map.Strict as Map import Data.Misc (PlainTextPassword (..)) -import Data.Qualified (Qualified (..), partitionQualified, partitionRemoteOrLocalIds) +import Data.Qualified import qualified Data.Set as Set -import Galley.Types (UserClients (..)) import Imports import Network.Wai.Utilities import System.Logger.Class (field, msg, val, (~~)) import qualified System.Logger.Class as Log import UnliftIO.Async (Concurrently (Concurrently, runConcurrently)) import Wire.API.Federation.API.Brig (GetUserClients (GetUserClients)) +import Wire.API.Federation.Client (FederationError (..)) import qualified Wire.API.Message as Message import Wire.API.Team.LegalHold (LegalholdProtectee (..)) -import Wire.API.User.Client (ClientCapabilityList (..), QualifiedUserClientPrekeyMap (..), QualifiedUserClients (..), UserClientPrekeyMap, mkQualifiedUserClientPrekeyMap, mkUserClientPrekeyMap) -import qualified Wire.API.User.Client as Client +import Wire.API.User.Client import Wire.API.UserMap (QualifiedUserMap (QualifiedUserMap, qualifiedUserMap), UserMap (userMap)) lookupLocalClient :: UserId -> ClientId -> AppIO (Maybe Client) @@ -106,14 +106,14 @@ lookupPubClients qid@(Qualified uid domain) = do lookupPubClientsBulk :: [Qualified UserId] -> ExceptT ClientError AppIO (QualifiedUserMap (Set PubClient)) lookupPubClientsBulk qualifiedUids = do - domain <- viewFederationDomain - let (remoteUsers, localUsers) = partitionRemoteOrLocalIds domain qualifiedUids + loc <- qualifyLocal () + let (localUsers, remoteUsers) = partitionQualified loc qualifiedUids remoteUserClientMap <- traverseWithKey (\domain' uids -> getUserClients domain' (GetUserClients uids)) - (partitionQualified remoteUsers) + (indexQualified (fmap qUntagged remoteUsers)) !>> ClientFederationError - localUserClientMap <- Map.singleton domain <$> lookupLocalPubClientsBulk localUsers + localUserClientMap <- Map.singleton (tDomain loc) <$> lookupLocalPubClientsBulk localUsers pure $ QualifiedUserMap (Map.union localUserClientMap remoteUserClientMap) lookupLocalPubClientsBulk :: [UserId] -> ExceptT ClientError AppIO (UserMap (Set PubClient)) @@ -126,14 +126,14 @@ addClient u con ip new = do acc <- lift (Data.lookupAccount u) >>= maybe (throwE (ClientUserNotFound u)) return loc <- maybe (return Nothing) locationOf ip maxPermClients <- fromMaybe Opt.defUserMaxPermClients <$> Opt.setUserMaxPermClients <$> view settings - let caps :: Maybe (Set Client.ClientCapability) + let caps :: Maybe (Set ClientCapability) caps = updlhdev $ newClientCapabilities new where updlhdev = if newClientType new == LegalHoldClientType then Just . maybe (Set.singleton lhcaps) (Set.insert lhcaps) else id - lhcaps = Client.ClientSupportsLegalholdImplicitConsent + lhcaps = ClientSupportsLegalholdImplicitConsent (clt, old, count) <- Data.addClient u clientId' new maxPermClients loc caps !>> ClientDataError let usr = accountUser acc lift $ do @@ -186,7 +186,7 @@ claimPrekey protectee u d c = do claimLocalPrekey :: LegalholdProtectee -> UserId -> ClientId -> ExceptT ClientError AppIO (Maybe ClientPrekey) claimLocalPrekey protectee user client = do - guardLegalhold protectee (Client.mkUserClients [(user, [client])]) + guardLegalhold protectee (mkUserClients [(user, [client])]) lift $ do prekey <- Data.claimPrekey user client when (isNothing prekey) (noPrekeys user client) @@ -205,7 +205,7 @@ claimPrekeyBundle protectee domain uid = do claimLocalPrekeyBundle :: LegalholdProtectee -> UserId -> ExceptT ClientError AppIO PrekeyBundle claimLocalPrekeyBundle protectee u = do clients <- map clientId <$> Data.lookupClients u - guardLegalhold protectee (Client.mkUserClients [(u, clients)]) + guardLegalhold protectee (mkUserClients [(u, clients)]) PrekeyBundle u . catMaybes <$> lift (mapM (Data.claimPrekey u) clients) claimRemotePrekeyBundle :: Qualified UserId -> ExceptT ClientError AppIO PrekeyBundle @@ -214,18 +214,33 @@ claimRemotePrekeyBundle quser = do claimMultiPrekeyBundles :: LegalholdProtectee -> QualifiedUserClients -> ExceptT ClientError AppIO QualifiedUserClientPrekeyMap claimMultiPrekeyBundles protectee quc = do - localDomain <- viewFederationDomain - fmap (mkQualifiedUserClientPrekeyMap . Map.fromList) - -- FUTUREWORK(federation): parallelise federator requests here - . traverse (\(domain, uc) -> (domain,) <$> claim localDomain domain (UserClients uc)) - . Map.assocs - . qualifiedUserClients - $ quc + loc <- qualifyLocal () + let (locals, remotes) = + partitionQualifiedAndTag + loc + ( map + (fmap UserClients . uncurry (flip Qualified)) + (Map.assocs (qualifiedUserClients quc)) + ) + localPrekeys <- traverse claimLocal locals + remotePrekeys <- + traverseConcurrentlyWithErrors + claimRemote + remotes + !>> ClientFederationError + pure . qualifiedUserClientPrekeyMapFromList $ localPrekeys <> remotePrekeys where - claim :: Domain -> Domain -> UserClients -> ExceptT ClientError AppIO UserClientPrekeyMap - claim localDomain domain uc - | domain == localDomain = claimLocalMultiPrekeyBundles protectee uc - | otherwise = Federation.claimMultiPrekeyBundle domain uc !>> ClientFederationError + claimRemote :: + Remote UserClients -> + ExceptT FederationError AppIO (Qualified UserClientPrekeyMap) + claimRemote ruc = + qUntagged . qualifyAs ruc + <$> Federation.claimMultiPrekeyBundle (tDomain ruc) (tUnqualified ruc) + + claimLocal :: Local UserClients -> ExceptT ClientError AppIO (Qualified UserClientPrekeyMap) + claimLocal luc = + qUntagged . qualifyAs luc + <$> claimLocalMultiPrekeyBundles protectee (tUnqualified luc) claimLocalMultiPrekeyBundles :: LegalholdProtectee -> UserClients -> ExceptT ClientError AppIO UserClientPrekeyMap claimLocalMultiPrekeyBundles protectee userClients = do diff --git a/services/brig/src/Brig/API/Connection.hs b/services/brig/src/Brig/API/Connection.hs index 78c7e047ab..d2e1a1d08f 100644 --- a/services/brig/src/Brig/API/Connection.hs +++ b/services/brig/src/Brig/API/Connection.hs @@ -14,7 +14,6 @@ -- -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . - -- TODO: Move to Brig.User.Connection (& split out Brig.User.Invitation?) -- | > docs/reference/user/connection.md {#RefConnection} @@ -26,7 +25,6 @@ module Brig.API.Connection updateConnection, UpdateConnectionsInternal (..), updateConnectionInternal, - lookupLocalConnection, lookupConnections, Data.lookupConnectionStatus, Data.lookupConnectionStatus', @@ -34,102 +32,107 @@ module Brig.API.Connection ) where +import Brig.API.Connection.Remote +import Brig.API.Connection.Util import Brig.API.Error (errorDescriptionTypeToWai) import Brig.API.Types import Brig.API.User (getLegalHoldStatus) import Brig.App -import Brig.Data.Connection (LocalConnection (..), localToUserConn) import qualified Brig.Data.Connection as Data import Brig.Data.Types (resultHasMore, resultList) import qualified Brig.Data.User as Data import qualified Brig.IO.Intra as Intra -import Brig.Options (setUserMaxConnections) import Brig.Types import Brig.Types.User.Event import Control.Error -import Control.Lens (view) import Control.Monad.Catch (throwM) import Data.Id as Id import qualified Data.LegalHold as LH import Data.Proxy (Proxy (Proxy)) -import Data.Qualified (Qualified (Qualified)) +import Data.Qualified import Data.Range +import qualified Data.UUID.V4 as UUID import Galley.Types (ConvType (..), cnvType) import Imports import qualified System.Logger.Class as Log import System.Logger.Message import Wire.API.Connection (RelationWithHistory (..)) -import qualified Wire.API.Conversation as Conv import Wire.API.ErrorDescription import Wire.API.Routes.Public.Util (ResponseForExistedCreated (..)) -lookupLocalConnection :: UserId -> UserId -> AppIO (Maybe UserConnection) -lookupLocalConnection uid1 uid2 = do - localDomain <- viewFederationDomain - Data.localToUserConn localDomain <$$> Data.lookupLocalConnection uid1 uid2 +ensureIsActivated :: Local UserId -> MaybeT AppIO () +ensureIsActivated lusr = do + active <- lift $ Data.isActivated (tUnqualified lusr) + guard active + +ensureNotSameTeam :: Local UserId -> Local UserId -> ConnectionM () +ensureNotSameTeam self target = do + selfTeam <- lift $ Intra.getTeamId (tUnqualified self) + targetTeam <- lift $ Intra.getTeamId (tUnqualified target) + when (isJust selfTeam && selfTeam == targetTeam) $ + throwE ConnectSameBindingTeamUsers createConnection :: - UserId -> - ConnectionRequest -> + Local UserId -> ConnId -> - ExceptT ConnectionError AppIO (ResponseForExistedCreated UserConnection) -createConnection self req conn = - createConnectionToLocalUser self (crUser req) req conn + Qualified UserId -> + ConnectionM (ResponseForExistedCreated UserConnection) +createConnection self con target = do + -- basic checks: no need to distinguish between local and remote at this point + when (qUntagged self == target) $ + throwE (InvalidUser target) + noteT ConnectNoIdentity $ + ensureIsActivated self + + -- branch according to whether we are connecting to a local or remote user + foldQualified + self + (createConnectionToLocalUser self con) + (createConnectionToRemoteUser self con) + target createConnectionToLocalUser :: - UserId -> - UserId -> - ConnectionRequest -> + Local UserId -> ConnId -> - ExceptT ConnectionError AppIO (ResponseForExistedCreated UserConnection) -createConnectionToLocalUser self crUser ConnectionRequest {crName} conn = do - when (self == crUser) $ - throwE $ - InvalidUser crUser - selfActive <- lift $ Data.isActivated self - unless selfActive $ - throwE ConnectNoIdentity - otherActive <- lift $ Data.isActivated crUser - unless otherActive $ - throwE $ - InvalidUser crUser - checkLegalholdPolicyConflict self crUser - -- Users belonging to the same team are always treated as connected, so creating a - -- connection between them is useless. {#RefConnectionTeam} - sameTeam <- lift belongSameTeam - when sameTeam $ - throwE ConnectSameBindingTeamUsers - s2o <- lift $ Data.lookupLocalConnection self crUser - o2s <- lift $ Data.lookupLocalConnection crUser self - localDomain <- viewFederationDomain + Local UserId -> + ConnectionM (ResponseForExistedCreated UserConnection) +createConnectionToLocalUser self conn target = do + noteT (InvalidUser (qUntagged target)) $ + ensureIsActivated target + checkLegalholdPolicyConflict (tUnqualified self) (tUnqualified target) + ensureNotSameTeam self target + s2o <- lift $ Data.lookupConnection self (qUntagged target) + o2s <- lift $ Data.lookupConnection target (qUntagged self) + case update <$> s2o <*> o2s of - Just rs -> localToUserConn localDomain <$$> rs + Just rs -> rs Nothing -> do checkLimit self - Created . localToUserConn localDomain <$> insert Nothing Nothing + Created <$> insert Nothing Nothing where - insert :: Maybe LocalConnection -> Maybe LocalConnection -> ExceptT ConnectionError AppIO LocalConnection + insert :: Maybe UserConnection -> Maybe UserConnection -> ExceptT ConnectionError AppIO UserConnection insert s2o o2s = lift $ do - localDomain <- viewFederationDomain Log.info $ - logConnection self (Qualified crUser localDomain) + logConnection (tUnqualified self) (qUntagged target) . msg (val "Creating connection") - cnv <- Intra.createConnectConv self crUser (Just (fromRange crName)) (Just conn) - s2o' <- Data.insertLocalConnection self crUser SentWithHistory cnv - o2s' <- Data.insertLocalConnection crUser self PendingWithHistory cnv - e2o <- ConnectionUpdated (localToUserConn localDomain o2s') (lcStatus <$> o2s) <$> Data.lookupName self - let e2s = ConnectionUpdated (localToUserConn localDomain s2o') (lcStatus <$> s2o) Nothing - mapM_ (Intra.onConnectionEvent self (Just conn)) [e2o, e2s] + qcnv <- Intra.createConnectConv (qUntagged self) (qUntagged target) Nothing (Just conn) + s2o' <- Data.insertConnection self (qUntagged target) SentWithHistory qcnv + o2s' <- Data.insertConnection target (qUntagged self) PendingWithHistory qcnv + e2o <- + ConnectionUpdated o2s' (ucStatus <$> o2s) + <$> Data.lookupName (tUnqualified self) + let e2s = ConnectionUpdated s2o' (ucStatus <$> s2o) Nothing + mapM_ (Intra.onConnectionEvent (tUnqualified self) (Just conn)) [e2o, e2s] return s2o' - update :: LocalConnection -> LocalConnection -> ExceptT ConnectionError AppIO (ResponseForExistedCreated LocalConnection) - update s2o o2s = case (lcStatus s2o, lcStatus o2s) of - (MissingLegalholdConsent, _) -> throwE $ InvalidTransition self Sent - (_, MissingLegalholdConsent) -> throwE $ InvalidTransition self Sent + update :: UserConnection -> UserConnection -> ExceptT ConnectionError AppIO (ResponseForExistedCreated UserConnection) + update s2o o2s = case (ucStatus s2o, ucStatus o2s) of + (MissingLegalholdConsent, _) -> throwE $ InvalidTransition (tUnqualified self) + (_, MissingLegalholdConsent) -> throwE $ InvalidTransition (tUnqualified self) (Accepted, Accepted) -> return $ Existed s2o (Accepted, Blocked) -> return $ Existed s2o (Sent, Blocked) -> return $ Existed s2o - (Blocked, _) -> throwE $ InvalidTransition self Sent + (Blocked, _) -> throwE $ InvalidTransition (tUnqualified self) (_, Blocked) -> change s2o SentWithHistory (_, Sent) -> accept s2o o2s (_, Accepted) -> accept s2o o2s @@ -137,44 +140,40 @@ createConnectionToLocalUser self crUser ConnectionRequest {crName} conn = do (_, Pending) -> resend s2o o2s (_, Cancelled) -> resend s2o o2s - accept :: LocalConnection -> LocalConnection -> ExceptT ConnectionError AppIO (ResponseForExistedCreated LocalConnection) + accept :: UserConnection -> UserConnection -> ExceptT ConnectionError AppIO (ResponseForExistedCreated UserConnection) accept s2o o2s = do - localDomain <- viewFederationDomain - when (lcStatus s2o `notElem` [Sent, Accepted]) $ + when (ucStatus s2o `notElem` [Sent, Accepted]) $ checkLimit self Log.info $ - logLocalConnection self (lcTo s2o) + logLocalConnection (tUnqualified self) (qUnqualified (ucTo s2o)) . msg (val "Accepting connection") - cnv <- lift $ for (lcConv s2o) $ Intra.acceptConnectConv self (Just conn) - s2o' <- lift $ Data.updateLocalConnection s2o AcceptedWithHistory + cnv <- lift $ for (ucConvId s2o) $ Intra.acceptConnectConv self (Just conn) + s2o' <- lift $ Data.updateConnection s2o AcceptedWithHistory o2s' <- lift $ if (cnvType <$> cnv) == Just ConnectConv - then Data.updateLocalConnection o2s BlockedWithHistory - else Data.updateLocalConnection o2s AcceptedWithHistory - e2o <- lift $ ConnectionUpdated (localToUserConn localDomain o2s') (Just $ lcStatus o2s) <$> Data.lookupName self - let e2s = ConnectionUpdated (localToUserConn localDomain s2o') (Just $ lcStatus s2o) Nothing - lift $ mapM_ (Intra.onConnectionEvent self (Just conn)) [e2o, e2s] + then Data.updateConnection o2s BlockedWithHistory + else Data.updateConnection o2s AcceptedWithHistory + e2o <- + lift $ + ConnectionUpdated o2s' (Just $ ucStatus o2s) + <$> Data.lookupName (tUnqualified self) + let e2s = ConnectionUpdated s2o' (Just $ ucStatus s2o) Nothing + lift $ mapM_ (Intra.onConnectionEvent (tUnqualified self) (Just conn)) [e2o, e2s] return $ Existed s2o' - resend :: LocalConnection -> LocalConnection -> ExceptT ConnectionError AppIO (ResponseForExistedCreated LocalConnection) + resend :: UserConnection -> UserConnection -> ExceptT ConnectionError AppIO (ResponseForExistedCreated UserConnection) resend s2o o2s = do - when (lcStatus s2o `notElem` [Sent, Accepted]) $ + when (ucStatus s2o `notElem` [Sent, Accepted]) $ checkLimit self Log.info $ - logLocalConnection self (lcTo s2o) + logLocalConnection (tUnqualified self) (qUnqualified (ucTo s2o)) . msg (val "Resending connection request") s2o' <- insert (Just s2o) (Just o2s) return $ Existed s2o' - change :: LocalConnection -> RelationWithHistory -> ExceptT ConnectionError AppIO (ResponseForExistedCreated LocalConnection) - change c s = Existed <$> lift (Data.updateLocalConnection c s) - - belongSameTeam :: AppIO Bool - belongSameTeam = do - selfTeam <- Intra.getTeamId self - crTeam <- Intra.getTeamId crUser - pure $ isJust selfTeam && selfTeam == crTeam + change :: UserConnection -> RelationWithHistory -> ExceptT ConnectionError AppIO (ResponseForExistedCreated UserConnection) + change c s = Existed <$> lift (Data.updateConnection c s) -- | Throw error if one user has a LH device and the other status `no_consent` or vice versa. -- @@ -202,29 +201,43 @@ checkLegalholdPolicyConflict uid1 uid2 = do oneway status1 status2 oneway status2 status1 +updateConnection :: + Local UserId -> + Qualified UserId -> + Relation -> + Maybe ConnId -> + ConnectionM (Maybe UserConnection) +updateConnection self other newStatus conn = + let doUpdate = + foldQualified + self + (updateConnectionToLocalUser self) + (updateConnectionToRemoteUser self) + in doUpdate other newStatus conn + -- | Change the status of a connection from one user to another. -- -- Note: 'updateConnection' doesn't explicitly check that users don't belong to the same team, -- because a connection between two team members can not exist in the first place. -- {#RefConnectionTeam} -updateConnection :: +updateConnectionToLocalUser :: -- | From - UserId -> + Local UserId -> -- | To - UserId -> + Local UserId -> -- | Desired relation status Relation -> -- | Acting device connection ID Maybe ConnId -> - ExceptT ConnectionError AppIO (Maybe UserConnection) -updateConnection self other newStatus conn = do + ConnectionM (Maybe UserConnection) +updateConnectionToLocalUser self other newStatus conn = do s2o <- localConnection self other o2s <- localConnection other self - s2o' <- case (lcStatus s2o, lcStatus o2s, newStatus) of + s2o' <- case (ucStatus s2o, ucStatus o2s, newStatus) of -- missing legalhold consent: call 'updateConectionInternal' instead. - (MissingLegalholdConsent, _, _) -> throwE $ InvalidTransition self newStatus - (_, MissingLegalholdConsent, _) -> throwE $ InvalidTransition self newStatus - (_, _, MissingLegalholdConsent) -> throwE $ InvalidTransition self newStatus + (MissingLegalholdConsent, _, _) -> throwE $ InvalidTransition (tUnqualified self) + (_, MissingLegalholdConsent, _) -> throwE $ InvalidTransition (tUnqualified self) + (_, _, MissingLegalholdConsent) -> throwE $ InvalidTransition (tUnqualified self) -- Pending -> {Blocked, Ignored, Accepted} (Pending, _, Blocked) -> block s2o (Pending, _, Ignored) -> change s2o Ignored @@ -260,84 +273,88 @@ updateConnection self other newStatus conn = do -- no change (old, _, new) | old == new -> return Nothing -- invalid - _ -> throwE $ InvalidTransition self newStatus - localDomain <- viewFederationDomain - let s2oUserConn = Data.localToUserConn localDomain <$> s2o' + _ -> throwE $ InvalidTransition (tUnqualified self) + let s2oUserConn = s2o' lift . for_ s2oUserConn $ \c -> - let e2s = ConnectionUpdated c (Just $ lcStatus s2o) Nothing - in Intra.onConnectionEvent self conn e2s + let e2s = ConnectionUpdated c (Just $ ucStatus s2o) Nothing + in Intra.onConnectionEvent (tUnqualified self) conn e2s return s2oUserConn where - accept :: LocalConnection -> LocalConnection -> ExceptT ConnectionError AppIO (Maybe LocalConnection) + accept :: UserConnection -> UserConnection -> ExceptT ConnectionError AppIO (Maybe UserConnection) accept s2o o2s = do - localDomain <- viewFederationDomain checkLimit self Log.info $ - logLocalConnection self (lcTo s2o) + logLocalConnection (tUnqualified self) (qUnqualified (ucTo s2o)) . msg (val "Accepting connection") - cnv <- lift . for (lcConv s2o) $ Intra.acceptConnectConv self conn + cnv <- lift $ traverse (Intra.acceptConnectConv self conn) (ucConvId s2o) -- Note: The check for @Pending@ accounts for situations in which both -- sides are pending, which can occur due to rare race conditions -- when sending mutual connection requests, combined with untimely -- crashes. - when (lcStatus o2s `elem` [Sent, Pending]) . lift $ do + when (ucStatus o2s `elem` [Sent, Pending]) . lift $ do o2s' <- if (cnvType <$> cnv) /= Just ConnectConv - then Data.updateLocalConnection o2s AcceptedWithHistory - else Data.updateLocalConnection o2s BlockedWithHistory - e2o <- ConnectionUpdated (localToUserConn localDomain o2s') (Just $ lcStatus o2s) <$> Data.lookupName self - Intra.onConnectionEvent self conn e2o - lift $ Just <$> Data.updateLocalConnection s2o AcceptedWithHistory + then Data.updateConnection o2s AcceptedWithHistory + else Data.updateConnection o2s BlockedWithHistory + e2o <- + ConnectionUpdated o2s' (Just $ ucStatus o2s) + <$> Data.lookupName (tUnqualified self) + Intra.onConnectionEvent (tUnqualified self) conn e2o + lift $ Just <$> Data.updateConnection s2o AcceptedWithHistory - block :: LocalConnection -> ExceptT ConnectionError AppIO (Maybe LocalConnection) + block :: UserConnection -> ExceptT ConnectionError AppIO (Maybe UserConnection) block s2o = lift $ do Log.info $ - logLocalConnection self (lcTo s2o) + logLocalConnection (tUnqualified self) (qUnqualified (ucTo s2o)) . msg (val "Blocking connection") - for_ (lcConv s2o) $ Intra.blockConv (lcFrom s2o) conn - Just <$> Data.updateLocalConnection s2o BlockedWithHistory + traverse_ (Intra.blockConv self conn) (ucConvId s2o) + Just <$> Data.updateConnection s2o BlockedWithHistory - unblock :: LocalConnection -> LocalConnection -> Relation -> ExceptT ConnectionError AppIO (Maybe LocalConnection) + unblock :: UserConnection -> UserConnection -> Relation -> ExceptT ConnectionError AppIO (Maybe UserConnection) unblock s2o o2s new = do - localDomain <- viewFederationDomain -- FUTUREWORK: new is always in [Sent, Accepted]. Refactor to total function. when (new `elem` [Sent, Accepted]) $ checkLimit self Log.info $ - logLocalConnection self (lcTo s2o) + logLocalConnection (tUnqualified self) (qUnqualified (ucTo s2o)) . msg (val "Unblocking connection") - cnv :: Maybe Conv.Conversation <- lift . for (lcConv s2o) $ Intra.unblockConv (lcFrom s2o) conn - when (lcStatus o2s == Sent && new == Accepted) . lift $ do + cnv <- lift $ traverse (Intra.unblockConv self conn) (ucConvId s2o) + when (ucStatus o2s == Sent && new == Accepted) . lift $ do o2s' <- if (cnvType <$> cnv) /= Just ConnectConv - then Data.updateLocalConnection o2s AcceptedWithHistory - else Data.updateLocalConnection o2s BlockedWithHistory - e2o :: ConnectionEvent <- ConnectionUpdated (localToUserConn localDomain o2s') (Just $ lcStatus o2s) <$> Data.lookupName self + then Data.updateConnection o2s AcceptedWithHistory + else Data.updateConnection o2s BlockedWithHistory + e2o :: ConnectionEvent <- + ConnectionUpdated o2s' (Just $ ucStatus o2s) + <$> Data.lookupName (tUnqualified self) -- TODO: is this correct? shouldnt o2s be sent to other? - Intra.onConnectionEvent self conn e2o - lift $ Just <$> Data.updateLocalConnection s2o (mkRelationWithHistory (error "impossible") new) + Intra.onConnectionEvent (tUnqualified self) conn e2o + lift $ Just <$> Data.updateConnection s2o (mkRelationWithHistory (error "impossible") new) - cancel :: LocalConnection -> LocalConnection -> ExceptT ConnectionError AppIO (Maybe LocalConnection) + cancel :: UserConnection -> UserConnection -> ExceptT ConnectionError AppIO (Maybe UserConnection) cancel s2o o2s = do - localDomain <- viewFederationDomain Log.info $ - logLocalConnection self (lcTo s2o) + logLocalConnection (tUnqualified self) (qUnqualified (ucTo s2o)) . msg (val "Cancelling connection") - lift . for_ (lcConv s2o) $ Intra.blockConv (lcFrom s2o) conn - o2s' <- lift $ Data.updateLocalConnection o2s CancelledWithHistory - let e2o = ConnectionUpdated (localToUserConn localDomain o2s') (Just $ lcStatus o2s) Nothing - lift $ Intra.onConnectionEvent self conn e2o + lfrom <- qualifyLocal (ucFrom s2o) + lift $ traverse_ (Intra.blockConv lfrom conn) (ucConvId s2o) + o2s' <- lift $ Data.updateConnection o2s CancelledWithHistory + let e2o = ConnectionUpdated o2s' (Just $ ucStatus o2s) Nothing + lift $ Intra.onConnectionEvent (tUnqualified self) conn e2o change s2o Cancelled - change :: LocalConnection -> Relation -> ExceptT ConnectionError AppIO (Maybe LocalConnection) + change :: UserConnection -> Relation -> ExceptT ConnectionError AppIO (Maybe UserConnection) change c s = do -- FUTUREWORK: refactor to total function. Gets only called with either Ignored, Accepted, Cancelled - lift $ Just <$> Data.updateLocalConnection c (mkRelationWithHistory (error "impossible") s) + lift $ Just <$> Data.updateConnection c (mkRelationWithHistory (error "impossible") s) -localConnection :: UserId -> UserId -> ExceptT ConnectionError AppIO LocalConnection -localConnection a b = do - lift (Data.lookupLocalConnection a b) - >>= tryJust (NotConnected a b) +localConnection :: + Local UserId -> + Local UserId -> + ExceptT ConnectionError AppIO UserConnection +localConnection la lb = do + lift (Data.lookupConnection la (qUntagged lb)) + >>= tryJust (NotConnected (tUnqualified la) (qUntagged lb)) mkRelationWithHistory :: HasCallStack => Relation -> Relation -> RelationWithHistory mkRelationWithHistory oldRel = \case @@ -361,42 +378,52 @@ updateConnectionInternal :: UpdateConnectionsInternal -> ExceptT ConnectionError AppIO () updateConnectionInternal = \case - BlockForMissingLHConsent uid others -> blockForMissingLegalholdConsent uid others - RemoveLHBlocksInvolving uid -> removeLHBlocksInvolving uid + BlockForMissingLHConsent uid others -> do + self <- qualifyLocal uid + blockForMissingLegalholdConsent self others + RemoveLHBlocksInvolving uid -> removeLHBlocksInvolving =<< qualifyLocal uid + CreateConnectionForTest usr other -> do + lusr <- qualifyLocal usr + lift $ + foldQualified + lusr + (createLocalConnectionUnchecked lusr) + (createRemoteConnectionUnchecked lusr) + other where -- inspired by @block@ in 'updateConnection'. - blockForMissingLegalholdConsent :: UserId -> [UserId] -> ExceptT ConnectionError AppIO () + blockForMissingLegalholdConsent :: Local UserId -> [UserId] -> ExceptT ConnectionError AppIO () blockForMissingLegalholdConsent self others = do - localDomain <- viewFederationDomain - for_ others $ \other -> do + for_ others $ \(qualifyAs self -> other) -> do Log.info $ - logConnection self (Qualified other localDomain) + logConnection (tUnqualified self) (qUntagged other) . msg (val "Blocking connection (legalhold device present, but missing consent)") s2o <- localConnection self other o2s <- localConnection other self - for_ [s2o, o2s] $ \(uconn :: LocalConnection) -> lift $ do - Intra.blockConv (lcFrom uconn) Nothing `mapM_` lcConv uconn - uconn' <- Data.updateLocalConnection uconn (mkRelationWithHistory (lcStatus uconn) MissingLegalholdConsent) - let ev = ConnectionUpdated (Data.localToUserConn localDomain uconn') (Just $ lcStatus uconn) Nothing - Intra.onConnectionEvent self Nothing ev + for_ [s2o, o2s] $ \(uconn :: UserConnection) -> lift $ do + lfrom <- qualifyLocal (ucFrom uconn) + traverse_ (Intra.blockConv lfrom Nothing) (ucConvId uconn) + uconn' <- Data.updateConnection uconn (mkRelationWithHistory (ucStatus uconn) MissingLegalholdConsent) + let ev = ConnectionUpdated uconn' (Just $ ucStatus uconn) Nothing + Intra.onConnectionEvent (tUnqualified self) Nothing ev - removeLHBlocksInvolving :: UserId -> ExceptT ConnectionError AppIO () + removeLHBlocksInvolving :: Local UserId -> ExceptT ConnectionError AppIO () removeLHBlocksInvolving self = iterateConnections self (toRange (Proxy @500)) $ \conns -> do - localDomain <- viewFederationDomain for_ conns $ \s2o -> - when (Data.lcStatus s2o == MissingLegalholdConsent) $ do + when (ucStatus s2o == MissingLegalholdConsent) $ do -- (this implies @ucStatus o2s == MissingLegalholdConsent@) - let other = Data.lcTo s2o + -- Here we are using the fact that s2o is a local connection + other <- qualifyLocal (qUnqualified (ucTo s2o)) o2s <- localConnection other self Log.info $ - logConnection (Data.lcFrom s2o) (Qualified (Data.lcTo s2o) localDomain) + logConnection (ucFrom s2o) (ucTo s2o) . msg (val "Unblocking connection (legalhold device removed or consent given)") unblockDirected s2o o2s unblockDirected o2s s2o where - iterateConnections :: UserId -> Range 1 500 Int32 -> ([Data.LocalConnection] -> ExceptT ConnectionError AppIO ()) -> ExceptT ConnectionError AppIO () + iterateConnections :: Local UserId -> Range 1 500 Int32 -> ([UserConnection] -> ExceptT ConnectionError AppIO ()) -> ExceptT ConnectionError AppIO () iterateConnections user pageSize handleConns = go Nothing where go :: Maybe UserId -> ExceptT ConnectionError (AppT IO) () @@ -406,26 +433,29 @@ updateConnectionInternal = \case case resultList page of (conn : rest) -> if resultHasMore page - then go (Just (maximum (Data.lcTo <$> (conn : rest)))) + then go (Just (maximum (qUnqualified . ucTo <$> (conn : rest)))) else pure () [] -> pure () - unblockDirected :: Data.LocalConnection -> Data.LocalConnection -> ExceptT ConnectionError AppIO () + unblockDirected :: UserConnection -> UserConnection -> ExceptT ConnectionError AppIO () unblockDirected uconn uconnRev = do - void . lift . for (Data.lcConv uconn) $ Intra.unblockConv (Data.lcFrom uconn) Nothing - uconnRevRel :: RelationWithHistory <- relationWithHistory (Data.lcFrom uconnRev) (Data.lcTo uconnRev) - uconnRev' <- lift $ Data.updateLocalConnection uconnRev (undoRelationHistory uconnRevRel) - localDomain <- viewFederationDomain - connName <- lift $ Data.lookupName (Data.lcFrom uconn) + lfrom <- qualifyLocal (ucFrom uconnRev) + void . lift . for (ucConvId uconn) $ Intra.unblockConv lfrom Nothing + uconnRevRel :: RelationWithHistory <- relationWithHistory lfrom (ucTo uconnRev) + uconnRev' <- lift $ Data.updateConnection uconnRev (undoRelationHistory uconnRevRel) + connName <- lift $ Data.lookupName (tUnqualified lfrom) let connEvent = ConnectionUpdated - { ucConn = Data.localToUserConn localDomain uconnRev', - ucPrev = Just $ Data.lcStatus uconnRev, + { ucConn = uconnRev', + ucPrev = Just $ ucStatus uconnRev, ucName = connName } - lift $ Intra.onConnectionEvent (Data.lcFrom uconn) Nothing connEvent - relationWithHistory :: UserId -> UserId -> ExceptT ConnectionError AppIO RelationWithHistory - relationWithHistory a b = lift (Data.lookupRelationWithHistory a b) >>= tryJust (NotConnected a b) + lift $ Intra.onConnectionEvent (ucFrom uconn) Nothing connEvent + + relationWithHistory :: Local UserId -> Qualified UserId -> ExceptT ConnectionError AppIO RelationWithHistory + relationWithHistory self target = + lift (Data.lookupRelationWithHistory self target) + >>= tryJust (NotConnected (tUnqualified self) target) undoRelationHistory :: RelationWithHistory -> RelationWithHistory undoRelationHistory = \case @@ -444,18 +474,19 @@ updateConnectionInternal = \case SentWithHistory -> SentWithHistory CancelledWithHistory -> CancelledWithHistory +createLocalConnectionUnchecked :: Local UserId -> Local UserId -> AppIO () +createLocalConnectionUnchecked self other = do + qcnv <- liftIO $ qUntagged . qualifyAs self <$> (Id <$> UUID.nextRandom) + void $ Data.insertConnection self (qUntagged other) AcceptedWithHistory qcnv + void $ Data.insertConnection other (qUntagged self) AcceptedWithHistory qcnv + +createRemoteConnectionUnchecked :: Local UserId -> Remote UserId -> AppIO () +createRemoteConnectionUnchecked self other = do + qcnv <- liftIO $ qUntagged . qualifyAs self <$> (Id <$> UUID.nextRandom) + void $ Data.insertConnection self (qUntagged other) AcceptedWithHistory qcnv + lookupConnections :: UserId -> Maybe UserId -> Range 1 500 Int32 -> AppIO UserConnectionList lookupConnections from start size = do - rs <- Data.lookupLocalConnections from start size - localDomain <- viewFederationDomain - return $! UserConnectionList (Data.localToUserConn localDomain <$> Data.resultList rs) (Data.resultHasMore rs) - --- Helpers - -checkLimit :: UserId -> ExceptT ConnectionError AppIO () -checkLimit u = do - n <- lift $ Data.countConnections u [Accepted, Sent] - l <- setUserMaxConnections <$> view settings - unless (n < l) $ - throwE $ - TooManyConnections u + lusr <- qualifyLocal from + rs <- Data.lookupLocalConnections lusr start size + return $! UserConnectionList (Data.resultList rs) (Data.resultHasMore rs) diff --git a/services/brig/src/Brig/API/Connection/Remote.hs b/services/brig/src/Brig/API/Connection/Remote.hs new file mode 100644 index 0000000000..be1c64ecfe --- /dev/null +++ b/services/brig/src/Brig/API/Connection/Remote.hs @@ -0,0 +1,287 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 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.API.Connection.Remote + ( performLocalAction, + performRemoteAction, + createConnectionToRemoteUser, + updateConnectionToRemoteUser, + ) +where + +import Brig.API.Connection.Util (ConnectionM, checkLimit) +import Brig.API.Types (ConnectionError (..)) +import Brig.App +import qualified Brig.Data.Connection as Data +import Brig.Federation.Client (sendConnectionAction) +import qualified Brig.IO.Intra as Intra +import Brig.Types +import Brig.Types.User.Event +import Control.Comonad +import Control.Error.Util ((??)) +import Control.Monad.Trans.Except (runExceptT, throwE) +import Data.Id as Id +import Data.Qualified +import Galley.Types.Conversations.Intra (Actor (..), DesiredMembership (..), UpsertOne2OneConversationRequest (..), UpsertOne2OneConversationResponse (uuorConvId)) +import Imports +import Network.Wai.Utilities.Error +import Wire.API.Connection (relationWithHistory) +import Wire.API.Federation.API.Brig + ( NewConnectionResponse (..), + RemoteConnectionAction (..), + ) +import Wire.API.Routes.Public.Util (ResponseForExistedCreated (..)) + +data LocalConnectionAction + = LocalConnect + | LocalBlock + | LocalIgnore + | LocalRescind + deriving (Eq) + +data ConnectionAction + = LCA LocalConnectionAction + | RCA RemoteConnectionAction + +-- | Connection state transition logic. +-- +-- In the following, A is a local user, and B is a remote user. +-- +-- LocalConnect: A communicates that they now want to connect. This +-- transitions Pending → Accepted, and every other state (but including Sent) to Sent. +-- LocalBlock: A communicates that they do not want to connect. This +-- transitions every state except Blocked to Blocked. +-- LocalIgnore: A ignores the connection. Pending → Ignored. +-- LocalRescind: A withdraws their intention to connect. Sent → Cancelled, Accepted → Pending. +-- RemoteConnect: B communicates that they now want to connect. Sent → Accepted, Cancelled → Pending, Accepted → Accepted. +-- RemoteRescind: B withdraws their intention to connect. Pending → Cancelled, Accepted → Sent. +-- +-- Returns 'Nothing' if no transition is possible from the current state for +-- the given action. This results in an 'InvalidTransition' error if the +-- connection does not exist. +transition :: ConnectionAction -> Relation -> Maybe Relation +-- MissingLegalholdConsent is treated exactly like blocked +transition action MissingLegalholdConsent = transition action Blocked +transition (LCA LocalConnect) Pending = Just Accepted +transition (LCA LocalConnect) Accepted = Just Accepted +transition (LCA LocalConnect) _ = Just Sent +transition (LCA LocalBlock) Blocked = Nothing +transition (LCA LocalBlock) _ = Just Blocked +transition (LCA LocalIgnore) Pending = Just Ignored +transition (LCA LocalIgnore) _ = Nothing +transition (LCA LocalRescind) Sent = Just Cancelled +-- The following transition is to make sure we always end up in state P +-- when we start in S and receive the two actions RC and LR in an arbitrary +-- order. +transition (LCA LocalRescind) Accepted = Just Pending +transition (LCA LocalRescind) _ = Nothing +transition (RCA RemoteConnect) Sent = Just Accepted +transition (RCA RemoteConnect) Accepted = Just Accepted +transition (RCA RemoteConnect) Blocked = Nothing +transition (RCA RemoteConnect) _ = Just Pending +transition (RCA RemoteRescind) Pending = Just Cancelled +-- The following transition is to make sure we always end up in state S +-- when we start in P and receive the two actions LC and RR in an arbitrary +-- order. +transition (RCA RemoteRescind) Accepted = Just Sent +transition (RCA RemoteRescind) _ = Nothing + +-- When user A has made a request -> Only user A's membership in conv is affected -> User A wants to be in one2one conv with B, or User A doesn't want to be in one2one conv with B +updateOne2OneConv :: + Local UserId -> + Maybe ConnId -> + Remote UserId -> + Maybe (Qualified ConvId) -> + Relation -> + Actor -> + AppIO (Qualified ConvId) +updateOne2OneConv lUsr _mbConn remoteUser mbConvId rel actor = do + let request = + UpsertOne2OneConversationRequest + { uooLocalUser = lUsr, + uooRemoteUser = remoteUser, + uooActor = actor, + uooActorDesiredMembership = desiredMembership actor rel, + uooConvId = mbConvId + } + uuorConvId <$> Intra.upsertOne2OneConversation request + where + desiredMembership :: Actor -> Relation -> DesiredMembership + desiredMembership a r = + let isIncluded = + a + `elem` case r of + Accepted -> [LocalActor, RemoteActor] + Blocked -> [] + Pending -> [RemoteActor] + Ignored -> [RemoteActor] + Sent -> [LocalActor] + Cancelled -> [] + MissingLegalholdConsent -> [] + in if isIncluded then Included else Excluded + +-- | Perform a state transition on a connection, handle conversation updates and +-- push events. +-- +-- NOTE: This function does not check whether the max connection limit has been +-- reached, the consumers must ensure of this. +-- +-- Returns the connection, and whether it was updated or not. +transitionTo :: + Local UserId -> + Maybe ConnId -> + Remote UserId -> + Maybe UserConnection -> + Maybe Relation -> + Actor -> + ConnectionM (ResponseForExistedCreated UserConnection, Bool) +transitionTo self _ _ Nothing Nothing _ = + -- This can only happen if someone tries to ignore as a first action on a + -- connection. This shouldn't be possible. + throwE (InvalidTransition (tUnqualified self)) +transitionTo self mzcon other Nothing (Just rel) actor = lift $ do + -- update 1-1 connection + qcnv <- updateOne2OneConv self mzcon other Nothing rel actor + + -- create connection + connection <- + Data.insertConnection + self + (qUntagged other) + (relationWithHistory rel) + qcnv + + -- send event + pushEvent self mzcon connection + pure (Created connection, True) +transitionTo _self _zcon _other (Just connection) Nothing _actor = pure (Existed connection, False) +transitionTo self mzcon other (Just connection) (Just rel) actor = lift $ do + -- update 1-1 conversation + void $ updateOne2OneConv self Nothing other (ucConvId connection) rel actor + + -- update connection + connection' <- Data.updateConnection connection (relationWithHistory rel) + + -- send event + pushEvent self mzcon connection' + pure (Existed connection', True) + +-- | Send an event to the local user when the state of a connection changes. +pushEvent :: Local UserId -> Maybe ConnId -> UserConnection -> AppIO () +pushEvent self mzcon connection = do + let event = ConnectionUpdated connection Nothing Nothing + Intra.onConnectionEvent (tUnqualified self) mzcon event + +performLocalAction :: + Local UserId -> + Maybe ConnId -> + Remote UserId -> + Maybe UserConnection -> + LocalConnectionAction -> + ConnectionM (ResponseForExistedCreated UserConnection, Bool) +performLocalAction self mzcon other mconnection action = do + let rel0 = maybe Cancelled ucStatus mconnection + checkLimitForLocalAction self rel0 action + mrel2 <- for (transition (LCA action) rel0) $ \rel1 -> do + mreaction <- fmap join . for (remoteAction action) $ \ra -> do + response <- sendConnectionAction self other ra !>> ConnectFederationError + case (response :: NewConnectionResponse) of + NewConnectionResponseOk reaction -> pure reaction + NewConnectionResponseUserNotActivated -> throwE (InvalidUser (qUntagged other)) + pure $ + fromMaybe rel1 $ do + reactionAction <- (mreaction :: Maybe RemoteConnectionAction) + transition (RCA reactionAction) rel1 + transitionTo self mzcon other mconnection mrel2 LocalActor + where + remoteAction :: LocalConnectionAction -> Maybe RemoteConnectionAction + remoteAction LocalConnect = Just RemoteConnect + remoteAction LocalRescind = Just RemoteRescind + remoteAction _ = Nothing + +-- | The 'RemoteConnectionAction' "reaction" that may be returned is processed +-- by the remote caller. This extra action allows to automatically resolve some +-- inconsistent states, for example: +-- +-- Without any reaction +-- @ +-- A B +-- A connects: Sent Pending +-- B ignores: Sent Ignore +-- B connects: Accepted Sent +-- @ +-- +-- Using the reaction returned by A +-- +-- @ +-- A B +-- A connects: Sent Pending +-- B ignores: Sent Ignore +-- B connects & A reacts: Accepted Accepted +-- @ +performRemoteAction :: + Local UserId -> + Remote UserId -> + Maybe UserConnection -> + RemoteConnectionAction -> + AppIO (Maybe RemoteConnectionAction) +performRemoteAction self other mconnection action = do + let rel0 = maybe Cancelled ucStatus mconnection + let rel1 = transition (RCA action) rel0 + result <- runExceptT . void $ transitionTo self Nothing other mconnection rel1 RemoteActor + pure $ either (const (Just RemoteRescind)) (const (reaction rel1)) result + where + reaction :: Maybe Relation -> Maybe RemoteConnectionAction + reaction (Just Accepted) = Just RemoteConnect + reaction (Just Sent) = Just RemoteConnect + reaction _ = Nothing + +createConnectionToRemoteUser :: + Local UserId -> + ConnId -> + Remote UserId -> + ConnectionM (ResponseForExistedCreated UserConnection) +createConnectionToRemoteUser self zcon other = do + mconnection <- lift $ Data.lookupConnection self (qUntagged other) + fst <$> performLocalAction self (Just zcon) other mconnection LocalConnect + +updateConnectionToRemoteUser :: + Local UserId -> + Remote UserId -> + Relation -> + Maybe ConnId -> + ConnectionM (Maybe UserConnection) +updateConnectionToRemoteUser self other rel1 zcon = do + mconnection <- lift $ Data.lookupConnection self (qUntagged other) + action <- + actionForTransition rel1 + ?? InvalidTransition (tUnqualified self) + (conn, wasUpdated) <- performLocalAction self zcon other mconnection action + pure $ guard wasUpdated $> extract conn + where + actionForTransition Cancelled = Just LocalRescind + actionForTransition Sent = Just LocalConnect + actionForTransition Accepted = Just LocalConnect + actionForTransition Blocked = Just LocalBlock + actionForTransition Ignored = Just LocalIgnore + actionForTransition Pending = Nothing + actionForTransition MissingLegalholdConsent = Nothing + +checkLimitForLocalAction :: Local UserId -> Relation -> LocalConnectionAction -> ConnectionM () +checkLimitForLocalAction u oldRel action = + when (oldRel `notElem` [Accepted, Sent] && (action == LocalConnect)) $ + checkLimit u diff --git a/services/brig/src/Brig/API/Connection/Util.hs b/services/brig/src/Brig/API/Connection/Util.hs new file mode 100644 index 0000000000..0f1f7b5b10 --- /dev/null +++ b/services/brig/src/Brig/API/Connection/Util.hs @@ -0,0 +1,44 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 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.API.Connection.Util + ( ConnectionM, + checkLimit, + ) +where + +import Brig.API.Types +import Brig.App +import qualified Brig.Data.Connection as Data +import Brig.Options (Settings (setUserMaxConnections)) +import Control.Error (noteT) +import Control.Lens (view) +import Control.Monad.Trans.Except +import Data.Id (UserId) +import Data.Qualified (Local, tUnqualified) +import Imports +import Wire.API.Connection (Relation (..)) + +type ConnectionM = ExceptT ConnectionError AppIO + +-- Helpers + +checkLimit :: Local UserId -> ExceptT ConnectionError AppIO () +checkLimit u = noteT (TooManyConnections (tUnqualified u)) $ do + n <- lift $ Data.countConnections u [Accepted, Sent] + l <- setUserMaxConnections <$> view settings + guard (n < l) diff --git a/services/brig/src/Brig/API/Error.hs b/services/brig/src/Brig/API/Error.hs index edce388008..a2c87b1b06 100644 --- a/services/brig/src/Brig/API/Error.hs +++ b/services/brig/src/Brig/API/Error.hs @@ -116,6 +116,7 @@ connError (ConnectInvalidEmail _ _) = StdError invalidEmail connError ConnectInvalidPhone {} = StdError invalidPhone connError ConnectSameBindingTeamUsers = StdError sameBindingTeamUsers connError ConnectMissingLegalholdConsent = StdError (errorDescriptionTypeToWai @MissingLegalholdConsent) +connError (ConnectFederationError e) = fedError e actError :: ActivationError -> Error actError (UserKeyExists _) = StdError userKeyExists diff --git a/services/brig/src/Brig/API/Federation.hs b/services/brig/src/Brig/API/Federation.hs index 9ef12ad8a1..9ae84c6eee 100644 --- a/services/brig/src/Brig/API/Federation.hs +++ b/services/brig/src/Brig/API/Federation.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE RecordWildCards #-} + -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2020 Wire Swiss GmbH @@ -18,22 +20,37 @@ module Brig.API.Federation (federationSitemap) where import qualified Brig.API.Client as API +import Brig.API.Connection.Remote (performRemoteAction) import Brig.API.Error (clientError) import Brig.API.Handler (Handler) import qualified Brig.API.User as API -import Brig.Types (PrekeyBundle) +import Brig.App (qualifyLocal) +import qualified Brig.Data.Connection as Data +import qualified Brig.Data.User as Data +import Brig.IO.Intra (notify) +import Brig.Types (PrekeyBundle, Relation (Accepted)) +import Brig.Types.User.Event import Brig.User.API.Handle +import Data.Domain import Data.Handle (Handle (..), parseHandle) import Data.Id (ClientId, UserId) +import Data.List.NonEmpty (nonEmpty) +import Data.List1 +import Data.Qualified +import Data.Range +import qualified Gundeck.Types.Push as Push import Imports import Network.Wai.Utilities.Error ((!>>)) import Servant (ServerT) import Servant.API.Generic (ToServantApi) import Servant.Server.Generic (genericServerT) +import UnliftIO.Async (pooledForConcurrentlyN_) import Wire.API.Federation.API.Brig hiding (Api (..)) import qualified Wire.API.Federation.API.Brig as Federated import qualified Wire.API.Federation.API.Brig as FederationAPIBrig +import Wire.API.Federation.API.Common import Wire.API.Message (UserClients) +import Wire.API.Routes.Internal.Brig.Connection import Wire.API.Team.LegalHold (LegalholdProtectee (LegalholdPlusFederationNotImplemented)) import Wire.API.User (UserProfile) import Wire.API.User.Client (PubClient, UserClientPrekeyMap) @@ -51,9 +68,23 @@ federationSitemap = Federated.claimPrekeyBundle = claimPrekeyBundle, Federated.claimMultiPrekeyBundle = claimMultiPrekeyBundle, Federated.searchUsers = searchUsers, - Federated.getUserClients = getUserClients + Federated.getUserClients = getUserClients, + Federated.sendConnectionAction = sendConnectionAction, + Federated.onUserDeleted = onUserDeleted } +sendConnectionAction :: Domain -> NewConnectionRequest -> Handler NewConnectionResponse +sendConnectionAction originDomain NewConnectionRequest {..} = do + active <- lift $ Data.isActivated ncrTo + if active + then do + self <- qualifyLocal ncrTo + let other = toRemoteUnsafe originDomain ncrFrom + mconnection <- lift $ Data.lookupConnection self (qUntagged other) + maction <- lift $ performRemoteAction self other mconnection ncrAction + pure $ NewConnectionResponseOk maction + else pure NewConnectionResponseUserNotActivated + getUserByHandle :: Handle -> Handler (Maybe UserProfile) getUserByHandle handle = lift $ do maybeOwnerId <- API.lookupHandle handle @@ -91,3 +122,17 @@ searchUsers (SearchRequest searchTerm) = do getUserClients :: GetUserClients -> Handler (UserMap (Set PubClient)) getUserClients (GetUserClients uids) = API.lookupLocalPubClientsBulk uids !>> clientError + +onUserDeleted :: Domain -> UserDeletedConnectionsNotification -> Handler EmptyResponse +onUserDeleted origDomain udcn = lift $ do + let deletedUser = toRemoteUnsafe origDomain (udcnUser udcn) + connections = udcnConnections udcn + event = pure . UserEvent $ UserDeleted (qUntagged deletedUser) + acceptedLocals <- + map csv2From + . filter (\x -> csv2Status x == Accepted) + <$> Data.lookupRemoteConnectionStatuses (fromRange connections) (fmap pure deletedUser) + pooledForConcurrentlyN_ 16 (nonEmpty acceptedLocals) $ \(List1 -> recipients) -> + notify event (tUnqualified deletedUser) Push.RouteDirect Nothing (pure recipients) + Data.deleteRemoteConnections deletedUser connections + pure EmptyResponse diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index 225c4784ee..9ad43d1bdb 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -33,6 +33,7 @@ import qualified Brig.API.User as API import Brig.API.Util (validateHandle) import Brig.App import qualified Brig.Data.Client as Data +import qualified Brig.Data.Connection as Data import qualified Brig.Data.User as Data import qualified Brig.IO.Intra as Intra import Brig.Options hiding (internalEvents, sesQueue) @@ -55,6 +56,7 @@ import Data.Handle (Handle) import Data.Id as Id import qualified Data.List1 as List1 import qualified Data.Map.Strict as Map +import Data.Qualified import qualified Data.Set as Set import Galley.Types (UserClients (..)) import Imports hiding (head) @@ -70,6 +72,7 @@ import Servant.Swagger.UI import qualified System.Logger.Class as Log import Wire.API.ErrorDescription import qualified Wire.API.Routes.Internal.Brig as BrigIRoutes +import Wire.API.Routes.Internal.Brig.Connection import qualified Wire.API.Team.Feature as ApiFt import Wire.API.User import Wire.API.User.Client (UserClientsFull (..)) @@ -84,6 +87,8 @@ servantSitemap = :<|> getAccountFeatureConfig :<|> putAccountFeatureConfig :<|> deleteAccountFeatureConfig + :<|> getConnectionsStatusUnqualified + :<|> getConnectionsStatus -- | Responds with 'Nothing' if field is NULL in existing user or user does not exist. getAccountFeatureConfig :: UserId -> Handler ApiFt.TeamFeatureStatusNoConfig @@ -131,13 +136,6 @@ sitemap = do -- - MemberLeave event to members for all conversations the user was in (via galley) delete "/i/users/:uid" (continue deleteUserNoVerifyH) $ capture "uid" - get "/i/users/connections-status" (continue deprecatedGetConnectionsStatusH) $ - query "users" - .&. opt (query "filter") - post "/i/users/connections-status" (continue getConnectionsStatusH) $ - accept "application" "json" - .&. jsonRequest @ConnectionsStatusRequest - .&. opt (query "filter") put "/i/connections/connection-update" (continue updateConnectionInternalH) $ accept "application" "json" @@ -450,20 +448,25 @@ getAccountStatusH (_ ::: usr) = do Just s -> json $ AccountStatusResp s Nothing -> setStatus status404 empty -getConnectionsStatusH :: - JSON ::: JsonRequest ConnectionsStatusRequest ::: Maybe Relation -> - Handler Response -getConnectionsStatusH (_ ::: req ::: flt) = do - body <- parseJsonBody req - json <$> lift (getConnectionsStatus body flt) - -getConnectionsStatus :: ConnectionsStatusRequest -> Maybe Relation -> AppIO [ConnectionStatus] -getConnectionsStatus ConnectionsStatusRequest {csrFrom, csrTo} flt = do +getConnectionsStatusUnqualified :: ConnectionsStatusRequest -> Maybe Relation -> Handler [ConnectionStatus] +getConnectionsStatusUnqualified ConnectionsStatusRequest {csrFrom, csrTo} flt = lift $ do r <- maybe (API.lookupConnectionStatus' csrFrom) (API.lookupConnectionStatus csrFrom) csrTo return $ maybe r (filterByRelation r) flt where filterByRelation l rel = filter ((== rel) . csStatus) l +getConnectionsStatus :: ConnectionsStatusRequestV2 -> Handler [ConnectionStatusV2] +getConnectionsStatus (ConnectionsStatusRequestV2 froms mtos mrel) = do + loc <- qualifyLocal () + conns <- lift $ case mtos of + Nothing -> Data.lookupAllStatuses =<< qualifyLocal froms + Just tos -> do + let getStatusesForOneDomain = foldQualified loc (Data.lookupLocalConnectionStatuses froms) (Data.lookupRemoteConnectionStatuses froms) + concat <$> mapM getStatusesForOneDomain (bucketQualified tos) + pure $ maybe conns (filterByRelation conns) mrel + where + filterByRelation l rel = filter ((== rel) . csv2Status) l + revokeIdentityH :: Either Email Phone -> Handler Response revokeIdentityH emailOrPhone = do lift $ API.revokeIdentity emailOrPhone @@ -599,19 +602,6 @@ getContactListH (_ ::: uid) = do contacts <- lift $ API.lookupContactList uid return $ json $ UserIds contacts --- Deprecated - --- Deprecated and to be removed after new versions of brig and galley are --- deployed. Reason for deprecation: it returns N^2 things (which is not --- needed), it doesn't scale, and it accepts everything in URL parameters, --- which doesn't work when the list of users is long. -deprecatedGetConnectionsStatusH :: List UserId ::: Maybe Relation -> Handler Response -deprecatedGetConnectionsStatusH (users ::: flt) = do - r <- lift $ API.lookupConnectionStatus (fromList users) (fromList users) - return . json $ maybe r (filterByRelation r) flt - where - filterByRelation l rel = filter ((== rel) . csStatus) l - -- Utilities ifNothing :: Utilities.Error -> Maybe a -> Handler a diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index 7d607552c0..3ed826d088 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -56,7 +56,7 @@ import Brig.User.Phone import qualified Cassandra as C import qualified Cassandra as Data import Control.Error hiding (bool) -import Control.Lens (view, (%~), (.~), (?~), (^.)) +import Control.Lens (view, (%~), (.~), (?~), (^.), _Just) import Control.Monad.Catch (throwM) import Data.Aeson hiding (json) import Data.ByteString.Conversion @@ -70,7 +70,7 @@ import Data.Handle (Handle, parseHandle) import Data.Id as Id import qualified Data.Map.Strict as Map import Data.Misc (IpAddr (..)) -import Data.Qualified (Qualified (..), partitionRemoteOrLocalIds) +import Data.Qualified import Data.Range import Data.String.Interpolate as QQ import qualified Data.Swagger as S @@ -98,7 +98,6 @@ import qualified System.Logger.Class as Log import Util.Logging (logFunction, logHandle, logTeam, logUser) import qualified Wire.API.Connection as Public import Wire.API.ErrorDescription -import Wire.API.Federation.Error (federationNotImplemented) import qualified Wire.API.Properties as Public import qualified Wire.API.Routes.MultiTablePaging as Public import Wire.API.Routes.Public.Brig (Api (updateConnectionUnqualified)) @@ -134,10 +133,24 @@ swaggerDocsAPI = & S.info . S.title .~ "Wire-Server API" & S.info . S.description ?~ desc & S.security %~ nub + -- sanitise definitions & S.definitions . traverse %~ sanitise + -- sanitise general responses + & S.responses . traverse . S.schema . _Just . S._Inline %~ sanitise + -- sanitise all responses of all paths + & S.allOperations . S.responses . S.responses + . traverse + . S._Inline + . S.schema + . _Just + . S._Inline + %~ sanitise where sanitise :: S.Schema -> S.Schema - sanitise = (S.properties . traverse . S._Inline %~ sanitise) . (S.required %~ nubOrd) + sanitise = + (S.properties . traverse . S._Inline %~ sanitise) + . (S.required %~ nubOrd) + . (S.enum_ . _Just %~ nub) desc = Text.pack [QQ.i| @@ -261,7 +274,7 @@ servantSitemap = BrigAPI.getClient = getClient, BrigAPI.getClientCapabilities = getClientCapabilities, BrigAPI.getClientPrekeys = getClientPrekeys, - BrigAPI.createConnectionUnqualified = createLocalConnection, + BrigAPI.createConnectionUnqualified = createConnectionUnqualified, BrigAPI.createConnection = createConnection, BrigAPI.listLocalConnections = listLocalConnections, BrigAPI.listConnections = listConnections, @@ -905,7 +918,9 @@ getUserUnqualifiedH self uid = do getUser self (Qualified uid domain) getUser :: UserId -> Qualified UserId -> Handler (Maybe Public.UserProfile) -getUser self qualifiedUserId = API.lookupProfile self qualifiedUserId !>> fedError +getUser self qualifiedUserId = do + lself <- qualifyLocal self + API.lookupProfile lself qualifiedUserId !>> fedError getUserDisplayNameH :: JSON ::: UserId -> Handler Response getUserDisplayNameH (_ ::: self) = do @@ -933,14 +948,14 @@ listUsersByUnqualifiedIdsOrHandles self mUids mHandles = do listUsersByIdsOrHandles :: UserId -> Public.ListUsersQuery -> Handler [Public.UserProfile] listUsersByIdsOrHandles self q = do + lself <- qualifyLocal self foundUsers <- case q of Public.ListUsersByIds us -> - byIds us + byIds lself us Public.ListUsersByHandles hs -> do - domain <- viewFederationDomain - let (_remoteHandles, localHandles) = partitionRemoteOrLocalIds domain (fromRange hs) + let (localHandles, _) = partitionQualified lself (fromRange hs) us <- getIds localHandles - Handle.filterHandleResults self =<< byIds us + Handle.filterHandleResults lself =<< byIds lself us case foundUsers of [] -> throwStd $ notFound "None of the specified ids or handles match any users" _ -> pure foundUsers @@ -950,8 +965,8 @@ listUsersByIdsOrHandles self q = do localUsers <- catMaybes <$> traverse (lift . API.lookupHandle) localHandles domain <- viewFederationDomain pure $ map (`Qualified` domain) localUsers - byIds :: [Qualified UserId] -> Handler [Public.UserProfile] - byIds uids = API.lookupProfiles self uids !>> fedError + byIds :: Local UserId -> [Qualified UserId] -> Handler [Public.UserProfile] + byIds lself uids = API.lookupProfiles lself uids !>> fedError newtype GetActivationCodeResp = GetActivationCodeResp (Public.ActivationKey, Public.ActivationCode) @@ -1085,69 +1100,85 @@ customerExtensionCheckBlockedDomains email = do when (domain `elem` blockedDomains) $ throwM $ customerExtensionBlockedDomain domain -createLocalConnection :: UserId -> ConnId -> Public.ConnectionRequest -> Handler (Public.ResponseForExistedCreated Public.UserConnection) -createLocalConnection self conn cr = do - API.createConnection self cr conn !>> connError +createConnectionUnqualified :: UserId -> ConnId -> Public.ConnectionRequest -> Handler (Public.ResponseForExistedCreated Public.UserConnection) +createConnectionUnqualified self conn cr = do + lself <- qualifyLocal self + target <- qualifyLocal (Public.crUser cr) + API.createConnection lself conn (qUntagged target) !>> connError --- | FUTUREWORK: also create remote connections: https://wearezeta.atlassian.net/browse/SQCORE-958 createConnection :: UserId -> ConnId -> Qualified UserId -> Handler (Public.ResponseForExistedCreated Public.UserConnection) -createConnection self conn (Qualified otherUser otherDomain) = do - localDomain <- viewFederationDomain - if localDomain == otherDomain - then createLocalConnection self conn (Public.ConnectionRequest otherUser (unsafeRange "_")) - else throwM federationNotImplemented +createConnection self conn target = do + lself <- qualifyLocal self + API.createConnection lself conn target !>> connError updateLocalConnection :: UserId -> ConnId -> UserId -> Public.ConnectionUpdate -> Handler (Public.UpdateResult Public.UserConnection) updateLocalConnection self conn other update = do - let newStatus = Public.cuStatus update - mc <- API.updateConnection self other newStatus (Just conn) !>> connError - return $ maybe Public.Unchanged Public.Updated mc + lother <- qualifyLocal other + updateConnection self conn (qUntagged lother) update --- | FUTUREWORK: also update remote connections: https://wearezeta.atlassian.net/browse/SQCORE-959 updateConnection :: UserId -> ConnId -> Qualified UserId -> Public.ConnectionUpdate -> Handler (Public.UpdateResult Public.UserConnection) -updateConnection self conn (Qualified otherUid otherDomain) update = do - localDomain <- viewFederationDomain - if localDomain == otherDomain - then updateLocalConnection self conn otherUid update - else throwM federationNotImplemented +updateConnection self conn other update = do + let newStatus = Public.cuStatus update + lself <- qualifyLocal self + mc <- API.updateConnection lself other newStatus (Just conn) !>> connError + return $ maybe Public.Unchanged Public.Updated mc listLocalConnections :: UserId -> Maybe UserId -> Maybe (Range 1 500 Int32) -> Handler Public.UserConnectionList listLocalConnections uid start msize = do let defaultSize = toRange (Proxy @100) lift $ API.lookupConnections uid start (fromMaybe defaultSize msize) --- | FUTUREWORK: also list remote connections: https://wearezeta.atlassian.net/browse/SQCORE-963 +-- | Lists connection IDs for the logged in user in a paginated way. +-- +-- Pagination requires an order, in this case the order is defined as: +-- +-- - First all the local connections are listed ordered by their id +-- +-- - After local connections, remote connections are listed ordered +-- - lexicographically by their domain and then by their id. listConnections :: UserId -> Public.ListConnectionsRequestPaginated -> Handler Public.ConnectionsPage -listConnections uid req = do - localDomain <- viewFederationDomain - let size = Public.gmtprSize req - res :: C.PageWithState Data.LocalConnection <- Data.lookupLocalConnectionsPage uid convertedState (rcast size) - return (pageToConnectionsPage localDomain Public.PagingLocals res) +listConnections uid Public.GetMultiTablePageRequest {..} = do + self <- qualifyLocal uid + case gmtprState of + Just (Public.ConnectionPagingState Public.PagingRemotes stateBS) -> remotesOnly self (mkState <$> stateBS) (fromRange gmtprSize) + _ -> localsAndRemotes self (fmap mkState . Public.mtpsState =<< gmtprState) gmtprSize where - pageToConnectionsPage :: Domain -> Public.LocalOrRemoteTable -> Data.PageWithState Data.LocalConnection -> Public.ConnectionsPage - pageToConnectionsPage localDomain table page@Data.PageWithState {..} = + pageToConnectionsPage :: Public.LocalOrRemoteTable -> Data.PageWithState Public.UserConnection -> Public.ConnectionsPage + pageToConnectionsPage table page@Data.PageWithState {..} = Public.MultiTablePage - { mtpResults = Data.localToUserConn localDomain <$> pwsResults, + { mtpResults = pwsResults, mtpHasMore = C.pwsHasMore page, -- FUTUREWORK confusingly, using 'ConversationPagingState' instead of 'ConnectionPagingState' doesn't fail any tests. -- Is this type actually useless? Or the tests not good enough? mtpPagingState = Public.ConnectionPagingState table (LBS.toStrict . C.unPagingState <$> pwsState) } + mkState :: ByteString -> C.PagingState mkState = C.PagingState . LBS.fromStrict - convertedState :: Maybe C.PagingState - convertedState = fmap mkState . Public.mtpsState =<< Public.gmtprState req + localsAndRemotes :: Local UserId -> Maybe C.PagingState -> Range 1 500 Int32 -> Handler Public.ConnectionsPage + localsAndRemotes self pagingState size = do + localPage <- pageToConnectionsPage Public.PagingLocals <$> Data.lookupLocalConnectionsPage self pagingState (rcast size) + let remainingSize = fromRange size - fromIntegral (length (Public.mtpResults localPage)) + if Public.mtpHasMore localPage || remainingSize <= 0 + then pure localPage {Public.mtpHasMore = True} -- We haven't checked the remotes yet, so has_more must always be True here. + else do + remotePage <- remotesOnly self Nothing remainingSize + pure remotePage {Public.mtpResults = Public.mtpResults localPage <> Public.mtpResults remotePage} + + remotesOnly :: Local UserId -> Maybe C.PagingState -> Int32 -> Handler Public.ConnectionsPage + remotesOnly self pagingState size = + pageToConnectionsPage Public.PagingRemotes <$> Data.lookupRemoteConnectionsPage self pagingState size getLocalConnection :: UserId -> UserId -> Handler (Maybe Public.UserConnection) -getLocalConnection self other = lift $ API.lookupLocalConnection self other +getLocalConnection self other = do + lother <- qualifyLocal other + getConnection self (qUntagged lother) getConnection :: UserId -> Qualified UserId -> Handler (Maybe Public.UserConnection) -getConnection self (Qualified otherUser otherDomain) = do - localDomain <- viewFederationDomain - if localDomain == otherDomain - then getLocalConnection self otherUser - else throwM federationNotImplemented +getConnection self other = do + lself <- qualifyLocal self + lift $ Data.lookupConnection lself other deleteUser :: UserId -> diff --git a/services/brig/src/Brig/API/Types.hs b/services/brig/src/Brig/API/Types.hs index 10f3a4fc39..a0d4244199 100644 --- a/services/brig/src/Brig/API/Types.hs +++ b/services/brig/src/Brig/API/Types.hs @@ -41,6 +41,7 @@ import Brig.Types.Code (Timeout) import Brig.Types.Intra import Brig.User.Auth.Cookie (RetryAfter (..)) import Data.Id +import Data.Qualified import Imports import qualified Network.Wai.Utilities.Error as Wai import Wire.API.Federation.Client (FederationError) @@ -114,11 +115,11 @@ data ConnectionError -- when attempting to create or accept a connection. TooManyConnections UserId | -- | An invalid connection status change. - InvalidTransition UserId Relation + InvalidTransition UserId | -- | The target user in an connection attempt is invalid, e.g. not activated. - InvalidUser UserId + InvalidUser (Qualified UserId) | -- | An attempt at updating a non-existent connection. - NotConnected UserId UserId + NotConnected UserId (Qualified UserId) | -- | An attempt at creating a connection from an account with -- no verified user identity. ConnectNoIdentity @@ -132,6 +133,8 @@ data ConnectionError ConnectSameBindingTeamUsers | -- | Something doesn't work because somebody has a LH device and somebody else has not granted consent. ConnectMissingLegalholdConsent + | -- | Remote connection creation or update failed because of a federation error + ConnectFederationError FederationError data PasswordResetError = PasswordResetInProgress (Maybe Timeout) diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index e39aba706a..950b3184d5 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE RecordWildCards #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2020 Wire Swiss GmbH @@ -93,7 +91,7 @@ where import qualified Brig.API.Error as Error import qualified Brig.API.Handler as API (Handler) import Brig.API.Types -import Brig.API.Util (fetchUserIdentity, validateHandle) +import Brig.API.Util import Brig.App import qualified Brig.Code as Code import Brig.Data.Activation (ActivationEvent (..)) @@ -129,13 +127,11 @@ import Brig.User.Handle.Blacklist import Brig.User.Phone import qualified Brig.User.Search.TeamSize as TeamSize import Control.Arrow ((&&&)) -import Control.Concurrent.Async (mapConcurrently, mapConcurrently_) import Control.Error import Control.Lens (view, (^.)) import Control.Monad.Catch import Data.ByteString.Conversion import qualified Data.Currency as Currency -import Data.Domain (Domain) import Data.Handle (Handle) import Data.Id as Id import Data.Json.Util @@ -144,7 +140,7 @@ import Data.List1 (List1) import qualified Data.Map.Strict as Map import qualified Data.Metrics as Metrics import Data.Misc (PlainTextPassword (..)) -import Data.Qualified (Qualified, partitionQualified) +import Data.Qualified import Data.Time.Clock (addUTCTime, diffUTCTime) import Data.UUID.V4 (nextRandom) import qualified Galley.Types.Teams as Team @@ -153,7 +149,9 @@ import Imports import Network.Wai.Utilities import qualified System.Logger.Class as Log import System.Logger.Message +import UnliftIO.Async import Wire.API.Federation.Client (FederationError (..)) +import Wire.API.Routes.Internal.Brig.Connection import Wire.API.Team.Member (legalHoldStatus) data AllowSCIMUpdates @@ -259,7 +257,7 @@ createUser new = do Nothing -> pure Nothing joinedTeamSSO <- case (newUserIdentity new', tid) of - (Just ident@(SSOIdentity (UserSSOId _ _) _ _), Just tid') -> Just <$> addUserToTeamSSO account tid' ident + (Just ident@(SSOIdentity (UserSSOId _) _ _), Just tid') -> Just <$> addUserToTeamSSO account tid' ident _ -> pure Nothing pure (activatedTeam <|> joinedTeamInvite <|> joinedTeamSSO) @@ -1056,7 +1054,8 @@ deleteAccount account@(accountUser -> user) = do Data.insertAccount tombstone Nothing Nothing False Intra.rmUser uid (userAssets user) Data.lookupClients uid >>= mapM_ (Data.rmClient uid . clientId) - Intra.onUserEvent uid Nothing (UserDeleted uid) + luid <- qualifyLocal uid + Intra.onUserEvent uid Nothing (UserDeleted (qUntagged luid)) -- Note: Connections can only be deleted afterwards, since -- they need to be notified. Data.deleteConnections uid @@ -1124,8 +1123,12 @@ userGC u = case (userExpire u) of deleteUserNoVerify (userId u) return u -lookupProfile :: UserId -> Qualified UserId -> ExceptT FederationError AppIO (Maybe UserProfile) -lookupProfile self other = listToMaybe <$> lookupProfiles self [other] +lookupProfile :: Local UserId -> Qualified UserId -> ExceptT FederationError AppIO (Maybe UserProfile) +lookupProfile self other = + listToMaybe + <$> lookupProfilesFromDomain + self + (fmap pure other) -- | Obtain user profiles for a list of users as they can be seen by -- a given user 'self'. User 'self' can see the 'FullProfile' of any other user 'other', @@ -1134,22 +1137,27 @@ lookupProfile self other = listToMaybe <$> lookupProfiles self [other] -- If 'self' is an unknown 'UserId', return '[]'. lookupProfiles :: -- | User 'self' on whose behalf the profiles are requested. - UserId -> + Local UserId -> -- | The users ('others') for which to obtain the profiles. [Qualified UserId] -> ExceptT FederationError AppIO [UserProfile] -lookupProfiles self others = do - localDomain <- viewFederationDomain - let userMap = partitionQualified others - -- FUTUREWORK(federation): parallelise federator requests here - fold <$> traverse (uncurry (getProfiles localDomain)) (Map.assocs userMap) - where - getProfiles localDomain domain uids - | localDomain == domain = lift (lookupLocalProfiles (Just self) uids) - | otherwise = lookupRemoteProfiles domain uids - -lookupRemoteProfiles :: Domain -> [UserId] -> ExceptT FederationError AppIO [UserProfile] -lookupRemoteProfiles = Federation.getUsersByIds +lookupProfiles self others = + fmap concat $ + traverseConcurrentlyWithErrors + (lookupProfilesFromDomain self) + (bucketQualified others) + +lookupProfilesFromDomain :: + Local UserId -> Qualified [UserId] -> ExceptT FederationError AppIO [UserProfile] +lookupProfilesFromDomain self = + foldQualified + self + (lift . lookupLocalProfiles (Just (tUnqualified self)) . tUnqualified) + lookupRemoteProfiles + +lookupRemoteProfiles :: Remote [UserId] -> ExceptT FederationError AppIO [UserProfile] +lookupRemoteProfiles (qUntagged -> Qualified uids domain) = + Federation.getUsersByIds domain uids -- FUTUREWORK: This function encodes a few business rules about exposing email -- ids, but it is also very complex. Maybe this can be made easy by extracting a diff --git a/services/brig/src/Brig/API/Util.hs b/services/brig/src/Brig/API/Util.hs index 358f5d665e..05d22451cf 100644 --- a/services/brig/src/Brig/API/Util.hs +++ b/services/brig/src/Brig/API/Util.hs @@ -22,6 +22,7 @@ module Brig.API.Util logInvitationCode, validateHandle, logEmail, + traverseConcurrentlyWithErrors, ) where @@ -33,7 +34,7 @@ import qualified Brig.Data.User as Data import Brig.Types import Brig.Types.Intra (accountUser) import Control.Monad.Catch (throwM) -import Control.Monad.Trans.Except (throwE) +import Control.Monad.Trans.Except import Data.Handle (Handle, parseHandle) import Data.Id import Data.Maybe @@ -42,6 +43,8 @@ import Data.Text.Ascii (AsciiText (toText)) import Imports import System.Logger (Msg) import qualified System.Logger as Log +import UnliftIO.Async +import UnliftIO.Exception (throwIO, try) import Util.Logging (sha256String) lookupProfilesMaybeFilterSameTeamOnly :: UserId -> [UserProfile] -> Handler [UserProfile] @@ -73,3 +76,13 @@ 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) => + (a -> ExceptT e AppIO b) -> + t a -> + ExceptT e AppIO (t b) +traverseConcurrentlyWithErrors f = + ExceptT . try . (traverse (either throwIO pure) =<<) + . pooledMapConcurrentlyN 8 (runExceptT . f) diff --git a/services/brig/src/Brig/App.hs b/services/brig/src/Brig/App.hs index d30481333f..0089940425 100644 --- a/services/brig/src/Brig/App.hs +++ b/services/brig/src/Brig/App.hs @@ -64,6 +64,7 @@ module Brig.App forkAppIO, locationOf, viewFederationDomain, + qualifyLocal, ) where @@ -106,6 +107,7 @@ import Data.List1 (List1, list1) import Data.Metrics (Metrics) import qualified Data.Metrics.Middleware as Metrics import Data.Misc +import Data.Qualified import Data.Text (unpack) import qualified Data.Text as Text import Data.Text.Encoding (encodeUtf8) @@ -538,5 +540,8 @@ readTurnList = Text.readFile >=> return . fn . mapMaybe fromByteString . fmap Te -------------------------------------------------------------------------------- -- Federation -viewFederationDomain :: MonadReader Env m => m (Domain) +viewFederationDomain :: MonadReader Env m => m Domain viewFederationDomain = view (settings . Opt.federationDomain) + +qualifyLocal :: MonadReader Env m => a -> m (Local a) +qualifyLocal a = toLocalUnsafe <$> viewFederationDomain <*> pure a diff --git a/services/brig/src/Brig/Data/Connection.hs b/services/brig/src/Brig/Data/Connection.hs index e4b5ab2f47..79d6999056 100644 --- a/services/brig/src/Brig/Data/Connection.hs +++ b/services/brig/src/Brig/Data/Connection.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE RecordWildCards #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2020 Wire Swiss GmbH @@ -18,24 +16,27 @@ -- with this program. If not, see . module Brig.Data.Connection - ( -- * DB Types - LocalConnection (..), - RemoteConnection (..), - localToUserConn, - - -- * DB Operations - insertLocalConnection, - updateLocalConnection, - lookupLocalConnection, + ( -- * DB Operations + insertConnection, + updateConnection, + updateConnectionStatus, + lookupConnection, + lookupRelation, lookupLocalConnectionsPage, + lookupRemoteConnectionsPage, lookupRelationWithHistory, lookupLocalConnections, lookupConnectionStatus, lookupConnectionStatus', lookupContactList, lookupContactListWithRelation, + lookupLocalConnectionStatuses, + lookupRemoteConnectionStatuses, + lookupAllStatuses, + lookupRemoteConnectedUsersC, countConnections, deleteConnections, + deleteRemoteConnections, remoteConnectionInsert, remoteConnectionSelect, remoteConnectionSelectFrom, @@ -47,13 +48,14 @@ module Brig.Data.Connection ) where -import Brig.App (AppIO) +import Brig.App (AppIO, qualifyLocal) import Brig.Data.Instances () import Brig.Data.Types as T import Brig.Types -import Brig.Types.Intra import Cassandra -import Data.Conduit (runConduit, (.|)) +import Control.Monad.Morph +import Control.Monad.Trans.Maybe +import Data.Conduit (ConduitT, runConduit, (.|)) import qualified Data.Conduit.List as C import Data.Domain (Domain) import Data.Id @@ -61,100 +63,137 @@ import Data.Json.Util (UTCTimeMillis, toUTCTimeMillis) import Data.Qualified import Data.Range import Data.Time (getCurrentTime) -import Imports -import UnliftIO.Async (pooledMapConcurrentlyN_) +import Imports hiding (local) +import UnliftIO.Async (pooledForConcurrentlyN_, pooledMapConcurrentlyN, pooledMapConcurrentlyN_) import Wire.API.Connection +import Wire.API.Routes.Internal.Brig.Connection -data LocalConnection = LocalConnection - { lcFrom :: UserId, - lcTo :: UserId, - lcStatus :: Relation, - -- | Why is this a Maybe? Are there actually any users who have this as null in DB? - lcConv :: Maybe ConvId, - lcLastUpdated :: UTCTimeMillis - } - -localToUserConn :: Domain -> LocalConnection -> UserConnection -localToUserConn localDomain lc = - UserConnection - { ucFrom = lcFrom lc, - ucTo = Qualified (lcTo lc) localDomain, - ucStatus = lcStatus lc, - ucLastUpdate = lcLastUpdated lc, - ucConvId = flip Qualified localDomain <$> lcConv lc - } - -data RemoteConnection = RemoteConnection - { rcFrom :: UserId, - rcTo :: Qualified UserId, - rcRelationWithHistory :: Relation, - rcConv :: Qualified ConvId - } - -insertLocalConnection :: - -- | From - UserId -> - -- | To - UserId -> +insertConnection :: + Local UserId -> + Qualified UserId -> RelationWithHistory -> - ConvId -> - AppIO LocalConnection -insertLocalConnection from to status cid = do + Qualified ConvId -> + AppIO UserConnection +insertConnection self target rel qcnv@(Qualified cnv cdomain) = do now <- toUTCTimeMillis <$> liftIO getCurrentTime - retry x5 . write connectionInsert $ params Quorum (from, to, status, now, cid) - return $ toLocalUserConnection (from, to, status, now, Just cid) + let local (tUnqualified -> ltarget) = + write connectionInsert $ + params Quorum (tUnqualified self, ltarget, rel, now, cnv) + let remote (qUntagged -> Qualified rtarget domain) = + write remoteConnectionInsert $ + params Quorum (tUnqualified self, domain, rtarget, rel, now, cdomain, cnv) + retry x5 $ foldQualified self local remote target + pure $ + UserConnection + { ucFrom = tUnqualified self, + ucTo = target, + ucStatus = relationDropHistory rel, + ucLastUpdate = now, + ucConvId = Just qcnv + } -updateLocalConnection :: LocalConnection -> RelationWithHistory -> AppIO LocalConnection -updateLocalConnection c@LocalConnection {..} status = do - now <- toUTCTimeMillis <$> liftIO getCurrentTime - retry x5 . write connectionUpdate $ params Quorum (status, now, lcFrom, lcTo) - return $ +updateConnection :: UserConnection -> RelationWithHistory -> AppIO UserConnection +updateConnection c status = do + self <- qualifyLocal (ucFrom c) + now <- updateConnectionStatus self (ucTo c) status + pure $ c - { lcStatus = relationDropHistory status, - lcLastUpdated = now + { ucStatus = relationDropHistory status, + ucLastUpdate = now } +updateConnectionStatus :: Local UserId -> Qualified UserId -> RelationWithHistory -> AppIO UTCTimeMillis +updateConnectionStatus self target status = do + now <- toUTCTimeMillis <$> liftIO getCurrentTime + let local (tUnqualified -> ltarget) = + write connectionUpdate $ + params Quorum (status, now, tUnqualified self, ltarget) + let remote (qUntagged -> Qualified rtarget domain) = + write remoteConnectionUpdate $ + params Quorum (status, now, tUnqualified self, domain, rtarget) + retry x5 $ foldQualified self local remote target + pure now + -- | Lookup the connection from a user 'A' to a user 'B' (A -> B). -lookupLocalConnection :: - -- | User 'A' - UserId -> - -- | User 'B' - UserId -> - AppIO (Maybe LocalConnection) -lookupLocalConnection from to = - toLocalUserConnection <$$> retry x1 (query1 connectionSelect (params Quorum (from, to))) +lookupConnection :: Local UserId -> Qualified UserId -> AppIO (Maybe UserConnection) +lookupConnection self target = runMaybeT $ do + let local (tUnqualified -> ltarget) = do + (_, _, rel, time, mcnv) <- + MaybeT . query1 connectionSelect $ + params Quorum (tUnqualified self, ltarget) + pure (rel, time, fmap (qUntagged . qualifyAs self) mcnv) + let remote (qUntagged -> Qualified rtarget domain) = do + (rel, time, cdomain, cnv) <- + MaybeT . query1 remoteConnectionSelectFrom $ + params Quorum (tUnqualified self, domain, rtarget) + pure (rel, time, Just (Qualified cnv cdomain)) + (rel, time, mqcnv) <- hoist (retry x1) $ foldQualified self local remote target + pure $ + UserConnection + { ucFrom = tUnqualified self, + ucTo = target, + ucStatus = relationDropHistory rel, + ucLastUpdate = time, + ucConvId = mqcnv + } -- | 'lookupConnection' with more 'Relation' info. lookupRelationWithHistory :: -- | User 'A' - UserId -> + Local UserId -> -- | User 'B' - UserId -> + Qualified UserId -> AppIO (Maybe RelationWithHistory) -lookupRelationWithHistory from to = - runIdentity - <$$> retry x1 (query1 relationSelect (params Quorum (from, to))) +lookupRelationWithHistory self target = do + let local (tUnqualified -> ltarget) = + query1 relationSelect (params Quorum (tUnqualified self, ltarget)) + let remote (qUntagged -> Qualified rtarget domain) = + query1 remoteRelationSelect (params Quorum (tUnqualified self, domain, rtarget)) + runIdentity <$$> retry x1 (foldQualified self local remote target) + +lookupRelation :: Local UserId -> Qualified UserId -> AppIO Relation +lookupRelation self target = + lookupRelationWithHistory self target <&> \case + Nothing -> Cancelled + Just relh -> (relationDropHistory relh) -- | For a given user 'A', lookup their outgoing connections (A -> X) to other users. -lookupLocalConnections :: UserId -> Maybe UserId -> Range 1 500 Int32 -> AppIO (ResultPage LocalConnection) -lookupLocalConnections from start (fromRange -> size) = +lookupLocalConnections :: Local UserId -> Maybe UserId -> Range 1 500 Int32 -> AppIO (ResultPage UserConnection) +lookupLocalConnections lfrom start (fromRange -> size) = toResult <$> case start of - Just u -> retry x1 $ paginate connectionsSelectFrom (paramsP Quorum (from, u) (size + 1)) - Nothing -> retry x1 $ paginate connectionsSelect (paramsP Quorum (Identity from) (size + 1)) + Just u -> + retry x1 $ + paginate connectionsSelectFrom (paramsP Quorum (tUnqualified lfrom, u) (size + 1)) + Nothing -> + retry x1 $ + paginate connectionsSelect (paramsP Quorum (Identity (tUnqualified lfrom)) (size + 1)) where - toResult = cassandraResultPage . fmap toLocalUserConnection . trim + toResult = cassandraResultPage . fmap (toLocalUserConnection lfrom) . trim trim p = p {result = take (fromIntegral size) (result p)} -- | For a given user 'A', lookup their outgoing connections (A -> X) to other users. -- Similar to lookupLocalConnections lookupLocalConnectionsPage :: (MonadClient m) => - UserId -> + Local UserId -> Maybe PagingState -> Range 1 1000 Int32 -> - m (PageWithState LocalConnection) -lookupLocalConnectionsPage usr pagingState (fromRange -> size) = - fmap toLocalUserConnection <$> paginateWithState connectionsSelect (paramsPagingState Quorum (Identity usr) size pagingState) + m (PageWithState UserConnection) +lookupLocalConnectionsPage self pagingState (fromRange -> size) = + fmap (toLocalUserConnection self) <$> paginateWithState connectionsSelect (paramsPagingState Quorum (Identity (tUnqualified self)) size pagingState) + +-- | For a given user 'A', lookup their outgoing connections (A -> X) to remote users. +lookupRemoteConnectionsPage :: + (MonadClient m) => + Local UserId -> + Maybe PagingState -> + Int32 -> + m (PageWithState UserConnection) +lookupRemoteConnectionsPage self pagingState size = + fmap (toRemoteUserConnection self) + <$> paginateWithState + remoteConnectionSelect + (paramsPagingState Quorum (Identity (tUnqualified self)) size pagingState) -- | Lookup all relations between two sets of users (cartesian product). lookupConnectionStatus :: [UserId] -> [UserId] -> AppIO [ConnectionStatus] @@ -168,6 +207,46 @@ lookupConnectionStatus' from = map toConnectionStatus <$> retry x1 (query connectionStatusSelect' (params Quorum (Identity from))) +lookupLocalConnectionStatuses :: [UserId] -> Local [UserId] -> AppIO [ConnectionStatusV2] +lookupLocalConnectionStatuses froms tos = do + concat <$> pooledMapConcurrentlyN 16 lookupStatuses froms + where + lookupStatuses :: UserId -> AppIO [ConnectionStatusV2] + lookupStatuses from = + map (uncurry $ toConnectionStatusV2 from (tDomain tos)) + <$> retry x1 (query relationsSelect (params Quorum (from, tUnqualified tos))) + +lookupRemoteConnectionStatuses :: [UserId] -> Remote [UserId] -> AppIO [ConnectionStatusV2] +lookupRemoteConnectionStatuses froms tos = do + concat <$> pooledMapConcurrentlyN 16 lookupStatuses froms + where + lookupStatuses :: UserId -> AppIO [ConnectionStatusV2] + lookupStatuses from = + map (uncurry $ toConnectionStatusV2 from (tDomain tos)) + <$> retry x1 (query remoteRelationsSelect (params Quorum (from, tDomain tos, tUnqualified tos))) + +lookupAllStatuses :: Local [UserId] -> AppIO [ConnectionStatusV2] +lookupAllStatuses lfroms = do + let froms = tUnqualified lfroms + concat <$> pooledMapConcurrentlyN 16 lookupAndCombine froms + where + lookupAndCombine :: UserId -> AppIO [ConnectionStatusV2] + lookupAndCombine u = (<>) <$> lookupLocalStatuses u <*> lookupRemoteStatuses u + + lookupLocalStatuses :: UserId -> AppIO [ConnectionStatusV2] + lookupLocalStatuses from = + map (uncurry $ toConnectionStatusV2 from (tDomain lfroms)) + <$> retry x1 (query relationsSelectAll (params Quorum (Identity from))) + lookupRemoteStatuses :: UserId -> AppIO [ConnectionStatusV2] + lookupRemoteStatuses from = + map (\(d, u, r) -> toConnectionStatusV2 from d u r) + <$> retry x1 (query remoteRelationsSelectAll (params Quorum (Identity from))) + +lookupRemoteConnectedUsersC :: forall m. (MonadClient m) => UserId -> Int32 -> ConduitT () [Remote UserId] m () +lookupRemoteConnectedUsersC u maxResults = + paginateC remoteConnectionsSelectUsers (paramsP Quorum (Identity u) maxResults) x1 + .| C.map (map (uncurry toRemoteUnsafe)) + -- | See 'lookupContactListWithRelation'. lookupContactList :: UserId -> AppIO [UserId] lookupContactList u = @@ -182,14 +261,19 @@ lookupContactListWithRelation u = -- | Count the number of connections a user has in a specific relation status. -- (If you want to distinguish 'RelationWithHistory', write a new function.) -- Note: The count is eventually consistent. -countConnections :: UserId -> [Relation] -> AppIO Int64 +countConnections :: Local UserId -> [Relation] -> AppIO Int64 countConnections u r = do - rels <- retry x1 . query selectStatus $ params One (Identity u) - return $ foldl' count 0 rels + rels <- retry x1 . query selectStatus $ params One (Identity (tUnqualified u)) + relsRemote <- retry x1 . query selectStatusRemote $ params One (Identity (tUnqualified u)) + + return $ foldl' count 0 rels + foldl' count 0 relsRemote where selectStatus :: QueryString R (Identity UserId) (Identity RelationWithHistory) selectStatus = "SELECT status FROM connection WHERE left = ?" + selectStatusRemote :: QueryString R (Identity UserId) (Identity RelationWithHistory) + selectStatusRemote = "SELECT status FROM connection_remote WHERE left = ?" + count n (Identity s) | (relationDropHistory s) `elem` r = n + 1 count n _ = n @@ -199,9 +283,15 @@ deleteConnections u = do paginateC contactsSelect (paramsP Quorum (Identity u) 100) x1 .| C.mapM_ (pooledMapConcurrentlyN_ 16 delete) retry x1 . write connectionClear $ params Quorum (Identity u) + retry x1 . write remoteConnectionClear $ params Quorum (Identity u) where delete (other, _status) = write connectionDelete $ params Quorum (other, u) +deleteRemoteConnections :: Remote UserId -> Range 1 1000 [UserId] -> AppIO () +deleteRemoteConnections (qUntagged -> Qualified remoteUser remoteDomain) (fromRange -> locals) = + pooledForConcurrentlyN_ 16 locals $ \u -> + write remoteConnectionDelete $ params Quorum (u, remoteDomain, remoteUser) + -- Queries connectionInsert :: PrepQuery W (UserId, UserId, RelationWithHistory, UTCTimeMillis, ConvId) () @@ -216,9 +306,19 @@ connectionSelect = "SELECT left, right, status, last_update, conv FROM connectio relationSelect :: PrepQuery R (UserId, UserId) (Identity RelationWithHistory) relationSelect = "SELECT status FROM connection WHERE left = ? AND right = ?" +relationsSelect :: PrepQuery R (UserId, [UserId]) (UserId, RelationWithHistory) +relationsSelect = "SELECT right, status FROM connection where left = ? AND right IN ?" + +relationsSelectAll :: PrepQuery R (Identity UserId) (UserId, RelationWithHistory) +relationsSelectAll = "SELECT right, status FROM connection where left = ?" + +-- FUTUREWORK: Delete this query, we shouldn't use `IN` with the primary key of +-- the table. connectionStatusSelect :: PrepQuery R ([UserId], [UserId]) (UserId, UserId, RelationWithHistory) connectionStatusSelect = "SELECT left, right, status FROM connection WHERE left IN ? AND right IN ?" +-- FUTUREWORK: Delete this query, we shouldn't use `IN` with the primary key of +-- the table. connectionStatusSelect' :: PrepQuery R (Identity [UserId]) (UserId, UserId, RelationWithHistory) connectionStatusSelect' = "SELECT left, right, status FROM connection WHERE left IN ?" @@ -242,22 +342,52 @@ connectionClear = "DELETE FROM connection WHERE left = ?" remoteConnectionInsert :: PrepQuery W (UserId, Domain, UserId, RelationWithHistory, UTCTimeMillis, Domain, ConvId) () remoteConnectionInsert = "INSERT INTO connection_remote (left, right_domain, right_user, status, last_update, conv_domain, conv_id) VALUES (?, ?, ?, ?, ?, ?, ?)" -remoteConnectionSelect :: PrepQuery R (Identity UserId) (Domain, UserId, RelationWithHistory, Domain, ConvId) -remoteConnectionSelect = "SELECT right_domain, right_user, status, conv_domain, conv_id FROM connection_remote where left = ?" +remoteConnectionSelect :: PrepQuery R (Identity UserId) (Domain, UserId, RelationWithHistory, UTCTimeMillis, Domain, ConvId) +remoteConnectionSelect = "SELECT right_domain, right_user, status, last_update, conv_domain, conv_id FROM connection_remote where left = ?" -remoteConnectionSelectFrom :: PrepQuery R (UserId, Domain, UserId) (RelationWithHistory, Domain, ConvId) -remoteConnectionSelectFrom = "SELECT status, conv_domain, conv_id FROM connection_remote where left = ? AND right_domain = ? AND right = ?" +remoteConnectionSelectFrom :: PrepQuery R (UserId, Domain, UserId) (RelationWithHistory, UTCTimeMillis, Domain, ConvId) +remoteConnectionSelectFrom = "SELECT status, last_update, conv_domain, conv_id FROM connection_remote where left = ? AND right_domain = ? AND right_user = ?" + +remoteConnectionUpdate :: PrepQuery W (RelationWithHistory, UTCTimeMillis, UserId, Domain, UserId) () +remoteConnectionUpdate = "UPDATE connection_remote set status = ?, last_update = ? WHERE left = ? and right_domain = ? and right_user = ?" remoteConnectionDelete :: PrepQuery W (UserId, Domain, UserId) () -remoteConnectionDelete = "DELETE FROM connection_remote where left = ? AND right_domain = ? AND right = ?" +remoteConnectionDelete = "DELETE FROM connection_remote where left = ? AND right_domain = ? AND right_user = ?" remoteConnectionClear :: PrepQuery W (Identity UserId) () remoteConnectionClear = "DELETE FROM connection_remote where left = ?" +remoteRelationSelect :: PrepQuery R (UserId, Domain, UserId) (Identity RelationWithHistory) +remoteRelationSelect = "SELECT status FROM connection_remote WHERE left = ? AND right_domain = ? AND right_user = ?" + +remoteRelationsSelect :: PrepQuery R (UserId, Domain, [UserId]) (UserId, RelationWithHistory) +remoteRelationsSelect = "SELECT right_user, status FROM connection_remote WHERE left = ? AND right_domain = ? AND right_user IN ?" + +remoteRelationsSelectAll :: PrepQuery R (Identity UserId) (Domain, UserId, RelationWithHistory) +remoteRelationsSelectAll = "SELECT right_domain, right_user, status FROM connection_remote WHERE left = ?" + +remoteConnectionsSelectUsers :: PrepQuery R (Identity UserId) (Domain, UserId) +remoteConnectionsSelectUsers = "SELECT right_domain, right_user FROM connection_remote WHERE left = ?" + -- Conversions -toLocalUserConnection :: (UserId, UserId, RelationWithHistory, UTCTimeMillis, Maybe ConvId) -> LocalConnection -toLocalUserConnection (l, r, relationDropHistory -> rel, time, cid) = LocalConnection l r rel cid time +toLocalUserConnection :: + Local x -> + (UserId, UserId, RelationWithHistory, UTCTimeMillis, Maybe ConvId) -> + UserConnection +toLocalUserConnection loc (l, r, relationDropHistory -> rel, time, cid) = + UserConnection l (qUntagged (qualifyAs loc r)) rel time (fmap (qUntagged . qualifyAs loc) cid) + +toRemoteUserConnection :: + Local UserId -> + (Domain, UserId, RelationWithHistory, UTCTimeMillis, Domain, ConvId) -> + UserConnection +toRemoteUserConnection l (rDomain, r, relationDropHistory -> rel, time, cDomain, cid) = + UserConnection (tUnqualified l) (Qualified r rDomain) rel time (Just $ Qualified cid cDomain) toConnectionStatus :: (UserId, UserId, RelationWithHistory) -> ConnectionStatus toConnectionStatus (l, r, relationDropHistory -> rel) = ConnectionStatus l r rel + +toConnectionStatusV2 :: UserId -> Domain -> UserId -> RelationWithHistory -> ConnectionStatusV2 +toConnectionStatusV2 from toDomain toUser relWithHistory = + ConnectionStatusV2 from (Qualified toUser toDomain) (relationDropHistory relWithHistory) diff --git a/services/brig/src/Brig/Federation/Client.hs b/services/brig/src/Brig/Federation/Client.hs index e0b732d315..951d67b4d4 100644 --- a/services/brig/src/Brig/Federation/Client.hs +++ b/services/brig/src/Brig/Federation/Client.hs @@ -31,6 +31,7 @@ import Data.Domain import Data.Handle import Data.Id (ClientId, UserId) import Data.Qualified +import Data.Range (Range) import qualified Data.Text as T import Imports import qualified System.Logger.Class as Log @@ -46,8 +47,8 @@ type FederationAppIO = ExceptT FederationError AppIO -- FUTUREWORK: Maybe find a way to tranform 'clientRoutes' into a client which -- only uses 'FederationAppIO' monad, then boilerplate in this module can all be -- deleted. -getUserHandleInfo :: Qualified Handle -> FederationAppIO (Maybe UserProfile) -getUserHandleInfo (Qualified handle domain) = do +getUserHandleInfo :: Remote Handle -> FederationAppIO (Maybe UserProfile) +getUserHandleInfo (qUntagged -> Qualified handle domain) = do Log.info $ Log.msg $ T.pack "Brig-federation: handle lookup call on remote backend" executeFederated domain $ getUserByHandle clientRoutes handle @@ -84,3 +85,24 @@ getUserClients :: Domain -> GetUserClients -> FederationAppIO (UserMap (Set PubC getUserClients domain guc = do Log.info $ Log.msg @Text "Brig-federation: get users' clients from remote backend" executeFederated domain $ FederatedBrig.getUserClients clientRoutes guc + +sendConnectionAction :: + Local UserId -> + Remote UserId -> + RemoteConnectionAction -> + FederationAppIO NewConnectionResponse +sendConnectionAction self (qUntagged -> other) action = do + let req = NewConnectionRequest (tUnqualified self) (qUnqualified other) action + Log.info $ Log.msg @Text "Brig-federation: sending connection action to remote backend" + executeFederated (qDomain other) $ FederatedBrig.sendConnectionAction clientRoutes (tDomain self) req + +notifyUserDeleted :: + Local UserId -> + Remote (Range 1 1000 [UserId]) -> + FederationAppIO () +notifyUserDeleted self remotes = do + let remoteConnections = tUnqualified remotes + let fedRPC = + FederatedBrig.onUserDeleted clientRoutes (tDomain self) $ + UserDeletedConnectionsNotification (tUnqualified self) remoteConnections + void $ executeFederated (tDomain remotes) fedRPC diff --git a/services/brig/src/Brig/IO/Intra.hs b/services/brig/src/Brig/IO/Intra.hs index 1b2d71880e..6ceed1c77f 100644 --- a/services/brig/src/Brig/IO/Intra.hs +++ b/services/brig/src/Brig/IO/Intra.hs @@ -32,6 +32,7 @@ module Brig.IO.Intra blockConv, unblockConv, getConv, + upsertOne2OneConversation, -- * Clients Brig.IO.Intra.newClient, @@ -59,6 +60,9 @@ module Brig.IO.Intra -- * Legalhold guardLegalhold, + + -- * Low Level API for Notifications + notify, ) where @@ -69,30 +73,38 @@ import Brig.API.Error (internalServerError) import Brig.API.Types import Brig.App import Brig.Data.Connection (lookupContactList) +import qualified Brig.Data.Connection as Data +import Brig.Federation.Client (notifyUserDeleted) import qualified Brig.IO.Journal as Journal import Brig.RPC import Brig.Types import Brig.Types.User.Event import qualified Brig.User.Search.Index as Search +import Conduit (runConduit, (.|)) import Control.Error (ExceptT) import Control.Lens (view, (.~), (?~), (^.)) import Control.Monad.Catch (MonadThrow (throwM)) -import Control.Monad.Trans.Except (throwE) +import Control.Monad.Trans.Except (runExceptT, throwE) import Control.Retry import Data.Aeson hiding (json) import Data.ByteString.Conversion import qualified Data.ByteString.Lazy as BL import Data.Coerce (coerce) +import qualified Data.Conduit.List as C import qualified Data.Currency as Currency +import Data.Domain import qualified Data.HashMap.Strict as M import Data.Id import Data.Json.Util (UTCTimeMillis, (#)) import Data.List.Split (chunksOf) import Data.List1 (List1, list1, singleton) +import Data.Proxy import Data.Qualified import Data.Range import qualified Data.Set as Set +import GHC.TypeLits import Galley.Types (Connect (..), Conversation) +import Galley.Types.Conversations.Intra (UpsertOne2OneConversationRequest, UpsertOne2OneConversationResponse) import qualified Galley.Types.Teams as Team import Galley.Types.Teams.Intra (GuardLegalholdPolicyConflicts (GuardLegalholdPolicyConflicts)) import qualified Galley.Types.Teams.Intra as Team @@ -104,6 +116,9 @@ import Network.HTTP.Types.Method import Network.HTTP.Types.Status import qualified Network.Wai.Utilities.Error as Wai import System.Logger.Class as Log hiding (name, (.=)) +import Wire.API.Federation.API.Brig +import Wire.API.Federation.Client +import Wire.API.Federation.Error (federationErrorToWai, federationNotImplemented) import Wire.API.Message (UserClients) import Wire.API.Team.Feature (TeamFeatureName (..), TeamFeatureStatus) import Wire.API.Team.LegalHold (LegalholdProtectee) @@ -231,11 +246,51 @@ dispatchNotifications orig conn e = case e of UserDeleted {} -> do -- n.b. Synchronously fetch the contact list on the current thread. -- If done asynchronously, the connections may already have been deleted. - recipients <- list1 orig <$> lookupContactList orig - notify event orig Push.RouteDirect conn (pure recipients) + notifyUserDeletionLocals orig conn event + notifyUserDeletionRemotes orig where event = singleton $ UserEvent e +notifyUserDeletionLocals :: UserId -> Maybe ConnId -> List1 Event -> AppIO () +notifyUserDeletionLocals deleted conn event = do + recipients <- list1 deleted <$> lookupContactList deleted + notify event deleted Push.RouteDirect conn (pure recipients) + +notifyUserDeletionRemotes :: UserId -> AppIO () +notifyUserDeletionRemotes deleted = do + runConduit $ + Data.lookupRemoteConnectedUsersC deleted (fromInteger (natVal (Proxy @UserDeletedNotificationMaxConnections))) + .| C.mapM_ fanoutNotifications + where + fanoutNotifications :: [Remote UserId] -> AppIO () + fanoutNotifications = mapM_ notifyBackend . bucketRemote + + notifyBackend :: Remote [UserId] -> AppIO () + notifyBackend uids = do + case tUnqualified (checked <$> uids) of + Nothing -> + -- The user IDs cannot be more than 1000, so we can assume the range + -- check will only fail because there are 0 User Ids. + pure () + Just rangedUids -> do + luidDeleted <- qualifyLocal deleted + eitherFErr <- runExceptT (notifyUserDeleted luidDeleted (qualifyAs uids rangedUids)) + case eitherFErr of + Left fErr -> do + logFederationError (tDomain uids) fErr + -- FUTUTREWORK: Do something better here? + -- FUTUREWORK: Write test that this happens + throwM $ federationErrorToWai fErr + Right () -> pure () + + logFederationError :: Domain -> FederationError -> AppT IO () + logFederationError domain fErr = + Log.err $ + Log.msg ("Federation error while notifying remote backends of a user deletion." :: ByteString) + . Log.field "user_id" (show deleted) + . Log.field "domain" (domainText domain) + . Log.field "error" (show fErr) + -- | Push events to other users. push :: -- | The events to push. @@ -286,7 +341,7 @@ rawPush (toList -> events) usrs orig route conn = do g ( method POST . path "/i/push/v2" - . zUser orig + . zUser orig -- FUTUREWORK: Remove, because gundeck handler ignores this. . json (map (mkPush rcps . snd) events) . expect2xx ) @@ -309,7 +364,7 @@ rawPush (toList -> events) usrs orig route conn = do -- | (Asynchronously) notifies other users of events. notify :: List1 Event -> - -- | Origin user. + -- | Origin user, TODO: Delete UserId -> -- | Push routing strategy. Push.Route -> @@ -439,11 +494,12 @@ toPushFormat (UserEvent (UserResumed i)) = [ "type" .= ("user.resume" :: Text), "id" .= i ] -toPushFormat (UserEvent (UserDeleted i)) = +toPushFormat (UserEvent (UserDeleted qid)) = Just $ M.fromList [ "type" .= ("user.delete" :: Text), - "id" .= i + "id" .= qUnqualified qid, + "qualified_id" .= qid ] toPushFormat (UserEvent (UserLegalHoldDisabled i)) = Just $ @@ -532,30 +588,50 @@ createSelfConv u = do . zUser u . expect2xx --- | Calls 'Galley.API.createConnectConversationH'. -createConnectConv :: UserId -> UserId -> Maybe Text -> Maybe ConnId -> AppIO ConvId -createConnectConv from to cname conn = do - localDomain <- viewFederationDomain +-- | Calls 'Galley.API.Create.createConnectConversation'. +createLocalConnectConv :: + Local UserId -> + Local UserId -> + Maybe Text -> + Maybe ConnId -> + AppIO ConvId +createLocalConnectConv from to cname conn = do debug $ - logConnection from (Qualified to localDomain) + logConnection (tUnqualified from) (qUntagged to) . remote "galley" . msg (val "Creating connect conversation") + let req = + path "/i/conversations/connect" + . zUser (tUnqualified from) + . maybe id (header "Z-Connection" . fromConnId) conn + . contentJson + . lbytes (encode $ Connect (qUntagged to) Nothing cname Nothing) + . expect2xx r <- galleyRequest POST req maybe (error "invalid conv id") return $ fromByteString $ getHeader' "Location" r + +createConnectConv :: + Qualified UserId -> + Qualified UserId -> + Maybe Text -> + Maybe ConnId -> + AppIO (Qualified ConvId) +createConnectConv from to cname conn = do + lfrom <- ensureLocal from + lto <- ensureLocal to + qUntagged . qualifyAs lfrom + <$> createLocalConnectConv lfrom lto cname conn where - req = - path "/i/conversations/connect" - . zUser from - . maybe id (header "Z-Connection" . fromConnId) conn - . contentJson - . lbytes (encode $ Connect to Nothing cname Nothing) - . expect2xx + ensureLocal :: Qualified a -> AppIO (Local a) + ensureLocal x = do + loc <- qualifyLocal () + foldQualified loc pure (\_ -> throwM federationNotImplemented) x -- | Calls 'Galley.API.acceptConvH'. -acceptConnectConv :: UserId -> Maybe ConnId -> ConvId -> AppIO Conversation -acceptConnectConv from conn cnv = do +acceptLocalConnectConv :: Local UserId -> Maybe ConnId -> ConvId -> AppIO Conversation +acceptLocalConnectConv from conn cnv = do debug $ remote "galley" . field "conv" (toByteString cnv) @@ -564,13 +640,20 @@ acceptConnectConv from conn cnv = do where req = paths ["/i/conversations", toByteString' cnv, "accept", "v2"] - . zUser from + . zUser (tUnqualified from) . maybe id (header "Z-Connection" . fromConnId) conn . expect2xx +acceptConnectConv :: Local UserId -> Maybe ConnId -> Qualified ConvId -> AppIO Conversation +acceptConnectConv from conn = + foldQualified + from + (acceptLocalConnectConv from conn . tUnqualified) + (const (throwM federationNotImplemented)) + -- | Calls 'Galley.API.blockConvH'. -blockConv :: UserId -> Maybe ConnId -> ConvId -> AppIO () -blockConv usr conn cnv = do +blockLocalConv :: Local UserId -> Maybe ConnId -> ConvId -> AppIO () +blockLocalConv lusr conn cnv = do debug $ remote "galley" . field "conv" (toByteString cnv) @@ -579,13 +662,20 @@ blockConv usr conn cnv = do where req = paths ["/i/conversations", toByteString' cnv, "block"] - . zUser usr + . zUser (tUnqualified lusr) . maybe id (header "Z-Connection" . fromConnId) conn . expect2xx +blockConv :: Local UserId -> Maybe ConnId -> Qualified ConvId -> AppIO () +blockConv lusr conn = + foldQualified + lusr + (blockLocalConv lusr conn . tUnqualified) + (const (throwM federationNotImplemented)) + -- | Calls 'Galley.API.unblockConvH'. -unblockConv :: UserId -> Maybe ConnId -> ConvId -> AppIO Conversation -unblockConv usr conn cnv = do +unblockLocalConv :: Local UserId -> Maybe ConnId -> ConvId -> AppIO Conversation +unblockLocalConv lusr conn cnv = do debug $ remote "galley" . field "conv" (toByteString cnv) @@ -594,10 +684,17 @@ unblockConv usr conn cnv = do where req = paths ["/i/conversations", toByteString' cnv, "unblock"] - . zUser usr + . zUser (tUnqualified lusr) . maybe id (header "Z-Connection" . fromConnId) conn . expect2xx +unblockConv :: Local UserId -> Maybe ConnId -> Qualified ConvId -> AppIO Conversation +unblockConv luid conn = + foldQualified + luid + (unblockLocalConv luid conn . tUnqualified) + (const (throwM federationNotImplemented)) + -- | Calls 'Galley.API.getConversationH'. getConv :: UserId -> ConvId -> AppIO (Maybe Conversation) getConv usr cnv = do @@ -615,6 +712,18 @@ getConv usr cnv = do . zUser usr . expect [status200, status404] +upsertOne2OneConversation :: UpsertOne2OneConversationRequest -> AppIO UpsertOne2OneConversationResponse +upsertOne2OneConversation urequest = do + response <- galleyRequest POST req + case Bilge.statusCode response of + 200 -> decodeBody "galley" response + _ -> throwM internalServerError + where + req = + paths ["i", "conversations", "one2one", "upsert"] + . header "Content-Type" "application/json" + . lbytes (encode urequest) + -- | Calls 'Galley.API.getTeamConversationH'. getTeamConv :: UserId -> TeamId -> ConvId -> AppIO (Maybe Team.TeamConversation) getTeamConv usr tid cnv = do diff --git a/services/brig/src/Brig/User/API/Handle.hs b/services/brig/src/Brig/User/API/Handle.hs index 0481d4c26d..4ef90c1bb3 100644 --- a/services/brig/src/Brig/User/API/Handle.hs +++ b/services/brig/src/Brig/User/API/Handle.hs @@ -26,14 +26,14 @@ where import Brig.API.Error (fedError) import Brig.API.Handler (Handler) import qualified Brig.API.User as API -import Brig.App (settings, viewFederationDomain) +import Brig.App import qualified Brig.Data.User as Data import qualified Brig.Federation.Client as Federation import Brig.Options (searchSameTeamOnly) import Control.Lens (view) import Data.Handle (Handle, fromHandle) import Data.Id (UserId) -import Data.Qualified (Qualified (..)) +import Data.Qualified import Imports import Network.Wai.Utilities ((!>>)) import qualified System.Logger.Class as Log @@ -42,19 +42,23 @@ import qualified Wire.API.User as Public import Wire.API.User.Search import qualified Wire.API.User.Search as Public --- FUTUREWORK: use 'runMaybeT' to simplify this. getHandleInfo :: UserId -> Qualified Handle -> Handler (Maybe Public.UserProfile) getHandleInfo self handle = do - domain <- viewFederationDomain - if qDomain handle == domain - then getLocalHandleInfo self (qUnqualified handle) - else getRemoteHandleInfo - where - getRemoteHandleInfo = do - Log.info $ Log.msg (Log.val "getHandleInfo - remote lookup") Log.~~ Log.field "domain" (show (qDomain handle)) - Federation.getUserHandleInfo handle !>> fedError + lself <- qualifyLocal self + foldQualified + lself + (getLocalHandleInfo lself . tUnqualified) + getRemoteHandleInfo + handle -getLocalHandleInfo :: UserId -> Handle -> Handler (Maybe Public.UserProfile) +getRemoteHandleInfo :: Remote Handle -> Handler (Maybe Public.UserProfile) +getRemoteHandleInfo handle = do + Log.info $ + Log.msg (Log.val "getHandleInfo - remote lookup") + . Log.field "domain" (show (tDomain handle)) + Federation.getUserHandleInfo handle !>> fedError + +getLocalHandleInfo :: Local UserId -> Handle -> Handler (Maybe Public.UserProfile) getLocalHandleInfo self handle = do Log.info $ Log.msg $ Log.val "getHandleInfo - local lookup" maybeOwnerId <- lift $ API.lookupHandle handle @@ -67,12 +71,12 @@ getLocalHandleInfo self handle = do return $ listToMaybe owner -- | Checks search permissions and filters accordingly -filterHandleResults :: UserId -> [Public.UserProfile] -> Handler [Public.UserProfile] +filterHandleResults :: Local UserId -> [Public.UserProfile] -> Handler [Public.UserProfile] filterHandleResults searchingUser us = do sameTeamSearchOnly <- fromMaybe False <$> view (settings . searchSameTeamOnly) if sameTeamSearchOnly then do - fromTeam <- lift $ Data.lookupUserTeam searchingUser + fromTeam <- lift $ Data.lookupUserTeam (tUnqualified searchingUser) return $ case fromTeam of Just team -> filter (\x -> Public.profileTeam x == Just team) us Nothing -> us diff --git a/services/brig/src/Brig/User/API/Search.hs b/services/brig/src/Brig/User/API/Search.hs index ecaccf457b..b0c3a8f6c3 100644 --- a/services/brig/src/Brig/User/API/Search.hs +++ b/services/brig/src/Brig/User/API/Search.hs @@ -188,13 +188,14 @@ searchLocally searcherId searchTerm maybeMaxResults = do exactHandleSearch :: TeamSearchInfo -> Handler (Maybe Contact) exactHandleSearch teamSearchInfo = do + lsearcherId <- qualifyLocal searcherId let searchedHandleMaybe = parseHandle searchTerm exactHandleResult <- case searchedHandleMaybe of Nothing -> pure Nothing Just searchedHandle -> contactFromProfile - <$$> HandleAPI.getLocalHandleInfo searcherId searchedHandle + <$$> HandleAPI.getLocalHandleInfo lsearcherId searchedHandle pure $ case teamSearchInfo of Search.TeamOnly t -> if Just t == (contactTeam =<< exactHandleResult) diff --git a/services/brig/src/Brig/User/Search/Index.hs b/services/brig/src/Brig/User/Search/Index.hs index 89a63abf80..ccb2e40414 100644 --- a/services/brig/src/Brig/User/Search/Index.hs +++ b/services/brig/src/Brig/User/Search/Index.hs @@ -79,7 +79,6 @@ import Imports hiding (log, searchable) import Network.HTTP.Client hiding (path) import Network.HTTP.Types (hContentType, statusCode) import qualified SAML2.WebSSO.Types as SAML -import qualified SAML2.WebSSO.XML as SAML import qualified System.Logger as Log import System.Logger.Class ( Logger, @@ -737,8 +736,6 @@ reindexRowToIndexUser ] idpUrl :: UserSSOId -> Maybe Text - idpUrl (UserSSOId tenant _subject) = - case SAML.decodeElem $ cs tenant of - Left _ -> Nothing - Right (SAML.Issuer uri) -> Just $ (cs . toLazyByteString . serializeURIRef) uri + idpUrl (UserSSOId (SAML.UserRef (SAML.Issuer uri) _subject)) = + Just $ (cs . toLazyByteString . serializeURIRef) uri idpUrl (UserScimExternalId _) = Nothing diff --git a/services/brig/test/integration/API/Federation.hs b/services/brig/test/integration/API/Federation.hs index 15e6a50840..7f8960d7e6 100644 --- a/services/brig/test/integration/API/Federation.hs +++ b/services/brig/test/integration/API/Federation.hs @@ -14,52 +14,60 @@ -- -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module API.Federation where import API.Search.Util (refreshIndex) +import API.User.Util import Bilge hiding (head) import Bilge.Assert +import qualified Brig.Options as Opt import Brig.Types import Control.Arrow (Arrow (first), (&&&)) import Data.Aeson (encode) import Data.Handle (Handle (..)) -import Data.Id (Id (..), UserId) +import Data.Id import qualified Data.Map as Map -import Data.Qualified (qUnqualified) +import Data.Qualified +import Data.Range import qualified Data.Set as Set +import Data.Timeout import qualified Data.UUID.V4 as UUIDv4 import Federation.Util (generateClientPrekeys) import Imports import Test.QuickCheck (arbitrary) import Test.QuickCheck.Gen (generate) import Test.Tasty +import qualified Test.Tasty.Cannon as WS import Test.Tasty.HUnit (assertEqual, assertFailure) import Util -import Wire.API.Federation.API.Brig (GetUserClients (..), SearchRequest (SearchRequest)) +import Wire.API.Federation.API.Brig (GetUserClients (..), SearchRequest (SearchRequest), UserDeletedConnectionsNotification (..)) import qualified Wire.API.Federation.API.Brig as FedBrig import Wire.API.Message (UserClients (..)) import Wire.API.User.Client (mkUserClientPrekeyMap) import Wire.API.UserMap (UserMap (UserMap)) -tests :: Manager -> Brig -> FedBrigClient -> IO TestTree -tests m brig fedBrigClient = +-- Note: POST /federation/send-connection-action is implicitly tested in API.User.Connection +tests :: Manager -> Opt.Opts -> Brig -> Cannon -> FedBrigClient -> IO TestTree +tests m opts brig cannon fedBrigClient = return $ testGroup "federation" - [ test m "GET /federation/search-users : Found" (testSearchSuccess brig fedBrigClient), - test m "GET /federation/search-users : NotFound" (testSearchNotFound fedBrigClient), - test m "GET /federation/search-users : Empty Input - NotFound" (testSearchNotFoundEmpty fedBrigClient), - test m "GET /federation/get-user-by-handle : Found" (testGetUserByHandleSuccess brig fedBrigClient), - test m "GET /federation/get-user-by-handle : NotFound" (testGetUserByHandleNotFound fedBrigClient), - test m "GET /federation/get-users-by-ids : 200 all found" (testGetUsersByIdsSuccess brig fedBrigClient), - test m "GET /federation/get-users-by-ids : 200 partially found" (testGetUsersByIdsPartial brig fedBrigClient), - test m "GET /federation/get-users-by-ids : 200 none found" (testGetUsersByIdsNoneFound fedBrigClient), - test m "GET /federation/claim-prekey : 200" (testClaimPrekeySuccess brig fedBrigClient), - test m "GET /federation/claim-prekey-bundle : 200" (testClaimPrekeyBundleSuccess brig fedBrigClient), + [ test m "POST /federation/search-users : Found" (testSearchSuccess brig fedBrigClient), + test m "POST /federation/search-users : NotFound" (testSearchNotFound fedBrigClient), + test m "POST /federation/search-users : Empty Input - NotFound" (testSearchNotFoundEmpty fedBrigClient), + test m "POST /federation/get-user-by-handle : Found" (testGetUserByHandleSuccess brig fedBrigClient), + test m "POST /federation/get-user-by-handle : NotFound" (testGetUserByHandleNotFound fedBrigClient), + test m "POST /federation/get-users-by-ids : 200 all found" (testGetUsersByIdsSuccess brig fedBrigClient), + test m "POST /federation/get-users-by-ids : 200 partially found" (testGetUsersByIdsPartial brig fedBrigClient), + test m "POST /federation/get-users-by-ids : 200 none found" (testGetUsersByIdsNoneFound fedBrigClient), + test m "POST /federation/claim-prekey : 200" (testClaimPrekeySuccess brig fedBrigClient), + test m "POST /federation/claim-prekey-bundle : 200" (testClaimPrekeyBundleSuccess brig fedBrigClient), test m "POST /federation/claim-multi-prekey-bundle : 200" (testClaimMultiPrekeyBundleSuccess brig fedBrigClient), test m "POST /federation/get-user-clients : 200" (testGetUserClients brig fedBrigClient), - test m "POST /federation/get-user-clients : Not Found" (testGetUserClientsNotFound fedBrigClient) + test m "POST /federation/get-user-clients : Not Found" (testGetUserClientsNotFound fedBrigClient), + test m "POST /federation/on-user-deleted/connections : 200" (testRemoteUserGetsDeleted opts brig cannon fedBrigClient) ] testSearchSuccess :: Brig -> FedBrigClient -> Http () @@ -203,10 +211,38 @@ testGetUserClients brig fedBrigClient = do testGetUserClientsNotFound :: FedBrigClient -> Http () testGetUserClientsNotFound fedBrigClient = do - absentUserId :: UserId <- Id <$> lift UUIDv4.nextRandom + absentUserId <- randomId UserMap userClients <- FedBrig.getUserClients fedBrigClient (GetUserClients [absentUserId]) liftIO $ assertEqual "client set for user should match" (Just (Set.fromList [])) (fmap (Set.map pubClientId) . Map.lookup absentUserId $ userClients) + +testRemoteUserGetsDeleted :: Opt.Opts -> Brig -> Cannon -> FedBrigClient -> Http () +testRemoteUserGetsDeleted opts brig cannon fedBrigClient = do + connectedUser <- userId <$> randomUser brig + pendingUser <- userId <$> randomUser brig + blockedUser <- userId <$> randomUser brig + unconnectedUser <- userId <$> randomUser brig + remoteUser <- fakeRemoteUser + + sendConnectionAction brig opts connectedUser remoteUser (Just FedBrig.RemoteConnect) Accepted + receiveConnectionAction brig fedBrigClient pendingUser remoteUser FedBrig.RemoteConnect Nothing Pending + sendConnectionAction brig opts blockedUser remoteUser (Just FedBrig.RemoteConnect) Accepted + putConnectionQualified brig blockedUser remoteUser Blocked !!! statusCode === const 200 + + let localUsers = [connectedUser, pendingUser, blockedUser, unconnectedUser] + void . WS.bracketRN cannon localUsers $ \[cc, pc, bc, uc] -> do + _ <- + FedBrig.onUserDeleted + fedBrigClient + (qDomain remoteUser) + (UserDeletedConnectionsNotification (qUnqualified remoteUser) (unsafeRange localUsers)) + + WS.assertMatchN_ (5 # Second) [cc] $ matchDeleteUserNotification remoteUser + WS.assertNoEvent (1 # Second) [pc, bc, uc] + + for_ localUsers $ \u -> + getConnectionQualified brig u remoteUser !!! do + const 404 === statusCode diff --git a/services/brig/test/integration/API/Provider.hs b/services/brig/test/integration/API/Provider.hs index 0d31b98412..fb3a09bbc0 100644 --- a/services/brig/test/integration/API/Provider.hs +++ b/services/brig/test/integration/API/Provider.hs @@ -489,33 +489,29 @@ testDeleteService config db brig galley cannon = withTestService config db brig -- Create a conversation u1 <- createUser "Ernie" brig u2 <- createUser "Bert" brig - let uid1 = userId u1 - quid1 = userQualifiedId u1 - localDomain = qDomain quid1 - uid2 = userId u2 + let uid2 = userId u2 + Qualified uid1 localDomain = userQualifiedId u1 + luid1 = toLocalUnsafe localDomain uid1 postConnection brig uid1 uid2 !!! const 201 === statusCode putConnection brig uid2 uid1 Accepted !!! const 200 === statusCode cnv <- responseJsonError =<< (createConv galley uid1 [uid2] do deleteService brig pid sid defProviderPassword !!! const 202 === statusCode - _ <- waitFor (5 # Second) not (isMember galley buid1 cid) - _ <- waitFor (5 # Second) not (isMember galley buid2 cid) + _ <- waitFor (5 # Second) not (isMember galley lbuid1 cid) + _ <- waitFor (5 # Second) not (isMember galley lbuid2 cid) getBotConv galley bid1 cid !!! const 404 === statusCode getBotConv galley bid2 cid !!! const 404 === statusCode - wsAssertMemberLeave ws qcid qbuid1 [qbuid1] - wsAssertMemberLeave ws qcid qbuid2 [qbuid2] + wsAssertMemberLeave ws qcid (qUntagged lbuid1) [qUntagged lbuid1] + wsAssertMemberLeave ws qcid (qUntagged lbuid2) [qUntagged lbuid2] -- The service should not be available getService brig pid sid !!! const 404 === statusCode @@ -598,9 +594,9 @@ testAddRemoveBotTeam config db brig galley cannon = withTestService config db br testBotTeamOnlyConv :: Config -> DB.ClientState -> Brig -> Galley -> Cannon -> Http () testBotTeamOnlyConv config db brig galley cannon = withTestService config db brig defServiceApp $ \sref buf -> do (u1, u2, _h, _tid, cid, pid, sid) <- prepareBotUsersTeam brig galley sref - let (uid1, uid2) = (userId u1, userId u2) - quid1 = userQualifiedId u1 - localDomain = qDomain quid1 + let uid2 = userId u2 + Qualified uid1 localDomain = userQualifiedId u1 + luid1 = toLocalUnsafe localDomain uid1 qcid = Qualified cid localDomain -- Make the conversation team-only and check that the bot can't be added -- to the conversation @@ -611,21 +607,20 @@ testBotTeamOnlyConv config db brig galley cannon = withTestService config db bri -- Make the conversation allowed for guests and add the bot successfully setAccessRole uid1 cid NonActivatedAccessRole bid <- addBotConv localDomain brig cannon uid1 uid2 cid pid sid buf - let buid = botUserId bid - qbuid = Qualified buid localDomain + let lbuid = qualifyAs luid1 . botUserId $ bid -- Make the conversation team-only again and check that the bot has been removed WS.bracketR cannon uid1 $ \ws -> do setAccessRole uid1 cid TeamAccessRole - _ <- waitFor (5 # Second) not (isMember galley buid cid) + _ <- waitFor (5 # Second) not (isMember galley lbuid cid) getBotConv galley bid cid !!! const 404 === statusCode svcAssertConvAccessUpdate buf - quid1 + (qUntagged luid1) (ConversationAccessData (Set.singleton InviteAccess) TeamAccessRole) qcid - svcAssertMemberLeave buf qbuid [qbuid] qcid - wsAssertMemberLeave ws qcid qbuid [qbuid] + svcAssertMemberLeave buf (qUntagged lbuid) [qUntagged lbuid] qcid + wsAssertMemberLeave ws qcid (qUntagged lbuid) [qUntagged lbuid] where setAccessRole uid cid role = updateConversationAccess galley uid cid [InviteAccess] role @@ -876,6 +871,7 @@ testWhitelistKickout localDomain config db brig galley cannon = do -- Create a team and a conversation (owner, tid) <- Team.createUserWithTeam brig let qowner = Qualified owner localDomain + lowner = toLocalUnsafe localDomain owner cid <- Team.createTeamConv galley tid owner [] Nothing let qcid = Qualified cid localDomain -- Create a service @@ -888,18 +884,17 @@ testWhitelistKickout localDomain config db brig galley cannon = do responseJsonError =<< (addBot brig owner pid sid cid do dewhitelistService brig owner tid pid sid - _ <- waitFor (2 # Second) not (isMember galley buid cid) + _ <- waitFor (2 # Second) not (isMember galley lbuid cid) getBotConv galley bid cid !!! const 404 === statusCode - wsAssertMemberLeave ws qcid qowner [qbuid] - svcAssertMemberLeave buf qowner [qbuid] qcid + wsAssertMemberLeave ws qcid qowner [qUntagged lbuid] + svcAssertMemberLeave buf qowner [qUntagged lbuid] qcid -- The bot should not get any further events liftIO $ timeout (2 # Second) (readChan buf) >>= \case @@ -1750,6 +1745,8 @@ svcAssertConvAccessUpdate buf usr upd cnv = liftIO $ do evt <- timeout (5 # Second) $ readChan buf case evt of Just (TestBotMessage e) -> do + -- FUTUREWORK: Sometimes the assertion on the event type fails, but not + -- always. See https://wearezeta.atlassian.net/browse/BE-522. assertEqual "event type" ConvAccessUpdate (evtType e) assertEqual "conv" cnv (evtConv e) assertEqual "user" usr (evtFrom e) @@ -1941,18 +1938,18 @@ testMessageBotUtil :: WS.Cannon -> Http () testMessageBotUtil quid uc cid pid sid sref buf brig galley cannon = do - let uid = qUnqualified quid - localDomain = qDomain quid + let Qualified uid localDomain = quid + luid = toLocalUnsafe localDomain uid qcid = Qualified cid localDomain -- Add bot to conversation _rs <- addBot brig uid pid sid cid do postBotMessage galley bid bc cid [(uid, uc, (toBase64Text "Hi User!"))] !!! const 201 === statusCode - wsAssertMessage ws qcid qbuid bc uc (toBase64Text "Hi User!") + wsAssertMessage ws qcid (qUntagged lbuid) bc uc (toBase64Text "Hi User!") -- The user replies postMessage galley uid uc cid [(buid, bc, (toBase64Text "Hi Bot"))] !!! const 201 === statusCode @@ -1979,10 +1976,10 @@ testMessageBotUtil quid uc cid pid sid sref buf brig galley cannon = do WS.bracketR cannon uid $ \ws -> do deleteService brig pid sid defProviderPassword !!! const 202 === statusCode - _ <- waitFor (5 # Second) not (isMember galley buid cid) + _ <- waitFor (5 # Second) not (isMember galley lbuid cid) getBotConv galley bid cid !!! const 404 === statusCode - wsAssertMemberLeave ws qcid qbuid [qbuid] + wsAssertMemberLeave ws qcid (qUntagged lbuid) [qUntagged lbuid] prepareBotUsersTeam :: HasCallStack => diff --git a/services/brig/test/integration/API/Search.hs b/services/brig/test/integration/API/Search.hs index b6e73b4bb1..1febe169a7 100644 --- a/services/brig/test/integration/API/Search.hs +++ b/services/brig/test/integration/API/Search.hs @@ -258,6 +258,9 @@ testReindex brig = do -- This test is currently disabled, because it fails sporadically, probably due -- to imprecisions in ES exact match scoring. -- FUTUREWORK: Find the reason for the failures and fix ES behaviour. +-- See also the "cassandra writetime hypothesis": +-- https://wearezeta.atlassian.net/browse/BE-523 +-- https://github.com/wireapp/wire-server/pull/1798#issuecomment-933174913 _testOrderName :: TestConstraints m => Brig -> m () _testOrderName brig = do searcher <- userId <$> randomUser brig @@ -447,7 +450,7 @@ testSearchOtherDomain opts brig = do -- a mocked federator started and stopped during this test otherSearchResult :: [Contact] <- liftIO $ generate arbitrary let mockResponse = OutwardResponseBody (cs $ Aeson.encode otherSearchResult) - (results, _) <- liftIO . withTempMockFederator opts (Domain "non-existent.example.com") mockResponse $ do + (results, _) <- liftIO . withTempMockFederator opts mockResponse $ do executeSearchWithDomain brig (userId user) "someSearchText" (Domain "non-existent.example.com") let expectedResult = SearchResult diff --git a/services/brig/test/integration/API/Team.hs b/services/brig/test/integration/API/Team.hs index aa338e2253..d8e695b783 100644 --- a/services/brig/test/integration/API/Team.hs +++ b/services/brig/test/integration/API/Team.hs @@ -56,6 +56,7 @@ import UnliftIO.Async (mapConcurrently_, pooledForConcurrentlyN_, replicateConcu import Util import Util.AWS as Util import Web.Cookie (parseSetCookie, setCookieName) +import Wire.API.User.Identity (mkSimpleSampleUref) newtype TeamSizeLimit = TeamSizeLimit Word32 @@ -757,7 +758,7 @@ testConnectionSameTeam brig = do testCreateUserInternalSSO :: Brig -> Galley -> Http () testCreateUserInternalSSO brig galley = do teamid <- snd <$> createUserWithTeam brig - let ssoid = UserSSOId "nil" "nil" + let ssoid = UserSSOId mkSimpleSampleUref -- creating users requires both sso_id and team_id postUser' True False "dummy" True False (Just ssoid) Nothing brig !!! const 400 === statusCode @@ -788,7 +789,7 @@ testCreateUserInternalSSO brig galley = do testDeleteUserSSO :: Brig -> Galley -> Http () testDeleteUserSSO brig galley = do (creator, tid) <- createUserWithTeam brig - let ssoid = UserSSOId "nil" "nil" + let ssoid = UserSSOId mkSimpleSampleUref mkuser :: Bool -> Http (Maybe User) mkuser withemail = responseJsonMaybe diff --git a/services/brig/test/integration/API/Team/Util.hs b/services/brig/test/integration/API/Team/Util.hs index f2bea23d82..2e7329bf5c 100644 --- a/services/brig/test/integration/API/Team/Util.hs +++ b/services/brig/test/integration/API/Team/Util.hs @@ -85,7 +85,9 @@ createPopulatedBindingTeamWithNames brig names = do invitees <- forM names $ \name -> do inviteeEmail <- randomEmail let invite = stdInvitationRequest inviteeEmail - inv <- responseJsonError =<< postInvitation brig tid (userId inviter) invite + inv <- + responseJsonError =<< postInvitation brig tid (userId inviter) invite + Manager -> Brig -> Cannon -> CargoHold -> Galley -> Nginz -> AWS.Env -> IO TestTree -tests conf p b c ch g n aws = do +tests :: Opt.Opts -> FedBrigClient -> FedGalleyClient -> Manager -> Brig -> Cannon -> CargoHold -> Galley -> Nginz -> AWS.Env -> DB.ClientState -> IO TestTree +tests conf fbc fgc p b c ch g n aws db = do let cl = ConnectionLimit $ Opt.setUserMaxConnections (Opt.optSettings conf) let at = Opt.setActivationTimeout (Opt.optSettings conf) z <- mkZAuthEnv (Just conf) @@ -51,7 +52,7 @@ tests conf p b c ch g n aws = do [ API.User.Client.tests cl at conf p b c g, API.User.Account.tests cl at conf p b c ch g aws, API.User.Auth.tests conf p z b g n, - API.User.Connection.tests cl at conf p b c g, + API.User.Connection.tests cl at conf p b c g fbc fgc db, API.User.Handles.tests cl at conf p b c g, API.User.PasswordReset.tests cl at conf p b c g, API.User.Property.tests cl at conf p b c g, diff --git a/services/brig/test/integration/API/User/Account.hs b/services/brig/test/integration/API/User/Account.hs index a7a4de6b24..fcc529fd2d 100644 --- a/services/brig/test/integration/API/User/Account.hs +++ b/services/brig/test/integration/API/User/Account.hs @@ -1,5 +1,4 @@ -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - +{-# LANGUAGE NumericUnderscores #-} -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2020 Wire Swiss GmbH @@ -16,6 +15,7 @@ -- -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module API.User.Account ( tests, @@ -45,13 +45,16 @@ import qualified Data.Aeson.Lens as AesonL import qualified Data.ByteString as C8 import Data.ByteString.Char8 (pack) import Data.ByteString.Conversion +import Data.Domain (Domain (..), domainText) import Data.Id hiding (client) import Data.Json.Util (fromUTCTimeMillis) import Data.List1 (singleton) import qualified Data.List1 as List1 import Data.Misc (PlainTextPassword (..)) import Data.Qualified +import Data.Range (Range (fromRange)) import qualified Data.Set as Set +import Data.String.Conversions (cs) import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.Time (UTCTime, getCurrentTime) @@ -63,6 +66,8 @@ import qualified Data.Vector as Vec import Galley.Types.Teams (noPermissions) import Gundeck.Types.Notification import Imports hiding (head) +import qualified Network.HTTP.Types as Http +import qualified Network.Wai as Wai import qualified Network.Wai.Utilities.Error as Error import Test.Tasty hiding (Timeout) import Test.Tasty.Cannon hiding (Cannon) @@ -72,7 +77,13 @@ import UnliftIO (mapConcurrently_) import Util as Util import Util.AWS as Util import Web.Cookie (parseSetCookie) +import Wire.API.Federation.API.Brig (UserDeletedConnectionsNotification (..)) +import qualified Wire.API.Federation.API.Brig as FedBrig +import Wire.API.Federation.API.Common (EmptyResponse (EmptyResponse)) +import Wire.API.Federation.GRPC.Types (OutwardResponse (OutwardResponseBody)) +import qualified Wire.API.Federation.GRPC.Types as F import Wire.API.User (ListUsersQuery (..)) +import Wire.API.User.Identity (mkSampleUref, mkSimpleSampleUref) tests :: ConnectionLimit -> Opt.Timeout -> Opt.Opts -> Manager -> Brig -> Cannon -> CargoHold -> Galley -> AWS.Env -> TestTree tests _ at opts p b c ch g aws = @@ -124,6 +135,7 @@ tests _ at opts p b c ch g aws = test' aws p "delete/anonymous" $ testDeleteAnonUser b, test' aws p "delete /i/users/:uid - 202" $ testDeleteInternal b c aws, test' aws p "delete with profile pic" $ testDeleteWithProfilePic b ch, + test' aws p "delete with connected remote users" $ testDeleteWithRemotes opts b, test' aws p "put /i/users/:uid/sso-id" $ testUpdateSSOId b g, testGroup "temporary customer extensions" @@ -389,7 +401,7 @@ testCreateUserBlacklist _ brig aws = testCreateUserExternalSSO :: Brig -> Http () testCreateUserExternalSSO brig = do teamid <- Id <$> liftIO UUID.nextRandom - let ssoid = UserSSOId "nil" "nil" + let ssoid = UserSSOId mkSimpleSampleUref p withsso withteam = RequestBodyLBS . encode . object $ ["name" .= ("foo" :: Text)] @@ -779,6 +791,9 @@ testPhoneUpdateBlacklisted brig = do const 200 === statusCode const (Right Nothing) === fmap userPhone . responseJsonEither + -- cleanup to avoid other tests failing sporadically + deletePrefix brig (phonePrefix prefix) + testCreateAccountPendingActivationKey :: Opt.Opts -> Brig -> Http () testCreateAccountPendingActivationKey (Opt.setRestrictUserCreation . Opt.optSettings -> Just True) _ = pure () testCreateAccountPendingActivationKey _ brig = do @@ -1106,7 +1121,7 @@ testDeleteUserByPassword brig cannon aws = do !!! const 200 === statusCode n1 <- countCookies brig uid1 defCookieLabel liftIO $ Just 1 @=? n1 - setHandleAndDeleteUser brig cannon u [] aws $ + setHandleAndDeleteUser brig cannon u [uid2, uid3] aws $ \uid -> deleteUser uid (Just defPassword) brig !!! const 200 === statusCode -- Activating the new email address now should not work act <- getActivationCode brig (Left eml) @@ -1178,9 +1193,6 @@ testDeleteInternal brig cannon aws = do setHandleAndDeleteUser brig cannon u [] aws $ \uid -> delete (brig . paths ["/i/users", toByteString' uid]) !!! const 202 === statusCode --- Check that user deletion is also triggered --- liftIO $ Util.assertUserJournalQueue "user deletion testDeleteInternal2: " aws (userDeleteJournaled $ userId u) - testDeleteWithProfilePic :: Brig -> CargoHold -> Http () testDeleteWithProfilePic brig cargohold = do uid <- userId <$> createAnonUser "anon" brig @@ -1197,13 +1209,61 @@ testDeleteWithProfilePic brig cargohold = do -- Check that the asset gets deleted downloadAsset cargohold uid (toByteString' (ast ^. CHV3.assetKey)) !!! const 404 === statusCode +testDeleteWithRemotes :: Opt.Opts -> Brig -> Http () +testDeleteWithRemotes opts brig = do + localUser <- randomUser brig + + let remote1Domain = Domain "remote1.example.com" + remote2Domain = Domain "remote2.example.com" + remote1UserConnected <- Qualified <$> randomId <*> pure remote1Domain + remote1UserPending <- Qualified <$> randomId <*> pure remote1Domain + remote2UserBlocked <- Qualified <$> randomId <*> pure remote2Domain + + sendConnectionAction brig opts (userId localUser) remote1UserConnected (Just FedBrig.RemoteConnect) Accepted + sendConnectionAction brig opts (userId localUser) remote1UserPending Nothing Sent + sendConnectionAction brig opts (userId localUser) remote2UserBlocked (Just FedBrig.RemoteConnect) Accepted + void $ putConnectionQualified brig (userId localUser) remote2UserBlocked Blocked + + let fedMockResponse = OutwardResponseBody (cs $ Aeson.encode EmptyResponse) + let galleyHandler :: ReceivedRequest -> MockT IO Wai.Response + galleyHandler (ReceivedRequest requestMethod requestPath _requestBody) = + case (requestMethod, requestPath) of + (_methodDelete, ["i", "user"]) -> do + let response = Wai.responseLBS Http.status200 [(Http.hContentType, "application/json")] (cs $ Aeson.encode EmptyResponse) + pure response + _ -> error "not mocked" + + (_, rpcCalls, _galleyCalls) <- liftIO $ + withMockedFederatorAndGalley opts (Domain "example.com") fedMockResponse galleyHandler $ do + deleteUser (userId localUser) (Just defPassword) brig !!! do + const 200 === statusCode + + liftIO $ do + remote1Call <- assertOne $ filter (\c -> F.domain c == domainText remote1Domain) rpcCalls + remote1Udn <- assertRight $ parseFedRequest remote1Call + udcnUser remote1Udn @?= userId localUser + sort (fromRange (udcnConnections remote1Udn)) + @?= sort (map qUnqualified [remote1UserConnected, remote1UserPending]) + + remote2Call <- assertOne $ filter (\c -> F.domain c == domainText remote2Domain) rpcCalls + remote2Udn <- assertRight $ parseFedRequest remote2Call + udcnUser remote2Udn @?= userId localUser + fromRange (udcnConnections remote2Udn) @?= [qUnqualified remote2UserBlocked] + where + parseFedRequest :: FromJSON a => F.FederatedRequest -> Either String a + parseFedRequest fr = + case F.request fr of + Just r -> + (eitherDecode . cs) (F.body r) + Nothing -> Left "No request" + testUpdateSSOId :: Brig -> Galley -> Http () testUpdateSSOId brig galley = do noSuchUserId <- Id <$> liftIO UUID.nextRandom put ( brig . paths ["i", "users", toByteString' noSuchUserId, "sso-id"] - . Bilge.json (UserSSOId "1" "1") + . Bilge.json (UserSSOId (mkSampleUref "1" "1")) ) !!! const 404 === statusCode let go :: HasCallStack => User -> UserSSOId -> Http () @@ -1230,8 +1290,8 @@ testUpdateSSOId brig galley = do when (not hasEmail) $ do error "not implemented" selfUser <$> (responseJsonError =<< get (brig . path "/self" . zUser (userId member))) - let ssoids1 = [UserSSOId "1" "1", UserSSOId "1" "2"] - ssoids2 = [UserSSOId "2" "1", UserSSOId "2" "2"] + let ssoids1 = [UserSSOId (mkSampleUref "1" "1"), UserSSOId (mkSampleUref "1" "2")] + ssoids2 = [UserSSOId (mkSampleUref "2" "1"), UserSSOId (mkSampleUref "2" "2")] users <- sequence [ mkMember True False, @@ -1325,7 +1385,7 @@ testRestrictedUserCreation opts brig = do -- NOTE: SSO users are anyway not allowed on the `/register` endpoint teamid <- Id <$> liftIO UUID.nextRandom - let ssoid = UserSSOId "nil" "nil" + let ssoid = UserSSOId mkSimpleSampleUref let Object ssoUser = object [ "name" .= Name "Alice", @@ -1349,12 +1409,7 @@ setHandleAndDeleteUser brig cannon u others aws execDelete = do -- Delete the user WS.bracketRN cannon (uid : others) $ \wss -> do execDelete uid - void . liftIO . WS.assertMatchN (5 # Second) wss $ \n -> do - let j = Object $ List1.head (ntfPayload n) - let etype = j ^? key "type" . _String - let euser = j ^? key "id" . _String - etype @?= Just "user.delete" - euser @?= Just (UUID.toText (toUUID uid)) + void . liftIO . WS.assertMatchN (5 # Second) wss $ matchDeleteUserNotification quid liftIO $ Util.assertUserJournalQueue "user deletion, setHandleAndDeleteUser: " aws (userDeleteJournaled uid) -- Cookies are gone n2 <- countCookies brig uid defCookieLabel diff --git a/services/brig/test/integration/API/User/Connection.hs b/services/brig/test/integration/API/User/Connection.hs index fbd9509b11..e2678598c9 100644 --- a/services/brig/test/integration/API/User/Connection.hs +++ b/services/brig/test/integration/API/User/Connection.hs @@ -25,13 +25,17 @@ where import API.User.Util import Bilge hiding (accept, timeout) import Bilge.Assert +import Brig.Data.Connection (remoteConnectionInsert) import qualified Brig.Options as Opt import Brig.Types -import Brig.Types.Intra +import qualified Cassandra as DB import Control.Arrow ((&&&)) import Data.ByteString.Conversion +import Data.Domain import Data.Id hiding (client) +import Data.Json.Util (UTCTimeMillis, toUTCTimeMillis) import Data.Qualified +import Data.Time.Clock (getCurrentTime) import qualified Data.UUID.V4 as UUID import Galley.Types import Imports @@ -40,10 +44,14 @@ import Test.Tasty hiding (Timeout) import Test.Tasty.HUnit import Util import Wire.API.Connection +import qualified Wire.API.Federation.API.Brig as F +import Wire.API.Federation.API.Galley (GetConversationsRequest (..), GetConversationsResponse (gcresConvs), RemoteConvMembers (rcmOthers), RemoteConversation (rcnvMembers)) +import qualified Wire.API.Federation.API.Galley as F +import Wire.API.Routes.Internal.Brig.Connection import Wire.API.Routes.MultiTablePaging -tests :: ConnectionLimit -> Opt.Timeout -> Opt.Opts -> Manager -> Brig -> Cannon -> Galley -> TestTree -tests cl _at _conf p b _c g = +tests :: ConnectionLimit -> Opt.Timeout -> Opt.Opts -> Manager -> Brig -> Cannon -> Galley -> FedBrigClient -> FedGalleyClient -> DB.ClientState -> TestTree +tests cl _at opts p b _c g fedBrigClient fedGalleyClient db = testGroup "connection" [ test p "post /connections" $ testCreateManualConnections b, @@ -73,9 +81,23 @@ tests cl _at _conf p b _c g = test p "put /connections/:id noop" $ testUpdateConnectionNoop b, test p "put /connections/:domain/:id noop" $ testUpdateConnectionNoopQualified b, test p "get /connections - 200 (paging)" $ testLocalConnectionsPaging b, - test p "post /list-connections - 200 (paging)" $ testAllConnectionsPaging b, + test p "post /list-connections - 200 (paging)" $ testAllConnectionsPaging b db, test p "post /connections - 400 (max conns)" $ testConnectionLimit b cl, - test p "post /connections/:domain/:id - 400 (max conns)" $ testConnectionLimitQualified b cl + test p "post /connections/:domain/:id - 400 (max conns)" $ testConnectionLimitQualified b cl, + test p "Remote connections: connect with no federation" (testConnectFederationNotAvailable b), + test p "Remote connections: connect OK" (testConnectOK b g fedBrigClient), + test p "Remote connections: connect with Anon" (testConnectWithAnon b fedBrigClient), + test p "Remote connections: connection from Anon" (testConnectFromAnon b), + test p "Remote connections: mutual Connect - local action then remote action" (testConnectMutualLocalActionThenRemoteAction opts b g fedBrigClient), + test p "Remote connections: mutual Connect - remote action then local action" (testConnectMutualRemoteActionThenLocalAction opts b fedBrigClient fedGalleyClient), + test p "Remote connections: connect twice" (testConnectFromPending b fedBrigClient), + test p "Remote connections: ignore then accept" (testConnectFromIgnored opts b fedBrigClient), + test p "Remote connections: ignore, remote cancels, then accept" (testSentFromIgnored opts b fedBrigClient), + test p "Remote connections: block then accept" (testConnectFromBlocked opts b g fedBrigClient), + test p "Remote connections: block, remote cancels, then accept" (testSentFromBlocked opts b fedBrigClient), + test p "Remote connections: send then cancel" (testCancel opts b), + test p "Remote connections: limits" (testConnectionLimits opts b fedBrigClient), + test p "post /users/connections-status/v2 : All connections" (testInternalGetConnStatusesAll b opts fedBrigClient) ] testCreateConnectionInvalidUser :: Brig -> Http () @@ -593,14 +615,20 @@ testLocalConnectionsPaging b = do liftIO $ assertEqual "has more" (Just (count' < total)) more return . (count',) $ (conns >>= fmap (qUnqualified . ucTo) . listToMaybe . reverse) -testAllConnectionsPaging :: Brig -> Http () -testAllConnectionsPaging b = do +testAllConnectionsPaging :: Brig -> DB.ClientState -> Http () +testAllConnectionsPaging b db = do quid <- userQualifiedId <$> randomUser b let uid = qUnqualified quid - replicateM_ total $ do + replicateM_ totalLocal $ do qOther <- userQualifiedId <$> randomUser b postConnectionQualified b uid qOther !!! const 201 === statusCode + -- FUTUREWORK: For now, because we do not support creating remote connections + -- yet (as of Oct 1, 2021), we write some made-up remote connections directly + -- to the database such that querying works. + now <- toUTCTimeMillis <$> liftIO getCurrentTime + replicateM_ totalRemote $ createRemoteConnection uid now + -- get all connections at once resAll :: ConnectionsPage <- responseJsonError =<< listAllConnections b uid Nothing Nothing liftIO $ assertEqual "all: size" total (length . mtpResults $ resAll) @@ -616,7 +644,20 @@ testAllConnectionsPaging b = do liftIO $ assertEqual "next: has_more" False (mtpHasMore resNext) where size = 2 - total = 5 + totalLocal = 5 + totalRemote = 3 + total = totalLocal + totalRemote + remoteDomain = Domain "faraway.example.com" + createRemoteConnection :: UserId -> UTCTimeMillis -> Http () + createRemoteConnection self now = do + qOther <- (`Qualified` remoteDomain) <$> randomId + qConv <- (`Qualified` remoteDomain) <$> randomId + liftIO . DB.runClient db $ + DB.retry DB.x5 $ + DB.write remoteConnectionInsert $ + DB.params + DB.Quorum + (self, remoteDomain, qUnqualified qOther, SentWithHistory, now, qDomain qConv, qUnqualified qConv) testConnectionLimit :: Brig -> ConnectionLimit -> Http () testConnectionLimit brig (ConnectionLimit l) = do @@ -665,3 +706,279 @@ testConnectionLimitQualified brig (ConnectionLimit l) = do assertLimited = do const 403 === statusCode const (Just "connection-limit") === fmap Error.label . responseJsonMaybe + +testConnectFederationNotAvailable :: Brig -> Http () +testConnectFederationNotAvailable brig = do + (uid1, quid2) <- localAndRemoteUser brig + postConnectionQualified brig uid1 quid2 + !!! const 422 === statusCode + +testConnectOK :: Brig -> Galley -> FedBrigClient -> Http () +testConnectOK brig galley fedBrigClient = do + let convIsLocal = True + (uid1, quid2, convId) <- localAndRemoteUserWithConvId brig convIsLocal + receiveConnectionAction brig fedBrigClient uid1 quid2 F.RemoteConnect Nothing Pending + + -- The conversation exists uid1 is not a participant however + getConversationQualified galley uid1 convId + !!! statusCode === const 403 + +testConnectWithAnon :: Brig -> FedBrigClient -> Http () +testConnectWithAnon brig fedBrigClient = do + fromUser <- randomId + toUser <- userId <$> createAnonUser "anon1234" brig + res <- F.sendConnectionAction fedBrigClient (Domain "far-away.example.com") (F.NewConnectionRequest fromUser toUser F.RemoteConnect) + liftIO $ + assertEqual "The response should specify that the user is not activated" F.NewConnectionResponseUserNotActivated res + +testConnectFromAnon :: Brig -> Http () +testConnectFromAnon brig = do + anonUser <- userId <$> createAnonUser "anon1234" brig + remoteUser <- fakeRemoteUser + postConnectionQualified brig anonUser remoteUser !!! const 403 === statusCode + +testConnectMutualLocalActionThenRemoteAction :: Opt.Opts -> Brig -> Galley -> FedBrigClient -> Http () +testConnectMutualLocalActionThenRemoteAction opts brig galley fedBrigClient = do + let convIsLocal = True + (uid1, quid2, convId) <- localAndRemoteUserWithConvId brig convIsLocal + + -- First create a connection request from local to remote user, as this test + -- aims to test the behaviour of recieving a mutual request from remote + sendConnectionAction brig opts uid1 quid2 Nothing Sent + + do + res <- + getConversationQualified galley uid1 convId Brig -> FedBrigClient -> FedGalleyClient -> Http () +testConnectMutualRemoteActionThenLocalAction opts brig fedBrigClient fedGalleyClient = do + let convIsLocal = True + (uid1, quid2, convId) <- localAndRemoteUserWithConvId brig convIsLocal + + -- First create a connection request from remote to local user, as this test + -- aims to test the behaviour of sending a mutual request to remote + receiveConnectionAction brig fedBrigClient uid1 quid2 F.RemoteConnect Nothing Pending + + let request = + GetConversationsRequest + { gcrUserId = qUnqualified quid2, + gcrConvIds = [qUnqualified convId] + } + + res <- F.getConversations fedGalleyClient (qDomain quid2) request + liftIO $ + fmap (fmap omQualifiedId . rcmOthers . rcnvMembers) (gcresConvs res) @?= [[]] + + -- The mock response has 'RemoteConnect' as action, because the remote backend + -- cannot be sure if the local backend was previously in Ignored state or not + sendConnectionAction brig opts uid1 quid2 (Just F.RemoteConnect) Accepted + +testConnectFromPending :: Brig -> FedBrigClient -> Http () +testConnectFromPending brig fedBrigClient = do + (uid1, quid2) <- localAndRemoteUser brig + receiveConnectionAction brig fedBrigClient uid1 quid2 F.RemoteConnect Nothing Pending + receiveConnectionAction brig fedBrigClient uid1 quid2 F.RemoteConnect Nothing Pending + receiveConnectionAction brig fedBrigClient uid1 quid2 F.RemoteRescind Nothing Cancelled + +testConnectFromIgnored :: Opt.Opts -> Brig -> FedBrigClient -> Http () +testConnectFromIgnored opts brig fedBrigClient = do + (uid1, quid2) <- localAndRemoteUser brig + + -- set up an initial 'Ignored' state + receiveConnectionAction brig fedBrigClient uid1 quid2 F.RemoteConnect Nothing Pending + putConnectionQualified brig uid1 quid2 Ignored !!! statusCode === const 200 + assertConnectionQualified brig uid1 quid2 Ignored + + -- if the remote side sends a new connection request, we go back to 'Pending' + receiveConnectionAction brig fedBrigClient uid1 quid2 F.RemoteConnect Nothing Pending + + -- if we accept, and the remote side still wants to connect, we transition to 'Accepted' + sendConnectionAction brig opts uid1 quid2 (Just F.RemoteConnect) Accepted + +testSentFromIgnored :: Opt.Opts -> Brig -> FedBrigClient -> Http () +testSentFromIgnored opts brig fedBrigClient = do + (uid1, quid2) <- localAndRemoteUser brig + + -- set up an initial 'Ignored' state + receiveConnectionAction brig fedBrigClient uid1 quid2 F.RemoteConnect Nothing Pending + putConnectionQualified brig uid1 quid2 Ignored !!! statusCode === const 200 + assertConnectionQualified brig uid1 quid2 Ignored + + -- if the remote side rescinds, we stay in 'Ignored' + receiveConnectionAction brig fedBrigClient uid1 quid2 F.RemoteRescind Nothing Ignored + + -- if we accept, and the remote does not want to connect anymore, we transition to 'Sent' + sendConnectionAction brig opts uid1 quid2 Nothing Sent + +testConnectFromBlocked :: Opt.Opts -> Brig -> Galley -> FedBrigClient -> Http () +testConnectFromBlocked opts brig galley fedBrigClient = do + let convIsLocal = True + (uid1, quid2, convId) <- localAndRemoteUserWithConvId brig convIsLocal + + -- set up an initial 'Blocked' state + receiveConnectionAction brig fedBrigClient uid1 quid2 F.RemoteConnect Nothing Pending + putConnectionQualified brig uid1 quid2 Blocked !!! statusCode === const 200 + assertConnectionQualified brig uid1 quid2 Blocked + + getConversationQualified galley uid1 convId + !!! statusCode === const 403 + + -- if the remote side sends a new connection request, we ignore it + receiveConnectionAction brig fedBrigClient uid1 quid2 F.RemoteConnect Nothing Blocked + + -- if we accept (or send a connection request), and the remote side still + -- wants to connect, we transition to 'Accepted' + sendConnectionAction brig opts uid1 quid2 (Just F.RemoteConnect) Accepted + + do + res <- + getConversationQualified galley uid1 convId Brig -> FedBrigClient -> Http () +testSentFromBlocked opts brig fedBrigClient = do + (uid1, quid2) <- localAndRemoteUser brig + + -- set up an initial 'Blocked' state + receiveConnectionAction brig fedBrigClient uid1 quid2 F.RemoteConnect Nothing Pending + putConnectionQualified brig uid1 quid2 Blocked !!! statusCode === const 200 + assertConnectionQualified brig uid1 quid2 Blocked + + -- if the remote side rescinds, we stay in 'Blocked' + receiveConnectionAction brig fedBrigClient uid1 quid2 F.RemoteRescind Nothing Blocked + + -- if we accept, and the remote does not want to connect anymore, we transition to 'Sent' + sendConnectionAction brig opts uid1 quid2 Nothing Sent + +testCancel :: Opt.Opts -> Brig -> Http () +testCancel opts brig = do + (uid1, quid2) <- localAndRemoteUser brig + + sendConnectionAction brig opts uid1 quid2 Nothing Sent + sendConnectionUpdateAction brig opts uid1 quid2 Nothing Cancelled + +testConnectionLimits :: Opt.Opts -> Brig -> FedBrigClient -> Http () +testConnectionLimits opts brig fedBrigClient = do + let connectionLimit = Opt.setUserMaxConnections (Opt.optSettings opts) + (uid1, quid2) <- localAndRemoteUser brig + [quid3, quid4, quid5] <- replicateM 3 fakeRemoteUser + + -- set up N-1 connections from uid1 to remote users + (quid6Sent : _) <- replicateM (fromIntegral connectionLimit - 1) (newConn uid1) + + -- accepting another one should be allowed + receiveConnectionAction brig fedBrigClient uid1 quid2 F.RemoteConnect Nothing Pending + sendConnectionAction brig opts uid1 quid2 (Just F.RemoteConnect) Accepted + + -- get an incoming connection requests beyond the limit, This connection + -- cannot be accepted. This is also the behaviour without federation, if the + -- user wants to accept this one, they have to either sacrifice another + -- connection or ask the backend operator to increase the limit. + receiveConnectionAction brig fedBrigClient uid1 quid3 F.RemoteConnect Nothing Pending + + -- accepting the second one hits the limit (and relation stays Pending): + sendConnectionActionExpectLimit uid1 quid3 (Just F.RemoteConnect) + assertConnectionQualified brig uid1 quid3 Pending + + -- When a remote accepts, it is allowed, this does not break the limit as a + -- Sent becomes an Accepted. + assertConnectionQualified brig uid1 quid6Sent Sent + receiveConnectionAction brig fedBrigClient uid1 quid6Sent F.RemoteConnect (Just F.RemoteConnect) Accepted + + -- attempting to send an own new connection request also hits the limit + sendConnectionActionExpectLimit uid1 quid4 (Just F.RemoteConnect) + getConnectionQualified brig uid1 quid4 !!! const 404 === statusCode + + -- (re-)sending an already accepted connection does not affect the limit + sendConnectionAction brig opts uid1 quid2 (Just F.RemoteConnect) Accepted + + -- blocked connections do not count towards the limit + putConnectionQualified brig uid1 quid2 Blocked !!! statusCode === const 200 + assertConnectionQualified brig uid1 quid2 Blocked + + -- after blocking quid2, we can now accept another connection request + receiveConnectionAction brig fedBrigClient uid1 quid5 F.RemoteConnect Nothing Pending + sendConnectionAction brig opts uid1 quid5 (Just F.RemoteConnect) Accepted + where + newConn :: UserId -> Http (Qualified UserId) + newConn from = do + to <- fakeRemoteUser + sendConnectionAction brig opts from to Nothing Sent + pure to + + sendConnectionActionExpectLimit :: HasCallStack => UserId -> Qualified UserId -> Maybe F.RemoteConnectionAction -> Http () + sendConnectionActionExpectLimit uid1 quid2 _reaction = do + postConnectionQualified brig uid1 quid2 !!! do + const 403 === statusCode + const (Just "connection-limit") === fmap Error.label . responseJsonMaybe + +testInternalGetConnStatusesAll :: Brig -> Opt.Opts -> FedBrigClient -> Http () +testInternalGetConnStatusesAll brig opts fedBrigClient = do + quids <- replicateM 2 $ userQualifiedId <$> randomUser brig + let uids = qUnqualified <$> quids + + localUsers@(localUser1 : _) <- replicateM 5 $ userQualifiedId <$> randomUser brig + let remoteDomain1 = Domain "remote1.example.com" + remoteDomain1Users@(remoteDomain1User1 : _) <- replicateM 5 $ (`Qualified` remoteDomain1) <$> randomId + let remoteDomain2 = Domain "remote2.example.com" + remoteDomain2Users@(remoteDomain2User1 : _) <- replicateM 5 $ (`Qualified` remoteDomain2) <$> randomId + + for_ uids $ \uid -> do + -- Create 5 local connections, accept 1 + for_ localUsers $ \qOther -> do + postConnectionQualified brig uid qOther sendConnectionAction brig opts uid qOther Nothing Sent + receiveConnectionAction brig fedBrigClient uid remoteDomain1User1 F.RemoteConnect (Just F.RemoteConnect) Accepted + + -- Create 5 remote connections with remote2, accept 1 + for_ remoteDomain2Users $ \qOther -> sendConnectionAction brig opts uid qOther Nothing Sent + receiveConnectionAction brig fedBrigClient uid remoteDomain2User1 F.RemoteConnect (Just F.RemoteConnect) Accepted + + allStatuses :: [ConnectionStatusV2] <- + responseJsonError =<< getConnStatusInternal brig (ConnectionsStatusRequestV2 uids Nothing Nothing) + remoteDomain1Users <> remoteDomain2Users + sort (map csv2To allStatuses) @?= sort (allUsers <> allUsers) + length (filter ((== Sent) . csv2Status) allStatuses) @?= 24 + length (filter ((== Accepted) . csv2Status) allStatuses) @?= 6 + + acceptedRemoteDomain1Only :: [ConnectionStatusV2] <- + responseJsonError =<< getConnStatusInternal brig (ConnectionsStatusRequestV2 uids (Just remoteDomain1Users) (Just Accepted)) + (csv2From x, csv2To x)) + sortOn ordFn acceptedRemoteDomain1Only @?= sortOn ordFn (map (\u -> ConnectionStatusV2 u remoteDomain1User1 Accepted) uids) + +getConnStatusInternal :: (MonadIO m, MonadHttp m) => (Request -> Request) -> ConnectionsStatusRequestV2 -> m (Response (Maybe LByteString)) +getConnStatusInternal brig req = + post $ + brig + . path "/i/users/connections-status/v2" + . json req diff --git a/services/brig/test/integration/API/User/Util.hs b/services/brig/test/integration/API/User/Util.hs index 155a5c7e83..6ee884a3dc 100644 --- a/services/brig/test/integration/API/User/Util.hs +++ b/services/brig/test/integration/API/User/Util.hs @@ -22,8 +22,8 @@ module API.User.Util where import Bilge hiding (accept, timeout) import Bilge.Assert import Brig.Data.PasswordReset +import Brig.Options (Opts) import Brig.Types -import Brig.Types.Intra import Brig.Types.Team.LegalHold (LegalHoldClientRequest (..)) import Brig.Types.User.Auth hiding (user) import qualified Brig.ZAuth @@ -37,17 +37,25 @@ import Data.ByteString.Builder (toLazyByteString) import Data.ByteString.Char8 (pack) import Data.ByteString.Conversion import qualified Data.ByteString.Lazy as LB -import Data.Domain (Domain) +import Data.Domain (Domain, domainText) import Data.Handle (Handle (Handle)) import Data.Id hiding (client) +import qualified Data.List1 as List1 import Data.Misc (PlainTextPassword (..)) import Data.Qualified import Data.Range (unsafeRange) +import Data.String.Conversions (cs) import qualified Data.Text.Ascii as Ascii import qualified Data.Vector as Vec +import Federation.Util (withTempMockFederator) +import Gundeck.Types (Notification (..)) import Imports import Test.Tasty.HUnit import Util +import qualified Wire.API.Federation.API.Brig as F +import Wire.API.Federation.GRPC.Types hiding (body, path) +import qualified Wire.API.Federation.GRPC.Types as F +import Wire.API.Routes.Internal.Brig.Connection import Wire.API.Routes.MultiTablePaging (LocalOrRemoteTable, MultiTablePagingState) newtype ConnectionLimit = ConnectionLimit Int64 @@ -310,12 +318,12 @@ countCookies brig u label = do return $ Vec.length <$> (preview (key "cookies" . _Array) =<< responseJsonMaybe @Value r) assertConnections :: (MonadCatch m, MonadIO m, MonadHttp m, HasCallStack) => Brig -> UserId -> [ConnectionStatus] -> m () -assertConnections brig u cs = +assertConnections brig u connections = listConnections brig u !!! do const 200 === statusCode const (Just True) === fmap (check . map status . clConnections) . responseJsonMaybe where - check xs = all (`elem` xs) cs + check xs = all (`elem` xs) connections status c = ConnectionStatus (ucFrom c) (qUnqualified $ ucTo c) (ucStatus c) assertConnectionQualified :: (MonadCatch m, MonadIO m, MonadHttp m, HasCallStack) => Brig -> UserId -> Qualified UserId -> Relation -> m () @@ -324,6 +332,68 @@ assertConnectionQualified brig u1 qu2 rel = const 200 === statusCode const (Right rel) === fmap ucStatus . responseJsonEither +receiveConnectionAction :: + HasCallStack => + Brig -> + FedBrigClient -> + UserId -> + Qualified UserId -> + F.RemoteConnectionAction -> + Maybe F.RemoteConnectionAction -> + Relation -> + Http () +receiveConnectionAction brig fedBrigClient uid1 quid2 action expectedReaction expectedRel = do + res <- + F.sendConnectionAction fedBrigClient (qDomain quid2) $ + F.NewConnectionRequest (qUnqualified quid2) uid1 action + liftIO $ do + res @?= F.NewConnectionResponseOk expectedReaction + assertConnectionQualified brig uid1 quid2 expectedRel + +sendConnectionAction :: + HasCallStack => + Brig -> + Opts -> + UserId -> + Qualified UserId -> + Maybe F.RemoteConnectionAction -> + Relation -> + Http () +sendConnectionAction brig opts uid1 quid2 reaction expectedRel = do + let mockConnectionResponse = F.NewConnectionResponseOk reaction + mockResponse = OutwardResponseBody (cs $ encode mockConnectionResponse) + (res, reqs) <- + liftIO . withTempMockFederator opts mockResponse $ + postConnectionQualified brig uid1 quid2 + + liftIO $ do + req <- assertOne reqs + F.domain req @?= domainText (qDomain quid2) + fmap F.component (F.request req) @?= Just F.Brig + fmap F.path (F.request req) @?= Just "/federation/send-connection-action" + eitherDecode . cs . F.body <$> F.request req + @?= Just (Right (F.NewConnectionRequest uid1 (qUnqualified quid2) F.RemoteConnect)) + + liftIO $ assertBool "postConnectionQualified failed" $ statusCode res `elem` [200, 201] + assertConnectionQualified brig uid1 quid2 expectedRel + +sendConnectionUpdateAction :: + HasCallStack => + Brig -> + Opts -> + UserId -> + Qualified UserId -> + Maybe F.RemoteConnectionAction -> + Relation -> + Http () +sendConnectionUpdateAction brig opts uid1 quid2 reaction expectedRel = do + let mockConnectionResponse = F.NewConnectionResponseOk reaction + mockResponse = OutwardResponseBody (cs $ encode mockConnectionResponse) + void $ + liftIO . withTempMockFederator opts mockResponse $ + putConnectionQualified brig uid1 quid2 expectedRel !!! const 200 === statusCode + assertConnectionQualified brig uid1 quid2 expectedRel + assertEmailVisibility :: (MonadCatch m, MonadIO m, MonadHttp m, HasCallStack) => Brig -> User -> User -> Bool -> m () assertEmailVisibility brig a b visible = get (brig . paths ["users", pack . show $ userId b] . zUser (userId a)) !!! do @@ -382,3 +452,13 @@ deleteLegalHoldDevice brig uid = brig . paths ["i", "clients", "legalhold", toByteString' uid] . contentJson + +matchDeleteUserNotification :: Qualified UserId -> Notification -> Assertion +matchDeleteUserNotification quid n = do + let j = Object $ List1.head (ntfPayload n) + let etype = j ^? key "type" . _String + let eUnqualifiedId = maybeFromJSON =<< j ^? key "id" + let eQualifiedId = maybeFromJSON =<< j ^? key "qualified_id" + etype @?= Just "user.delete" + eUnqualifiedId @?= Just (qUnqualified quid) + eQualifiedId @?= Just quid diff --git a/services/brig/test/integration/Federation/End2end.hs b/services/brig/test/integration/Federation/End2end.hs index 39961ea247..d197a6b3c8 100644 --- a/services/brig/test/integration/Federation/End2end.hs +++ b/services/brig/test/integration/Federation/End2end.hs @@ -37,8 +37,9 @@ import Data.List1 as List1 import qualified Data.Map as Map import qualified Data.ProtoLens as Protolens import Data.Qualified +import Data.Range (checked) import qualified Data.Set as Set -import Federation.Util (generateClientPrekeys, getConvQualified) +import Federation.Util (connectUsersEnd2End, generateClientPrekeys, getConvQualified) import Gundeck.Types.Notification (ntfTransient) import Imports import qualified System.Logger as Log @@ -52,6 +53,7 @@ import Wire.API.Conversation import Wire.API.Conversation.Role (roleNameWireAdmin) import Wire.API.Event.Conversation import Wire.API.Message +import Wire.API.Routes.MultiTablePaging import Wire.API.User (ListUsersQuery (ListUsersByIds)) import Wire.API.User.Client @@ -213,7 +215,7 @@ testClaimMultiPrekeyBundleSuccess brig1 brig2 = do mkClientMap :: [ClientPrekey] -> Map ClientId (Maybe Prekey) mkClientMap = Map.fromList . map (prekeyClient &&& Just . prekeyData) qmap :: Ord a => [(Qualified a, b)] -> Map Domain (Map a b) - qmap = fmap Map.fromList . partitionQualified . map (sequenceAOf _1) + qmap = fmap Map.fromList . indexQualified . map (sequenceAOf _1) c1 <- generateClientPrekeys brig1 prekeys1 c2 <- generateClientPrekeys brig2 prekeys2 let uc = @@ -242,8 +244,8 @@ testAddRemoteUsersToLocalConv brig1 galley1 brig2 galley2 = do let newConv = NewConvUnmanaged $ NewConv [] [] (Just "gossip") mempty Nothing Nothing Nothing Nothing roleNameWireAdmin convId <- - cnvQualifiedId . responseJsonUnsafe - <$> post + fmap cnvQualifiedId . responseJsonError + =<< post ( galley1 . path "/conversations" . zUser (userId alice) @@ -252,6 +254,8 @@ testAddRemoteUsersToLocalConv brig1 galley1 brig2 galley2 = do . json newConv ) + connectUsersEnd2End brig1 brig2 (userQualifiedId alice) (userQualifiedId bob) + let invite = InviteQualified (userQualifiedId bob :| []) roleNameWireAdmin post ( galley1 @@ -285,7 +289,12 @@ testRemoveRemoteUserFromLocalConv brig1 galley1 brig2 galley2 = do let aliceId = userQualifiedId alice let bobId = userQualifiedId bob - convId <- cnvQualifiedId . responseJsonUnsafe <$> createConversation galley1 (userId alice) [bobId] + connectUsersEnd2End brig1 brig2 aliceId bobId + + convId <- + fmap cnvQualifiedId . responseJsonError + =<< createConversation galley1 (userId alice) [bobId] + getConversationQualified galley1 (userId alice) convId liftIO $ map omQualifiedId (cmOthers (cnvMembers aliceConvBeforeDelete)) @?= [bobId] @@ -322,7 +331,12 @@ leaveRemoteConversation brig1 galley1 brig2 galley2 = do let aliceId = userQualifiedId alice let bobId = userQualifiedId bob - convId <- cnvQualifiedId . responseJsonUnsafe <$> createConversation galley1 (userId alice) [bobId] + connectUsersEnd2End brig1 brig2 aliceId bobId + + convId <- + fmap cnvQualifiedId . responseJsonError + =<< createConversation galley1 (userId alice) [bobId] + getConversationQualified galley1 (userId alice) convId liftIO $ map omQualifiedId (cmOthers (cnvMembers aliceConvBeforeDelete)) @?= [bobId] @@ -358,9 +372,13 @@ testRemoteUsersInNewConv :: Brig -> Galley -> Brig -> Galley -> Http () testRemoteUsersInNewConv brig1 galley1 brig2 galley2 = do alice <- randomUser brig1 bob <- randomUser brig2 + + connectUsersEnd2End brig1 brig2 (userQualifiedId alice) (userQualifiedId bob) convId <- - cnvQualifiedId . responseJsonUnsafe - <$> createConversation galley1 (userId alice) [userQualifiedId bob] + fmap cnvQualifiedId . responseJsonError + =<< createConversation galley1 (userId alice) [userQualifiedId bob] + createConversation galley1 (userId alice) [userQualifiedId bob] - cnv2 <- responseJsonUnsafe <$> createConversation galley2 (userId bob) [userQualifiedId alice] + cnv1 <- + responseJsonError + =<< createConversation galley1 (userId alice) [userQualifiedId bob] + responseJsonUnsafe rs - let c1 = cs >>= find ((== cnvQualifiedId cnv1) . cnvQualifiedId) - let c2 = cs >>= find ((== cnvQualifiedId cnv2) . cnvQualifiedId) + rs <- listConvIdsFirstPage galley1 (userId alice) assertFailure "too many conversations" + Just r -> pure r + (cs :: [Conversation]) <- + (fmap crFound . responseJsonError) + =<< listConvs galley1 (userId alice) cids do assertEqual "self member mismatch" @@ -455,10 +488,13 @@ testSendMessage brig1 brig2 galley2 cannon1 = do (userId bob) (defNewClient PermanentClientType [] (someLastPrekeys !! 1)) + connectUsersEnd2End brig1 brig2 (userQualifiedId alice) (userQualifiedId bob) + -- create conversation on domain 2 convId <- - qUnqualified . cnvQualifiedId . responseJsonUnsafe - <$> createConversation galley2 (userId bob) [userQualifiedId alice] + fmap (qUnqualified . cnvQualifiedId) . responseJsonError + =<< createConversation galley2 (userId bob) [userQualifiedId alice] + addClient - brig1 - (userId alice) - (defNewClient PermanentClientType [] (someLastPrekeys !! 0)) + fmap clientId . responseJsonError + =<< addClient brig1 (userId alice) (defNewClient PermanentClientType [] (someLastPrekeys !! 0)) + addClient - brig2 - (userId bob) - (defNewClient PermanentClientType [] (someLastPrekeys !! 1)) + fmap clientId . responseJsonError + =<< addClient brig2 (userId bob) (defNewClient PermanentClientType [] (someLastPrekeys !! 1)) + createConversation galley1 (userId alice) [userQualifiedId bob] + fmap (qUnqualified . cnvQualifiedId) . responseJsonError + =<< createConversation galley1 (userId alice) [userQualifiedId bob] + Domain -> OutwardResponse -> Session a -> IO (a, Mock.ReceivedRequests) -withTempMockFederator opts targetDomain resp action = assertRightT +withTempMockFederator :: Opt.Opts -> OutwardResponse -> Session a -> IO (a, Mock.ReceivedRequests) +withTempMockFederator opts resp action = assertRightT . Mock.withTempMockFederator st0 (const (pure resp)) $ \st -> lift $ do let opts' = @@ -95,7 +95,7 @@ withTempMockFederator opts targetDomain resp action = assertRightT } withSettingsOverrides opts' action where - st0 = Mock.initState targetDomain (Domain "example.com") + st0 = Mock.initState (Domain "example.com") generateClientPrekeys :: Brig -> [(Prekey, LastPrekey)] -> Http (Qualified UserId, [ClientPrekey]) generateClientPrekeys brig prekeys = do @@ -106,11 +106,6 @@ generateClientPrekeys brig prekeys = do clients <- traverse (responseJsonError <=< addClient brig (qUnqualified quser)) nclients pure (quser, zipWith mkClientPrekey prekeys clients) -assertRight :: (MonadIO m, Show a, HasCallStack) => Either a b -> m b -assertRight = \case - Left e -> liftIO $ assertFailure $ "Expected Right, got Left: " <> show e - Right x -> pure x - assertRightT :: (MonadIO m, Show a, HasCallStack) => ExceptT a m b -> m b assertRightT = assertRight <=< runExceptT @@ -122,3 +117,10 @@ getConvQualified g u (Qualified cnvId domain) = . zUser u . zConn "conn" . header "Z-Type" "access" + +connectUsersEnd2End :: Brig -> Brig -> Qualified UserId -> Qualified UserId -> Http () +connectUsersEnd2End brig1 brig2 quid1 quid2 = do + postConnectionQualified brig1 (qUnqualified quid1) quid2 + !!! const 201 === statusCode + putConnectionQualified brig2 (qUnqualified quid2) quid1 Accepted + !!! const 200 === statusCode diff --git a/services/brig/test/integration/Main.hs b/services/brig/test/integration/Main.hs index ab31aa1d33..9380b84a4f 100644 --- a/services/brig/test/integration/Main.hs +++ b/services/brig/test/integration/Main.hs @@ -50,16 +50,21 @@ import Network.HTTP.Client.TLS (tlsManagerSettings) import Network.Wai.Utilities.Server (compile) import OpenSSL (withOpenSSL) import Options.Applicative hiding (action) +import Servant.API.Generic (GenericServant, ToServant, ToServantApi) +import Servant.Client (HasClient) import qualified Servant.Client as Servant +import Servant.Client.Generic (AsClientT) import qualified Servant.Client.Generic as Servant import System.Environment (withArgs) import qualified System.Environment.Blank as Blank import qualified System.Logger as Logger import Test.Tasty import Test.Tasty.HUnit -import Util (FedBrigClient) +import Util (FedBrigClient, FedGalleyClient) import Util.Options import Util.Test +import qualified Wire.API.Federation.API.Brig as FedBrig +import qualified Wire.API.Federation.API.Galley as FedGalley data BackendConf = BackendConf { remoteBrig :: Endpoint, @@ -120,9 +125,10 @@ runTests iConf brigOpts otherArgs = do db <- defInitCassandra casKey casHost casPort lg mg <- newManager tlsManagerSettings let fedBrigClient = mkFedBrigClient mg (brig iConf) + let fedGalleyClient = mkFedGalleyClient mg (galley iConf) emailAWSOpts <- parseEmailAWSOpts awsEnv <- AWS.mkEnv lg awsOpts emailAWSOpts mg - userApi <- User.tests brigOpts mg b c ch g n awsEnv + userApi <- User.tests brigOpts fedBrigClient fedGalleyClient mg b c ch g n awsEnv db providerApi <- Provider.tests localDomain (provider iConf) mg db b c g searchApis <- Search.tests brigOpts mg g b teamApis <- Team.tests brigOpts mg n b c g awsEnv @@ -133,7 +139,7 @@ runTests iConf brigOpts otherArgs = do browseTeam <- TeamUserSearch.tests brigOpts mg g b userPendingActivation <- UserPendingActivation.tests brigOpts mg db b g s federationEnd2End <- Federation.End2end.spec brigOpts mg b g c f brigTwo galleyTwo - federationEndpoints <- API.Federation.tests mg b fedBrigClient + federationEndpoints <- API.Federation.tests mg brigOpts b c fedBrigClient includeFederationTests <- (== Just "1") <$> Blank.getEnv "INTEGRATION_FEDERATION_TESTS" internalApi <- API.Internal.tests brigOpts mg db b (brig iConf) gd g withArgs otherArgs . defaultMain $ @@ -214,12 +220,26 @@ parseConfigPaths = do ) mkFedBrigClient :: Manager -> Endpoint -> FedBrigClient -mkFedBrigClient mgr brigEndpoint = Servant.genericClientHoist servantClienMToHttp +mkFedBrigClient = mkFedBrigClientGen @FedBrig.Api + +mkFedGalleyClient :: Manager -> Endpoint -> FedGalleyClient +mkFedGalleyClient = mkFedBrigClientGen @FedGalley.Api + +mkFedBrigClientGen :: + forall routes. + ( HasClient Servant.ClientM (ToServantApi routes), + GenericServant routes (AsClientT (HttpT IO)), + Servant.Client (HttpT IO) (ToServantApi routes) ~ ToServant routes (AsClientT (HttpT IO)) + ) => + Manager -> + Endpoint -> + routes (AsClientT (HttpT IO)) +mkFedBrigClientGen mgr endpoint = Servant.genericClientHoist servantClienMToHttp where servantClienMToHttp :: Servant.ClientM a -> Http a servantClienMToHttp action = liftIO $ do - let brigHost = Text.unpack $ brigEndpoint ^. epHost - brigPort = fromInteger . toInteger $ brigEndpoint ^. epPort + let brigHost = Text.unpack $ endpoint ^. epHost + brigPort = fromInteger . toInteger $ endpoint ^. epPort baseUrl = Servant.BaseUrl Servant.Http brigHost brigPort "" clientEnv = Servant.ClientEnv mgr baseUrl Nothing Servant.defaultMakeClientRequest eitherRes <- Servant.runClientM action clientEnv diff --git a/services/brig/test/integration/Util.hs b/services/brig/test/integration/Util.hs index e584032156..b6ad08f42d 100644 --- a/services/brig/test/integration/Util.hs +++ b/services/brig/test/integration/Util.hs @@ -1,5 +1,3 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2020 Wire Swiss GmbH @@ -16,8 +14,10 @@ -- -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . - -- for SES notifications +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NumericUnderscores #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Util where @@ -27,6 +27,7 @@ import qualified Brig.AWS as AWS import Brig.AWS.Types import Brig.App (applog, sftEnv) import Brig.Calling as Calling +import qualified Brig.Options as Opt import qualified Brig.Options as Opts import qualified Brig.Run as Run import Brig.Types.Activation @@ -38,21 +39,25 @@ import Brig.Types.User.Auth import qualified Brig.ZAuth as ZAuth import Control.Lens ((^.), (^?), (^?!)) import Control.Monad.Catch (MonadCatch, MonadMask) +import qualified Control.Monad.Catch as Catch +import Control.Monad.State.Class (MonadState) +import qualified Control.Monad.State.Class as MonadState +import Control.Monad.Trans.Except (ExceptT (ExceptT), runExceptT) import Control.Retry import Data.Aeson hiding (json) import Data.Aeson.Lens (key, _Integral, _JSON, _String) -import Data.Aeson.Types (emptyObject) import qualified Data.Aeson.Types as Aeson import qualified Data.ByteString as BS import Data.ByteString.Char8 (pack) import qualified Data.ByteString.Char8 as C8 import Data.ByteString.Conversion -import Data.Domain (Domain, domainText, mkDomain) +import Data.Domain (Domain (..), domainText, mkDomain) import Data.Handle (Handle (..)) import Data.Id import Data.List1 (List1) import qualified Data.List1 as List1 import Data.Misc (PlainTextPassword (..)) +import Data.Proxy import Data.Qualified import Data.Range import qualified Data.Text as Text @@ -60,22 +65,33 @@ import qualified Data.Text.Ascii as Ascii import Data.Text.Encoding (encodeUtf8) import qualified Data.UUID as UUID import qualified Data.UUID.V4 as UUID +import Galley.Types.Conversations.One2One (one2OneConvId) import qualified Galley.Types.Teams as Team import Gundeck.Types.Notification import Imports +import Network.HTTP.Types (Method) +import Network.Wai (Application) +import qualified Network.Wai as Wai +import qualified Network.Wai.Handler.Warp as Warp +import Network.Wai.Test (Session) import qualified Network.Wai.Test as WaiTest import Servant.Client.Generic (AsClientT) import System.Random (randomIO, randomRIO) +import qualified System.Timeout as System import Test.Tasty (TestName, TestTree) import Test.Tasty.Cannon import qualified Test.Tasty.Cannon as WS import Test.Tasty.HUnit import qualified UnliftIO.Async as Async import Util.AWS -import Wire.API.Conversation (ListConversations, NewConv (..), NewConvUnmanaged (..)) -import Wire.API.Conversation.Member (Member (..)) +import Util.Options (Endpoint (Endpoint)) +import Wire.API.Conversation import Wire.API.Conversation.Role (roleNameWireAdmin) import qualified Wire.API.Federation.API.Brig as FedBrig +import qualified Wire.API.Federation.API.Galley as FedGalley +import Wire.API.Federation.GRPC.Types (OutwardResponse) +import qualified Wire.API.Federation.Mock as Mock +import Wire.API.Routes.MultiTablePaging type Brig = Request -> Request @@ -93,6 +109,8 @@ type Spar = Request -> Request type FedBrigClient = FedBrig.Api (AsClientT (HttpT IO)) +type FedGalleyClient = FedGalley.Api (AsClientT (HttpT IO)) + instance ToJSON SESBounceType where toJSON BounceUndetermined = String "Undetermined" toJSON BouncePermanent = String "Permanent" @@ -131,6 +149,34 @@ twoRandomUsers brig = do uid2 = qUnqualified quid2 pure (quid1, uid1, quid2, uid2) +localAndRemoteUser :: + (MonadCatch m, MonadIO m, MonadHttp m, HasCallStack) => + Brig -> + m (UserId, Qualified UserId) +localAndRemoteUser brig = do + uid1 <- userId <$> randomUser brig + quid2 <- fakeRemoteUser + pure (uid1, quid2) + +localAndRemoteUserWithConvId :: + (MonadCatch m, MonadIO m, MonadHttp m, HasCallStack) => + Brig -> + Bool -> + m (UserId, Qualified UserId, Qualified ConvId) +localAndRemoteUserWithConvId brig shouldBeLocal = do + quid <- userQualifiedId <$> randomUser brig + let go = do + other <- Qualified <$> randomId <*> pure (Domain "far-away.example.com") + let convId = one2OneConvId quid other + isLocal = qDomain quid == qDomain convId + if shouldBeLocal == isLocal + then pure (qUnqualified quid, other, convId) + else go + go + +fakeRemoteUser :: (HasCallStack, MonadIO m) => m (Qualified UserId) +fakeRemoteUser = Qualified <$> randomId <*> pure (Domain "far-away.example.com") + randomUser :: (MonadCatch m, MonadIO m, MonadHttp m, HasCallStack) => Brig -> @@ -305,7 +351,7 @@ postUserRegister' :: (MonadIO m, MonadCatch m, MonadHttp m) => Object -> Brig -> postUserRegister' payload brig = do post (brig . path "/register" . contentJson . body (RequestBodyLBS $ encode payload)) -deleteUser :: UserId -> Maybe PlainTextPassword -> Brig -> Http ResponseLBS +deleteUser :: (Functor m, MonadIO m, MonadCatch m, MonadHttp m, HasCallStack) => UserId -> Maybe PlainTextPassword -> Brig -> m ResponseLBS deleteUser u p brig = delete $ brig @@ -584,39 +630,40 @@ createConversation galley zusr usersToAdd = do . zConn "conn" . json conv --- (should be) equivalent to --- listConvs u (ListConversations [] Nothing Nothing) -listAllConvs :: (MonadIO m, MonadHttp m) => Galley -> UserId -> m ResponseLBS -listAllConvs g u = do +listConvIdsFirstPage :: (MonadIO m, MonadHttp m) => Galley -> UserId -> m ResponseLBS +listConvIdsFirstPage galley zusr = do + let req = GetMultiTablePageRequest (toRange (Proxy @1000)) Nothing :: GetPaginatedConversationIds post $ - g - . path "/list-conversations" - . zUser u + galley + . path "/conversations/list-ids" + . zUser zusr . zConn "conn" - . json emptyObject + . json req -listConvs :: (MonadIO m, MonadHttp m) => Galley -> UserId -> ListConversations -> m ResponseLBS -listConvs g u req = do - -- when using servant-client (pending #1605), this would become: - -- galleyClient <- view tsGalleyClient - -- res :: Public.ConversationList Public.Conversation <- listConversations galleyClient req +listConvs :: + (MonadIO m, MonadHttp m) => + Galley -> + UserId -> + Range 1 1000 [Qualified ConvId] -> + m ResponseLBS +listConvs galley zusr convs = do post $ - g - . path "/list-conversations" - . zUser u + galley + . path "/conversations/list/v2" + . zUser zusr . zConn "conn" - . json req + . json (ListConversations convs) -isMember :: Galley -> UserId -> ConvId -> (MonadIO m, MonadHttp m) => m Bool +isMember :: Galley -> Local UserId -> ConvId -> (MonadIO m, MonadHttp m) => m Bool isMember g usr cnv = do res <- get $ g - . paths ["i", "conversations", toByteString' cnv, "members", toByteString' usr] + . paths ["i", "conversations", toByteString' cnv, "members", toByteString' (tUnqualified usr)] . expect2xx case responseJsonMaybe res of Nothing -> return False - Just m -> return (usr == memId m) + Just m -> return (qUntagged usr == memId m) getStatus :: HasCallStack => Brig -> UserId -> (MonadIO m, MonadHttp m) => m AccountStatus getStatus brig u = @@ -694,12 +741,14 @@ randomPhone = liftIO $ do let phone = parsePhone . Text.pack $ "+0" ++ concat nrs return $ fromMaybe (error "Invalid random phone#") phone -updatePhone :: Brig -> UserId -> Phone -> Http () +updatePhone :: HasCallStack => Brig -> UserId -> Phone -> Http () updatePhone brig uid phn = do -- update phone let phoneUpdate = RequestBodyLBS . encode $ PhoneUpdate phn - put (brig . path "/self/phone" . contentJson . zUser uid . zConn "c" . body phoneUpdate) - !!! (const 202 === statusCode) + failMsg = "updatePhone (PUT /self/phone): failed to update to " <> show phn <> " - might be a flaky test tracked in https://wearezeta.atlassian.net/browse/BE-526" + put (brig . path "/self/phone" . contentJson . zUser uid . zConn "c" . body phoneUpdate) !!! do + const 202 === statusCode + assertTrue failMsg ((== 202) . statusCode) -- activate act <- getActivationCode brig (Right phn) case act of @@ -885,3 +934,126 @@ aFewTimes (exponentialBackoff 1000 <> limitRetries retries) (\_ -> pure . not . good) (\_ -> action) + +assertOne :: (HasCallStack, MonadIO m, Show a) => [a] -> m a +assertOne [a] = pure a +assertOne xs = liftIO . assertFailure $ "Expected exactly one element, found " <> show xs + +-------------------------------------------------------------------------------- + +newtype MockT m a = MockT {unMock :: ReaderT (IORef MockState) m a} + deriving newtype (Functor, Applicative, Monad, MonadReader (IORef MockState), MonadIO) + +instance MonadIO m => MonadState MockState (MockT m) where + get = readIORef =<< ask + put x = do + ref <- ask + writeIORef ref x + +data ReceivedRequest = ReceivedRequest Method [Text] LByteString + +data MockState = MockState + { receivedRequests :: [ReceivedRequest], + serverThread :: Async.Async (), + serverPort :: Integer, + mockHandler :: ReceivedRequest -> MockT IO Wai.Response + } + +mkMockApp :: IORef MockState -> Application +mkMockApp ref request mkResponse = do + let action = do + req <- liftIO $ getReceivedRequest request + handler <- mockHandler <$> liftIO (readIORef ref) + response <- handler req + MonadState.modify (\ms -> ms {receivedRequests = receivedRequests ms <> [req]}) + pure response + runMockT ref action >>= mkResponse + +getReceivedRequest :: Wai.Request -> IO ReceivedRequest +getReceivedRequest r = + ReceivedRequest (Wai.requestMethod r) (Wai.pathInfo r) <$> Wai.strictRequestBody r + +runMockT :: IORef MockState -> MockT m a -> m a +runMockT ref mock = runReaderT (unMock mock) ref + +startMockService :: MonadIO m => IORef MockState -> ExceptT String m () +startMockService ref = ExceptT . liftIO $ do + (sPort, sock) <- Warp.openFreePort + serverStarted <- newEmptyMVar + let settings = + Warp.defaultSettings + & Warp.setPort sPort + & Warp.setGracefulCloseTimeout2 0 -- Defaults to 2 seconds, causes server stop to take very long + & Warp.setBeforeMainLoop (putMVar serverStarted ()) + let app = mkMockApp ref + serviceThread <- Async.async $ Warp.runSettingsSocket settings sock app + serverStartedSignal <- System.timeout 10_000_000 (takeMVar serverStarted) + case serverStartedSignal of + Nothing -> do + liftIO $ Async.cancel serviceThread + pure . Left $ "Failed to start the mock server within 10 seconds on port: " <> show sPort + _ -> do + liftIO . modifyIORef ref $ \s -> s {serverThread = serviceThread, serverPort = toInteger sPort} + pure (Right ()) + +initState :: MockState +initState = MockState [] (error "server not started") (error "server not started") (error "No mock response provided") + +stopMockedService :: MonadIO m => IORef MockState -> m () +stopMockedService ref = + liftIO $ Async.cancel . serverThread <=< readIORef $ ref + +withTempMockedService :: + (MonadIO m, MonadMask m) => + MockState -> + (ReceivedRequest -> MockT IO Wai.Response) -> + (MockState -> ExceptT String m a) -> + ExceptT String m (a, [ReceivedRequest]) +withTempMockedService state handler action = do + ref <- newIORef state + startMockService ref + ( do + liftIO . modifyIORef ref $ \s -> s {mockHandler = handler} + st <- liftIO $ readIORef ref + actualResponse <- action st + st' <- liftIO $ readIORef ref + pure (actualResponse, receivedRequests st') + ) + `Catch.finally` stopMockedService ref + +assertRight :: (MonadIO m, Show a, HasCallStack) => Either a b -> m b +assertRight = \case + Left e -> liftIO $ assertFailure $ "Expected Right, got Left: " <> show e + Right x -> pure x + +withMockedGalley :: (MonadIO m, MonadMask m) => Opt.Opts -> (ReceivedRequest -> MockT IO Wai.Response) -> Session a -> m (a, [ReceivedRequest]) +withMockedGalley opts handler action = + assertRight <=< runExceptT $ + withTempMockedService initState handler $ \st -> lift $ do + let opts' = + opts + { Opt.galley = Endpoint "127.0.0.1" (fromIntegral (serverPort st)) + } + withSettingsOverrides opts' action + +withMockedFederatorAndGalley :: + Opt.Opts -> + Domain -> + OutwardResponse -> + (ReceivedRequest -> MockT IO Wai.Response) -> + Session a -> + IO (a, Mock.ReceivedRequests, [ReceivedRequest]) +withMockedFederatorAndGalley opts domain fedResp galleyHandler action = do + result <- assertRight <=< runExceptT $ + withTempMockedService initState galleyHandler $ \galleyMockState -> + Mock.withTempMockFederator (Mock.initState domain) (const (pure fedResp)) $ \fedMockState -> do + let opts' = + opts + { Opt.galley = Endpoint "127.0.0.1" (fromIntegral (serverPort galleyMockState)), + Opt.federatorInternal = Just (Endpoint "127.0.0.1" (fromIntegral (Mock.serverPort fedMockState))) + } + withSettingsOverrides opts' action + pure (combineResults result) + where + combineResults :: ((a, Mock.ReceivedRequests), [ReceivedRequest]) -> (a, Mock.ReceivedRequests, [ReceivedRequest]) + combineResults ((a, mrr), rr) = (a, mrr, rr) diff --git a/services/federator/federator.cabal b/services/federator/federator.cabal index ade0ac7332..7bd2efef16 100644 --- a/services/federator/federator.cabal +++ b/services/federator/federator.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 9a181e3a92130220d845ad959ca6e02a217b07a38602513bff4c9376a4ffe145 +-- hash: 9cb4007a4aa28024c1ac5077eb0840c877b7fd3a7afee0b48a9c218a54afc40a name: federator version: 1.0.0 @@ -25,9 +25,12 @@ extra-source-files: test/resources/unit/localhost-dot-key.pem test/resources/unit/localhost-dot.pem test/resources/unit/localhost-key.pem + test/resources/unit/localhost.client-only-key.pem + test/resources/unit/localhost.client-only.pem test/resources/unit/localhost.example.com-key.pem test/resources/unit/localhost.example.com.pem test/resources/unit/localhost.pem + test/resources/unit/README.md test/resources/unit/second-federator.example.com-key.pem test/resources/unit/second-federator.example.com.pem test/resources/unit/unit-ca-key.pem diff --git a/services/federator/src/Federator/InternalServer.hs b/services/federator/src/Federator/InternalServer.hs index 936464fc30..ab1404bbc3 100644 --- a/services/federator/src/Federator/InternalServer.hs +++ b/services/federator/src/Federator/InternalServer.hs @@ -45,6 +45,7 @@ import qualified Polysemy.Error as Polysemy import Polysemy.IO (embedToMonadIO) import qualified Polysemy.Input as Polysemy import qualified Polysemy.Reader as Polysemy +import qualified Polysemy.Resource as Polysemy import Polysemy.TinyLog (TinyLog) import qualified Polysemy.TinyLog as Log import Wire.API.Federation.GRPC.Client (GrpcClientErr (..)) @@ -134,6 +135,7 @@ serveOutward env port = do Polysemy.Error ServerError, Polysemy.Reader RunSettings, Polysemy.Input TLSSettings, + Polysemy.Resource, Embed IO, Embed Federator ] @@ -143,6 +145,7 @@ serveOutward env port = do runAppT env . runM -- Embed Federator . embedToMonadIO @Federator -- Embed IO + . Polysemy.runResource -- Resource . Polysemy.runInputSem (embed @IO (readIORef (view tls env))) -- Input TLSSettings . Polysemy.runReader (view runSettings env) -- Reader RunSettings . absorbServerError diff --git a/services/federator/src/Federator/Remote.hs b/services/federator/src/Federator/Remote.hs index 38e6a143f9..1fe137d803 100644 --- a/services/federator/src/Federator/Remote.hs +++ b/services/federator/src/Federator/Remote.hs @@ -28,6 +28,7 @@ module Federator.Remote where import Control.Lens ((^.)) +import Control.Monad.Except import Data.Default (def) import Data.Domain (Domain, domainText) import Data.String.Conversions (cs) @@ -42,12 +43,14 @@ import Mu.GRpc.Client.Optics (GRpcReply) import Mu.GRpc.Client.Record (GRpcMessageProtocol (MsgProtoBuf)) import Mu.GRpc.Client.TyApps (gRpcCall) import Network.GRPC.Client.Helpers +import Network.HTTP2.Client.Exceptions import Network.TLS as TLS import qualified Network.TLS.Extra.Cipher as TLS import Polysemy import qualified Polysemy.Error as Polysemy import qualified Polysemy.Input as Polysemy import qualified Polysemy.Reader as Polysemy +import qualified Polysemy.Resource as Polysemy import Polysemy.TinyLog (TinyLog) import qualified Polysemy.TinyLog as Log import qualified System.Logger.Message as Log @@ -72,7 +75,8 @@ interpretRemote :: DiscoverFederator, TinyLog, Polysemy.Reader RunSettings, - Polysemy.Input TLSSettings + Polysemy.Input TLSSettings, + Polysemy.Resource ] r => Sem (Remote ': r) a -> @@ -82,8 +86,8 @@ interpretRemote = interpret $ \case target <- Polysemy.mapError (RemoteErrorDiscoveryFailure vDomain) $ discoverFederatorWithError vDomain - client <- mkGrpcClient target - callInward client vRequest + Polysemy.bracket (mkGrpcClient target) (closeGrpcClient target) $ \client -> + callInward client vRequest callInward :: MonadIO m => GrpcClient -> Request -> m (GRpcReply InwardResponse) callInward client request = @@ -143,8 +147,8 @@ mkGrpcClient target@(SrvTarget host port) = do { TLS.onServerCertificate = X509.validate X509.HashSHA256 - (X509.defaultHooks {X509.hookValidateName = validateDomainName}) - X509.defaultChecks, + X509.defaultHooks {X509.hookValidateName = validateDomainName} + X509.defaultChecks {X509.checkLeafKeyPurpose = [X509.KeyUsagePurpose_ServerAuth]}, TLS.onCertificateRequest = \_ -> pure (Just (settings ^. creds)) }, TLS.clientShared = def {TLS.sharedCAStore = settings ^. caStore} @@ -154,6 +158,20 @@ mkGrpcClient target@(SrvTarget host port) = do . Polysemy.fromEither =<< Polysemy.fromExceptionVia (RemoteErrorTLSException target) (createGrpcClient cfg') +closeGrpcClient :: + Members '[Embed IO, Polysemy.Error RemoteError] r => + SrvTarget -> + GrpcClient -> + Sem r () +closeGrpcClient target = + Polysemy.mapError handle + . Polysemy.fromEitherM + . runExceptT + . close + where + handle :: ClientError -> RemoteError + handle = RemoteErrorClientFailure target . grpcClientError Nothing + logRemoteErrors :: Members '[Polysemy.Error RemoteError, TinyLog] r => Sem r x -> diff --git a/services/federator/test/resources/unit/README.md b/services/federator/test/resources/unit/README.md new file mode 100644 index 0000000000..3ccc580109 --- /dev/null +++ b/services/federator/test/resources/unit/README.md @@ -0,0 +1,5 @@ +localhost.client-only.pem has been created with: + +``` +openssl x509 -req -in <(openssl req -nodes -newkey rsa:2048 -keyout localhost.client-only-key.pem -out /dev/stdout -subj "/") -CA unit-ca.pem -CAkey unit-ca-key.pem -out localhost.client-only.pem -set_serial 0 -extfile <(echo 'subjectAltName = DNS:*integration.example.com, DNS:localhost'; echo 'extendedKeyUsage = clientAuth') +``` diff --git a/services/federator/test/resources/unit/localhost.client-only-key.pem b/services/federator/test/resources/unit/localhost.client-only-key.pem new file mode 100644 index 0000000000..4a8fb59656 --- /dev/null +++ b/services/federator/test/resources/unit/localhost.client-only-key.pem @@ -0,0 +1,28 @@ +-----BEGIN PRIVATE KEY----- +MIIEvwIBADANBgkqhkiG9w0BAQEFAASCBKkwggSlAgEAAoIBAQC6Zp5uNWp581WJ +BwrneDnQRAuecmAHjnUwF1c/EAe/GJ3vO7erBU9//vDvGutNwZRXYrrGV1Jy2WY3 +dADk513M0vc2OcOBWxKo+8svsio2rCLhTwDpR91DIINP8SjPRYxX9qSY8C8hRdxI +cER1EcwIf20EM5qL/shYl2p0wIpXQuwV3FwQGMELmkSzrb5kyq8tCPa2vzPtT5Lq +G50PyhcvnmPj/D0IpxalfOjLDvkeAXyEb79yTyuY3zDOFY2QjqJcxQkWu9uQH94L +3aMKIX2D8VCiPGbZTAKcW6BQACHjd74Kq6eyHW66C6lXBr0P2BDVAn8/w/Nduw/h +lZuUvMTLAgMBAAECggEBAK6b2EcmtHI+Vl7BAR7pSUblpviq7XfGo9ID20+QpaEF +31Qt3ZRPqjQdTfa9gbRZ5KqjKpEHVY2ORqklenzymrR23uql25T+ChHPpHsua0rB +nv7t8c2U6xipiThGkNLwtFHmEjPNsmh5t6sHt6junfFL5IQuDtSbO3N5i1iI0E6C +IZPmnkCOqQI+FjesJXvRgEwqJPDFlHNWTRAV751K1dBQsvsYSEetrR/+JGV8fgF6 +vmFsaYmbLzeuGMg2I3tgiD0s5MdgWu6OvasZUS2OyGv2IPX9fWId5YoIcneVDE6X +q1Yw0nuF6Tf+jwVJEvk6telRhEJACx7p0Nkw65kC9SkCgYEA4O60hkRwzrwPhxXq +ZskZ3jjsAN+pL7PCWzPFJ4UxhJAlAdPpB48DM9D1u76sJkK5y5FhA7glFmNfH5eM +HX2LVB/oQNzjKzJp4o2e0WEb3Asvzo3koCTNEbMCPhOlmx8T5s/+HTndFPS34BYB +epa9TJTWz5CPz8uBIuaQfH0SMt8CgYEA1CV9r7GOcdVqPOO8+VdqXAuIvMyYpzFQ +ETNlU5A3G2kbmlViJTEGLHC1tiJe5cv6Kt74uFdR7pl+0Hba67Q8vZLWuj0aRwc7 +EzmpXYSkpSi2+q3ntuTjMGmWx9ZmOldNmBiarm850lAsGrx9TNahZfzk9fZVif6m +h6y6t5fw95UCgYAJsF6YVgRh81nb4MbLDKiPmPYZh4jbJCwgD5fTfvpGEot1i7JD +ABcMOVkMcEcsEr28FhQOu/TlBPzI+JcxggHpasJvYNRsPOywtJb9v+gaT2UMybHq +cAthUsuq7t+4Udtimt0AV0i9qVjuTyRbKnkW/mZOZJS9R6/VWAcrRZvuEwKBgQCb +HOZvBdXu6WoKJ0HO1dmQf2Z1FOswo9+1E+0sUi/YvNtP1soyA0xORgK2rx7PynqZ +yfn1XvMrD9QnPCAJYvleavTRq0eBU4ogHnL1S7zOfZx8YZcgpO5wQWPbramFUrwL +T0IZ9H1EhxYYXmUHP4828Ne/92LHyQed/+9tuYyYmQKBgQC2lzwQQAVRTM2sVHt2 +r/szB4/QXZpBcXUiUJoVdI2NETuSwxf6XhxiXtI6NPYIWjNiA+dZyWA/AY+EeMJL +9OPV/OtZArHILYHP1lyABs5ZwSC/qorkqct601T5+rjJyd8RVLJe+iWIrDEvU2V1 +inC3V5SG3R5wDEzBfQRuxnKfpA== +-----END PRIVATE KEY----- diff --git a/services/federator/test/resources/unit/localhost.client-only.pem b/services/federator/test/resources/unit/localhost.client-only.pem new file mode 100644 index 0000000000..57b05bbeb1 --- /dev/null +++ b/services/federator/test/resources/unit/localhost.client-only.pem @@ -0,0 +1,18 @@ +-----BEGIN CERTIFICATE----- +MIIC2zCCAcOgAwIBAgIBADANBgkqhkiG9w0BAQsFADAZMRcwFQYDVQQDEw5jYS5l +eGFtcGxlLmNvbTAeFw0yMTEwMTMwODAwMTRaFw0yMTExMTIwODAwMTRaMAAwggEi +MA0GCSqGSIb3DQEBAQUAA4IBDwAwggEKAoIBAQC6Zp5uNWp581WJBwrneDnQRAue +cmAHjnUwF1c/EAe/GJ3vO7erBU9//vDvGutNwZRXYrrGV1Jy2WY3dADk513M0vc2 +OcOBWxKo+8svsio2rCLhTwDpR91DIINP8SjPRYxX9qSY8C8hRdxIcER1EcwIf20E +M5qL/shYl2p0wIpXQuwV3FwQGMELmkSzrb5kyq8tCPa2vzPtT5LqG50PyhcvnmPj +/D0IpxalfOjLDvkeAXyEb79yTyuY3zDOFY2QjqJcxQkWu9uQH94L3aMKIX2D8VCi +PGbZTAKcW6BQACHjd74Kq6eyHW66C6lXBr0P2BDVAn8/w/Nduw/hlZuUvMTLAgMB +AAGjRzBFMC4GA1UdEQQnMCWCGCppbnRlZ3JhdGlvbi5leGFtcGxlLmNvbYIJbG9j +YWxob3N0MBMGA1UdJQQMMAoGCCsGAQUFBwMCMA0GCSqGSIb3DQEBCwUAA4IBAQBB +wCeqw5FGB8GuZG9nEbRinfPKcMKNidy9zh/ppS6HyqOLuls3mAOgvdNZugUFsZq9 +RSOXofk8lAP8bwaZubp4VB2DSf/EsJoFXydPgT5TDqGVcBRGXJ0EKxqjonWbjOlR +69BwNsE8nZ/vmTY+5RdyUJNCy+CUtXSRmggYa8ix5WqZFOGZ0BmOM+vzw98OuhH2 +eZa9+e27fHiL1UVhS70RaMNixVai0cx8U+k2ntMCSbEbPoE25QWzfJEu6D7teh4c +nFv+6I5vZ/0g2z28h6Or/N6Bp2svvuuo5iyRzrWMPldHrbyP+zDh0A7Qtf8Io1Fv +LadoTB43UaTNaYdrwq2K +-----END CERTIFICATE----- diff --git a/services/federator/test/unit/Test/Federator/Remote.hs b/services/federator/test/unit/Test/Federator/Remote.hs index 618c78dc85..3535f859d1 100644 --- a/services/federator/test/unit/Test/Federator/Remote.hs +++ b/services/federator/test/unit/Test/Federator/Remote.hs @@ -101,6 +101,18 @@ testValidatesCertificateWrongHostname = "refuses to connect with server" [ testCase "when the server's certificate doesn't match the hostname" $ bracket (startMockServer certForWrongDomain) (Async.cancel . fst) $ \(_, port) -> do + tlsSettings <- mkTLSSettingsOrThrow settings + eitherClient <- + Polysemy.runM + . Polysemy.runError + . Polysemy.runInputConst tlsSettings + $ mkGrpcClient (SrvTarget "localhost." (fromIntegral port)) + case eitherClient of + Left (RemoteErrorTLSException _ _) -> pure () + Left x -> assertFailure $ "Expected TLS failure, got: " <> show x + Right _ -> assertFailure "Expected connection with the server to fail", + testCase "when the server's certificate does not have the server key usage flag" $ + bracket (startMockServer certWithoutServerKeyUsage) (Async.cancel . fst) $ \(_, port) -> do tlsSettings <- mkTLSSettingsOrThrow settings eitherClient <- Polysemy.runM @@ -122,6 +134,12 @@ certForLocalhostDot = WarpTLS.tlsSettings "test/resources/unit/localhost-dot.pem certForWrongDomain :: WarpTLS.TLSSettings certForWrongDomain = WarpTLS.tlsSettings "test/resources/unit/localhost.example.com.pem" "test/resources/unit/localhost.example.com-key.pem" +certWithoutServerKeyUsage :: WarpTLS.TLSSettings +certWithoutServerKeyUsage = + WarpTLS.tlsSettings + "test/resources/unit/localhost.client-only.pem" + "test/resources/unit/localhost.client-only-key.pem" + startMockServer :: MonadIO m => WarpTLS.TLSSettings -> m (Async.Async (), Warp.Port) startMockServer tlsSettings = liftIO $ do (port, sock) <- bindRandomPortTCP "*6" diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index a43ea91733..81c99088c3 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: a5b2ec0bd44d4fcabec564b4e7683a01cfb75cdb1c78a6eee520d6c48c95bb1d +-- hash: 8bf007e90cc28a7b92252e0fccfb998d850e30df040205e1bc7316b9008a0c9f name: galley version: 0.83.0 @@ -35,6 +35,7 @@ library Galley.API.LegalHold.Conflicts Galley.API.Mapping Galley.API.Message + Galley.API.One2One Galley.API.Public Galley.API.Query Galley.API.Teams @@ -54,6 +55,8 @@ library Galley.Data.TeamFeatures Galley.Data.TeamNotifications Galley.Data.Types + Galley.Effects + Galley.Effects.FireAndForget Galley.External Galley.External.LegalHoldService Galley.Intra.Client @@ -87,6 +90,7 @@ library , base >=4.6 && <5 , base64-bytestring >=1.0 , bilge >=0.21.1 + , binary , brig-types >=0.73.1 , bytestring >=0.9 , bytestring-conversion >=0.2 @@ -95,6 +99,7 @@ library , cassava >=0.5.2 , cereal >=0.4 , containers >=0.5 + , cryptonite , currency-codes >=2.0 , data-default >=0.5 , enclosed-exceptions >=1.0 @@ -113,10 +118,12 @@ library , imports , insert-ordered-containers , lens >=4.4 + , memory , metrics-wai >=0.4 , mtl >=2.2 , optparse-applicative >=0.10 , pem + , polysemy , proto-lens >=0.2 , protobuf >=0.2 , raw-strings-qq >=1.0 @@ -142,7 +149,7 @@ library , time >=1.4 , tinylog >=0.10 , tls >=1.3.10 - , transformers >=0.3 + , transformers , types-common >=0.16 , types-common-journal >=0.1 , unliftio >=0.2 @@ -172,14 +179,17 @@ executable galley , base , case-insensitive , extended + , extra >=1.3 , galley , galley-types , imports , raw-strings-qq >=1.0 , safe >=0.3 + , saml2-web-sso >=0.18 , servant-client , ssl-util , tagged + , transformers , types-common , wire-api , wire-api-federation @@ -230,11 +240,13 @@ executable galley-integration , cereal , containers , cookie + , cql-io , currency-codes , data-timeout , errors , exceptions , extended + , extra >=1.3 , galley , galley-types , gundeck-types @@ -257,6 +269,7 @@ executable galley-integration , raw-strings-qq >=1.0 , retry , safe >=0.3 + , saml2-web-sso >=0.18 , schema-profunctor , servant , servant-client @@ -274,6 +287,7 @@ executable galley-integration , time , tinylog , tls >=1.3.8 + , transformers , types-common , types-common-journal , unliftio @@ -311,18 +325,21 @@ executable galley-migrate-data , containers , exceptions , extended + , extra >=1.3 , galley-types , imports , lens , optparse-applicative , raw-strings-qq >=1.0 , safe >=0.3 + , saml2-web-sso >=0.18 , servant-client , ssl-util , tagged , text , time , tinylog + , transformers , types-common , unliftio , wire-api @@ -378,15 +395,18 @@ executable galley-schema , case-insensitive , cassandra-util , extended + , extra >=1.3 , imports , optparse-applicative , raw-strings-qq >=1.0 , safe >=0.3 + , saml2-web-sso >=0.18 , servant-client , ssl-util , tagged , text , tinylog + , transformers , wire-api , wire-api-federation if flag(static) @@ -399,6 +419,7 @@ test-suite galley-types-tests other-modules: Test.Galley.API Test.Galley.API.Message + Test.Galley.API.One2One Test.Galley.Intra.User Test.Galley.Mapping Test.Galley.Roundtrip @@ -413,6 +434,7 @@ test-suite galley-types-tests , case-insensitive , containers , extended + , extra >=1.3 , galley , galley-types , http-types @@ -420,6 +442,7 @@ test-suite galley-types-tests , lens , raw-strings-qq >=1.0 , safe >=0.3 + , saml2-web-sso >=0.18 , servant-client , servant-swagger , ssl-util @@ -428,6 +451,7 @@ test-suite galley-types-tests , tasty-hspec , tasty-hunit , tasty-quickcheck + , transformers , types-common , wai , wai-predicates diff --git a/services/galley/package.yaml b/services/galley/package.yaml index a4bda422ab..03a557c84e 100644 --- a/services/galley/package.yaml +++ b/services/galley/package.yaml @@ -13,6 +13,7 @@ dependencies: - imports - case-insensitive - extended +- extra >=1.3 - safe >=0.3 - ssl-util - raw-strings-qq >=1.0 @@ -20,6 +21,8 @@ dependencies: - wire-api-federation - tagged - servant-client +- saml2-web-sso >=0.18 +- transformers library: source-dirs: src @@ -31,6 +34,7 @@ library: - base >=4.6 && <5 - base64-bytestring >=1.0 - bilge >=0.21.1 + - binary - brig-types >=0.73.1 - bytestring >=0.9 - bytestring-conversion >=0.2 @@ -38,12 +42,12 @@ library: - cassava >= 0.5.2 - cereal >=0.4 - containers >=0.5 + - cryptonite - currency-codes >=2.0 - data-default >=0.5 - enclosed-exceptions >=1.0 - errors >=2.0 - exceptions >=0.4 - - extra >=1.3 - galley-types >=0.65.0 - gundeck-types >=1.35.2 - HsOpenSSL >=0.11 @@ -56,17 +60,18 @@ library: - http2-client-grpc - insert-ordered-containers - lens >=4.4 + - memory - metrics-wai >=0.4 - mtl >=2.2 - optparse-applicative >=0.10 - pem + - polysemy - protobuf >=0.2 - proto-lens >=0.2 - QuickCheck >=2.14 - resourcet >=1.1 - retry >=0.5 - safe-exceptions >=0.1 - - saml2-web-sso >=0.18 - servant - servant-server - servant-swagger @@ -82,7 +87,6 @@ library: - time >=1.4 - tinylog >=0.10 - tls >=1.3.10 - - transformers >=0.3 - types-common >=0.16 - types-common-journal >=0.1 - unliftio >=0.2 @@ -162,6 +166,7 @@ executables: - cereal - containers - cookie + - cql-io - currency-codes - metrics-wai - data-timeout diff --git a/services/galley/src/Galley/API.hs b/services/galley/src/Galley/API.hs index 6e964ad982..122c06859f 100644 --- a/services/galley/src/Galley/API.hs +++ b/services/galley/src/Galley/API.hs @@ -24,10 +24,10 @@ where import qualified Data.Swagger.Build.Api as Doc import qualified Galley.API.Internal as Internal import qualified Galley.API.Public as Public -import Galley.App (Galley) +import Galley.App (Galley, GalleyEffects) import Network.Wai.Routing (Routes) -sitemap :: Routes Doc.ApiBuilder Galley () +sitemap :: Routes Doc.ApiBuilder (Galley GalleyEffects) () sitemap = do Public.sitemap Public.apiDocs diff --git a/services/galley/src/Galley/API/Clients.hs b/services/galley/src/Galley/API/Clients.hs index 526c753051..e9c90bf5a2 100644 --- a/services/galley/src/Galley/API/Clients.hs +++ b/services/galley/src/Galley/API/Clients.hs @@ -26,6 +26,7 @@ import Control.Lens (view) import Data.Id import Galley.App import qualified Galley.Data as Data +import Galley.Effects import qualified Galley.Intra.Client as Intra import Galley.Options import Galley.Types.Clients (clientIds, fromUserClients) @@ -34,11 +35,11 @@ import Network.Wai import Network.Wai.Predicate hiding (setStatus) import Network.Wai.Utilities -getClientsH :: UserId -> Galley Response +getClientsH :: Member BrigAccess r => UserId -> Galley r Response getClientsH usr = do json <$> getClients usr -getClients :: UserId -> Galley [ClientId] +getClients :: Member BrigAccess r => UserId -> Galley r [ClientId] getClients usr = do isInternal <- view $ options . optSettings . setIntraListing clts <- @@ -47,12 +48,12 @@ getClients usr = do else Data.lookupClients [usr] return $ clientIds usr clts -addClientH :: UserId ::: ClientId -> Galley Response +addClientH :: UserId ::: ClientId -> Galley r Response addClientH (usr ::: clt) = do Data.updateClient True usr clt return empty -rmClientH :: UserId ::: ClientId -> Galley Response +rmClientH :: UserId ::: ClientId -> Galley r Response rmClientH (usr ::: clt) = do Data.updateClient False usr clt return empty diff --git a/services/galley/src/Galley/API/Create.hs b/services/galley/src/Galley/API/Create.hs index 9c1f82c351..182deff326 100644 --- a/services/galley/src/Galley/API/Create.hs +++ b/services/galley/src/Galley/API/Create.hs @@ -20,7 +20,7 @@ module Galley.API.Create internalCreateManagedConversationH, createSelfConversation, createOne2OneConversation, - createConnectConversationH, + createConnectConversation, ) where @@ -32,14 +32,15 @@ import Data.Misc (FutureWork (FutureWork)) import Data.Qualified import Data.Range import qualified Data.Set as Set -import Data.Tagged import Data.Time import qualified Data.UUID.Tagged as U import Galley.API.Error import Galley.API.Mapping +import Galley.API.One2One import Galley.API.Util import Galley.App import qualified Galley.Data as Data +import Galley.Effects import Galley.Intra.Push import Galley.Types import Galley.Types.Teams (ListType (..), Perm (..), TeamBinding (Binding), notTeamMember) @@ -52,6 +53,7 @@ import Network.Wai.Predicate hiding (setStatus) import Network.Wai.Utilities import qualified Wire.API.Conversation as Public import Wire.API.ErrorDescription (MissingLegalholdConsent) +import Wire.API.Federation.Error (federationNotImplemented) import Wire.API.Routes.Public.Galley (ConversationResponse) import Wire.API.Routes.Public.Util import Wire.API.Team.LegalHold (LegalholdProtectee (LegalholdPlusFederationNotImplemented)) @@ -63,10 +65,11 @@ import Wire.API.Team.LegalHold (LegalholdProtectee (LegalholdPlusFederationNotIm -- -- See Note [managed conversations]. createGroupConversation :: + Members '[BrigAccess, FederatorAccess, GundeckAccess] r => UserId -> ConnId -> Public.NewConvUnmanaged -> - Galley ConversationResponse + Galley r ConversationResponse createGroupConversation user conn wrapped@(Public.NewConvUnmanaged body) = case newConvTeam body of Nothing -> createRegularGroupConv user conn wrapped @@ -74,18 +77,29 @@ createGroupConversation user conn wrapped@(Public.NewConvUnmanaged body) = -- | An internal endpoint for creating managed group conversations. Will -- throw an error for everything else. -internalCreateManagedConversationH :: UserId ::: ConnId ::: JsonRequest NewConvManaged -> Galley Response +internalCreateManagedConversationH :: + Members '[BrigAccess, FederatorAccess, GundeckAccess] r => + UserId ::: ConnId ::: JsonRequest NewConvManaged -> + Galley r Response internalCreateManagedConversationH (zusr ::: zcon ::: req) = do newConv <- fromJsonBody req handleConversationResponse <$> internalCreateManagedConversation zusr zcon newConv -internalCreateManagedConversation :: UserId -> ConnId -> NewConvManaged -> Galley ConversationResponse +internalCreateManagedConversation :: + Members '[BrigAccess, FederatorAccess, GundeckAccess] r => + UserId -> + ConnId -> + NewConvManaged -> + Galley r ConversationResponse internalCreateManagedConversation zusr zcon (NewConvManaged body) = do case newConvTeam body of Nothing -> throwM internalError Just tinfo -> createTeamGroupConv zusr zcon tinfo body -ensureNoLegalholdConflicts :: [Remote UserId] -> [UserId] -> Galley () +ensureNoLegalholdConflicts :: + [Remote UserId] -> + [UserId] -> + Galley r () ensureNoLegalholdConflicts remotes locals = do let FutureWork _remotes = FutureWork @'LegalholdPlusFederationNotImplemented remotes whenM (anyLegalholdActivated locals) $ @@ -93,18 +107,18 @@ ensureNoLegalholdConflicts remotes locals = do throwErrorDescriptionType @MissingLegalholdConsent -- | A helper for creating a regular (non-team) group conversation. -createRegularGroupConv :: UserId -> ConnId -> NewConvUnmanaged -> Galley ConversationResponse +createRegularGroupConv :: + Members '[BrigAccess, FederatorAccess, GundeckAccess] r => + UserId -> + ConnId -> + NewConvUnmanaged -> + Galley r ConversationResponse createRegularGroupConv zusr zcon (NewConvUnmanaged body) = do lusr <- qualifyLocal zusr name <- rangeCheckedMaybe (newConvName body) - let unqualifiedUserIds = newConvUsers body - qualifiedUserIds = newConvQualifiedUsers body - allUsers = - toUserList lusr $ - map (unTagged . qualifyAs lusr) unqualifiedUserIds <> qualifiedUserIds + let allUsers = newConvMembers lusr body checkedUsers <- checkedConvSize allUsers - ensureConnected zusr (ulLocals allUsers) - checkRemoteUsersExist (ulRemotes allUsers) + ensureConnected lusr allUsers ensureNoLegalholdConflicts (ulRemotes allUsers) (ulLocals allUsers) c <- Data.createConversation @@ -122,15 +136,17 @@ createRegularGroupConv zusr zcon (NewConvUnmanaged body) = do -- | A helper for creating a team group conversation, used by the endpoint -- handlers above. Only supports unmanaged conversations. -createTeamGroupConv :: UserId -> ConnId -> Public.ConvTeamInfo -> Public.NewConv -> Galley ConversationResponse +createTeamGroupConv :: + Members '[BrigAccess, FederatorAccess, GundeckAccess] r => + UserId -> + ConnId -> + Public.ConvTeamInfo -> + Public.NewConv -> + Galley r ConversationResponse createTeamGroupConv zusr zcon tinfo body = do lusr <- qualifyLocal zusr name <- rangeCheckedMaybe (newConvName body) - let unqualifiedUserIds = newConvUsers body - qualifiedUserIds = newConvQualifiedUsers body - allUsers = - toUserList lusr $ - map (unTagged . qualifyAs lusr) unqualifiedUserIds <> qualifiedUserIds + let allUsers = newConvMembers lusr body convTeam = cnvTeamId tinfo zusrMembership <- Data.teamMember convTeam zusr @@ -153,7 +169,7 @@ createTeamGroupConv zusr zcon tinfo body = do -- Team members are always considered to be connected, so we only check -- 'ensureConnected' for non-team-members. ensureConnectedToLocals zusr (notTeamMember (ulLocals allUsers) (catMaybes convLocalMemberships)) - checkRemoteUsersExist (ulRemotes allUsers) + ensureConnectedToRemotes lusr (ulRemotes allUsers) ensureNoLegalholdConflicts (ulRemotes allUsers) (ulLocals allUsers) conv <- Data.createConversation @@ -174,7 +190,7 @@ createTeamGroupConv zusr zcon tinfo body = do ---------------------------------------------------------------------------- -- Other kinds of conversations -createSelfConversation :: UserId -> Galley ConversationResponse +createSelfConversation :: UserId -> Galley r ConversationResponse createSelfConversation zusr = do lusr <- qualifyLocal zusr c <- Data.conversation (Id . toUUID $ zusr) @@ -184,78 +200,170 @@ createSelfConversation zusr = do c <- Data.createSelfConversation lusr Nothing conversationCreated zusr c -createOne2OneConversation :: UserId -> ConnId -> NewConvUnmanaged -> Galley ConversationResponse +createOne2OneConversation :: + Members '[BrigAccess, FederatorAccess, GundeckAccess] r => + UserId -> + ConnId -> + NewConvUnmanaged -> + Galley r ConversationResponse createOne2OneConversation zusr zcon (NewConvUnmanaged j) = do lusr <- qualifyLocal zusr - otherUserId <- head . fromRange <$> (rangeChecked (newConvUsers j) :: Galley (Range 1 1 [UserId])) - (x, y) <- toUUIDs zusr otherUserId - when (x == y) $ - throwM $ - invalidOp "Cannot create a 1-1 with yourself" - case newConvTeam j of + let allUsers = newConvMembers lusr j + other <- ensureOne (ulAll lusr allUsers) + when (qUntagged lusr == other) $ + throwM (invalidOp "Cannot create a 1-1 with yourself") + mtid <- case newConvTeam j of Just ti | cnvManaged ti -> throwM noManagedTeamConv - | otherwise -> - checkBindingTeamPermissions zusr otherUserId (cnvTeamId ti) - Nothing -> do - ensureConnected zusr [otherUserId] + | otherwise -> do + foldQualified + lusr + (\lother -> checkBindingTeamPermissions lusr lother (cnvTeamId ti)) + (const (pure Nothing)) + other + Nothing -> ensureConnected lusr allUsers $> Nothing n <- rangeCheckedMaybe (newConvName j) - c <- Data.conversation (Data.one2OneConvId x y) - maybe (create lusr x y n $ newConvTeam j) (conversationExisted zusr) c + foldQualified + lusr + (createLegacyOne2OneConversationUnchecked lusr zcon n mtid) + (createOne2OneConversationUnchecked lusr zcon n mtid . qUntagged) + other where verifyMembership tid u = do membership <- Data.teamMember tid u when (isNothing membership) $ throwM noBindingTeamMembers - checkBindingTeamPermissions x y tid = do - zusrMembership <- Data.teamMember tid zusr + checkBindingTeamPermissions lusr lother tid = do + zusrMembership <- Data.teamMember tid (tUnqualified lusr) void $ permissionCheck CreateConversation zusrMembership Data.teamBinding tid >>= \case Just Binding -> do - verifyMembership tid x - verifyMembership tid y + verifyMembership tid (tUnqualified lusr) + verifyMembership tid (tUnqualified lother) + pure (Just tid) Just _ -> throwM nonBindingTeam Nothing -> throwM teamNotFound - create lusr x y n tinfo = do - c <- Data.createOne2OneConversation lusr x y n (cnvTeamId <$> tinfo) - notifyCreatedConversation Nothing zusr (Just zcon) c - conversationCreated zusr c -createConnectConversationH :: UserId ::: Maybe ConnId ::: JsonRequest Connect -> Galley Response -createConnectConversationH (usr ::: conn ::: req) = do - j <- fromJsonBody req - handleConversationResponse <$> createConnectConversation usr conn j +createLegacyOne2OneConversationUnchecked :: + Members '[FederatorAccess, GundeckAccess] r => + Local UserId -> + ConnId -> + Maybe (Range 1 256 Text) -> + Maybe TeamId -> + Local UserId -> + Galley r ConversationResponse +createLegacyOne2OneConversationUnchecked self zcon name mtid other = do + lcnv <- localOne2OneConvId self other + mc <- Data.conversation (tUnqualified lcnv) + case mc of + Just c -> conversationExisted (tUnqualified self) c + Nothing -> do + (x, y) <- toUUIDs (tUnqualified self) (tUnqualified other) + c <- Data.createLegacyOne2OneConversation self x y name mtid + notifyCreatedConversation Nothing (tUnqualified self) (Just zcon) c + conversationCreated (tUnqualified self) c + +createOne2OneConversationUnchecked :: + Members '[FederatorAccess, GundeckAccess] r => + Local UserId -> + ConnId -> + Maybe (Range 1 256 Text) -> + Maybe TeamId -> + Qualified UserId -> + Galley r ConversationResponse +createOne2OneConversationUnchecked self zcon name mtid other = do + let create = + foldQualified + self + createOne2OneConversationLocally + createOne2OneConversationRemotely + create (one2OneConvId (qUntagged self) other) self zcon name mtid other + +createOne2OneConversationLocally :: + Members '[FederatorAccess, GundeckAccess] r => + Local ConvId -> + Local UserId -> + ConnId -> + Maybe (Range 1 256 Text) -> + Maybe TeamId -> + Qualified UserId -> + Galley r ConversationResponse +createOne2OneConversationLocally lcnv self zcon name mtid other = do + mc <- Data.conversation (tUnqualified lcnv) + case mc of + Just c -> conversationExisted (tUnqualified self) c + Nothing -> do + c <- Data.createOne2OneConversation lcnv self other name mtid + notifyCreatedConversation Nothing (tUnqualified self) (Just zcon) c + conversationCreated (tUnqualified self) c -createConnectConversation :: UserId -> Maybe ConnId -> Connect -> Galley ConversationResponse +createOne2OneConversationRemotely :: + Remote ConvId -> + Local UserId -> + ConnId -> + Maybe (Range 1 256 Text) -> + Maybe TeamId -> + Qualified UserId -> + Galley r ConversationResponse +createOne2OneConversationRemotely _ _ _ _ _ _ = + throwM federationNotImplemented + +createConnectConversation :: + Members '[FederatorAccess, GundeckAccess] r => + UserId -> + Maybe ConnId -> + Connect -> + Galley r ConversationResponse createConnectConversation usr conn j = do lusr <- qualifyLocal usr - (x, y) <- toUUIDs usr (cRecipient j) + foldQualified + lusr + (\lrcpt -> createLegacyConnectConversation lusr conn lrcpt j) + (createConnectConversationWithRemote lusr conn) + (cRecipient j) + +createConnectConversationWithRemote :: + Local UserId -> + Maybe ConnId -> + Remote UserId -> + Galley r ConversationResponse +createConnectConversationWithRemote _ _ _ = + throwM federationNotImplemented + +createLegacyConnectConversation :: + Members '[FederatorAccess, GundeckAccess] r => + Local UserId -> + Maybe ConnId -> + Local UserId -> + Connect -> + Galley r ConversationResponse +createLegacyConnectConversation lusr conn lrecipient j = do + (x, y) <- toUUIDs (tUnqualified lusr) (tUnqualified lrecipient) n <- rangeCheckedMaybe (cName j) - conv <- Data.conversation (Data.one2OneConvId x y) - maybe (create lusr x y n) (update n) conv + conv <- Data.conversation (Data.localOne2OneConvId x y) + maybe (create x y n) (update n) conv where - create lusr x y n = do + create x y n = do c <- Data.createConnectConversation lusr x y n now <- liftIO getCurrentTime let lcid = qualifyAs lusr (Data.convId c) - e = Event ConvConnect (unTagged lcid) (unTagged lusr) now (EdConnect j) - notifyCreatedConversation Nothing usr conn c - for_ (newPushLocal ListComplete usr (ConvEvent e) (recipient <$> Data.convLocalMembers c)) $ \p -> + e = Event ConvConnect (qUntagged lcid) (qUntagged lusr) now (EdConnect j) + notifyCreatedConversation Nothing (tUnqualified lusr) conn c + for_ (newPushLocal ListComplete (tUnqualified lusr) (ConvEvent e) (recipient <$> Data.convLocalMembers c)) $ \p -> push1 $ p & pushRoute .~ RouteDirect & pushConn .~ conn - conversationCreated usr c + conversationCreated (tUnqualified lusr) c update n conv = do let mems = Data.convLocalMembers conv - in conversationExisted usr + in conversationExisted (tUnqualified lusr) =<< if - | usr `isMember` mems -> + | (tUnqualified lusr) `isMember` mems -> -- we already were in the conversation, maybe also other connect n conv | otherwise -> do lcid <- qualifyLocal (Data.convId conv) - lusr <- qualifyLocal usr mm <- Data.addMember lcid lusr let conv' = conv @@ -267,7 +375,7 @@ createConnectConversation usr conn j = do connect n conv' else do -- we were not in the conversation, but someone else - conv'' <- acceptOne2One usr conv' conn + conv'' <- acceptOne2One (tUnqualified lusr) conv' conn if Data.convType conv'' == ConnectConv then connect n conv'' else return conv'' @@ -275,15 +383,14 @@ createConnectConversation usr conn j = do | Data.convType conv == ConnectConv = do localDomain <- viewFederationDomain let qconv = Qualified (Data.convId conv) localDomain - qusr = Qualified usr localDomain n' <- case n of Just x -> do Data.updateConversation (Data.convId conv) x return . Just $ fromRange x Nothing -> return $ Data.convName conv t <- liftIO getCurrentTime - let e = Event ConvConnect qconv qusr t (EdConnect j) - for_ (newPushLocal ListComplete usr (ConvEvent e) (recipient <$> Data.convLocalMembers conv)) $ \p -> + let e = Event ConvConnect qconv (qUntagged lusr) t (EdConnect j) + for_ (newPushLocal ListComplete (tUnqualified lusr) (ConvEvent e) (recipient <$> Data.convLocalMembers conv)) $ \p -> push1 $ p & pushRoute .~ RouteDirect @@ -294,10 +401,10 @@ createConnectConversation usr conn j = do ------------------------------------------------------------------------------- -- Helpers -conversationCreated :: UserId -> Data.Conversation -> Galley ConversationResponse +conversationCreated :: UserId -> Data.Conversation -> Galley r ConversationResponse conversationCreated usr cnv = Created <$> conversationView usr cnv -conversationExisted :: UserId -> Data.Conversation -> Galley ConversationResponse +conversationExisted :: UserId -> Data.Conversation -> Galley r ConversationResponse conversationExisted usr cnv = Existed <$> conversationView usr cnv handleConversationResponse :: ConversationResponse -> Response @@ -305,7 +412,13 @@ handleConversationResponse = \case Created cnv -> json cnv & setStatus status201 . location (qUnqualified . cnvQualifiedId $ cnv) Existed cnv -> json cnv & setStatus status200 . location (qUnqualified . cnvQualifiedId $ cnv) -notifyCreatedConversation :: Maybe UTCTime -> UserId -> Maybe ConnId -> Data.Conversation -> Galley () +notifyCreatedConversation :: + Members '[FederatorAccess, GundeckAccess] r => + Maybe UTCTime -> + UserId -> + Maybe ConnId -> + Data.Conversation -> + Galley r () notifyCreatedConversation dtime usr conn c = do localDomain <- viewFederationDomain now <- maybe (liftIO getCurrentTime) pure dtime @@ -331,7 +444,12 @@ notifyCreatedConversation dtime usr conn c = do & pushConn .~ conn & pushRoute .~ route -toUUIDs :: UserId -> UserId -> Galley (U.UUID U.V4, U.UUID U.V4) +localOne2OneConvId :: Local UserId -> Local UserId -> Galley r (Local ConvId) +localOne2OneConvId self other = do + (x, y) <- toUUIDs (tUnqualified self) (tUnqualified other) + pure . qualifyAs self $ Data.localOne2OneConvId x y + +toUUIDs :: UserId -> UserId -> Galley r (U.UUID U.V4, U.UUID U.V4) toUUIDs a b = do a' <- U.fromUUID (toUUID a) & ifNothing invalidUUID4 b' <- U.fromUUID (toUUID b) & ifNothing invalidUUID4 @@ -344,3 +462,12 @@ access :: NewConv -> [Access] access a = case Set.toList (newConvAccess a) of [] -> Data.defRegularConvAccess (x : xs) -> x : xs + +newConvMembers :: Local x -> NewConv -> UserList UserId +newConvMembers loc body = + UserList (newConvUsers body) [] + <> toUserList loc (newConvQualifiedUsers body) + +ensureOne :: [a] -> Galley r a +ensureOne [x] = pure x +ensureOne _ = throwM (invalidRange "One-to-one conversations can only have a single invited member") diff --git a/services/galley/src/Galley/API/CustomBackend.hs b/services/galley/src/Galley/API/CustomBackend.hs index ab75da493a..fa98803c79 100644 --- a/services/galley/src/Galley/API/CustomBackend.hs +++ b/services/galley/src/Galley/API/CustomBackend.hs @@ -38,11 +38,11 @@ import qualified Wire.API.CustomBackend as Public -- PUBLIC --------------------------------------------------------------------- -getCustomBackendByDomainH :: Domain ::: JSON -> Galley Response +getCustomBackendByDomainH :: Domain ::: JSON -> Galley r Response getCustomBackendByDomainH (domain ::: _) = json <$> getCustomBackendByDomain domain -getCustomBackendByDomain :: Domain -> Galley Public.CustomBackend +getCustomBackendByDomain :: Domain -> Galley r Public.CustomBackend getCustomBackendByDomain domain = Data.getCustomBackend domain >>= \case Nothing -> throwM (customBackendNotFound domain) @@ -50,14 +50,14 @@ getCustomBackendByDomain domain = -- INTERNAL ------------------------------------------------------------------- -internalPutCustomBackendByDomainH :: Domain ::: JsonRequest CustomBackend -> Galley Response +internalPutCustomBackendByDomainH :: Domain ::: JsonRequest CustomBackend -> Galley r Response internalPutCustomBackendByDomainH (domain ::: req) = do customBackend <- fromJsonBody req -- simple enough to not need a separate function Data.setCustomBackend domain customBackend pure (empty & setStatus status201) -internalDeleteCustomBackendByDomainH :: Domain ::: JSON -> Galley Response +internalDeleteCustomBackendByDomainH :: Domain ::: JSON -> Galley r Response internalDeleteCustomBackendByDomainH (domain ::: _) = do Data.deleteCustomBackend domain pure (empty & setStatus status200) diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index 512077e7de..5889cb12a1 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -16,6 +16,7 @@ -- with this program. If not, see . module Galley.API.Federation where +import Brig.Types.Connection (Relation (Accepted)) import Control.Lens (itraversed, (<.>)) import Control.Monad.Catch (throwM) import Control.Monad.Trans.Maybe (runMaybeT) @@ -24,20 +25,23 @@ import Data.Containers.ListUtils (nubOrd) import Data.Domain import Data.Id (ConvId, UserId) import Data.Json.Util (Base64ByteString (..)) -import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.Map as Map import Data.Map.Lens (toMapOf) -import Data.Qualified (Qualified (..), toRemote) +import Data.Qualified +import Data.Range import qualified Data.Set as Set -import Data.Tagged import qualified Data.Text.Lazy as LT import Galley.API.Error (invalidPayload) import qualified Galley.API.Mapping as Mapping import Galley.API.Message (MessageMetadata (..), UserType (..), postQualifiedOtrMessage, sendLocalMessages) +import Galley.API.Update (notifyConversationMetadataUpdate) import qualified Galley.API.Update as API import Galley.API.Util -import Galley.App (Galley) +import Galley.App import qualified Galley.Data as Data +import Galley.Effects +import Galley.Intra.User (getConnections) import Galley.Types.Conversations.Members (LocalMember (..), defMemberStatus) import Imports import Servant (ServerT) @@ -49,6 +53,7 @@ import Wire.API.Conversation.Action import Wire.API.Conversation.Member (OtherMember (..)) import qualified Wire.API.Conversation.Role as Public import Wire.API.Event.Conversation +import Wire.API.Federation.API.Common import Wire.API.Federation.API.Galley ( ConversationUpdate (..), GetConversationsRequest (..), @@ -59,13 +64,15 @@ import Wire.API.Federation.API.Galley MessageSendResponse (..), NewRemoteConversation (..), RemoteMessage (..), + UserDeletedConversationsNotification, ) import qualified Wire.API.Federation.API.Galley as FederationAPIGalley +import Wire.API.Routes.Internal.Brig.Connection import Wire.API.Routes.Public.Galley.Responses (RemoveFromConversationError (..)) import Wire.API.ServantProto (FromProto (..)) import Wire.API.User.Client (userClientMap) -federationSitemap :: ServerT (ToServantApi FederationAPIGalley.Api) Galley +federationSitemap :: ServerT (ToServantApi FederationAPIGalley.Api) (Galley GalleyEffects) federationSitemap = genericServerT $ FederationAPIGalley.Api @@ -74,37 +81,57 @@ federationSitemap = FederationAPIGalley.onConversationUpdated = onConversationUpdated, FederationAPIGalley.leaveConversation = leaveConversation, FederationAPIGalley.onMessageSent = onMessageSent, - FederationAPIGalley.sendMessage = sendMessage + FederationAPIGalley.sendMessage = sendMessage, + FederationAPIGalley.onUserDeleted = onUserDeleted } -onConversationCreated :: Domain -> NewRemoteConversation ConvId -> Galley () +onConversationCreated :: + Members '[BrigAccess, GundeckAccess, ExternalAccess] r => + Domain -> + NewRemoteConversation ConvId -> + Galley r () onConversationCreated domain rc = do - let qrc = fmap (`Qualified` domain) rc - localDomain <- viewFederationDomain - let localUsers = - foldMap (\om -> guard (qDomain (omQualifiedId om) == localDomain) $> omQualifiedId om) - . rcMembers - $ rc - localUserIds = fmap qUnqualified localUsers - unless (null localUsers) $ do - Data.addLocalMembersToRemoteConv (rcCnvId qrc) localUserIds - forM_ (fromNewRemoteConversation localDomain qrc) $ \(mem, c) -> do + let qrc = fmap (toRemoteUnsafe domain) rc + loc <- qualifyLocal () + let (localUserIds, _) = partitionQualified loc (map omQualifiedId (toList (rcNonCreatorMembers rc))) + + addedUserIds <- + addLocalUsersToRemoteConv + (rcCnvId qrc) + (qUntagged (FederationAPIGalley.rcRemoteOrigUserId qrc)) + localUserIds + + let connectedMembers = + Set.filter + ( foldQualified + loc + (flip Set.member addedUserIds . tUnqualified) + (const True) + . omQualifiedId + ) + (rcNonCreatorMembers rc) + -- Make sure to notify only about local users connected to the adder + let qrcConnected = qrc {rcNonCreatorMembers = connectedMembers} + + forM_ (fromNewRemoteConversation loc qrcConnected) $ \(mem, c) -> do let event = Event ConvCreate - (rcCnvId qrc) - (rcOrigUserId rc) - (rcTime rc) + (qUntagged (rcCnvId qrcConnected)) + (qUntagged (FederationAPIGalley.rcRemoteOrigUserId qrcConnected)) + (rcTime qrcConnected) (EdConversation c) - pushConversationEvent Nothing event [Public.memId mem] [] + pushConversationEvent Nothing event [qUnqualified . Public.memId $ mem] [] -getConversations :: Domain -> GetConversationsRequest -> Galley GetConversationsResponse +getConversations :: + Domain -> + GetConversationsRequest -> + Galley r GetConversationsResponse getConversations domain (GetConversationsRequest uid cids) = do - let ruid = toRemote $ Qualified uid domain + let ruid = toRemoteUnsafe domain uid localDomain <- viewFederationDomain GetConversationsResponse - . catMaybes - . map (Mapping.conversationToRemote localDomain ruid) + . mapMaybe (Mapping.conversationToRemote localDomain ruid) <$> Data.localConversations cids getLocalUsers :: Domain -> NonEmpty (Qualified UserId) -> [UserId] @@ -112,10 +139,16 @@ getLocalUsers localDomain = map qUnqualified . filter ((== localDomain) . qDomai -- | Update the local database with information on conversation members joining -- or leaving. Finally, push out notifications to local users. -onConversationUpdated :: Domain -> ConversationUpdate -> Galley () +onConversationUpdated :: + Members '[BrigAccess, GundeckAccess, ExternalAccess] r => + Domain -> + ConversationUpdate -> + Galley r () onConversationUpdated requestingDomain cu = do localDomain <- viewFederationDomain - let qconvId = Qualified (cuConvId cu) requestingDomain + loc <- qualifyLocal () + let rconvId = toRemoteUnsafe requestingDomain (cuConvId cu) + qconvId = qUntagged rconvId -- Note: we generally do not send notifications to users that are not part of -- the conversation (from our point of view), to prevent spam from the remote @@ -130,43 +163,77 @@ onConversationUpdated requestingDomain cu = do -- are not in the conversations are being removed or have their membership state -- updated, we do **not** add them to the list of targets, because we have no -- way to make sure that they are actually supposed to receive that notification. - extraTargets <- case cuAction cu of - ConversationActionAddMembers toAdd _ -> do - let localUsers = getLocalUsers localDomain toAdd - Data.addLocalMembersToRemoteConv qconvId localUsers - pure localUsers - ConversationActionRemoveMember toRemove -> do - let localUsers = getLocalUsers localDomain (pure toRemove) - Data.removeLocalMembersFromRemoteConv qconvId localUsers - pure [] - ConversationActionRename _ -> pure [] - ConversationActionMessageTimerUpdate _ -> pure [] - ConversationActionMemberUpdate _ _ -> pure [] - ConversationActionReceiptModeUpdate _ -> pure [] - ConversationActionAccessUpdate _ -> pure [] - - -- Send notifications - let event = conversationActionToEvent (cuTime cu) (cuOrigUserId cu) qconvId (cuAction cu) - targets = nubOrd $ presentUsers <> extraTargets + (mActualAction, extraTargets) <- case cuAction cu of + ConversationActionAddMembers toAdd role -> do + let (localUsers, remoteUsers) = partitionQualified loc toAdd + addedLocalUsers <- Set.toList <$> addLocalUsersToRemoteConv rconvId (cuOrigUserId cu) localUsers + let allAddedUsers = map (qUntagged . qualifyAs loc) addedLocalUsers <> map qUntagged remoteUsers + case allAddedUsers of + [] -> pure (Nothing, []) -- If no users get added, its like no action was performed. + (u : us) -> pure (Just $ ConversationActionAddMembers (u :| us) role, addedLocalUsers) + ConversationActionRemoveMembers toRemove -> do + let localUsers = getLocalUsers localDomain toRemove + Data.removeLocalMembersFromRemoteConv rconvId localUsers + pure (Just $ cuAction cu, []) + ConversationActionRename _ -> pure (Just $ cuAction cu, []) + ConversationActionMessageTimerUpdate _ -> pure (Just $ cuAction cu, []) + ConversationActionMemberUpdate _ _ -> pure (Just $ cuAction cu, []) + ConversationActionReceiptModeUpdate _ -> pure (Just $ cuAction cu, []) + ConversationActionAccessUpdate _ -> pure (Just $ cuAction cu, []) + ConversationActionDelete -> do + Data.removeLocalMembersFromRemoteConv rconvId presentUsers + pure (Just $ cuAction cu, []) unless allUsersArePresent $ Log.warn $ Log.field "conversation" (toByteString' (cuConvId cu)) - Log.~~ Log.field "domain" (toByteString' requestingDomain) - Log.~~ Log.msg + . Log.field "domain" (toByteString' requestingDomain) + . Log.msg ( "Attempt to send notification about conversation update \ \to users not in the conversation" :: ByteString ) - -- FUTUREWORK: support bots? - pushConversationEvent Nothing event targets [] + -- Send notifications + for_ mActualAction $ \action -> do + let event = conversationActionToEvent (cuTime cu) (cuOrigUserId cu) qconvId action + targets = nubOrd $ presentUsers <> extraTargets + + -- FUTUREWORK: support bots? + pushConversationEvent Nothing event targets [] + +addLocalUsersToRemoteConv :: + Member BrigAccess r => + Remote ConvId -> + Qualified UserId -> + [UserId] -> + Galley r (Set UserId) +addLocalUsersToRemoteConv remoteConvId qAdder localUsers = do + connStatus <- getConnections localUsers (Just [qAdder]) (Just Accepted) + let localUserIdsSet = Set.fromList localUsers + connected = Set.fromList $ fmap csv2From connStatus + unconnected = Set.difference localUserIdsSet connected + connectedList = Set.toList connected + + -- FUTUREWORK: Consider handling the discrepancy between the views of the + -- conversation-owning backend and the local backend + unless (Set.null unconnected) $ + Log.warn $ + Log.msg ("A remote user is trying to add unconnected local users to a remote conversation" :: Text) + . Log.field "remote_user" (show qAdder) + . Log.field "local_unconnected_users" (show unconnected) + + -- Update the local view of the remote conversation by adding only those local + -- users that are connected to the adder + Data.addLocalMembersToRemoteConv remoteConvId connectedList + pure connected -- FUTUREWORK: actually return errors as part of the response instead of throwing leaveConversation :: + Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => Domain -> LeaveConversationRequest -> - Galley LeaveConversationResponse + Galley r LeaveConversationResponse leaveConversation requestingDomain lc = do let leaver = Qualified (lcLeaver lc) requestingDomain lcnv <- qualifyLocal (lcConvId lc) @@ -177,15 +244,20 @@ leaveConversation requestingDomain lc = do . runMaybeT . void . API.updateLocalConversation lcnv leaver Nothing - . ConversationActionRemoveMember + . ConversationActionRemoveMembers + . pure $ leaver -- FUTUREWORK: report errors to the originating backend -- FUTUREWORK: error handling for missing / mismatched clients -onMessageSent :: Domain -> RemoteMessage ConvId -> Galley () +onMessageSent :: + Members '[BotAccess, GundeckAccess, ExternalAccess] r => + Domain -> + RemoteMessage ConvId -> + Galley r () onMessageSent domain rmUnqualified = do - let rm = fmap (Tagged . (`Qualified` domain)) rmUnqualified - let convId = unTagged $ rmConversation rm + let rm = fmap (toRemoteUnsafe domain) rmUnqualified + convId = qUntagged $ rmConversation rm msgMetadata = MessageMetadata { mmNativePush = rmPush rm, @@ -209,7 +281,7 @@ onMessageSent domain rmUnqualified = do void $ sendLocalMessages (rmTime rm) (rmSender rm) (rmSenderClient rm) Nothing convId localMembers msgMetadata msgs where -- FUTUREWORK: https://wearezeta.atlassian.net/browse/SQCORE-875 - mkLocalMember :: UserId -> Galley LocalMember + mkLocalMember :: UserId -> Galley r LocalMember mkLocalMember m = pure $ LocalMember @@ -219,10 +291,46 @@ onMessageSent domain rmUnqualified = do lmConvRoleName = Public.roleNameWireMember } -sendMessage :: Domain -> MessageSendRequest -> Galley MessageSendResponse +sendMessage :: + Members '[BotAccess, BrigAccess, FederatorAccess, GundeckAccess, ExternalAccess] r => + Domain -> + MessageSendRequest -> + Galley r MessageSendResponse sendMessage originDomain msr = do let sender = Qualified (msrSender msr) originDomain msg <- either err pure (fromProto (fromBase64ByteString (msrRawMessage msr))) MessageSendResponse <$> postQualifiedOtrMessage User sender Nothing (msrConvId msr) msg where err = throwM . invalidPayload . LT.pack + +onUserDeleted :: + Members '[FederatorAccess, FireAndForget, ExternalAccess, GundeckAccess] r => + Domain -> + UserDeletedConversationsNotification -> + Galley r EmptyResponse +onUserDeleted origDomain udcn = do + let deletedUser = toRemoteUnsafe origDomain (FederationAPIGalley.udcnUser udcn) + untaggedDeletedUser = qUntagged deletedUser + convIds = FederationAPIGalley.udcnConversations udcn + + spawnMany $ + fromRange convIds <&> \c -> do + lc <- qualifyLocal c + mconv <- Data.conversation c + Data.removeRemoteMembersFromLocalConv c (pure deletedUser) + for_ mconv $ \conv -> do + when (isRemoteMember deletedUser (Data.convRemoteMembers conv)) $ + case Data.convType conv of + -- No need for a notification on One2One conv as the user is being + -- deleted and that notification should suffice. + Public.One2OneConv -> pure () + -- No need for a notification on Connect Conv as there should be no + -- other user in the conv. + Public.ConnectConv -> pure () + -- The self conv cannot be on a remote backend. + Public.SelfConv -> pure () + Public.RegularConv -> do + let action = ConversationActionRemoveMembers (pure untaggedDeletedUser) + botsAndMembers = convBotsAndMembers conv + void $ notifyConversationMetadataUpdate untaggedDeletedUser Nothing lc botsAndMembers action + pure EmptyResponse diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index 2f51149b5b..5cc940a457 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -28,13 +28,14 @@ where import qualified Cassandra as Cql import Control.Exception.Safe (catchAny) import Control.Lens hiding ((.=)) -import Control.Monad.Catch (MonadCatch) +import Control.Monad.Except (runExceptT) import Data.Data (Proxy (Proxy)) import Data.Id as Id import Data.List1 (maybeList1) -import Data.Qualified (Local, Qualified (..), Remote, lUnqualified, partitionRemoteOrLocalIds') +import Data.Qualified import Data.Range import Data.String.Conversions (cs) +import qualified Data.Text as T import Data.Time import GHC.TypeLits (AppendSymbol) import qualified Galley.API.Clients as Clients @@ -43,6 +44,7 @@ import qualified Galley.API.CustomBackend as CustomBackend import Galley.API.Error (throwErrorDescriptionType) import Galley.API.LegalHold (getTeamLegalholdWhitelistedH, setTeamLegalholdWhitelistedH, unsetTeamLegalholdWhitelistedH) import Galley.API.LegalHold.Conflicts (guardLegalholdPolicyConflicts) +import qualified Galley.API.One2One as One2One import qualified Galley.API.Query as Query import Galley.API.Teams (uncheckedDeleteTeamMember) import qualified Galley.API.Teams as Teams @@ -52,11 +54,13 @@ import qualified Galley.API.Update as Update import Galley.API.Util (JSON, isMember, qualifyLocal, viewFederationDomain) import Galley.App import qualified Galley.Data as Data +import Galley.Effects import qualified Galley.Intra.Push as Intra import qualified Galley.Queue as Q import Galley.Types import Galley.Types.Bot (AddBot, RemoveBot) import Galley.Types.Bot.Service +import Galley.Types.Conversations.Intra (UpsertOne2OneConversationRequest (..), UpsertOne2OneConversationResponse (..)) import Galley.Types.Teams hiding (MemberLeave) import Galley.Types.Teams.Intra import Galley.Types.Teams.SearchVisibility @@ -74,11 +78,16 @@ import Servant.API.Generic import Servant.Server import Servant.Server.Generic (genericServerT) import System.Logger.Class hiding (Path, name) +import qualified System.Logger.Class as Log import Wire.API.Conversation (ConvIdsPage, pattern GetPaginatedConversationIds) import Wire.API.ErrorDescription (MissingLegalholdConsent) +import Wire.API.Federation.API.Galley (UserDeletedConversationsNotification (UserDeletedConversationsNotification)) +import qualified Wire.API.Federation.API.Galley as FedGalley +import Wire.API.Federation.Client (executeFederated) import Wire.API.Routes.MultiTablePaging (mtpHasMore, mtpPagingState, mtpResults) import Wire.API.Routes.MultiVerb (MultiVerb, RespondEmpty) import Wire.API.Routes.Public (ZOptConn, ZUser) +import Wire.API.Routes.Public.Galley (ConversationVerb) import qualified Wire.API.Team.Feature as Public data InternalApi routes = InternalApi @@ -175,7 +184,29 @@ data InternalApi routes = InternalApi :> ZOptConn :> "i" :> "user" - :> MultiVerb 'DELETE '[Servant.JSON] '[RespondEmpty 200 "Remove a user from Galley"] () + :> MultiVerb 'DELETE '[Servant.JSON] '[RespondEmpty 200 "Remove a user from Galley"] (), + -- This endpoint can lead to the following events being sent: + -- - ConvCreate event to self, if conversation did not exist before + -- - ConvConnect event to self, if other didn't join the connect conversation before + iConnect :: + routes + :- Summary "Create a connect conversation (deprecated)" + :> ZUser + :> ZOptConn + :> "i" + :> "conversations" + :> "connect" + :> ReqBody '[Servant.JSON] Connect + :> ConversationVerb, + iUpsertOne2OneConversation :: + routes + :- Summary "Create or Update a connect or one2one conversation." + :> "i" + :> "conversations" + :> "one2one" + :> "upsert" + :> ReqBody '[Servant.JSON] UpsertOne2OneConversationRequest + :> Post '[Servant.JSON] UpsertOne2OneConversationResponse } deriving (Generic) @@ -221,7 +252,7 @@ type IFeatureStatusDeprecatedPut featureName = :> ReqBody '[Servant.JSON] (Public.TeamFeatureStatus featureName) :> Put '[Servant.JSON] (Public.TeamFeatureStatus featureName) -servantSitemap :: ServerT ServantAPI Galley +servantSitemap :: ServerT ServantAPI (Galley GalleyEffects) servantSitemap = genericServerT $ InternalApi @@ -250,27 +281,29 @@ servantSitemap = iTeamFeatureStatusClassifiedDomainsGet = iGetTeamFeature @'Public.TeamFeatureClassifiedDomains Features.getClassifiedDomainsInternal, iTeamFeatureStatusConferenceCallingPut = iPutTeamFeature @'Public.TeamFeatureConferenceCalling Features.setConferenceCallingInternal, iTeamFeatureStatusConferenceCallingGet = iGetTeamFeature @'Public.TeamFeatureConferenceCalling Features.getConferenceCallingInternal, - iDeleteUser = rmUser + iDeleteUser = rmUser, + iConnect = Create.createConnectConversation, + iUpsertOne2OneConversation = One2One.iUpsertOne2OneConversation } iGetTeamFeature :: - forall a. + forall a r. Public.KnownTeamFeatureName a => - (Features.GetFeatureInternalParam -> Galley (Public.TeamFeatureStatus a)) -> + (Features.GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus a)) -> TeamId -> - Galley (Public.TeamFeatureStatus a) + Galley r (Public.TeamFeatureStatus a) iGetTeamFeature getter = Features.getFeatureStatus @a getter DontDoAuth iPutTeamFeature :: - forall a. + forall a r. Public.KnownTeamFeatureName a => - (TeamId -> Public.TeamFeatureStatus a -> Galley (Public.TeamFeatureStatus a)) -> + (TeamId -> Public.TeamFeatureStatus a -> Galley r (Public.TeamFeatureStatus a)) -> TeamId -> Public.TeamFeatureStatus a -> - Galley (Public.TeamFeatureStatus a) + Galley r (Public.TeamFeatureStatus a) iPutTeamFeature setter = Features.setFeatureStatus @a setter DontDoAuth -sitemap :: Routes a Galley () +sitemap :: Routes a (Galley GalleyEffects) () sitemap = do -- Conversation API (internal) ---------------------------------------- @@ -290,14 +323,6 @@ sitemap = do .&. zauthConnId .&. jsonRequest @NewConvManaged - -- This endpoint can lead to the following events being sent: - -- - ConvCreate event to self, if conversation did not exist before - -- - ConvConnect event to self, if other didn't join the connect conversation before - post "/i/conversations/connect" (continue Create.createConnectConversationH) $ - zauthUserId - .&. opt zauthConnId - .&. jsonRequest @Connect - -- This endpoint can lead to the following events being sent: -- - MemberJoin event to you, if the conversation existed and had < 2 members before -- - MemberJoin event to other, if the conversation existed and only the other was member @@ -440,7 +465,12 @@ sitemap = do get "/i/legalhold/whitelisted-teams/:tid" (continue getTeamLegalholdWhitelistedH) $ capture "tid" -rmUser :: UserId -> Maybe ConnId -> Galley () +rmUser :: + forall r. + Members '[BrigAccess, ExternalAccess, FederatorAccess, GundeckAccess] r => + UserId -> + Maybe ConnId -> + Galley r () rmUser user conn = do let n = toRange (Proxy @100) :: Range 1 100 Int32 nRange1000 = rcast n :: Range 1 1000 Int32 @@ -451,15 +481,14 @@ rmUser user conn = do goConvPages lusr nRange1000 allConvIds Data.eraseClients user where - goConvPages :: Local UserId -> Range 1 1000 Int32 -> ConvIdsPage -> Galley () + goConvPages :: Local UserId -> Range 1 1000 Int32 -> ConvIdsPage -> Galley r () goConvPages lusr range page = do - localDomain <- viewFederationDomain - let (remoteConvs, localConvs) = partitionRemoteOrLocalIds' localDomain . mtpResults $ page + let (localConvs, remoteConvs) = partitionQualified lusr (mtpResults page) leaveLocalConversations localConvs - leaveRemoteConversations lusr remoteConvs + for_ (rangedChunks remoteConvs) (leaveRemoteConversations lusr) when (mtpHasMore page) $ do let nextState = mtpPagingState page - usr = lUnqualified lusr + usr = tUnqualified lusr nextQuery = GetPaginatedConversationIds (Just nextState) range newCids <- Query.conversationIdsPageFrom usr nextQuery goConvPages lusr range newCids @@ -469,7 +498,8 @@ rmUser user conn = do uncheckedDeleteTeamMember user conn tid user mems leaveTeams =<< Cql.liftClient (Cql.nextPage tids) - leaveLocalConversations :: [ConvId] -> Galley () + -- FUTUREWORK: Ensure that remote members of local convs get notified of this activity + leaveLocalConversations :: [ConvId] -> Galley r () leaveLocalConversations ids = do localDomain <- viewFederationDomain cc <- Data.localConversations ids @@ -497,17 +527,33 @@ rmUser user conn = do (maybeList1 (catMaybes pp)) Intra.push - leaveRemoteConversations :: Foldable t => Local UserId -> t (Remote ConvId) -> Galley () - leaveRemoteConversations lusr cids = - for_ cids $ \cid -> - Update.removeMemberFromRemoteConv cid lusr Nothing (unTagged lusr) - -deleteLoop :: Galley () -deleteLoop = do + leaveRemoteConversations :: Local UserId -> Range 1 FedGalley.UserDeletedNotificationMaxConvs [Remote ConvId] -> Galley r () + leaveRemoteConversations lusr cids = do + for_ (bucketRemote (fromRange cids)) $ \remoteConvs -> do + let userDelete = UserDeletedConversationsNotification (tUnqualified lusr) (unsafeRange (tUnqualified remoteConvs)) + let rpc = FedGalley.onUserDeleted FedGalley.clientRoutes (tDomain lusr) userDelete + res <- runExceptT (executeFederated (tDomain remoteConvs) rpc) + case res of + -- FUTUREWORK: Add a retry mechanism if there are federation errrors. + -- See https://wearezeta.atlassian.net/browse/SQCORE-1091 + Left federationError -> do + Log.err $ + Log.msg $ + T.unwords + [ "Federation error while notifying remote backends of a user deletion (Galley).", + "user_id: " <> (cs . show) lusr, + "details: " <> (cs . show) federationError + ] + pure () + Right _ -> pure () + +deleteLoop :: Galley r () +deleteLoop = liftGalley0 $ do q <- view deleteQueue safeForever "deleteLoop" $ do i@(TeamItem tid usr con) <- Q.pop q - Teams.uncheckedDeleteTeam usr con tid `catchAny` someError q i + interpretGalleyToGalley0 (Teams.uncheckedDeleteTeam usr con tid) + `catchAny` someError q i where someError q i x = do err $ "error" .= show x ~~ msg (val "failed to delete") @@ -516,14 +562,17 @@ deleteLoop = do err (msg (val "delete queue is full, dropping item") ~~ "item" .= show i) liftIO $ threadDelay 1000000 -safeForever :: (MonadIO m, MonadLogger m, MonadCatch m) => String -> m () -> m () +safeForever :: String -> Galley0 () -> Galley0 () safeForever funName action = forever $ action `catchAny` \exc -> do err $ "error" .= show exc ~~ msg (val $ cs funName <> " failed") threadDelay 60000000 -- pause to keep worst-case noise in logs manageable -guardLegalholdPolicyConflictsH :: (JsonRequest GuardLegalholdPolicyConflicts ::: JSON) -> Galley Response +guardLegalholdPolicyConflictsH :: + Member BrigAccess r => + (JsonRequest GuardLegalholdPolicyConflicts ::: JSON) -> + Galley r Response guardLegalholdPolicyConflictsH (req ::: _) = do glh <- fromJsonBody req guardLegalholdPolicyConflicts (glhProtectee glh) (glhUserClients glh) diff --git a/services/galley/src/Galley/API/LegalHold.hs b/services/galley/src/Galley/API/LegalHold.hs index d4ea7c3ed7..48d9eed39a 100644 --- a/services/galley/src/Galley/API/LegalHold.hs +++ b/services/galley/src/Galley/API/LegalHold.hs @@ -34,7 +34,6 @@ where import Brig.Types.Client.Prekey import Brig.Types.Connection (UpdateConnectionsInternal (..)) -import Brig.Types.Intra (ConnectionStatus (..)) import Brig.Types.Provider import Brig.Types.Team.LegalHold hiding (userId) import Control.Exception (assert) @@ -46,8 +45,8 @@ import Data.LegalHold (UserLegalHoldStatus (..), defUserLegalHoldStatus) import Data.List.Split (chunksOf) import Data.Misc import Data.Proxy (Proxy (Proxy)) +import Data.Qualified (qUntagged) import Data.Range (toRange) -import Data.Tagged import Galley.API.Error import Galley.API.Query (iterateConversations) import Galley.API.Update (removeMemberFromLocalConv) @@ -57,9 +56,10 @@ import qualified Galley.Data as Data import Galley.Data.LegalHold (isTeamLegalholdWhitelisted) import qualified Galley.Data.LegalHold as LegalHoldData import qualified Galley.Data.TeamFeatures as TeamFeatures +import Galley.Effects import qualified Galley.External.LegalHoldService as LHService import qualified Galley.Intra.Client as Client -import Galley.Intra.User (getConnections, putConnectionInternal) +import Galley.Intra.User (getConnectionsUnqualified, putConnectionInternal) import qualified Galley.Options as Opts import Galley.Types (LocalMember, lmConvRoleName, lmId) import Galley.Types.Teams as Team @@ -70,17 +70,17 @@ import Network.Wai import Network.Wai.Predicate hiding (or, result, setStatus, _3) import Network.Wai.Utilities as Wai import qualified System.Logger.Class as Log -import UnliftIO.Async (pooledMapConcurrentlyN_) import Wire.API.Conversation (ConvType (..)) import Wire.API.Conversation.Role (roleNameWireAdmin) +import Wire.API.Routes.Internal.Brig.Connection import qualified Wire.API.Team.Feature as Public import Wire.API.Team.LegalHold (LegalholdProtectee (LegalholdPlusFederationNotImplemented)) import qualified Wire.API.Team.LegalHold as Public -assertLegalHoldEnabledForTeam :: TeamId -> Galley () +assertLegalHoldEnabledForTeam :: TeamId -> Galley r () assertLegalHoldEnabledForTeam tid = unlessM (isLegalHoldEnabledForTeam tid) $ throwM legalHoldNotEnabled -isLegalHoldEnabledForTeam :: TeamId -> Galley Bool +isLegalHoldEnabledForTeam :: TeamId -> Galley r Bool isLegalHoldEnabledForTeam tid = do view (options . Opts.optSettings . Opts.setFeatureFlags . flagLegalHold) >>= \case FeatureLegalHoldDisabledPermanently -> do @@ -94,12 +94,12 @@ isLegalHoldEnabledForTeam tid = do FeatureLegalHoldWhitelistTeamsAndImplicitConsent -> isTeamLegalholdWhitelisted tid -createSettingsH :: UserId ::: TeamId ::: JsonRequest Public.NewLegalHoldService ::: JSON -> Galley Response +createSettingsH :: UserId ::: TeamId ::: JsonRequest Public.NewLegalHoldService ::: JSON -> Galley r Response createSettingsH (zusr ::: tid ::: req ::: _) = do newService <- fromJsonBody req setStatus status201 . json <$> createSettings zusr tid newService -createSettings :: UserId -> TeamId -> Public.NewLegalHoldService -> Galley Public.ViewLegalHoldService +createSettings :: UserId -> TeamId -> Public.NewLegalHoldService -> Galley r Public.ViewLegalHoldService createSettings zusr tid newService = do assertLegalHoldEnabledForTeam tid zusrMembership <- Data.teamMember tid zusr @@ -116,11 +116,11 @@ createSettings zusr tid newService = do LegalHoldData.createSettings service pure . viewLegalHoldService $ service -getSettingsH :: UserId ::: TeamId ::: JSON -> Galley Response +getSettingsH :: UserId ::: TeamId ::: JSON -> Galley r Response getSettingsH (zusr ::: tid ::: _) = do json <$> getSettings zusr tid -getSettings :: UserId -> TeamId -> Galley Public.ViewLegalHoldService +getSettings :: UserId -> TeamId -> Galley r Public.ViewLegalHoldService getSettings zusr tid = do zusrMembership <- Data.teamMember tid zusr void $ permissionCheck (ViewTeamFeature Public.TeamFeatureLegalHold) zusrMembership @@ -131,13 +131,21 @@ getSettings zusr tid = do (True, Nothing) -> Public.ViewLegalHoldServiceNotConfigured (True, Just result) -> viewLegalHoldService result -removeSettingsH :: UserId ::: TeamId ::: JsonRequest Public.RemoveLegalHoldSettingsRequest ::: JSON -> Galley Response +removeSettingsH :: + Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + UserId ::: TeamId ::: JsonRequest Public.RemoveLegalHoldSettingsRequest ::: JSON -> + Galley r Response removeSettingsH (zusr ::: tid ::: req ::: _) = do removeSettingsRequest <- fromJsonBody req removeSettings zusr tid removeSettingsRequest pure noContent -removeSettings :: UserId -> TeamId -> Public.RemoveLegalHoldSettingsRequest -> Galley () +removeSettings :: + Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + UserId -> + TeamId -> + Public.RemoveLegalHoldSettingsRequest -> + Galley r () removeSettings zusr tid (Public.RemoveLegalHoldSettingsRequest mPassword) = do assertNotWhitelisting assertLegalHoldEnabledForTeam tid @@ -150,7 +158,7 @@ removeSettings zusr tid (Public.RemoveLegalHoldSettingsRequest mPassword) = do ensureReAuthorised zusr mPassword removeSettings' tid where - assertNotWhitelisting :: Galley () + assertNotWhitelisting :: Galley r () assertNotWhitelisting = do view (options . Opts.optSettings . Opts.setFeatureFlags . flagLegalHold) >>= \case FeatureLegalHoldDisabledPermanently -> pure () @@ -160,23 +168,24 @@ removeSettings zusr tid (Public.RemoveLegalHoldSettingsRequest mPassword) = do -- | Remove legal hold settings from team; also disabling for all users and removing LH devices removeSettings' :: + forall r. + Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => TeamId -> - Galley () + Galley r () removeSettings' tid = do -- Loop through team members and run this action. Data.withTeamMembersWithChunks tid action LegalHoldData.removeSettings tid where - action :: [TeamMember] -> Galley () + action :: [TeamMember] -> Galley r () action membs = do let zothers = map (view userId) membs let lhMembers = filter ((== UserLegalHoldEnabled) . view legalHoldStatus) membs Log.debug $ Log.field "targets" (toByteString . show $ toByteString <$> zothers) . Log.field "action" (Log.val "LegalHold.removeSettings'") - -- I picked this number by fair dice roll, feel free to change it :P - pooledMapConcurrentlyN_ 8 removeLHForUser lhMembers - removeLHForUser :: TeamMember -> Galley () + spawnMany (map removeLHForUser lhMembers) + removeLHForUser :: TeamMember -> Galley r () removeLHForUser member = do let uid = member ^. Team.userId Client.removeLegalHoldClientFromUser uid @@ -185,11 +194,11 @@ removeSettings' tid = do -- | Learn whether a user has LH enabled and fetch pre-keys. -- Note that this is accessible to ANY authenticated user, even ones outside the team -getUserStatusH :: UserId ::: TeamId ::: UserId ::: JSON -> Galley Response +getUserStatusH :: UserId ::: TeamId ::: UserId ::: JSON -> Galley r Response getUserStatusH (_zusr ::: tid ::: uid ::: _) = do json <$> getUserStatus tid uid -getUserStatus :: TeamId -> UserId -> Galley Public.UserLegalHoldStatusResponse +getUserStatus :: TeamId -> UserId -> Galley r Public.UserLegalHoldStatusResponse getUserStatus tid uid = do mTeamMember <- Data.teamMember tid uid teamMember <- maybe (throwM teamMemberNotFound) pure mTeamMember @@ -201,7 +210,7 @@ getUserStatus tid uid = do UserLegalHoldEnabled -> makeResponseDetails pure $ UserLegalHoldStatusResponse status mlk lcid where - makeResponseDetails :: Galley (Maybe LastPrekey, Maybe ClientId) + makeResponseDetails :: Galley r (Maybe LastPrekey, Maybe ClientId) makeResponseDetails = do mLastKey <- fmap snd <$> LegalHoldData.selectPendingPrekeys uid lastKey <- case mLastKey of @@ -218,7 +227,10 @@ getUserStatus tid uid = do -- | Change 'UserLegalHoldStatus' from no consent to disabled. FUTUREWORK: -- @withdrawExplicitConsentH@ (lots of corner cases we'd have to implement for that to pan -- out). -grantConsentH :: UserId ::: TeamId ::: JSON -> Galley Response +grantConsentH :: + Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + UserId ::: TeamId ::: JSON -> + Galley r Response grantConsentH (zusr ::: tid ::: _) = do grantConsent zusr tid >>= \case GrantConsentSuccess -> pure $ empty & setStatus status201 @@ -228,7 +240,11 @@ data GrantConsentResult = GrantConsentSuccess | GrantConsentAlreadyGranted -grantConsent :: UserId -> TeamId -> Galley GrantConsentResult +grantConsent :: + Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + UserId -> + TeamId -> + Galley r GrantConsentResult grantConsent zusr tid = do userLHStatus <- fmap (view legalHoldStatus) <$> Data.teamMember tid zusr case userLHStatus of @@ -241,7 +257,10 @@ grantConsent zusr tid = do Just UserLegalHoldDisabled -> pure GrantConsentAlreadyGranted -- | Request to provision a device on the legal hold service for a user -requestDeviceH :: UserId ::: TeamId ::: UserId ::: JSON -> Galley Response +requestDeviceH :: + Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + UserId ::: TeamId ::: UserId ::: JSON -> + Galley r Response requestDeviceH (zusr ::: tid ::: uid ::: _) = do requestDevice zusr tid uid <&> \case RequestDeviceSuccess -> empty & setStatus status201 @@ -251,7 +270,13 @@ data RequestDeviceResult = RequestDeviceSuccess | RequestDeviceAlreadyPending -requestDevice :: UserId -> TeamId -> UserId -> Galley RequestDeviceResult +requestDevice :: + forall r. + Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + UserId -> + TeamId -> + UserId -> + Galley r RequestDeviceResult requestDevice zusr tid uid = do assertLegalHoldEnabledForTeam tid Log.debug $ @@ -273,7 +298,7 @@ requestDevice zusr tid uid = do -- This will still work if the LH service creates two new device on two consecutive calls -- to `/init`, but there may be race conditions, eg. when updating and enabling a pending -- device at (almost) the same time. - provisionLHDevice :: UserLegalHoldStatus -> Galley () + provisionLHDevice :: UserLegalHoldStatus -> Galley r () provisionLHDevice userLHStatus = do (lastPrekey', prekeys) <- requestDeviceFromService -- We don't distinguish the last key here; brig will do so when the device is added @@ -281,7 +306,7 @@ requestDevice zusr tid uid = do changeLegalholdStatus tid uid userLHStatus UserLegalHoldPending Client.notifyClientsAboutLegalHoldRequest zusr uid lastPrekey' - requestDeviceFromService :: Galley (LastPrekey, [Prekey]) + requestDeviceFromService :: Galley r (LastPrekey, [Prekey]) requestDeviceFromService = do LegalHoldData.dropPendingPrekeys uid lhDevice <- LHService.requestNewDevice tid uid @@ -294,14 +319,22 @@ requestDevice zusr tid uid = do -- it gets interupted. There's really no reason to delete them anyways -- since they are replaced if needed when registering new LH devices. approveDeviceH :: + Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => UserId ::: TeamId ::: UserId ::: ConnId ::: JsonRequest Public.ApproveLegalHoldForUserRequest ::: JSON -> - Galley Response + Galley r Response approveDeviceH (zusr ::: tid ::: uid ::: connId ::: req ::: _) = do approve <- fromJsonBody req approveDevice zusr tid uid connId approve pure empty -approveDevice :: UserId -> TeamId -> UserId -> ConnId -> Public.ApproveLegalHoldForUserRequest -> Galley () +approveDevice :: + Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + UserId -> + TeamId -> + UserId -> + ConnId -> + Public.ApproveLegalHoldForUserRequest -> + Galley r () approveDevice zusr tid uid connId (Public.ApproveLegalHoldForUserRequest mPassword) = do assertLegalHoldEnabledForTeam tid Log.debug $ @@ -330,7 +363,7 @@ approveDevice zusr tid uid connId (Public.ApproveLegalHoldForUserRequest mPasswo -- https://github.com/wireapp/wire-server/pull/802#pullrequestreview-262280386) changeLegalholdStatus tid uid userLHStatus UserLegalHoldEnabled where - assertUserLHPending :: UserLegalHoldStatus -> Galley () + assertUserLHPending :: UserLegalHoldStatus -> Galley r () assertUserLHPending userLHStatus = do case userLHStatus of UserLegalHoldEnabled -> throwM userLegalHoldAlreadyEnabled @@ -339,8 +372,9 @@ approveDevice zusr tid uid connId (Public.ApproveLegalHoldForUserRequest mPasswo UserLegalHoldNoConsent -> throwM userLegalHoldNotPending disableForUserH :: + Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => UserId ::: TeamId ::: UserId ::: JsonRequest Public.DisableLegalHoldForUserRequest ::: JSON -> - Galley Response + Galley r Response disableForUserH (zusr ::: tid ::: uid ::: req ::: _) = do disable <- fromJsonBody req disableForUser zusr tid uid disable <&> \case @@ -351,7 +385,14 @@ data DisableLegalHoldForUserResponse = DisableLegalHoldSuccess | DisableLegalHoldWasNotEnabled -disableForUser :: UserId -> TeamId -> UserId -> Public.DisableLegalHoldForUserRequest -> Galley DisableLegalHoldForUserResponse +disableForUser :: + forall r. + Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + UserId -> + TeamId -> + UserId -> + Public.DisableLegalHoldForUserRequest -> + Galley r DisableLegalHoldForUserResponse disableForUser zusr tid uid (Public.DisableLegalHoldForUserRequest mPassword) = do Log.debug $ Log.field "targets" (toByteString uid) @@ -364,7 +405,7 @@ disableForUser zusr tid uid (Public.DisableLegalHoldForUserRequest mPassword) = then pure DisableLegalHoldWasNotEnabled else disableLH userLHStatus $> DisableLegalHoldSuccess where - disableLH :: UserLegalHoldStatus -> Galley () + disableLH :: UserLegalHoldStatus -> Galley r () disableLH userLHStatus = do ensureReAuthorised zusr mPassword Client.removeLegalHoldClientFromUser uid @@ -377,7 +418,13 @@ disableForUser zusr tid uid (Public.DisableLegalHoldForUserRequest mPassword) = -- | Allow no-consent => consent without further changes. If LH device is requested, enabled, -- or disabled, make sure the affected connections are screened for policy conflict (anybody -- with no-consent), and put those connections in the appropriate blocked state. -changeLegalholdStatus :: TeamId -> UserId -> UserLegalHoldStatus -> UserLegalHoldStatus -> Galley () +changeLegalholdStatus :: + Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + TeamId -> + UserId -> + UserLegalHoldStatus -> + UserLegalHoldStatus -> + Galley r () changeLegalholdStatus tid uid old new = do case old of UserLegalHoldEnabled -> case new of @@ -413,9 +460,9 @@ changeLegalholdStatus tid uid old new = do illegal = throwM userLegalHoldIllegalOperation -- FUTUREWORK: make this async? -blockNonConsentingConnections :: UserId -> Galley () +blockNonConsentingConnections :: forall r. Member BrigAccess r => UserId -> Galley r () blockNonConsentingConnections uid = do - conns <- getConnections [uid] Nothing Nothing + conns <- getConnectionsUnqualified [uid] Nothing Nothing errmsgs <- do conflicts <- mconcat <$> findConflicts conns blockConflicts uid conflicts @@ -425,7 +472,7 @@ blockNonConsentingConnections uid = do Log.warn $ Log.msg @String msgs throwM legalHoldCouldNotBlockConnections where - findConflicts :: [ConnectionStatus] -> Galley [[UserId]] + findConflicts :: [ConnectionStatus] -> Galley r [[UserId]] findConflicts conns = do let (FutureWork @'Public.LegalholdPlusFederationNotImplemented -> _remoteUids, localUids) = (undefined, csTo <$> conns) -- FUTUREWORK: Handle remoteUsers here when federation is implemented @@ -433,25 +480,25 @@ blockNonConsentingConnections uid = do teamsOfUsers <- Data.usersTeams others filterM (fmap (== ConsentNotGiven) . checkConsent teamsOfUsers) others - blockConflicts :: UserId -> [UserId] -> Galley [String] + blockConflicts :: UserId -> [UserId] -> Galley r [String] blockConflicts _ [] = pure [] blockConflicts userLegalhold othersToBlock@(_ : _) = do status <- putConnectionInternal (BlockForMissingLHConsent userLegalhold othersToBlock) pure $ ["blocking users failed: " <> show (status, othersToBlock) | status /= status200] -setTeamLegalholdWhitelisted :: TeamId -> Galley () +setTeamLegalholdWhitelisted :: TeamId -> Galley r () setTeamLegalholdWhitelisted tid = do LegalHoldData.setTeamLegalholdWhitelisted tid -setTeamLegalholdWhitelistedH :: TeamId -> Galley Response +setTeamLegalholdWhitelistedH :: TeamId -> Galley r Response setTeamLegalholdWhitelistedH tid = do empty <$ setTeamLegalholdWhitelisted tid -unsetTeamLegalholdWhitelisted :: TeamId -> Galley () +unsetTeamLegalholdWhitelisted :: TeamId -> Galley r () unsetTeamLegalholdWhitelisted tid = do LegalHoldData.unsetTeamLegalholdWhitelisted tid -unsetTeamLegalholdWhitelistedH :: TeamId -> Galley Response +unsetTeamLegalholdWhitelistedH :: TeamId -> Galley r Response unsetTeamLegalholdWhitelistedH tid = do () <- error @@ -460,7 +507,7 @@ unsetTeamLegalholdWhitelistedH tid = do \before you enable the end-point." setStatus status204 empty <$ unsetTeamLegalholdWhitelisted tid -getTeamLegalholdWhitelistedH :: TeamId -> Galley Response +getTeamLegalholdWhitelistedH :: TeamId -> Galley r Response getTeamLegalholdWhitelistedH tid = do lhEnabled <- isTeamLegalholdWhitelisted tid pure $ @@ -482,7 +529,11 @@ getTeamLegalholdWhitelistedH tid = do -- which may cause wrong behavior. In order to guarantee correct behavior, the first argument -- contains the hypothetical new LH status of `uid`'s so it can be consulted instead of the -- one from the database. -handleGroupConvPolicyConflicts :: UserId -> UserLegalHoldStatus -> Galley () +handleGroupConvPolicyConflicts :: + Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + UserId -> + UserLegalHoldStatus -> + Galley r () handleGroupConvPolicyConflicts uid hypotheticalLHStatus = void $ iterateConversations uid (toRange (Proxy @500)) $ \convs -> do @@ -510,8 +561,8 @@ handleGroupConvPolicyConflicts uid hypotheticalLHStatus = then do for_ (filter ((== ConsentNotGiven) . consentGiven . snd) membersAndLHStatus) $ \(memberNoConsent, _) -> do lusr <- qualifyLocal (lmId memberNoConsent) - removeMemberFromLocalConv lcnv lusr Nothing (unTagged lusr) + removeMemberFromLocalConv lcnv lusr Nothing (qUntagged lusr) else do for_ (filter (userLHEnabled . snd) membersAndLHStatus) $ \(legalholder, _) -> do lusr <- qualifyLocal (lmId legalholder) - removeMemberFromLocalConv lcnv lusr Nothing (unTagged lusr) + removeMemberFromLocalConv lcnv lusr Nothing (qUntagged lusr) diff --git a/services/galley/src/Galley/API/LegalHold/Conflicts.hs b/services/galley/src/Galley/API/LegalHold/Conflicts.hs index 89e774d837..42bebf1fe3 100644 --- a/services/galley/src/Galley/API/LegalHold/Conflicts.hs +++ b/services/galley/src/Galley/API/LegalHold/Conflicts.hs @@ -30,6 +30,7 @@ import qualified Data.Set as Set import Galley.API.Util import Galley.App import qualified Galley.Data as Data +import Galley.Effects import qualified Galley.Intra.Client as Intra import Galley.Intra.User (getUser) import Galley.Options @@ -42,7 +43,11 @@ import Wire.API.User.Client as Client data LegalholdConflicts = LegalholdConflicts -guardQualifiedLegalholdPolicyConflicts :: LegalholdProtectee -> QualifiedUserClients -> Galley (Either LegalholdConflicts ()) +guardQualifiedLegalholdPolicyConflicts :: + Member BrigAccess r => + LegalholdProtectee -> + QualifiedUserClients -> + Galley r (Either LegalholdConflicts ()) guardQualifiedLegalholdPolicyConflicts protectee qclients = do localDomain <- viewFederationDomain guardLegalholdPolicyConflicts protectee @@ -57,7 +62,11 @@ guardQualifiedLegalholdPolicyConflicts protectee qclients = do -- -- This is a fallback safeguard that shouldn't get triggered if backend and clients work as -- intended. -guardLegalholdPolicyConflicts :: LegalholdProtectee -> UserClients -> Galley (Either LegalholdConflicts ()) +guardLegalholdPolicyConflicts :: + Member BrigAccess r => + LegalholdProtectee -> + UserClients -> + Galley r (Either LegalholdConflicts ()) guardLegalholdPolicyConflicts LegalholdPlusFederationNotImplemented _otherClients = pure . pure $ () guardLegalholdPolicyConflicts UnprotectedBot _otherClients = pure . pure $ () guardLegalholdPolicyConflicts (ProtectedUser self) otherClients = do @@ -67,7 +76,12 @@ guardLegalholdPolicyConflicts (ProtectedUser self) otherClients = do FeatureLegalHoldDisabledByDefault -> guardLegalholdPolicyConflictsUid self otherClients FeatureLegalHoldWhitelistTeamsAndImplicitConsent -> guardLegalholdPolicyConflictsUid self otherClients -guardLegalholdPolicyConflictsUid :: UserId -> UserClients -> Galley (Either LegalholdConflicts ()) +guardLegalholdPolicyConflictsUid :: + forall r. + Member BrigAccess r => + UserId -> + UserClients -> + Galley r (Either LegalholdConflicts ()) guardLegalholdPolicyConflictsUid self otherClients = runExceptT $ do let otherCids :: [ClientId] otherCids = Set.toList . Set.unions . Map.elems . userClients $ otherClients @@ -111,7 +125,7 @@ guardLegalholdPolicyConflictsUid self otherClients = runExceptT $ do . Client.fromClientCapabilityList . Client.clientCapabilities - checkConsentMissing :: Galley Bool + checkConsentMissing :: Galley r Bool checkConsentMissing = do -- (we could also get the profile from brig. would make the code slightly more -- concise, but not really help with the rpc back-and-forth, so, like, why?) diff --git a/services/galley/src/Galley/API/Mapping.hs b/services/galley/src/Galley/API/Mapping.hs index e99921917e..9ee604c32b 100644 --- a/services/galley/src/Galley/API/Mapping.hs +++ b/services/galley/src/Galley/API/Mapping.hs @@ -30,7 +30,7 @@ import Control.Monad.Catch import Data.Domain (Domain) import Data.Id (UserId, idToText) import Data.Qualified -import Galley.API.Util (viewFederationDomain) +import Galley.API.Util (qualifyLocal) import Galley.App import qualified Galley.Data as Data import Galley.Data.Types (convId) @@ -46,10 +46,10 @@ import Wire.API.Federation.API.Galley -- | View for a given user of a stored conversation. -- -- Throws "bad-state" when the user is not part of the conversation. -conversationView :: UserId -> Data.Conversation -> Galley Conversation +conversationView :: UserId -> Data.Conversation -> Galley r Conversation conversationView uid conv = do - localDomain <- viewFederationDomain - let mbConv = conversationViewMaybe localDomain uid conv + luid <- qualifyLocal uid + let mbConv = conversationViewMaybe luid conv maybe memberNotFound pure mbConv where memberNotFound = do @@ -64,17 +64,18 @@ conversationView uid conv = do -- | View for a given user of a stored conversation. -- -- Returns 'Nothing' if the user is not part of the conversation. -conversationViewMaybe :: Domain -> UserId -> Data.Conversation -> Maybe Conversation -conversationViewMaybe localDomain uid conv = do - let (selfs, lothers) = partition ((uid ==) . lmId) (Data.convLocalMembers conv) +conversationViewMaybe :: Local UserId -> Data.Conversation -> Maybe Conversation +conversationViewMaybe luid conv = do + let (selfs, lothers) = partition ((tUnqualified luid ==) . lmId) (Data.convLocalMembers conv) rothers = Data.convRemoteMembers conv - self <- localMemberToSelf <$> listToMaybe selfs + self <- localMemberToSelf luid <$> listToMaybe selfs let others = - map (localMemberToOther localDomain) lothers + map (localMemberToOther (tDomain luid)) lothers <> map remoteMemberToOther rothers pure $ Conversation - (Data.convMetadata localDomain conv) + (qUntagged . qualifyAs luid . convId $ conv) + (Data.convMetadata conv) (ConvMembers self others) -- | View for a local user of a remote conversation. @@ -83,22 +84,23 @@ conversationViewMaybe localDomain uid conv = do -- discard the conversation altogether. This should only happen if the remote -- backend is misbehaving. remoteConversationView :: - UserId -> + Local UserId -> MemberStatus -> - RemoteConversation -> + Remote RemoteConversation -> Maybe Conversation -remoteConversationView uid status rconv = do +remoteConversationView uid status (qUntagged -> Qualified rconv rDomain) = do let mems = rcnvMembers rconv others = rcmOthers mems self = localMemberToSelf + uid LocalMember - { lmId = uid, + { lmId = tUnqualified uid, lmService = Nothing, lmStatus = status, lmConvRoleName = rcmSelfRole mems } - pure $ Conversation (rcnvMetadata rconv) (ConvMembers self others) + pure $ Conversation (Qualified (rcnvId rconv) rDomain) (rcnvMetadata rconv) (ConvMembers self others) -- | Convert a local conversation to a structure to be returned to a remote -- backend. @@ -118,7 +120,8 @@ conversationToRemote localDomain ruid conv = do <> map remoteMemberToOther rothers pure $ RemoteConversation - { rcnvMetadata = Data.convMetadata localDomain conv, + { rcnvId = Data.convId conv, + rcnvMetadata = Data.convMetadata conv, rcnvMembers = RemoteConvMembers { rcmSelfRole = selfRole, @@ -128,10 +131,10 @@ conversationToRemote localDomain ruid conv = do -- | Convert a local conversation member (as stored in the DB) to a publicly -- facing 'Member' structure. -localMemberToSelf :: LocalMember -> Member -localMemberToSelf lm = +localMemberToSelf :: Local x -> LocalMember -> Member +localMemberToSelf loc lm = Member - { memId = lmId lm, + { memId = qUntagged . qualifyAs loc . lmId $ lm, memService = lmService lm, memOtrMutedStatus = msOtrMutedStatus st, memOtrMutedRef = msOtrMutedRef st, diff --git a/services/galley/src/Galley/API/Message.hs b/services/galley/src/Galley/API/Message.hs index ab744e355d..5f03241147 100644 --- a/services/galley/src/Galley/API/Message.hs +++ b/services/galley/src/Galley/API/Message.hs @@ -17,31 +17,25 @@ import Data.Json.Util import Data.List1 (singleton) import qualified Data.Map as Map import Data.Map.Lens (toMapOf) -import Data.Qualified (Qualified (..), partitionRemote) +import Data.Qualified import qualified Data.Set as Set import Data.Set.Lens -import Data.Tagged (unTagged) import Data.Time.Clock (UTCTime, getCurrentTime) import Galley.API.LegalHold.Conflicts (guardQualifiedLegalholdPolicyConflicts) import Galley.API.Util - ( runFederatedBrig, - runFederatedGalley, - viewFederationDomain, - ) import Galley.App import qualified Galley.Data as Data import Galley.Data.Services as Data +import Galley.Effects import qualified Galley.External as External import qualified Galley.Intra.Client as Intra import Galley.Intra.Push -import Galley.Intra.User import Galley.Options (optSettings, setIntraListing) import qualified Galley.Types.Clients as Clients import Galley.Types.Conversations.Members import Gundeck.Types.Push.V2 (RecipientClients (..)) -import Imports +import Imports hiding (forkIO) import qualified System.Logger.Class as Log -import UnliftIO.Async import Wire.API.Event.Conversation import qualified Wire.API.Federation.API.Brig as FederatedBrig import qualified Wire.API.Federation.API.Galley as FederatedGalley @@ -180,24 +174,25 @@ checkMessageClients sender participantMap recipientMap mismatchStrat = mkQualifiedMismatch reportedMissing redundant deleted ) -getRemoteClients :: [RemoteMember] -> Galley (Map (Domain, UserId) (Set ClientId)) -getRemoteClients remoteMembers = do - fmap mconcat -- concatenating maps is correct here, because their sets of keys are disjoint - . pooledMapConcurrentlyN 8 (uncurry getRemoteClientsFromDomain) - . partitionRemote - . map rmId - $ remoteMembers +getRemoteClients :: + Member FederatorAccess r => + [RemoteMember] -> + Galley r (Map (Domain, UserId) (Set ClientId)) +getRemoteClients remoteMembers = + -- concatenating maps is correct here, because their sets of keys are disjoint + mconcat . map tUnqualified + <$> runFederatedConcurrently (map rmId remoteMembers) getRemoteClientsFromDomain where - getRemoteClientsFromDomain :: Domain -> [UserId] -> Galley (Map (Domain, UserId) (Set ClientId)) - getRemoteClientsFromDomain domain uids = do - let rpc = FederatedBrig.getUserClients FederatedBrig.clientRoutes (FederatedBrig.GetUserClients uids) - Map.mapKeys (domain,) . fmap (Set.map pubClientId) . userMap <$> runFederatedBrig domain rpc + getRemoteClientsFromDomain (qUntagged -> Qualified uids domain) = + Map.mapKeys (domain,) . fmap (Set.map pubClientId) . userMap + <$> FederatedBrig.getUserClients FederatedBrig.clientRoutes (FederatedBrig.GetUserClients uids) postRemoteOtrMessage :: + Member FederatorAccess r => Qualified UserId -> Qualified ConvId -> LByteString -> - Galley (PostOtrResponse MessageSendingStatus) + Galley r (PostOtrResponse MessageSendingStatus) postRemoteOtrMessage sender conv rawMsg = do let msr = FederatedGalley.MessageSendRequest @@ -208,9 +203,16 @@ postRemoteOtrMessage sender conv rawMsg = do rpc = FederatedGalley.sendMessage FederatedGalley.clientRoutes (qDomain sender) msr FederatedGalley.msResponse <$> runFederatedGalley (qDomain conv) rpc -postQualifiedOtrMessage :: UserType -> Qualified UserId -> Maybe ConnId -> ConvId -> QualifiedNewOtrMessage -> Galley (PostOtrResponse MessageSendingStatus) +postQualifiedOtrMessage :: + Members '[BotAccess, BrigAccess, FederatorAccess, GundeckAccess, ExternalAccess] r => + UserType -> + Qualified UserId -> + Maybe ConnId -> + ConvId -> + QualifiedNewOtrMessage -> + Galley r (PostOtrResponse MessageSendingStatus) postQualifiedOtrMessage senderType sender mconn convId msg = runExceptT $ do - alive <- Data.isConvAlive convId + alive <- lift $ Data.isConvAlive convId localDomain <- viewFederationDomain now <- liftIO getCurrentTime let nowMillis = toUTCTimeMillis now @@ -223,7 +225,7 @@ postQualifiedOtrMessage senderType sender mconn convId msg = runExceptT $ do -- conversation members localMembers <- lift $ Data.members convId - remoteMembers <- Data.lookupRemoteMembers convId + remoteMembers <- lift $ Data.lookupRemoteMembers convId let localMemberIds = lmId <$> localMembers localMemberMap :: Map UserId LocalMember @@ -231,7 +233,7 @@ postQualifiedOtrMessage senderType sender mconn convId msg = runExceptT $ do members :: Set (Qualified UserId) members = Set.map (`Qualified` localDomain) (Map.keysSet localMemberMap) - <> Set.fromList (map (unTagged . rmId) remoteMembers) + <> Set.fromList (map (qUntagged . rmId) remoteMembers) isInternal <- view $ options . optSettings . setIntraListing -- check if the sender is part of the conversation @@ -298,6 +300,7 @@ postQualifiedOtrMessage senderType sender mconn convId msg = runExceptT $ do -- | Send both local and remote messages, return the set of clients for which -- sending has failed. sendMessages :: + Members '[BotAccess, GundeckAccess, ExternalAccess] r => UTCTime -> Qualified UserId -> ClientId -> @@ -306,7 +309,7 @@ sendMessages :: Map UserId LocalMember -> MessageMetadata -> Map (Domain, UserId, ClientId) ByteString -> - Galley QualifiedUserClients + Galley r QualifiedUserClients sendMessages now sender senderClient mconn conv localMemberMap metadata messages = do localDomain <- viewFederationDomain let messageMap = byDomain $ fmap toBase64Text messages @@ -324,6 +327,7 @@ sendMessages now sender senderClient mconn conv localMemberMap metadata messages mempty sendLocalMessages :: + Members '[BotAccess, GundeckAccess, ExternalAccess] r => UTCTime -> Qualified UserId -> ClientId -> @@ -332,7 +336,7 @@ sendLocalMessages :: Map UserId LocalMember -> MessageMetadata -> Map (UserId, ClientId) Text -> - Galley (Set (UserId, ClientId)) + Galley r (Set (UserId, ClientId)) sendLocalMessages now sender senderClient mconn conv localMemberMap metadata localMessages = do localDomain <- viewFederationDomain let events = @@ -357,7 +361,7 @@ sendRemoteMessages :: ConvId -> MessageMetadata -> Map (UserId, ClientId) Text -> - Galley (Set (UserId, ClientId)) + Galley r (Set (UserId, ClientId)) sendRemoteMessages domain now sender senderClient conv metadata messages = handle <=< runExceptT $ do let rcpts = foldr @@ -382,7 +386,7 @@ sendRemoteMessages domain now sender senderClient conv metadata messages = handl let rpc = FederatedGalley.onMessageSent FederatedGalley.clientRoutes originDomain rm executeFederated domain rpc where - handle :: Either FederationError a -> Galley (Set (UserId, ClientId)) + handle :: Either FederationError a -> Galley r (Set (UserId, ClientId)) handle (Right _) = pure mempty handle (Left e) = do Log.warn $ @@ -420,20 +424,23 @@ newUserPush p = MessagePush {userPushes = pure p, botPushes = mempty} newBotPush :: BotMember -> Event -> MessagePush newBotPush b e = MessagePush {userPushes = mempty, botPushes = pure (b, e)} -runMessagePush :: Qualified ConvId -> MessagePush -> Galley () +runMessagePush :: + forall r. + Members '[BotAccess, GundeckAccess, ExternalAccess] r => + Qualified ConvId -> + MessagePush -> + Galley r () runMessagePush cnv mp = do pushSome (userPushes mp) pushToBots (botPushes mp) where - pushToBots :: [(BotMember, Event)] -> Galley () + pushToBots :: [(BotMember, Event)] -> Galley r () pushToBots pushes = do localDomain <- viewFederationDomain if localDomain /= qDomain cnv then unless (null pushes) $ do Log.warn $ Log.msg ("Ignoring messages for local bots in a remote conversation" :: ByteString) . Log.field "conversation" (show cnv) - else void . forkIO $ do - gone <- External.deliver pushes - mapM_ (deleteBot (qUnqualified cnv) . botMemId) gone + else External.deliverAndDeleteAsync (qUnqualified cnv) pushes newMessageEvent :: Qualified ConvId -> Qualified UserId -> ClientId -> Maybe Text -> UTCTime -> ClientId -> Text -> Event newMessageEvent convId sender senderClient dat time receiverClient cipherText = diff --git a/services/galley/src/Galley/API/One2One.hs b/services/galley/src/Galley/API/One2One.hs new file mode 100644 index 0000000000..d9978a18b2 --- /dev/null +++ b/services/galley/src/Galley/API/One2One.hs @@ -0,0 +1,73 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 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 . +{-# LANGUAGE RecordWildCards #-} + +module Galley.API.One2One + ( one2OneConvId, + iUpsertOne2OneConversation, + ) +where + +import Data.Id +import Data.Qualified +import Galley.App (Galley) +import qualified Galley.Data as Data +import Galley.Types.Conversations.Intra (Actor (..), DesiredMembership (..), UpsertOne2OneConversationRequest (..), UpsertOne2OneConversationResponse (..)) +import Galley.Types.Conversations.One2One (one2OneConvId) +import Galley.Types.UserList (UserList (..)) +import Imports + +iUpsertOne2OneConversation :: UpsertOne2OneConversationRequest -> Galley r UpsertOne2OneConversationResponse +iUpsertOne2OneConversation UpsertOne2OneConversationRequest {..} = do + let convId = fromMaybe (one2OneConvId (qUntagged uooLocalUser) (qUntagged uooRemoteUser)) uooConvId + + let dolocal :: Local ConvId -> Galley r () + dolocal lconvId = do + mbConv <- Data.conversation (tUnqualified lconvId) + case mbConv of + Nothing -> do + let members = + case (uooActor, uooActorDesiredMembership) of + (LocalActor, Included) -> UserList [tUnqualified uooLocalUser] [] + (LocalActor, Excluded) -> UserList [] [] + (RemoteActor, Included) -> UserList [] [uooRemoteUser] + (RemoteActor, Excluded) -> UserList [] [] + unless (null members) $ + Data.createConnectConversationWithRemote lconvId uooLocalUser members + Just conv -> do + case (uooActor, uooActorDesiredMembership) of + (LocalActor, Included) -> do + void $ Data.addMember lconvId uooLocalUser + unless (null (Data.convRemoteMembers conv)) $ + Data.acceptConnect (tUnqualified lconvId) + (LocalActor, Excluded) -> Data.removeMember (tUnqualified uooLocalUser) (tUnqualified lconvId) + (RemoteActor, Included) -> do + void $ Data.addMembers lconvId (UserList [] [uooRemoteUser]) + unless (null (Data.convLocalMembers conv)) $ + Data.acceptConnect (tUnqualified lconvId) + (RemoteActor, Excluded) -> Data.removeRemoteMembersFromLocalConv (tUnqualified lconvId) (pure uooRemoteUser) + doremote :: Remote ConvId -> Galley r () + doremote rconvId = + case (uooActor, uooActorDesiredMembership) of + (LocalActor, Included) -> do + Data.addLocalMembersToRemoteConv rconvId [tUnqualified uooLocalUser] + (LocalActor, Excluded) -> do + Data.removeLocalMembersFromRemoteConv rconvId [tUnqualified uooLocalUser] + (RemoteActor, _) -> pure () + + foldQualified uooLocalUser dolocal doremote convId + pure (UpsertOne2OneConversationResponse convId) diff --git a/services/galley/src/Galley/API/Public.hs b/services/galley/src/Galley/API/Public.hs index 9b863fb367..900e4b052f 100644 --- a/services/galley/src/Galley/API/Public.hs +++ b/services/galley/src/Galley/API/Public.hs @@ -54,7 +54,6 @@ import Network.Wai.Utilities.ZAuth hiding (ZAuthUser) import Servant hiding (Handler, JSON, addHeader, contentType, respond) import Servant.Server.Generic (genericServerT) import Servant.Swagger.Internal.Orphans () -import qualified Wire.API.Conversation as Public import qualified Wire.API.Conversation.Code as Public import qualified Wire.API.Conversation.Typing as Public import qualified Wire.API.CustomBackend as Public @@ -73,7 +72,7 @@ import qualified Wire.API.Team.SearchVisibility as Public import qualified Wire.API.User as Public (UserIdList, modelUserIdList) import Wire.Swagger (int32Between) -servantSitemap :: ServerT GalleyAPI.ServantAPI Galley +servantSitemap :: ServerT GalleyAPI.ServantAPI (Galley GalleyEffects) servantSitemap = genericServerT $ GalleyAPI.Api @@ -85,11 +84,11 @@ servantSitemap = GalleyAPI.getConversations = Query.getConversations, GalleyAPI.getConversationByReusableCode = Query.getConversationByReusableCode, GalleyAPI.listConversations = Query.listConversations, - GalleyAPI.listConversationsV2 = Query.listConversationsV2, GalleyAPI.createGroupConversation = Create.createGroupConversation, GalleyAPI.createSelfConversation = Create.createSelfConversation, GalleyAPI.createOne2OneConversation = Create.createOne2OneConversation, - GalleyAPI.addMembersToConversationV2 = Update.addMembers, + GalleyAPI.addMembersToConversationUnqualified = Update.addMembersUnqualified, + GalleyAPI.addMembersToConversation = Update.addMembers, GalleyAPI.removeMemberUnqualified = Update.removeMemberUnqualified, GalleyAPI.removeMember = Update.removeMemberQualified, GalleyAPI.updateOtherMemberUnqualified = Update.updateOtherMemberUnqualified, @@ -175,7 +174,7 @@ servantSitemap = GalleyAPI.featureConfigConferenceCallingGet = Features.getFeatureConfig @'Public.TeamFeatureConferenceCalling Features.getConferenceCallingInternal } -sitemap :: Routes ApiBuilder Galley () +sitemap :: Routes ApiBuilder (Galley GalleyEffects) () sitemap = do -- Team API ----------------------------------------------------------- @@ -644,28 +643,6 @@ sitemap = do errorResponse (Error.errorDescriptionTypeToWai @Error.ConvNotFound) errorResponse Error.invalidAccessOp - -- This endpoint can lead to the following events being sent: - -- - MemberJoin event to members - post "/conversations/:cnv/members" (continue Update.addMembersH) $ - zauthUserId - .&. zauthConnId - .&. capture "cnv" - .&. jsonRequest @Public.Invite - document "POST" "addMembers" $ do - summary "Add users to an existing conversation" - parameter Path "cnv" bytes' $ - description "Conversation ID" - body (ref Public.modelInvite) $ - description "JSON body" - returns (ref Public.modelEvent) - response 200 "Members added" end - response 204 "No change" end - response 412 "The user(s) cannot be added to the conversation (eg., due to legalhold policy conflict)." end - errorResponse (Error.errorDescriptionTypeToWai @Error.ConvNotFound) - errorResponse (Error.invalidOp "Conversation type does not allow adding members") - errorResponse (Error.errorDescriptionTypeToWai @Error.NotConnected) - errorResponse (Error.errorDescriptionTypeToWai @Error.ConvAccessDenied) - -- This endpoint can lead to the following events being sent: -- - Typing event to members post "/conversations/:cnv/typing" (continue Update.isTypingH) $ @@ -754,7 +731,7 @@ sitemap = do errorResponse (Error.errorDescriptionTypeToWai @Error.UnknownClient) errorResponse Error.broadcastLimitExceeded -apiDocs :: Routes ApiBuilder Galley () +apiDocs :: Routes ApiBuilder (Galley r) () apiDocs = get "/conversations/api-docs" (continue docs) $ accept "application" "json" @@ -762,7 +739,7 @@ apiDocs = type JSON = Media "application" "json" -docs :: JSON ::: ByteString -> Galley Response +docs :: JSON ::: ByteString -> Galley r Response docs (_ ::: url) = do let models = Public.Swagger.models let apidoc = encode $ mkSwaggerApi (decodeLatin1 url) models sitemap diff --git a/services/galley/src/Galley/API/Query.hs b/services/galley/src/Galley/API/Query.hs index cd7a495ff5..0666e32b50 100644 --- a/services/galley/src/Galley/API/Query.hs +++ b/services/galley/src/Galley/API/Query.hs @@ -25,7 +25,6 @@ module Galley.API.Query conversationIdsPageFrom, getConversations, listConversations, - listConversationsV2, iterateConversations, getLocalSelf, internalGetMemberH, @@ -35,6 +34,7 @@ module Galley.API.Query where import qualified Cassandra as C +import Control.Lens (sequenceAOf) import Control.Monad.Catch (throwM) import Control.Monad.Trans.Except import qualified Data.ByteString.Lazy as LBS @@ -44,16 +44,16 @@ import Data.Domain (Domain) import Data.Id as Id import qualified Data.Map as Map import Data.Proxy -import Data.Qualified (Qualified (..), Remote, partitionRemote, partitionRemoteOrLocalIds', toRemote) +import Data.Qualified import Data.Range import qualified Data.Set as Set -import Data.Tagged (unTagged) import Galley.API.Error import qualified Galley.API.Mapping as Mapping import Galley.API.Util import Galley.App import qualified Galley.Data as Data import qualified Galley.Data.Types as Data +import Galley.Effects import Galley.Types import Galley.Types.Conversations.Members import Galley.Types.Conversations.Roles @@ -76,11 +76,11 @@ import Wire.API.Federation.Error import qualified Wire.API.Provider.Bot as Public import qualified Wire.API.Routes.MultiTablePaging as Public -getBotConversationH :: BotId ::: ConvId ::: JSON -> Galley Response +getBotConversationH :: BotId ::: ConvId ::: JSON -> Galley r Response getBotConversationH (zbot ::: zcnv ::: _) = do json <$> getBotConversation zbot zcnv -getBotConversation :: BotId -> ConvId -> Galley Public.BotConvView +getBotConversation :: BotId -> ConvId -> Galley r Public.BotConvView getBotConversation zbot zcnv = do (c, _) <- getConversationAndMemberWithError (errorDescriptionTypeToWai @ConvNotFound) (botUserId zbot) zcnv domain <- viewFederationDomain @@ -94,19 +94,21 @@ getBotConversation zbot zcnv = do | otherwise = Just (OtherMember (Qualified (lmId m) domain) (lmService m) (lmConvRoleName m)) -getUnqualifiedConversation :: UserId -> ConvId -> Galley Public.Conversation +getUnqualifiedConversation :: UserId -> ConvId -> Galley r Public.Conversation getUnqualifiedConversation zusr cnv = do c <- getConversationAndCheckMembership zusr cnv Mapping.conversationView zusr c -getConversation :: UserId -> Qualified ConvId -> Galley Public.Conversation +getConversation :: UserId -> Qualified ConvId -> Galley r Public.Conversation getConversation zusr cnv = do - localDomain <- viewFederationDomain - if qDomain cnv == localDomain - then getUnqualifiedConversation zusr (qUnqualified cnv) - else getRemoteConversation (toRemote cnv) + lusr <- qualifyLocal zusr + foldQualified + lusr + (getUnqualifiedConversation zusr . tUnqualified) + getRemoteConversation + cnv where - getRemoteConversation :: Remote ConvId -> Galley Public.Conversation + getRemoteConversation :: Remote ConvId -> Galley r Public.Conversation getRemoteConversation remoteConvId = do conversations <- getRemoteConversations zusr [remoteConvId] case conversations of @@ -114,7 +116,7 @@ getConversation zusr cnv = do [conv] -> pure conv _convs -> throwM (federationUnexpectedBody "expected one conversation, got multiple") -getRemoteConversations :: UserId -> [Remote ConvId] -> Galley [Public.Conversation] +getRemoteConversations :: UserId -> [Remote ConvId] -> Galley r [Public.Conversation] getRemoteConversations zusr remoteConvs = getRemoteConversationsWithFailures zusr remoteConvs >>= \case -- throw first error @@ -138,9 +140,9 @@ fgcError :: FailedGetConversation -> Wai.Error fgcError (FailedGetConversation _ r) = fgcrError r failedGetConversationRemotely :: - [Qualified ConvId] -> FederationError -> FailedGetConversation + [Remote ConvId] -> FederationError -> FailedGetConversation failedGetConversationRemotely qconvs = - FailedGetConversation qconvs . FailedGetConversationRemotely + FailedGetConversation (map qUntagged qconvs) . FailedGetConversationRemotely failedGetConversationLocally :: [Qualified ConvId] -> FailedGetConversation @@ -157,42 +159,45 @@ partitionGetConversationFailures = bimap concat concat . partitionEithers . map getRemoteConversationsWithFailures :: UserId -> [Remote ConvId] -> - Galley ([FailedGetConversation], [Public.Conversation]) + Galley r ([FailedGetConversation], [Public.Conversation]) getRemoteConversationsWithFailures zusr convs = do localDomain <- viewFederationDomain + lusr <- qualifyLocal zusr -- get self member statuses from the database statusMap <- Data.remoteConversationStatus zusr convs - let remoteView rconv = + let remoteView :: Remote FederatedGalley.RemoteConversation -> Maybe Conversation + remoteView rconv = Mapping.remoteConversationView - zusr + lusr ( Map.findWithDefault defMemberStatus - (toRemote (cnvmQualifiedId (FederatedGalley.rcnvMetadata rconv))) + (fmap FederatedGalley.rcnvId rconv) statusMap ) rconv (locallyFound, locallyNotFound) = partition (flip Map.member statusMap) convs localFailures | null locallyNotFound = [] - | otherwise = [failedGetConversationLocally (map unTagged locallyNotFound)] + | otherwise = [failedGetConversationLocally (map qUntagged locallyNotFound)] -- request conversations from remote backends - fmap (bimap (localFailures <>) concat . partitionEithers) - . pooledForConcurrentlyN 8 (partitionRemote locallyFound) - $ \(domain, someConvs) -> do - let req = FederatedGalley.GetConversationsRequest zusr someConvs + liftGalley0 + . fmap (bimap (localFailures <>) concat . partitionEithers) + . pooledForConcurrentlyN 8 (bucketRemote locallyFound) + $ \someConvs -> do + let req = FederatedGalley.GetConversationsRequest zusr (tUnqualified someConvs) rpc = FederatedGalley.getConversations FederatedGalley.clientRoutes localDomain req - handleFailures (map (flip Qualified domain) someConvs) $ do - rconvs <- gcresConvs <$> executeFederated domain rpc - pure $ catMaybes (map remoteView rconvs) + handleFailures (sequenceAOf tUnqualifiedL someConvs) $ do + rconvs <- gcresConvs <$> executeFederated (tDomain someConvs) rpc + pure $ mapMaybe (remoteView . qualifyAs someConvs) rconvs where handleFailures :: - [Qualified ConvId] -> - ExceptT FederationError Galley a -> - Galley (Either FailedGetConversation a) - handleFailures qconvs action = runExceptT - . withExceptT (failedGetConversationRemotely qconvs) + [Remote ConvId] -> + ExceptT FederationError Galley0 a -> + Galley0 (Either FailedGetConversation a) + handleFailures rconvs action = runExceptT + . withExceptT (failedGetConversationRemotely rconvs) . catchE action $ \e -> do lift . Logger.warn $ @@ -200,14 +205,14 @@ getRemoteConversationsWithFailures zusr convs = do . Logger.field "error" (show e) throwE e -getConversationRoles :: UserId -> ConvId -> Galley Public.ConversationRolesList +getConversationRoles :: UserId -> ConvId -> Galley r Public.ConversationRolesList getConversationRoles zusr cnv = do void $ getConversationAndCheckMembership zusr cnv -- NOTE: If/when custom roles are added, these roles should -- be merged with the team roles (if they exist) pure $ Public.ConversationRolesList wireConvRoles -conversationIdsPageFromUnqualified :: UserId -> Maybe ConvId -> Maybe (Range 1 1000 Int32) -> Galley (Public.ConversationList ConvId) +conversationIdsPageFromUnqualified :: UserId -> Maybe ConvId -> Maybe (Range 1 1000 Int32) -> Galley r (Public.ConversationList ConvId) conversationIdsPageFromUnqualified zusr start msize = do let size = fromMaybe (toRange (Proxy @1000)) msize ids <- Data.conversationIdsFrom zusr start size @@ -224,7 +229,7 @@ conversationIdsPageFromUnqualified zusr start msize = do -- -- - After local conversations, remote conversations are listed ordered -- - lexicographically by their domain and then by their id. -conversationIdsPageFrom :: UserId -> Public.GetPaginatedConversationIds -> Galley Public.ConvIdsPage +conversationIdsPageFrom :: UserId -> Public.GetPaginatedConversationIds -> Galley r Public.ConvIdsPage conversationIdsPageFrom zusr Public.GetMultiTablePageRequest {..} = do localDomain <- viewFederationDomain case gmtprState of @@ -234,17 +239,17 @@ conversationIdsPageFrom zusr Public.GetMultiTablePageRequest {..} = do mkState :: ByteString -> C.PagingState mkState = C.PagingState . LBS.fromStrict - localsAndRemotes :: Domain -> Maybe C.PagingState -> Range 1 1000 Int32 -> Galley Public.ConvIdsPage + localsAndRemotes :: Domain -> Maybe C.PagingState -> Range 1 1000 Int32 -> Galley r Public.ConvIdsPage localsAndRemotes localDomain pagingState size = do localPage <- pageToConvIdPage Public.PagingLocals . fmap (`Qualified` localDomain) <$> Data.localConversationIdsPageFrom zusr pagingState size let remainingSize = fromRange size - fromIntegral (length (Public.mtpResults localPage)) if Public.mtpHasMore localPage || remainingSize <= 0 - then pure localPage {Public.mtpHasMore = True} -- We haven't check the remotes yet, so has_more must always be True here. + then pure localPage {Public.mtpHasMore = True} -- We haven't checked the remotes yet, so has_more must always be True here. else do remotePage <- remotesOnly Nothing remainingSize pure $ remotePage {Public.mtpResults = Public.mtpResults localPage <> Public.mtpResults remotePage} - remotesOnly :: Maybe C.PagingState -> Int32 -> Galley Public.ConvIdsPage + remotesOnly :: Maybe C.PagingState -> Int32 -> Galley r Public.ConvIdsPage remotesOnly pagingState size = pageToConvIdPage Public.PagingRemotes <$> Data.remoteConversationIdsPageFrom zusr pagingState size @@ -256,12 +261,22 @@ conversationIdsPageFrom zusr Public.GetMultiTablePageRequest {..} = do mtpPagingState = Public.ConversationPagingState table (LBS.toStrict . C.unPagingState <$> pwsState) } -getConversations :: UserId -> Maybe (Range 1 32 (CommaSeparatedList ConvId)) -> Maybe ConvId -> Maybe (Range 1 500 Int32) -> Galley (Public.ConversationList Public.Conversation) +getConversations :: + UserId -> + Maybe (Range 1 32 (CommaSeparatedList ConvId)) -> + Maybe ConvId -> + Maybe (Range 1 500 Int32) -> + Galley r (Public.ConversationList Public.Conversation) getConversations user mids mstart msize = do ConversationList cs more <- getConversationsInternal user mids mstart msize flip ConversationList more <$> mapM (Mapping.conversationView user) cs -getConversationsInternal :: UserId -> Maybe (Range 1 32 (CommaSeparatedList ConvId)) -> Maybe ConvId -> Maybe (Range 1 500 Int32) -> Galley (Public.ConversationList Data.Conversation) +getConversationsInternal :: + UserId -> + Maybe (Range 1 32 (CommaSeparatedList ConvId)) -> + Maybe ConvId -> + Maybe (Range 1 500 Int32) -> + Galley r (Public.ConversationList Data.Conversation) getConversationsInternal user mids mstart msize = do (more, ids) <- getIds mids let localConvIds = ids @@ -288,57 +303,14 @@ getConversationsInternal user mids mstart msize = do | Data.isConvDeleted c = Data.deleteConversation (Data.convId c) >> pure False | otherwise = pure True --- | Deprecated. FUTUREWORK(federation): Delete this endpoint -listConversations :: UserId -> Public.ListConversations -> Galley (Public.ConversationList Public.Conversation) -listConversations user (Public.ListConversations mIds qstart msize) = do - localDomain <- viewFederationDomain - when (isJust mIds && isJust qstart) $ - throwM (invalidPayload "'start' and 'qualified_ids' are mutually exclusive") - (localMore, localConvIds, remoteConvIds) <- case mIds of - Just xs -> do - let (remoteConvIds, localIds) = partitionRemoteOrLocalIds' localDomain (toList xs) - (localMore, localConvIds) <- getIdsAndMore localIds - pure (localMore, localConvIds, remoteConvIds) - Nothing -> do - (localMore, localConvIds) <- getAll (localstart localDomain) - remoteConvIds <- Data.conversationsRemote user - pure (localMore, localConvIds, remoteConvIds) - - localInternalConversations <- - Data.localConversations localConvIds - >>= filterM removeDeleted - >>= filterM (pure . isMember user . Data.convLocalMembers) - localConversations <- mapM (Mapping.conversationView user) localInternalConversations - - remoteConversations <- getRemoteConversations user remoteConvIds - let allConvs = localConversations <> remoteConversations - pure $ Public.ConversationList allConvs localMore - where - localstart localDomain = case qstart of - Just start | qDomain start == localDomain -> Just (qUnqualified start) - _ -> Nothing - - size = fromMaybe (toRange (Proxy @32)) msize - - getIdsAndMore :: [ConvId] -> Galley (Bool, [ConvId]) - getIdsAndMore ids = (False,) <$> Data.localConversationIdsOf user ids - - getAll :: Maybe ConvId -> Galley (Bool, [ConvId]) - getAll mstart = do - r <- Data.conversationIdsFrom user mstart (rcast size) - let hasMore = Data.resultSetType r == Data.ResultSetTruncated - pure (hasMore, Data.resultSetResult r) - - removeDeleted :: Data.Conversation -> Galley Bool - removeDeleted c - | Data.isConvDeleted c = Data.deleteConversation (Data.convId c) >> pure False - | otherwise = pure True - -listConversationsV2 :: UserId -> Public.ListConversationsV2 -> Galley Public.ConversationsResponse -listConversationsV2 user (Public.ListConversationsV2 ids) = do - localDomain <- viewFederationDomain +listConversations :: + UserId -> + Public.ListConversations -> + Galley r Public.ConversationsResponse +listConversations user (Public.ListConversations ids) = do + luser <- qualifyLocal user - let (remoteIds, localIds) = partitionRemoteOrLocalIds' localDomain (fromRange ids) + let (localIds, remoteIds) = partitionQualified luser (fromRange ids) (foundLocalIds, notFoundLocalIds) <- foundsAndNotFounds (Data.localConversationIdsOf user) localIds localInternalConversations <- @@ -351,7 +323,7 @@ listConversationsV2 user (Public.ListConversationsV2 ids) = do let (failedConvsLocally, failedConvsRemotely) = partitionGetConversationFailures remoteFailures failedConvs = failedConvsLocally <> failedConvsRemotely fetchedOrFailedRemoteIds = Set.fromList $ map Public.cnvQualifiedId remoteConversations <> failedConvs - remoteNotFoundRemoteIds = filter (`Set.notMember` fetchedOrFailedRemoteIds) $ map unTagged remoteIds + remoteNotFoundRemoteIds = filter (`Set.notMember` fetchedOrFailedRemoteIds) $ map qUntagged remoteIds unless (null remoteNotFoundRemoteIds) $ -- FUTUREWORK: This implies that the backends are out of sync. Maybe the -- current user should be considered removed from this conversation at this @@ -367,11 +339,11 @@ listConversationsV2 user (Public.ListConversationsV2 ids) = do crNotFound = failedConvsLocally <> remoteNotFoundRemoteIds - <> map (`Qualified` localDomain) notFoundLocalIds, + <> map (qUntagged . qualifyAs luser) notFoundLocalIds, crFailed = failedConvsRemotely } where - removeDeleted :: Data.Conversation -> Galley Bool + removeDeleted :: Data.Conversation -> Galley r Bool removeDeleted c | Data.isConvDeleted c = Data.deleteConversation (Data.convId c) >> pure False | otherwise = pure True @@ -381,10 +353,13 @@ listConversationsV2 user (Public.ListConversationsV2 ids) = do let notFounds = xs \\ founds pure (founds, notFounds) -iterateConversations :: forall a. UserId -> Range 1 500 Int32 -> ([Data.Conversation] -> Galley a) -> Galley [a] +iterateConversations :: + UserId -> + Range 1 500 Int32 -> + ([Data.Conversation] -> Galley r a) -> + Galley r [a] iterateConversations uid pageSize handleConvs = go Nothing where - go :: Maybe ConvId -> Galley [a] go mbConv = do convResult <- getConversationsInternal uid Nothing mbConv (Just pageSize) resultHead <- handleConvs (convList convResult) @@ -396,24 +371,25 @@ iterateConversations uid pageSize handleConvs = go Nothing _ -> pure [] pure $ resultHead : resultTail -internalGetMemberH :: ConvId ::: UserId -> Galley Response +internalGetMemberH :: ConvId ::: UserId -> Galley r Response internalGetMemberH (cnv ::: usr) = do json <$> getLocalSelf usr cnv -getLocalSelf :: UserId -> ConvId -> Galley (Maybe Public.Member) +getLocalSelf :: UserId -> ConvId -> Galley r (Maybe Public.Member) getLocalSelf usr cnv = do + lusr <- qualifyLocal usr alive <- Data.isConvAlive cnv if alive - then Mapping.localMemberToSelf <$$> Data.member cnv usr + then Mapping.localMemberToSelf lusr <$$> Data.member cnv usr else Nothing <$ Data.deleteConversation cnv -getConversationMetaH :: ConvId -> Galley Response +getConversationMetaH :: ConvId -> Galley r Response getConversationMetaH cnv = do getConversationMeta cnv <&> \case Nothing -> setStatus status404 empty Just meta -> json meta -getConversationMeta :: ConvId -> Galley (Maybe ConversationMetadata) +getConversationMeta :: ConvId -> Galley r (Maybe ConversationMetadata) getConversationMeta cnv = do alive <- Data.isConvAlive cnv localDomain <- viewFederationDomain @@ -423,7 +399,12 @@ getConversationMeta cnv = do Data.deleteConversation cnv pure Nothing -getConversationByReusableCode :: UserId -> Key -> Value -> Galley ConversationCoverView +getConversationByReusableCode :: + Member BrigAccess r => + UserId -> + Key -> + Value -> + Galley r ConversationCoverView getConversationByReusableCode zusr key value = do c <- verifyReusableCode (ConversationCode key value Nothing) conv <- ensureConversationAccess zusr (Data.codeConversation c) CodeAccess diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index 330aa44c94..b2d8f0681d 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -71,18 +71,18 @@ import qualified Data.LegalHold as LH import qualified Data.List.Extra as List import Data.List1 (list1) import qualified Data.Map.Strict as M -import Data.Misc (HttpsUrl) +import Data.Misc (HttpsUrl, mkHttpsUrl) import Data.Qualified import Data.Range as Range import Data.Set (fromList) import qualified Data.Set as Set -import Data.String.Conversions (cs) import Data.Time.Clock (UTCTime (..), getCurrentTime) import qualified Data.UUID as UUID import qualified Data.UUID.Util as UUID import Galley.API.Error as Galley import Galley.API.LegalHold import qualified Galley.API.Teams.Notifications as APITeamQueue +import qualified Galley.API.Update as API import Galley.API.Util import Galley.App import qualified Galley.Data as Data @@ -90,7 +90,7 @@ import qualified Galley.Data.LegalHold as Data import qualified Galley.Data.SearchVisibility as SearchVisibilityData import Galley.Data.Services (BotMember) import qualified Galley.Data.TeamFeatures as TeamFeatures -import qualified Galley.Data.Types as Data +import Galley.Effects import qualified Galley.External as External import qualified Galley.Intra.Journal as Journal import Galley.Intra.Push @@ -106,14 +106,14 @@ import Galley.Types.Conversations.Roles as Roles import Galley.Types.Teams hiding (newTeam) import Galley.Types.Teams.Intra import Galley.Types.Teams.SearchVisibility -import Imports +import Imports hiding (forkIO) import Network.HTTP.Types import Network.Wai import Network.Wai.Predicate hiding (or, result, setStatus) import Network.Wai.Utilities import qualified SAML2.WebSSO as SAML import qualified System.Logger.Class as Log -import UnliftIO (mapConcurrently) +import UnliftIO.Async (mapConcurrently) import qualified Wire.API.Conversation.Role as Public import Wire.API.ErrorDescription (ConvNotFound, NotATeamMember, operationDenied) import qualified Wire.API.Notification as Public @@ -129,35 +129,35 @@ import qualified Wire.API.User as U import Wire.API.User.Identity (UserSSOId (UserSSOId)) import Wire.API.User.RichInfo (RichInfo) -getTeamH :: UserId ::: TeamId ::: JSON -> Galley Response +getTeamH :: UserId ::: TeamId ::: JSON -> Galley r Response getTeamH (zusr ::: tid ::: _) = maybe (throwM teamNotFound) (pure . json) =<< lookupTeam zusr tid -getTeamInternalH :: TeamId ::: JSON -> Galley Response +getTeamInternalH :: TeamId ::: JSON -> Galley r Response getTeamInternalH (tid ::: _) = maybe (throwM teamNotFound) (pure . json) =<< getTeamInternal tid -getTeamInternal :: TeamId -> Galley (Maybe TeamData) +getTeamInternal :: TeamId -> Galley r (Maybe TeamData) getTeamInternal = Data.team -getTeamNameInternalH :: TeamId ::: JSON -> Galley Response +getTeamNameInternalH :: TeamId ::: JSON -> Galley r Response getTeamNameInternalH (tid ::: _) = maybe (throwM teamNotFound) (pure . json) =<< getTeamNameInternal tid -getTeamNameInternal :: TeamId -> Galley (Maybe TeamName) +getTeamNameInternal :: TeamId -> Galley r (Maybe TeamName) getTeamNameInternal = fmap (fmap TeamName) . Data.teamName -getManyTeamsH :: UserId ::: Maybe (Either (Range 1 32 (List TeamId)) TeamId) ::: Range 1 100 Int32 ::: JSON -> Galley Response +getManyTeamsH :: UserId ::: Maybe (Either (Range 1 32 (List TeamId)) TeamId) ::: Range 1 100 Int32 ::: JSON -> Galley r Response getManyTeamsH (zusr ::: range ::: size ::: _) = json <$> getManyTeams zusr range size -getManyTeams :: UserId -> Maybe (Either (Range 1 32 (List TeamId)) TeamId) -> Range 1 100 Int32 -> Galley Public.TeamList +getManyTeams :: UserId -> Maybe (Either (Range 1 32 (List TeamId)) TeamId) -> Range 1 100 Int32 -> Galley r Public.TeamList getManyTeams zusr range size = withTeamIds zusr range size $ \more ids -> do teams <- mapM (lookupTeam zusr) ids pure (Public.newTeamList (catMaybes teams) more) -lookupTeam :: UserId -> TeamId -> Galley (Maybe Public.Team) +lookupTeam :: UserId -> TeamId -> Galley r (Maybe Public.Team) lookupTeam zusr tid = do tm <- Data.teamMember tid zusr if isJust tm @@ -169,13 +169,21 @@ lookupTeam zusr tid = do pure (tdTeam <$> t) else pure Nothing -createNonBindingTeamH :: UserId ::: ConnId ::: JsonRequest Public.NonBindingNewTeam ::: JSON -> Galley Response +createNonBindingTeamH :: + Members '[GundeckAccess, BrigAccess] r => + UserId ::: ConnId ::: JsonRequest Public.NonBindingNewTeam ::: JSON -> + Galley r Response createNonBindingTeamH (zusr ::: zcon ::: req ::: _) = do newTeam <- fromJsonBody req newTeamId <- createNonBindingTeam zusr zcon newTeam pure (empty & setStatus status201 . location newTeamId) -createNonBindingTeam :: UserId -> ConnId -> Public.NonBindingNewTeam -> Galley TeamId +createNonBindingTeam :: + Members '[BrigAccess, GundeckAccess] r => + UserId -> + ConnId -> + Public.NonBindingNewTeam -> + Galley r TeamId createNonBindingTeam zusr zcon (Public.NonBindingNewTeam body) = do let owner = Public.TeamMember zusr fullPermissions Nothing LH.defUserLegalHoldStatus let others = @@ -192,26 +200,34 @@ createNonBindingTeam zusr zcon (Public.NonBindingNewTeam body) = do finishCreateTeam team owner others (Just zcon) pure (team ^. teamId) -createBindingTeamH :: UserId ::: TeamId ::: JsonRequest BindingNewTeam ::: JSON -> Galley Response +createBindingTeamH :: + Members '[BrigAccess, GundeckAccess] r => + UserId ::: TeamId ::: JsonRequest BindingNewTeam ::: JSON -> + Galley r Response createBindingTeamH (zusr ::: tid ::: req ::: _) = do newTeam <- fromJsonBody req newTeamId <- createBindingTeam zusr tid newTeam pure (empty & setStatus status201 . location newTeamId) -createBindingTeam :: UserId -> TeamId -> BindingNewTeam -> Galley TeamId +createBindingTeam :: + Members '[BrigAccess, GundeckAccess] r => + UserId -> + TeamId -> + BindingNewTeam -> + Galley r TeamId createBindingTeam zusr tid (BindingNewTeam body) = do let owner = Public.TeamMember zusr fullPermissions Nothing LH.defUserLegalHoldStatus team <- Data.createTeam (Just tid) zusr (body ^. newTeamName) (body ^. newTeamIcon) (body ^. newTeamIconKey) Binding finishCreateTeam team owner [] Nothing pure tid -updateTeamStatusH :: TeamId ::: JsonRequest TeamStatusUpdate ::: JSON -> Galley Response +updateTeamStatusH :: Member BrigAccess r => TeamId ::: JsonRequest TeamStatusUpdate ::: JSON -> Galley r Response updateTeamStatusH (tid ::: req ::: _) = do teamStatusUpdate <- fromJsonBody req updateTeamStatus tid teamStatusUpdate return empty -updateTeamStatus :: TeamId -> TeamStatusUpdate -> Galley () +updateTeamStatus :: Member BrigAccess r => TeamId -> TeamStatusUpdate -> Galley r () updateTeamStatus tid (TeamStatusUpdate newStatus cur) = do oldStatus <- tdStatus <$> (Data.team tid >>= ifNothing teamNotFound) valid <- validateTransition (oldStatus, newStatus) @@ -232,7 +248,7 @@ updateTeamStatus tid (TeamStatusUpdate newStatus cur) = do else possiblyStaleSize Journal.teamActivate tid size c teamCreationTime journal _ _ = throwM invalidTeamStatusUpdate - validateTransition :: (TeamStatus, TeamStatus) -> Galley Bool + validateTransition :: (TeamStatus, TeamStatus) -> Galley r Bool validateTransition = \case (PendingActive, Active) -> return True (Active, Active) -> return False @@ -241,13 +257,22 @@ updateTeamStatus tid (TeamStatusUpdate newStatus cur) = do (Suspended, Suspended) -> return False (_, _) -> throwM invalidTeamStatusUpdate -updateTeamH :: UserId ::: ConnId ::: TeamId ::: JsonRequest Public.TeamUpdateData ::: JSON -> Galley Response +updateTeamH :: + Member GundeckAccess r => + UserId ::: ConnId ::: TeamId ::: JsonRequest Public.TeamUpdateData ::: JSON -> + Galley r Response updateTeamH (zusr ::: zcon ::: tid ::: req ::: _) = do updateData <- fromJsonBody req updateTeam zusr zcon tid updateData pure empty -updateTeam :: UserId -> ConnId -> TeamId -> Public.TeamUpdateData -> Galley () +updateTeam :: + Member GundeckAccess r => + UserId -> + ConnId -> + TeamId -> + Public.TeamUpdateData -> + Galley r () updateTeam zusr zcon tid updateData = do zusrMembership <- Data.teamMember tid zusr -- let zothers = map (view userId) membs @@ -262,14 +287,23 @@ updateTeam zusr zcon tid updateData = do let r = list1 (userRecipient zusr) (membersToRecipients (Just zusr) (memList ^. teamMembers)) push1 $ newPushLocal1 (memList ^. teamMemberListType) zusr (TeamEvent e) r & pushConn .~ Just zcon -deleteTeamH :: UserId ::: ConnId ::: TeamId ::: OptionalJsonRequest Public.TeamDeleteData ::: JSON -> Galley Response +deleteTeamH :: + Member BrigAccess r => + UserId ::: ConnId ::: TeamId ::: OptionalJsonRequest Public.TeamDeleteData ::: JSON -> + Galley r Response deleteTeamH (zusr ::: zcon ::: tid ::: req ::: _) = do mBody <- fromOptionalJsonBody req deleteTeam zusr zcon tid mBody pure (empty & setStatus status202) -- | 'TeamDeleteData' is only required for binding teams -deleteTeam :: UserId -> ConnId -> TeamId -> Maybe Public.TeamDeleteData -> Galley () +deleteTeam :: + Member BrigAccess r => + UserId -> + ConnId -> + TeamId -> + Maybe Public.TeamDeleteData -> + Galley r () deleteTeam zusr zcon tid mBody = do team <- Data.team tid >>= ifNothing teamNotFound case tdStatus team of @@ -288,7 +322,7 @@ deleteTeam zusr zcon tid mBody = do ensureReAuthorised zusr (body ^. tdAuthPassword) -- This can be called by stern -internalDeleteBindingTeamWithOneMember :: TeamId -> Galley () +internalDeleteBindingTeamWithOneMember :: TeamId -> Galley r () internalDeleteBindingTeamWithOneMember tid = do team <- Data.team tid unless ((view teamBinding . tdTeam <$> team) == Just Binding) $ @@ -299,7 +333,13 @@ internalDeleteBindingTeamWithOneMember tid = do _ -> throwM notAOneMemberTeam -- This function is "unchecked" because it does not validate that the user has the `DeleteTeam` permission. -uncheckedDeleteTeam :: UserId -> Maybe ConnId -> TeamId -> Galley () +uncheckedDeleteTeam :: + forall r. + Members '[BrigAccess, ExternalAccess, GundeckAccess, SparAccess] r => + UserId -> + Maybe ConnId -> + TeamId -> + Galley r () uncheckedDeleteTeam zusr zcon tid = do team <- Data.team tid when (isJust team) $ do @@ -315,7 +355,7 @@ uncheckedDeleteTeam zusr zcon tid = do (ue, be) <- foldrM (createConvDeleteEvents now membs) ([], []) convs let e = newEvent TeamDelete tid now pushDeleteEvents membs e ue - void . forkIO $ void $ External.deliver be + External.deliverAsync be -- TODO: we don't delete bots here, but we should do that, since -- every bot user can only be in a single conversation. Just -- deleting conversations from the database is not enough. @@ -325,7 +365,7 @@ uncheckedDeleteTeam zusr zcon tid = do Data.unsetTeamLegalholdWhitelisted tid Data.deleteTeam tid where - pushDeleteEvents :: [TeamMember] -> Event -> [Push] -> Galley () + pushDeleteEvents :: [TeamMember] -> Event -> [Push] -> Galley r () pushDeleteEvents membs e ue = do o <- view $ options . optSettings let r = list1 (userRecipient zusr) (membersToRecipients (Just zusr) membs) @@ -348,7 +388,7 @@ uncheckedDeleteTeam zusr zcon tid = do [TeamMember] -> TeamConversation -> ([Push], [(BotMember, Conv.Event)]) -> - Galley ([Push], [(BotMember, Conv.Event)]) + Galley r ([Push], [(BotMember, Conv.Event)]) createConvDeleteEvents now teamMembs c (pp, ee) = do localDomain <- viewFederationDomain let qconvId = Qualified (c ^. conversationId) localDomain @@ -365,7 +405,7 @@ uncheckedDeleteTeam zusr zcon tid = do let pp' = maybe pp (\x -> (x & pushConn .~ zcon) : pp) p pure (pp', ee' ++ ee) -getTeamConversationRoles :: UserId -> TeamId -> Galley Public.ConversationRolesList +getTeamConversationRoles :: UserId -> TeamId -> Galley r Public.ConversationRolesList getTeamConversationRoles zusr tid = do mem <- Data.teamMember tid zusr case mem of @@ -375,12 +415,12 @@ getTeamConversationRoles zusr tid = do -- be merged with the team roles (if they exist) pure $ Public.ConversationRolesList wireConvRoles -getTeamMembersH :: UserId ::: TeamId ::: Range 1 Public.HardTruncationLimit Int32 ::: JSON -> Galley Response +getTeamMembersH :: UserId ::: TeamId ::: Range 1 Public.HardTruncationLimit Int32 ::: JSON -> Galley r Response getTeamMembersH (zusr ::: tid ::: maxResults ::: _) = do (memberList, withPerms) <- getTeamMembers zusr tid maxResults pure . json $ teamMemberListJson withPerms memberList -getTeamMembers :: UserId -> TeamId -> Range 1 Public.HardTruncationLimit Int32 -> Galley (Public.TeamMemberList, Public.TeamMember -> Bool) +getTeamMembers :: UserId -> TeamId -> Range 1 Public.HardTruncationLimit Int32 -> Galley r (Public.TeamMemberList, Public.TeamMember -> Bool) getTeamMembers zusr tid maxResults = do Data.teamMember tid zusr >>= \case Nothing -> throwErrorDescriptionType @NotATeamMember @@ -389,7 +429,10 @@ getTeamMembers zusr tid maxResults = do let withPerms = (m `canSeePermsOf`) pure (mems, withPerms) -getTeamMembersCSVH :: UserId ::: TeamId ::: JSON -> Galley Response +getTeamMembersCSVH :: + Member BrigAccess r => + UserId ::: TeamId ::: JSON -> + Galley r Response getTeamMembersCSVH (zusr ::: tid ::: _) = do Data.teamMember tid zusr >>= \case Nothing -> throwM accessDenied @@ -429,7 +472,7 @@ getTeamMembersCSVH (zusr ::: tid ::: _) = do defaultEncodeOptions :: EncodeOptions defaultEncodeOptions = EncodeOptions - { encDelimiter = 44, -- comma + { encDelimiter = fromIntegral (ord ','), encUseCrLf = True, -- to be compatible with Mac and Windows encIncludeHeader = False, -- (so we can flush when the header is on the wire) encQuoting = QuoteAll @@ -460,7 +503,7 @@ getTeamMembersCSVH (zusr ::: tid ::: _) = do tExportUserId = U.userId user } - lookupInviterHandle :: [TeamMember] -> Galley (UserId -> Maybe Handle.Handle) + lookupInviterHandle :: Member BrigAccess r => [TeamMember] -> Galley r (UserId -> Maybe Handle.Handle) lookupInviterHandle members = do let inviterIds :: [UserId] inviterIds = nub $ catMaybes $ fmap fst . view invitation <$> members @@ -476,7 +519,7 @@ getTeamMembersCSVH (zusr ::: tid ::: _) = do userToIdPIssuer :: U.User -> Maybe HttpsUrl userToIdPIssuer usr = case (U.userIdentity >=> U.ssoIdentity) usr of - Just (U.UserSSOId issuer _) -> fromByteString' $ cs issuer + Just (U.UserSSOId (SAML.UserRef issuer _)) -> either (const Nothing) Just . mkHttpsUrl $ issuer ^. SAML.fromIssuer Just _ -> Nothing Nothing -> Nothing @@ -489,17 +532,17 @@ getTeamMembersCSVH (zusr ::: tid ::: _) = do samlNamedId :: User -> Maybe Text samlNamedId = userSSOId >=> \case - (UserSSOId _idp nameId) -> CI.original . SAML.unsafeShowNameID <$> either (const Nothing) pure (SAML.decodeElem (cs nameId)) + (UserSSOId (SAML.UserRef _idp nameId)) -> Just . CI.original . SAML.unsafeShowNameID $ nameId (UserScimExternalId _) -> Nothing -bulkGetTeamMembersH :: UserId ::: TeamId ::: Range 1 Public.HardTruncationLimit Int32 ::: JsonRequest Public.UserIdList ::: JSON -> Galley Response +bulkGetTeamMembersH :: UserId ::: TeamId ::: Range 1 Public.HardTruncationLimit Int32 ::: JsonRequest Public.UserIdList ::: JSON -> Galley r Response bulkGetTeamMembersH (zusr ::: tid ::: maxResults ::: body ::: _) = do UserIdList uids <- fromJsonBody body (memberList, withPerms) <- bulkGetTeamMembers zusr tid maxResults uids pure . json $ teamMemberListJson withPerms memberList -- | like 'getTeamMembers', but with an explicit list of users we are to return. -bulkGetTeamMembers :: UserId -> TeamId -> Range 1 HardTruncationLimit Int32 -> [UserId] -> Galley (TeamMemberList, TeamMember -> Bool) +bulkGetTeamMembers :: UserId -> TeamId -> Range 1 HardTruncationLimit Int32 -> [UserId] -> Galley r (TeamMemberList, TeamMember -> Bool) bulkGetTeamMembers zusr tid maxResults uids = do unless (length uids <= fromIntegral (fromRange maxResults)) $ throwM bulkGetMemberLimitExceeded @@ -511,12 +554,12 @@ bulkGetTeamMembers zusr tid maxResults uids = do hasMore = ListComplete pure (newTeamMemberList mems hasMore, withPerms) -getTeamMemberH :: UserId ::: TeamId ::: UserId ::: JSON -> Galley Response +getTeamMemberH :: UserId ::: TeamId ::: UserId ::: JSON -> Galley r Response getTeamMemberH (zusr ::: tid ::: uid ::: _) = do (member, withPerms) <- getTeamMember zusr tid uid pure . json $ teamMemberJson withPerms member -getTeamMember :: UserId -> TeamId -> UserId -> Galley (Public.TeamMember, Public.TeamMember -> Bool) +getTeamMember :: UserId -> TeamId -> UserId -> Galley r (Public.TeamMember, Public.TeamMember -> Bool) getTeamMember zusr tid uid = do zusrMembership <- Data.teamMember tid zusr case zusrMembership of @@ -527,33 +570,45 @@ getTeamMember zusr tid uid = do Nothing -> throwM teamMemberNotFound Just member -> pure (member, withPerms) -internalDeleteBindingTeamWithOneMemberH :: TeamId -> Galley Response +internalDeleteBindingTeamWithOneMemberH :: TeamId -> Galley r Response internalDeleteBindingTeamWithOneMemberH tid = do internalDeleteBindingTeamWithOneMember tid pure (empty & setStatus status202) -uncheckedGetTeamMemberH :: TeamId ::: UserId ::: JSON -> Galley Response +uncheckedGetTeamMemberH :: TeamId ::: UserId ::: JSON -> Galley r Response uncheckedGetTeamMemberH (tid ::: uid ::: _) = do json <$> uncheckedGetTeamMember tid uid -uncheckedGetTeamMember :: TeamId -> UserId -> Galley TeamMember +uncheckedGetTeamMember :: TeamId -> UserId -> Galley r TeamMember uncheckedGetTeamMember tid uid = do Data.teamMember tid uid >>= ifNothing teamMemberNotFound -uncheckedGetTeamMembersH :: TeamId ::: Range 1 HardTruncationLimit Int32 ::: JSON -> Galley Response +uncheckedGetTeamMembersH :: TeamId ::: Range 1 HardTruncationLimit Int32 ::: JSON -> Galley r Response uncheckedGetTeamMembersH (tid ::: maxResults ::: _) = do json <$> uncheckedGetTeamMembers tid maxResults -uncheckedGetTeamMembers :: TeamId -> Range 1 HardTruncationLimit Int32 -> Galley TeamMemberList +uncheckedGetTeamMembers :: + TeamId -> + Range 1 HardTruncationLimit Int32 -> + Galley r TeamMemberList uncheckedGetTeamMembers tid maxResults = Data.teamMembersWithLimit tid maxResults -addTeamMemberH :: UserId ::: ConnId ::: TeamId ::: JsonRequest Public.NewTeamMember ::: JSON -> Galley Response +addTeamMemberH :: + Members '[BrigAccess, GundeckAccess] r => + UserId ::: ConnId ::: TeamId ::: JsonRequest Public.NewTeamMember ::: JSON -> + Galley r Response addTeamMemberH (zusr ::: zcon ::: tid ::: req ::: _) = do nmem <- fromJsonBody req addTeamMember zusr zcon tid nmem pure empty -addTeamMember :: UserId -> ConnId -> TeamId -> Public.NewTeamMember -> Galley () +addTeamMember :: + Members '[BrigAccess, GundeckAccess] r => + UserId -> + ConnId -> + TeamId -> + Public.NewTeamMember -> + Galley r () addTeamMember zusr zcon tid nmem = do let uid = nmem ^. ntmNewTeamMember . userId Log.debug $ @@ -574,13 +629,20 @@ addTeamMember zusr zcon tid nmem = do void $ addTeamMemberInternal tid (Just zusr) (Just zcon) nmem memList -- This function is "unchecked" because there is no need to check for user binding (invite only). -uncheckedAddTeamMemberH :: TeamId ::: JsonRequest NewTeamMember ::: JSON -> Galley Response +uncheckedAddTeamMemberH :: + Members '[BrigAccess, GundeckAccess] r => + TeamId ::: JsonRequest NewTeamMember ::: JSON -> + Galley r Response uncheckedAddTeamMemberH (tid ::: req ::: _) = do nmem <- fromJsonBody req uncheckedAddTeamMember tid nmem return empty -uncheckedAddTeamMember :: TeamId -> NewTeamMember -> Galley () +uncheckedAddTeamMember :: + Members '[BrigAccess, GundeckAccess] r => + TeamId -> + NewTeamMember -> + Galley r () uncheckedAddTeamMember tid nmem = do mems <- Data.teamMembersForFanout tid (TeamSize sizeBeforeJoin) <- BrigTeam.getSize tid @@ -589,14 +651,24 @@ uncheckedAddTeamMember tid nmem = do billingUserIds <- Journal.getBillingUserIds tid $ Just $ newTeamMemberList ((nmem ^. ntmNewTeamMember) : mems ^. teamMembers) (mems ^. teamMemberListType) Journal.teamUpdate tid (sizeBeforeAdd + 1) billingUserIds -updateTeamMemberH :: UserId ::: ConnId ::: TeamId ::: JsonRequest Public.NewTeamMember ::: JSON -> Galley Response +updateTeamMemberH :: + Members '[BrigAccess, GundeckAccess] r => + UserId ::: ConnId ::: TeamId ::: JsonRequest Public.NewTeamMember ::: JSON -> + Galley r Response updateTeamMemberH (zusr ::: zcon ::: tid ::: req ::: _) = do -- the team member to be updated targetMember <- view ntmNewTeamMember <$> fromJsonBody req updateTeamMember zusr zcon tid targetMember pure empty -updateTeamMember :: UserId -> ConnId -> TeamId -> TeamMember -> Galley () +updateTeamMember :: + forall r. + Members '[BrigAccess, GundeckAccess] r => + UserId -> + ConnId -> + TeamId -> + TeamMember -> + Galley r () updateTeamMember zusr zcon tid targetMember = do let targetId = targetMember ^. userId targetPermissions = targetMember ^. permissions @@ -638,14 +710,14 @@ updateTeamMember zusr zcon tid targetMember = do permissionsRole (previousMember ^. permissions) == Just RoleOwner && permissionsRole targetPermissions /= Just RoleOwner - updateJournal :: Team -> TeamMemberList -> Galley () + updateJournal :: Team -> TeamMemberList -> Galley r () updateJournal team mems = do when (team ^. teamBinding == Binding) $ do (TeamSize size) <- BrigTeam.getSize tid billingUserIds <- Journal.getBillingUserIds tid $ Just mems Journal.teamUpdate tid size billingUserIds - updatePeers :: UserId -> Permissions -> TeamMemberList -> Galley () + updatePeers :: UserId -> Permissions -> TeamMemberList -> Galley r () updatePeers targetId targetPermissions updatedMembers = do -- inform members of the team about the change -- some (privileged) users will be informed about which change was applied @@ -659,7 +731,10 @@ updateTeamMember zusr zcon tid targetMember = do let pushPriv = newPushLocal (updatedMembers ^. teamMemberListType) zusr (TeamEvent ePriv) $ privilegedRecipients for_ pushPriv $ \p -> push1 $ p & pushConn .~ Just zcon -deleteTeamMemberH :: UserId ::: ConnId ::: TeamId ::: UserId ::: OptionalJsonRequest Public.TeamMemberDeleteData ::: JSON -> Galley Response +deleteTeamMemberH :: + Members '[BrigAccess, ExternalAccess, GundeckAccess] r => + UserId ::: ConnId ::: TeamId ::: UserId ::: OptionalJsonRequest Public.TeamMemberDeleteData ::: JSON -> + Galley r Response deleteTeamMemberH (zusr ::: zcon ::: tid ::: remove ::: req ::: _) = do mBody <- fromOptionalJsonBody req deleteTeamMember zusr zcon tid remove mBody >>= \case @@ -671,7 +746,14 @@ data TeamMemberDeleteResult | TeamMemberDeleteCompleted -- | 'TeamMemberDeleteData' is only required for binding teams -deleteTeamMember :: UserId -> ConnId -> TeamId -> UserId -> Maybe Public.TeamMemberDeleteData -> Galley TeamMemberDeleteResult +deleteTeamMember :: + Members '[BrigAccess, ExternalAccess, GundeckAccess] r => + UserId -> + ConnId -> + TeamId -> + UserId -> + Maybe Public.TeamMemberDeleteData -> + Galley r TeamMemberDeleteResult deleteTeamMember zusr zcon tid remove mBody = do Log.debug $ Log.field "targets" (toByteString remove) @@ -706,7 +788,15 @@ deleteTeamMember zusr zcon tid remove mBody = do pure TeamMemberDeleteCompleted -- This function is "unchecked" because it does not validate that the user has the `RemoveTeamMember` permission. -uncheckedDeleteTeamMember :: UserId -> Maybe ConnId -> TeamId -> UserId -> TeamMemberList -> Galley () +uncheckedDeleteTeamMember :: + forall r. + Members '[BrigAccess, GundeckAccess, ExternalAccess] r => + UserId -> + Maybe ConnId -> + TeamId -> + UserId -> + TeamMemberList -> + Galley r () uncheckedDeleteTeamMember zusr zcon tid remove mems = do now <- liftIO getCurrentTime pushMemberLeaveEvent now @@ -714,13 +804,13 @@ uncheckedDeleteTeamMember zusr zcon tid remove mems = do removeFromConvsAndPushConvLeaveEvent now where -- notify all team members. - pushMemberLeaveEvent :: UTCTime -> Galley () + pushMemberLeaveEvent :: UTCTime -> Galley r () pushMemberLeaveEvent now = do let e = newEvent MemberLeave tid now & eventData ?~ EdMemberLeave remove let r = list1 (userRecipient zusr) (membersToRecipients (Just zusr) (mems ^. teamMembers)) push1 $ newPushLocal1 (mems ^. teamMemberListType) zusr (TeamEvent e) r & pushConn .~ zcon -- notify all conversation members not in this team. - removeFromConvsAndPushConvLeaveEvent :: UTCTime -> Galley () + removeFromConvsAndPushConvLeaveEvent :: UTCTime -> Galley r () removeFromConvsAndPushConvLeaveEvent now = do -- This may not make sense if that list has been truncated. In such cases, we still want to -- remove the user from conversations but never send out any events. We assume that clients @@ -736,7 +826,7 @@ uncheckedDeleteTeamMember zusr zcon tid remove mems = do -- If the list was truncated, then the tmids list is incomplete so we simply drop these events unless (c ^. managedConversation || mems ^. teamMemberListType == ListTruncated) $ pushEvent tmids edata now dc - pushEvent :: Set UserId -> Conv.EventData -> UTCTime -> Data.Conversation -> Galley () + pushEvent :: Set UserId -> Conv.EventData -> UTCTime -> Data.Conversation -> Galley r () pushEvent exceptTo edata now dc = do localDomain <- viewFederationDomain let qconvId = Qualified (Data.convId dc) localDomain @@ -746,47 +836,41 @@ uncheckedDeleteTeamMember zusr zcon tid remove mems = do let y = Conv.Event Conv.MemberLeave qconvId qusr now edata for_ (newPushLocal (mems ^. teamMemberListType) zusr (ConvEvent y) (recipient <$> x)) $ \p -> push1 $ p & pushConn .~ zcon - void . forkIO $ void $ External.deliver (bots `zip` repeat y) + External.deliverAsync (bots `zip` repeat y) -getTeamConversations :: UserId -> TeamId -> Galley Public.TeamConversationList +getTeamConversations :: UserId -> TeamId -> Galley r Public.TeamConversationList getTeamConversations zusr tid = do tm <- Data.teamMember tid zusr >>= ifNothing (errorDescriptionTypeToWai @NotATeamMember) unless (tm `hasPermission` GetTeamConversations) $ throwErrorDescription (operationDenied GetTeamConversations) Public.newTeamConversationList <$> Data.teamConversations tid -getTeamConversation :: UserId -> TeamId -> ConvId -> Galley Public.TeamConversation +getTeamConversation :: UserId -> TeamId -> ConvId -> Galley r Public.TeamConversation getTeamConversation zusr tid cid = do tm <- Data.teamMember tid zusr >>= ifNothing (errorDescriptionTypeToWai @NotATeamMember) unless (tm `hasPermission` GetTeamConversations) $ throwErrorDescription (operationDenied GetTeamConversations) Data.teamConversation tid cid >>= maybe (throwErrorDescriptionType @ConvNotFound) pure -deleteTeamConversation :: UserId -> ConnId -> TeamId -> ConvId -> Galley () -deleteTeamConversation zusr zcon tid cid = do - localDomain <- viewFederationDomain - let qconvId = Qualified cid localDomain - qusr = Qualified zusr localDomain - (bots, cmems) <- localBotsAndUsers <$> Data.members cid - ensureActionAllowed Roles.DeleteConversation =<< getSelfMemberFromLocalsLegacy zusr cmems - flip Data.deleteCode Data.ReusableCode =<< Data.mkKey cid - now <- liftIO getCurrentTime - let ce = Conv.Event Conv.ConvDelete qconvId qusr now Conv.EdConvDelete - let recps = fmap recipient cmems - let convPush = newPushLocal ListComplete zusr (ConvEvent ce) recps <&> pushConn .~ Just zcon - pushSome $ maybeToList convPush - void . forkIO $ void $ External.deliver (bots `zip` repeat ce) - -- TODO: we don't delete bots here, but we should do that, since every - -- bot user can only be in a single conversation - Data.removeTeamConv tid cid - -getSearchVisibilityH :: UserId ::: TeamId ::: JSON -> Galley Response +deleteTeamConversation :: + Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + UserId -> + ConnId -> + TeamId -> + ConvId -> + Galley r () +deleteTeamConversation zusr zcon _tid cid = do + lusr <- qualifyLocal zusr + lconv <- qualifyLocal cid + void $ API.deleteLocalConversation lusr zcon lconv + +getSearchVisibilityH :: UserId ::: TeamId ::: JSON -> Galley r Response getSearchVisibilityH (uid ::: tid ::: _) = do zusrMembership <- Data.teamMember tid uid void $ permissionCheck ViewTeamSearchVisibility zusrMembership json <$> getSearchVisibilityInternal tid -setSearchVisibilityH :: UserId ::: TeamId ::: JsonRequest Public.TeamSearchVisibilityView ::: JSON -> Galley Response +setSearchVisibilityH :: UserId ::: TeamId ::: JsonRequest Public.TeamSearchVisibilityView ::: JSON -> Galley r Response setSearchVisibilityH (uid ::: tid ::: req ::: _) = do zusrMembership <- Data.teamMember tid uid void $ permissionCheck ChangeTeamSearchVisibility zusrMembership @@ -809,8 +893,8 @@ withTeamIds :: UserId -> Maybe (Either (Range 1 32 (List TeamId)) TeamId) -> Range 1 100 Int32 -> - (Bool -> [TeamId] -> Galley a) -> - Galley a + (Bool -> [TeamId] -> Galley r a) -> + Galley r a withTeamIds usr range size k = case range of Nothing -> do r <- Data.teamIdsFrom usr Nothing (rcast size) @@ -823,18 +907,17 @@ withTeamIds usr range size k = case range of k False ids {-# INLINE withTeamIds #-} -ensureUnboundUsers :: [UserId] -> Galley () +ensureUnboundUsers :: [UserId] -> Galley r () ensureUnboundUsers uids = do - e <- ask -- We check only 1 team because, by definition, users in binding teams -- can only be part of one team. - ts <- liftIO $ mapConcurrently (evalGalley e . Data.oneUserTeam) uids + ts <- liftGalley0 $ mapConcurrently Data.oneUserTeam uids let teams = toList $ fromList (catMaybes ts) - binds <- liftIO $ mapConcurrently (evalGalley e . Data.teamBinding) teams + binds <- liftGalley0 $ mapConcurrently Data.teamBinding teams when (any ((==) (Just Binding)) binds) $ throwM userBindingExists -ensureNonBindingTeam :: TeamId -> Galley () +ensureNonBindingTeam :: TeamId -> Galley r () ensureNonBindingTeam tid = do team <- Data.team tid >>= ifNothing teamNotFound when ((tdTeam team) ^. teamBinding == Binding) $ @@ -842,7 +925,7 @@ ensureNonBindingTeam tid = do -- ensure that the permissions are not "greater" than the user's copy permissions -- this is used to ensure users cannot "elevate" permissions -ensureNotElevated :: Permissions -> TeamMember -> Galley () +ensureNotElevated :: Permissions -> TeamMember -> Galley r () ensureNotElevated targetPermissions member = unless ( (targetPermissions ^. self) @@ -850,7 +933,7 @@ ensureNotElevated targetPermissions member = ) $ throwM invalidPermissions -ensureNotTooLarge :: TeamId -> Galley TeamSize +ensureNotTooLarge :: Member BrigAccess r => TeamId -> Galley r TeamSize ensureNotTooLarge tid = do o <- view options (TeamSize size) <- BrigTeam.getSize tid @@ -867,19 +950,19 @@ ensureNotTooLarge tid = do -- size unlimited, because we make the assumption that these teams won't turn -- LegalHold off after activation. -- FUTUREWORK: Find a way around the fanout limit. -ensureNotTooLargeForLegalHold :: TeamId -> Int -> Galley () +ensureNotTooLargeForLegalHold :: Member BrigAccess r => TeamId -> Int -> Galley r () ensureNotTooLargeForLegalHold tid teamSize = do whenM (isLegalHoldEnabledForTeam tid) $ do unlessM (teamSizeBelowLimit teamSize) $ do throwM tooManyTeamMembersOnTeamWithLegalhold -ensureNotTooLargeToActivateLegalHold :: TeamId -> Galley () +ensureNotTooLargeToActivateLegalHold :: Member BrigAccess r => TeamId -> Galley r () ensureNotTooLargeToActivateLegalHold tid = do (TeamSize teamSize) <- BrigTeam.getSize tid unlessM (teamSizeBelowLimit (fromIntegral teamSize)) $ do throwM cannotEnableLegalHoldServiceLargeTeam -teamSizeBelowLimit :: Int -> Galley Bool +teamSizeBelowLimit :: Int -> Galley r Bool teamSizeBelowLimit teamSize = do limit <- fromIntegral . fromRange <$> fanoutLimit let withinLimit = teamSize <= limit @@ -890,7 +973,14 @@ teamSizeBelowLimit teamSize = do -- unlimited, see docs of 'ensureNotTooLargeForLegalHold' pure True -addTeamMemberInternal :: TeamId -> Maybe UserId -> Maybe ConnId -> NewTeamMember -> TeamMemberList -> Galley TeamSize +addTeamMemberInternal :: + Members '[BrigAccess, GundeckAccess] r => + TeamId -> + Maybe UserId -> + Maybe ConnId -> + NewTeamMember -> + TeamMemberList -> + Galley r TeamSize addTeamMemberInternal tid origin originConn (view ntmNewTeamMember -> new) memList = do Log.debug $ Log.field "targets" (toByteString (new ^. userId)) @@ -921,20 +1011,21 @@ addTeamMemberInternal tid origin originConn (view ntmNewTeamMember -> new) memLi -- less warped. This is a work-around because we cannot send events to all of a large team. -- See haddocks of module "Galley.API.TeamNotifications" for details. getTeamNotificationsH :: + Member BrigAccess r => UserId ::: Maybe ByteString {- NotificationId -} ::: Range 1 10000 Int32 ::: JSON -> - Galley Response + Galley r Response getTeamNotificationsH (zusr ::: sinceRaw ::: size ::: _) = do since <- parseSince json @Public.QueuedNotificationList <$> APITeamQueue.getTeamNotifications zusr since size where - parseSince :: Galley (Maybe Public.NotificationId) + parseSince :: Galley r (Maybe Public.NotificationId) parseSince = maybe (pure Nothing) (fmap Just . parseUUID) sinceRaw - parseUUID :: ByteString -> Galley Public.NotificationId + parseUUID :: ByteString -> Galley r Public.NotificationId parseUUID raw = maybe (throwM invalidTeamNotificationId) @@ -944,7 +1035,13 @@ getTeamNotificationsH (zusr ::: sinceRaw ::: size ::: _) = do isV1UUID :: UUID.UUID -> Maybe UUID.UUID isV1UUID u = if UUID.version u == 1 then Just u else Nothing -finishCreateTeam :: Team -> TeamMember -> [TeamMember] -> Maybe ConnId -> Galley () +finishCreateTeam :: + Member GundeckAccess r => + Team -> + TeamMember -> + [TeamMember] -> + Maybe ConnId -> + Galley r () finishCreateTeam team owner others zcon = do let zusr = owner ^. userId for_ (owner : others) $ @@ -954,7 +1051,7 @@ finishCreateTeam team owner others zcon = do let r = membersToRecipients Nothing others push1 $ newPushLocal1 ListComplete zusr (TeamEvent e) (list1 (userRecipient zusr) r) & pushConn .~ zcon -withBindingTeam :: UserId -> (TeamId -> Galley b) -> Galley b +withBindingTeam :: UserId -> (TeamId -> Galley r b) -> Galley r b withBindingTeam zusr callback = do tid <- Data.oneUserTeam zusr >>= ifNothing teamNotFound binding <- Data.teamBinding tid >>= ifNothing teamNotFound @@ -962,31 +1059,31 @@ withBindingTeam zusr callback = do Binding -> callback tid NonBinding -> throwM nonBindingTeam -getBindingTeamIdH :: UserId -> Galley Response +getBindingTeamIdH :: UserId -> Galley r Response getBindingTeamIdH = fmap json . getBindingTeamId -getBindingTeamId :: UserId -> Galley TeamId +getBindingTeamId :: UserId -> Galley r TeamId getBindingTeamId zusr = withBindingTeam zusr pure -getBindingTeamMembersH :: UserId -> Galley Response +getBindingTeamMembersH :: UserId -> Galley r Response getBindingTeamMembersH = fmap json . getBindingTeamMembers -getBindingTeamMembers :: UserId -> Galley TeamMemberList +getBindingTeamMembers :: UserId -> Galley r TeamMemberList getBindingTeamMembers zusr = withBindingTeam zusr $ \tid -> Data.teamMembersForFanout tid -canUserJoinTeamH :: TeamId -> Galley Response +canUserJoinTeamH :: Member BrigAccess r => TeamId -> Galley r Response canUserJoinTeamH tid = canUserJoinTeam tid >> pure empty -- This could be extended for more checks, for now we test only legalhold -canUserJoinTeam :: TeamId -> Galley () +canUserJoinTeam :: Member BrigAccess r => TeamId -> Galley r () canUserJoinTeam tid = do lhEnabled <- isLegalHoldEnabledForTeam tid when lhEnabled $ do (TeamSize sizeBeforeJoin) <- BrigTeam.getSize tid ensureNotTooLargeForLegalHold tid (fromIntegral sizeBeforeJoin + 1) -getTeamSearchVisibilityAvailableInternal :: TeamId -> Galley (Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility) +getTeamSearchVisibilityAvailableInternal :: TeamId -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility) getTeamSearchVisibilityAvailableInternal tid = do -- TODO: This is just redundant given there is a decent default defConfig <- do @@ -999,38 +1096,38 @@ getTeamSearchVisibilityAvailableInternal tid = do <$> TeamFeatures.getFeatureStatusNoConfig @'Public.TeamFeatureSearchVisibility tid -- | Modify and get visibility type for a team (internal, no user permission checks) -getSearchVisibilityInternalH :: TeamId ::: JSON -> Galley Response +getSearchVisibilityInternalH :: TeamId ::: JSON -> Galley r Response getSearchVisibilityInternalH (tid ::: _) = json <$> getSearchVisibilityInternal tid -getSearchVisibilityInternal :: TeamId -> Galley TeamSearchVisibilityView +getSearchVisibilityInternal :: TeamId -> Galley r TeamSearchVisibilityView getSearchVisibilityInternal = fmap TeamSearchVisibilityView . SearchVisibilityData.getSearchVisibility -setSearchVisibilityInternalH :: TeamId ::: JsonRequest TeamSearchVisibilityView ::: JSON -> Galley Response +setSearchVisibilityInternalH :: TeamId ::: JsonRequest TeamSearchVisibilityView ::: JSON -> Galley r Response setSearchVisibilityInternalH (tid ::: req ::: _) = do setSearchVisibilityInternal tid =<< fromJsonBody req pure noContent -setSearchVisibilityInternal :: TeamId -> TeamSearchVisibilityView -> Galley () +setSearchVisibilityInternal :: TeamId -> TeamSearchVisibilityView -> Galley r () setSearchVisibilityInternal tid (TeamSearchVisibilityView searchVisibility) = do status <- getTeamSearchVisibilityAvailableInternal tid unless (Public.tfwoStatus status == Public.TeamFeatureEnabled) $ throwM teamSearchVisibilityNotEnabled SearchVisibilityData.setSearchVisibility tid searchVisibility -userIsTeamOwnerH :: TeamId ::: UserId ::: JSON -> Galley Response +userIsTeamOwnerH :: TeamId ::: UserId ::: JSON -> Galley r Response userIsTeamOwnerH (tid ::: uid ::: _) = do userIsTeamOwner tid uid >>= \case True -> pure empty False -> throwM accessDenied -userIsTeamOwner :: TeamId -> UserId -> Galley Bool +userIsTeamOwner :: TeamId -> UserId -> Galley r Bool userIsTeamOwner tid uid = do let asking = uid isTeamOwner . fst <$> getTeamMember asking tid uid -- Queues a team for async deletion -queueTeamDeletion :: TeamId -> UserId -> Maybe ConnId -> Galley () +queueTeamDeletion :: TeamId -> UserId -> Maybe ConnId -> Galley r () queueTeamDeletion tid zusr zcon = do q <- view deleteQueue ok <- Q.tryPush q (TeamItem tid zusr zcon) diff --git a/services/galley/src/Galley/API/Teams/Features.hs b/services/galley/src/Galley/API/Teams/Features.hs index f0a25d91eb..b34917162d 100644 --- a/services/galley/src/Galley/API/Teams/Features.hs +++ b/services/galley/src/Galley/API/Teams/Features.hs @@ -60,6 +60,7 @@ import Galley.App import qualified Galley.Data as Data import qualified Galley.Data.SearchVisibility as SearchVisibilityData import qualified Galley.Data.TeamFeatures as TeamFeatures +import Galley.Effects import Galley.Intra.Push (PushEvent (FeatureConfigEvent), newPush, push1) import Galley.Options import Galley.Types.Teams hiding (newTeam) @@ -83,12 +84,12 @@ data DoAuth = DoAuth UserId | DontDoAuth -- | For team-settings, to administrate team feature configuration. Here we have an admin uid -- and a team id, but no uid of the member for which the feature config holds. getFeatureStatus :: - forall (a :: Public.TeamFeatureName). + forall (a :: Public.TeamFeatureName) r. Public.KnownTeamFeatureName a => - (GetFeatureInternalParam -> Galley (Public.TeamFeatureStatus a)) -> + (GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus a)) -> DoAuth -> TeamId -> - Galley (Public.TeamFeatureStatus a) + Galley r (Public.TeamFeatureStatus a) getFeatureStatus getter doauth tid = do case doauth of DoAuth uid -> do @@ -100,13 +101,13 @@ getFeatureStatus getter doauth tid = do -- | For team-settings, like 'getFeatureStatus'. setFeatureStatus :: - forall (a :: Public.TeamFeatureName). + forall (a :: Public.TeamFeatureName) r. Public.KnownTeamFeatureName a => - (TeamId -> Public.TeamFeatureStatus a -> Galley (Public.TeamFeatureStatus a)) -> + (TeamId -> Public.TeamFeatureStatus a -> Galley r (Public.TeamFeatureStatus a)) -> DoAuth -> TeamId -> Public.TeamFeatureStatus a -> - Galley (Public.TeamFeatureStatus a) + Galley r (Public.TeamFeatureStatus a) setFeatureStatus setter doauth tid status = do case doauth of DoAuth uid -> do @@ -118,11 +119,11 @@ setFeatureStatus setter doauth tid status = do -- | For individual users to get feature config for their account (personal or team). getFeatureConfig :: - forall (a :: Public.TeamFeatureName). + forall (a :: Public.TeamFeatureName) r. Public.KnownTeamFeatureName a => - (GetFeatureInternalParam -> Galley (Public.TeamFeatureStatus a)) -> + (GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus a)) -> UserId -> - Galley (Public.TeamFeatureStatus a) + Galley r (Public.TeamFeatureStatus a) getFeatureConfig getter zusr = do mbTeam <- Data.oneUserTeam zusr case mbTeam of @@ -133,17 +134,17 @@ getFeatureConfig getter zusr = do assertTeamExists tid getter (Right tid) -getAllFeatureConfigs :: UserId -> Galley AllFeatureConfigs +getAllFeatureConfigs :: UserId -> Galley r AllFeatureConfigs getAllFeatureConfigs zusr = do mbTeam <- Data.oneUserTeam zusr zusrMembership <- maybe (pure Nothing) (flip Data.teamMember zusr) mbTeam let getStatus :: - forall (a :: Public.TeamFeatureName). + forall (a :: Public.TeamFeatureName) r. ( Public.KnownTeamFeatureName a, Aeson.ToJSON (Public.TeamFeatureStatus a) ) => - (GetFeatureInternalParam -> Galley (Public.TeamFeatureStatus a)) -> - Galley (Text, Aeson.Value) + (GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus a)) -> + Galley r (Text, Aeson.Value) getStatus getter = do when (isJust mbTeam) $ do void $ permissionCheck (ViewTeamFeature (Public.knownTeamFeatureName @a)) zusrMembership @@ -164,11 +165,11 @@ getAllFeatureConfigs zusr = do getStatus @'Public.TeamFeatureConferenceCalling getConferenceCallingInternal ] -getAllFeaturesH :: UserId ::: TeamId ::: JSON -> Galley Response +getAllFeaturesH :: UserId ::: TeamId ::: JSON -> Galley r Response getAllFeaturesH (uid ::: tid ::: _) = json <$> getAllFeatures uid tid -getAllFeatures :: UserId -> TeamId -> Galley Aeson.Value +getAllFeatures :: UserId -> TeamId -> Galley r Aeson.Value getAllFeatures uid tid = do Aeson.object <$> sequence @@ -184,34 +185,38 @@ getAllFeatures uid tid = do ] where getStatus :: - forall (a :: Public.TeamFeatureName). + forall (a :: Public.TeamFeatureName) r. ( Public.KnownTeamFeatureName a, Aeson.ToJSON (Public.TeamFeatureStatus a) ) => - (GetFeatureInternalParam -> Galley (Public.TeamFeatureStatus a)) -> - Galley (Text, Aeson.Value) + (GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus a)) -> + Galley r (Text, Aeson.Value) getStatus getter = do status <- getFeatureStatus @a getter (DoAuth uid) tid let feature = Public.knownTeamFeatureName @a pure $ (cs (toByteString' feature) Aeson..= status) getFeatureStatusNoConfig :: - forall (a :: Public.TeamFeatureName). + forall (a :: Public.TeamFeatureName) r. (Public.KnownTeamFeatureName a, Public.FeatureHasNoConfig a, TeamFeatures.HasStatusCol a) => - Galley Public.TeamFeatureStatusValue -> + Galley r Public.TeamFeatureStatusValue -> TeamId -> - Galley (Public.TeamFeatureStatus a) + Galley r (Public.TeamFeatureStatus a) getFeatureStatusNoConfig getDefault tid = do defaultStatus <- Public.TeamFeatureStatusNoConfig <$> getDefault fromMaybe defaultStatus <$> TeamFeatures.getFeatureStatusNoConfig @a tid setFeatureStatusNoConfig :: - forall (a :: Public.TeamFeatureName). - (Public.KnownTeamFeatureName a, Public.FeatureHasNoConfig a, TeamFeatures.HasStatusCol a) => - (Public.TeamFeatureStatusValue -> TeamId -> Galley ()) -> + forall (a :: Public.TeamFeatureName) r. + ( Public.KnownTeamFeatureName a, + Public.FeatureHasNoConfig a, + TeamFeatures.HasStatusCol a, + Member GundeckAccess r + ) => + (Public.TeamFeatureStatusValue -> TeamId -> Galley r ()) -> TeamId -> Public.TeamFeatureStatus a -> - Galley (Public.TeamFeatureStatus a) + Galley r (Public.TeamFeatureStatus a) setFeatureStatusNoConfig applyState tid status = do applyState (Public.tfwoStatus status) tid newStatus <- TeamFeatures.setFeatureStatusNoConfig @a tid status @@ -223,24 +228,28 @@ setFeatureStatusNoConfig applyState tid status = do -- the feature flag, so that we get more type safety. type GetFeatureInternalParam = Either (Maybe UserId) TeamId -getSSOStatusInternal :: GetFeatureInternalParam -> Galley (Public.TeamFeatureStatus 'Public.TeamFeatureSSO) +getSSOStatusInternal :: GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureSSO) getSSOStatusInternal = either (const $ Public.TeamFeatureStatusNoConfig <$> getDef) (getFeatureStatusNoConfig @'Public.TeamFeatureSSO getDef) where - getDef :: Galley Public.TeamFeatureStatusValue + getDef :: Galley r Public.TeamFeatureStatusValue getDef = view (options . optSettings . setFeatureFlags . flagSSO) <&> \case FeatureSSOEnabledByDefault -> Public.TeamFeatureEnabled FeatureSSODisabledByDefault -> Public.TeamFeatureDisabled -setSSOStatusInternal :: TeamId -> (Public.TeamFeatureStatus 'Public.TeamFeatureSSO) -> Galley (Public.TeamFeatureStatus 'Public.TeamFeatureSSO) +setSSOStatusInternal :: + Member GundeckAccess r => + TeamId -> + (Public.TeamFeatureStatus 'Public.TeamFeatureSSO) -> + Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureSSO) setSSOStatusInternal = setFeatureStatusNoConfig @'Public.TeamFeatureSSO $ \case Public.TeamFeatureDisabled -> const (throwM disableSsoNotImplemented) Public.TeamFeatureEnabled -> const (pure ()) -getTeamSearchVisibilityAvailableInternal :: GetFeatureInternalParam -> Galley (Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility) +getTeamSearchVisibilityAvailableInternal :: GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility) getTeamSearchVisibilityAvailableInternal = either (const $ Public.TeamFeatureStatusNoConfig <$> getDef) @@ -251,12 +260,16 @@ getTeamSearchVisibilityAvailableInternal = FeatureTeamSearchVisibilityEnabledByDefault -> Public.TeamFeatureEnabled FeatureTeamSearchVisibilityDisabledByDefault -> Public.TeamFeatureDisabled -setTeamSearchVisibilityAvailableInternal :: TeamId -> (Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility) -> Galley (Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility) +setTeamSearchVisibilityAvailableInternal :: + Member GundeckAccess r => + TeamId -> + (Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility) -> + Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility) setTeamSearchVisibilityAvailableInternal = setFeatureStatusNoConfig @'Public.TeamFeatureSearchVisibility $ \case Public.TeamFeatureDisabled -> SearchVisibilityData.resetSearchVisibility Public.TeamFeatureEnabled -> const (pure ()) -getValidateSAMLEmailsInternal :: GetFeatureInternalParam -> Galley (Public.TeamFeatureStatus 'Public.TeamFeatureValidateSAMLEmails) +getValidateSAMLEmailsInternal :: GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureValidateSAMLEmails) getValidateSAMLEmailsInternal = either (const $ Public.TeamFeatureStatusNoConfig <$> getDef) @@ -267,10 +280,14 @@ getValidateSAMLEmailsInternal = -- Use getFeatureStatusWithDefault getDef = pure Public.TeamFeatureDisabled -setValidateSAMLEmailsInternal :: TeamId -> (Public.TeamFeatureStatus 'Public.TeamFeatureValidateSAMLEmails) -> Galley (Public.TeamFeatureStatus 'Public.TeamFeatureValidateSAMLEmails) +setValidateSAMLEmailsInternal :: + Member GundeckAccess r => + TeamId -> + (Public.TeamFeatureStatus 'Public.TeamFeatureValidateSAMLEmails) -> + Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureValidateSAMLEmails) setValidateSAMLEmailsInternal = setFeatureStatusNoConfig @'Public.TeamFeatureValidateSAMLEmails $ \_ _ -> pure () -getDigitalSignaturesInternal :: GetFeatureInternalParam -> Galley (Public.TeamFeatureStatus 'Public.TeamFeatureDigitalSignatures) +getDigitalSignaturesInternal :: GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureDigitalSignatures) getDigitalSignaturesInternal = either (const $ Public.TeamFeatureStatusNoConfig <$> getDef) @@ -281,10 +298,14 @@ getDigitalSignaturesInternal = -- Use getFeatureStatusWithDefault getDef = pure Public.TeamFeatureDisabled -setDigitalSignaturesInternal :: TeamId -> Public.TeamFeatureStatus 'Public.TeamFeatureDigitalSignatures -> Galley (Public.TeamFeatureStatus 'Public.TeamFeatureDigitalSignatures) +setDigitalSignaturesInternal :: + Member GundeckAccess r => + TeamId -> + Public.TeamFeatureStatus 'Public.TeamFeatureDigitalSignatures -> + Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureDigitalSignatures) setDigitalSignaturesInternal = setFeatureStatusNoConfig @'Public.TeamFeatureDigitalSignatures $ \_ _ -> pure () -getLegalholdStatusInternal :: GetFeatureInternalParam -> Galley (Public.TeamFeatureStatus 'Public.TeamFeatureLegalHold) +getLegalholdStatusInternal :: GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureLegalHold) getLegalholdStatusInternal (Left _) = pure $ Public.TeamFeatureStatusNoConfig Public.TeamFeatureDisabled getLegalholdStatusInternal (Right tid) = do @@ -292,7 +313,11 @@ getLegalholdStatusInternal (Right tid) = do True -> Public.TeamFeatureStatusNoConfig Public.TeamFeatureEnabled False -> Public.TeamFeatureStatusNoConfig Public.TeamFeatureDisabled -setLegalholdStatusInternal :: TeamId -> Public.TeamFeatureStatus 'Public.TeamFeatureLegalHold -> Galley (Public.TeamFeatureStatus 'Public.TeamFeatureLegalHold) +setLegalholdStatusInternal :: + Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + TeamId -> + Public.TeamFeatureStatus 'Public.TeamFeatureLegalHold -> + Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureLegalHold) setLegalholdStatusInternal tid status@(Public.tfwoStatus -> statusValue) = do do -- this extra do is to encapsulate the assertions running before the actual operation. @@ -314,42 +339,46 @@ setLegalholdStatusInternal tid status@(Public.tfwoStatus -> statusValue) = do ensureNotTooLargeToActivateLegalHold tid TeamFeatures.setFeatureStatusNoConfig @'Public.TeamFeatureLegalHold tid status -getFileSharingInternal :: GetFeatureInternalParam -> Galley (Public.TeamFeatureStatus 'Public.TeamFeatureFileSharing) +getFileSharingInternal :: GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureFileSharing) getFileSharingInternal = getFeatureStatusWithDefaultConfig @'Public.TeamFeatureFileSharing flagFileSharing . either (const Nothing) Just getFeatureStatusWithDefaultConfig :: - forall (a :: TeamFeatureName). + forall (a :: TeamFeatureName) r. (KnownTeamFeatureName a, TeamFeatures.HasStatusCol a, FeatureHasNoConfig a) => Lens' FeatureFlags (Defaults (Public.TeamFeatureStatus a)) -> Maybe TeamId -> - Galley (Public.TeamFeatureStatus a) + Galley r (Public.TeamFeatureStatus a) getFeatureStatusWithDefaultConfig lens' = maybe (Public.TeamFeatureStatusNoConfig <$> getDef) (getFeatureStatusNoConfig @a getDef) where - getDef :: Galley Public.TeamFeatureStatusValue + getDef :: Galley r Public.TeamFeatureStatusValue getDef = view (options . optSettings . setFeatureFlags . lens') <&> Public.tfwoStatus . view unDefaults -setFileSharingInternal :: TeamId -> Public.TeamFeatureStatus 'Public.TeamFeatureFileSharing -> Galley (Public.TeamFeatureStatus 'Public.TeamFeatureFileSharing) +setFileSharingInternal :: + Member GundeckAccess r => + TeamId -> + Public.TeamFeatureStatus 'Public.TeamFeatureFileSharing -> + Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureFileSharing) setFileSharingInternal = setFeatureStatusNoConfig @'Public.TeamFeatureFileSharing $ \_status _tid -> pure () -getAppLockInternal :: GetFeatureInternalParam -> Galley (Public.TeamFeatureStatus 'Public.TeamFeatureAppLock) +getAppLockInternal :: GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureAppLock) getAppLockInternal mbtid = do Defaults defaultStatus <- view (options . optSettings . setFeatureFlags . flagAppLockDefaults) status <- join <$> (TeamFeatures.getApplockFeatureStatus `mapM` either (const Nothing) Just mbtid) pure $ fromMaybe defaultStatus status -setAppLockInternal :: TeamId -> Public.TeamFeatureStatus 'Public.TeamFeatureAppLock -> Galley (Public.TeamFeatureStatus 'Public.TeamFeatureAppLock) +setAppLockInternal :: TeamId -> Public.TeamFeatureStatus 'Public.TeamFeatureAppLock -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureAppLock) setAppLockInternal tid status = do when (Public.applockInactivityTimeoutSecs (Public.tfwcConfig status) < 30) $ throwM inactivityTimeoutTooLow TeamFeatures.setApplockFeatureStatus tid status -getClassifiedDomainsInternal :: GetFeatureInternalParam -> Galley (Public.TeamFeatureStatus 'Public.TeamFeatureClassifiedDomains) +getClassifiedDomainsInternal :: GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureClassifiedDomains) getClassifiedDomainsInternal _mbtid = do globalConfig <- view (options . optSettings . setFeatureFlags . flagClassifiedDomains) let config = globalConfig @@ -358,7 +387,9 @@ getClassifiedDomainsInternal _mbtid = do Public.TeamFeatureStatusWithConfig Public.TeamFeatureDisabled (Public.TeamFeatureClassifiedDomainsConfig []) Public.TeamFeatureEnabled -> config -getConferenceCallingInternal :: GetFeatureInternalParam -> Galley (Public.TeamFeatureStatus 'Public.TeamFeatureConferenceCalling) +getConferenceCallingInternal :: + GetFeatureInternalParam -> + Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureConferenceCalling) getConferenceCallingInternal (Left (Just uid)) = do getFeatureConfigViaAccount @'Public.TeamFeatureConferenceCalling uid getConferenceCallingInternal (Left Nothing) = do @@ -366,10 +397,14 @@ getConferenceCallingInternal (Left Nothing) = do getConferenceCallingInternal (Right tid) = do getFeatureStatusWithDefaultConfig @'Public.TeamFeatureConferenceCalling flagConferenceCalling (Just tid) -setConferenceCallingInternal :: TeamId -> Public.TeamFeatureStatus 'Public.TeamFeatureConferenceCalling -> Galley (Public.TeamFeatureStatus 'Public.TeamFeatureConferenceCalling) +setConferenceCallingInternal :: + Member GundeckAccess r => + TeamId -> + Public.TeamFeatureStatus 'Public.TeamFeatureConferenceCalling -> + Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureConferenceCalling) setConferenceCallingInternal = setFeatureStatusNoConfig @'Public.TeamFeatureConferenceCalling $ \_status _tid -> pure () -pushFeatureConfigEvent :: TeamId -> Event.Event -> Galley () +pushFeatureConfigEvent :: Member GundeckAccess r => TeamId -> Event.Event -> Galley r () pushFeatureConfigEvent tid event = do memList <- Data.teamMembersForFanout tid when ((memList ^. teamMemberListType) == ListTruncated) $ do @@ -385,7 +420,10 @@ pushFeatureConfigEvent tid event = do -- | (Currently, we only have 'Public.TeamFeatureConferenceCalling' here, but we may have to -- extend this in the future.) -getFeatureConfigViaAccount :: flag ~ 'Public.TeamFeatureConferenceCalling => UserId -> Galley (Public.TeamFeatureStatus flag) +getFeatureConfigViaAccount :: + (flag ~ 'Public.TeamFeatureConferenceCalling) => + UserId -> + Galley r (Public.TeamFeatureStatus flag) getFeatureConfigViaAccount uid = do mgr <- asks (^. manager) brigep <- asks (^. brig) @@ -393,7 +431,7 @@ getFeatureConfigViaAccount uid = do where handleResp :: Either Client.ClientError Public.TeamFeatureStatusNoConfig -> - Galley Public.TeamFeatureStatusNoConfig + Galley r Public.TeamFeatureStatusNoConfig handleResp (Right cfg) = pure cfg handleResp (Left errmsg) = throwM . internalErrorWithDescription . cs . show $ errmsg diff --git a/services/galley/src/Galley/API/Teams/Notifications.hs b/services/galley/src/Galley/API/Teams/Notifications.hs index 7b6128a441..08edac5eb2 100644 --- a/services/galley/src/Galley/API/Teams/Notifications.hs +++ b/services/galley/src/Galley/API/Teams/Notifications.hs @@ -51,6 +51,7 @@ import qualified Data.UUID.V1 as UUID import Galley.API.Error import Galley.App import qualified Galley.Data.TeamNotifications as DataTeamQueue +import Galley.Effects import Galley.Intra.User as Intra import Galley.Types.Teams hiding (newTeam) import Gundeck.Types.Notification @@ -59,10 +60,11 @@ import Network.HTTP.Types import Network.Wai.Utilities getTeamNotifications :: + Member BrigAccess r => UserId -> Maybe NotificationId -> Range 1 10000 Int32 -> - Galley QueuedNotificationList + Galley r QueuedNotificationList getTeamNotifications zusr since size = do tid :: TeamId <- do mtid <- (userTeam . accountUser =<<) <$> Intra.getUser zusr @@ -75,7 +77,7 @@ getTeamNotifications zusr since size = do (DataTeamQueue.resultHasMore page) Nothing -pushTeamEvent :: TeamId -> Event -> Galley () +pushTeamEvent :: TeamId -> Event -> Galley r () pushTeamEvent tid evt = do nid <- mkNotificationId DataTeamQueue.add tid nid (List1.singleton $ toJSONObject evt) diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index 152d0735af..dee504abe4 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -36,9 +36,10 @@ module Galley.API.Update updateLocalConversation, updateConversationAccessUnqualified, updateConversationAccess, + deleteLocalConversation, -- * Managing Members - addMembersH, + addMembersUnqualified, addMembers, updateUnqualifiedSelfMember, updateSelfMember, @@ -49,6 +50,9 @@ module Galley.API.Update removeMemberFromLocalConv, removeMemberFromRemoteConv, + -- * Notifications + notifyConversationMetadataUpdate, + -- * Talking postProteusMessage, postOtrMessageUnqualified, @@ -81,7 +85,6 @@ import Data.Misc (FutureWork (FutureWork)) import Data.Qualified import Data.Range import qualified Data.Set as Set -import Data.Tagged import Data.Time import Galley.API.Error import Galley.API.LegalHold.Conflicts (guardLegalholdPolicyConflicts) @@ -92,6 +95,7 @@ import Galley.App import qualified Galley.Data as Data import Galley.Data.Services as Data import Galley.Data.Types hiding (Conversation) +import Galley.Effects import qualified Galley.External as External import qualified Galley.Intra.Client as Intra import Galley.Intra.Push @@ -106,12 +110,11 @@ import Galley.Types.Teams hiding (Event, EventData (..), EventType (..), self) import Galley.Types.UserList import Galley.Validation import Gundeck.Types.Push.V2 (RecipientClients (..)) -import Imports +import Imports hiding (forkIO) import Network.HTTP.Types import Network.Wai import Network.Wai.Predicate hiding (and, failure, setStatus, _1, _2) import Network.Wai.Utilities -import UnliftIO (pooledForConcurrentlyN) import qualified Wire.API.Conversation as Public import Wire.API.Conversation.Action import qualified Wire.API.Conversation.Code as Public @@ -126,7 +129,8 @@ import Wire.API.ErrorDescription import qualified Wire.API.ErrorDescription as Public import qualified Wire.API.Event.Conversation as Public import qualified Wire.API.Federation.API.Galley as FederatedGalley -import Wire.API.Federation.Error (federationNotImplemented) +import Wire.API.Federation.Client (HasFederatorConfig (..)) +import Wire.API.Federation.Error (federationNotConfigured, federationNotImplemented) import qualified Wire.API.Message as Public import Wire.API.Routes.Public.Galley.Responses import Wire.API.Routes.Public.Util (UpdateResult (..)) @@ -134,21 +138,21 @@ import Wire.API.ServantProto (RawProto (..)) import Wire.API.Team.LegalHold (LegalholdProtectee (..)) import Wire.API.User.Client -acceptConvH :: UserId ::: Maybe ConnId ::: ConvId -> Galley Response +acceptConvH :: Member GundeckAccess r => UserId ::: Maybe ConnId ::: ConvId -> Galley r Response acceptConvH (usr ::: conn ::: cnv) = setStatus status200 . json <$> acceptConv usr conn cnv -acceptConv :: UserId -> Maybe ConnId -> ConvId -> Galley Conversation +acceptConv :: Member GundeckAccess r => UserId -> Maybe ConnId -> ConvId -> Galley r Conversation acceptConv usr conn cnv = do conv <- Data.conversation cnv >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) conv' <- acceptOne2One usr conv conn conversationView usr conv' -blockConvH :: UserId ::: ConvId -> Galley Response +blockConvH :: UserId ::: ConvId -> Galley r Response blockConvH (zusr ::: cnv) = empty <$ blockConv zusr cnv -blockConv :: UserId -> ConvId -> Galley () +blockConv :: UserId -> ConvId -> Galley r () blockConv zusr cnv = do conv <- Data.conversation cnv >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) unless (Data.convType conv `elem` [ConnectConv, One2OneConv]) $ @@ -157,11 +161,19 @@ blockConv zusr cnv = do let mems = Data.convLocalMembers conv when (zusr `isMember` mems) $ Data.removeMember zusr cnv -unblockConvH :: UserId ::: Maybe ConnId ::: ConvId -> Galley Response +unblockConvH :: + Member GundeckAccess r => + UserId ::: Maybe ConnId ::: ConvId -> + Galley r Response unblockConvH (usr ::: conn ::: cnv) = setStatus status200 . json <$> unblockConv usr conn cnv -unblockConv :: UserId -> Maybe ConnId -> ConvId -> Galley Conversation +unblockConv :: + Member GundeckAccess r => + UserId -> + Maybe ConnId -> + ConvId -> + Galley r Conversation unblockConv usr conn cnv = do conv <- Data.conversation cnv >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) unless (Data.convType conv `elem` [ConnectConv, One2OneConv]) $ @@ -178,11 +190,12 @@ handleUpdateResult = \case Unchanged -> empty & setStatus status204 updateConversationAccess :: + Members UpdateConversationActions r => UserId -> ConnId -> Qualified ConvId -> Public.ConversationAccessData -> - Galley (UpdateResult Event) + Galley r (UpdateResult Event) updateConversationAccess usr con qcnv update = do lusr <- qualifyLocal usr let doUpdate = @@ -193,25 +206,27 @@ updateConversationAccess usr con qcnv update = do doUpdate qcnv lusr con update updateConversationAccessUnqualified :: + Members UpdateConversationActions r => UserId -> ConnId -> ConvId -> Public.ConversationAccessData -> - Galley (UpdateResult Event) + Galley r (UpdateResult Event) updateConversationAccessUnqualified usr zcon cnv update = do lusr <- qualifyLocal usr lcnv <- qualifyLocal cnv updateLocalConversationAccess lcnv lusr zcon update updateLocalConversationAccess :: + Members UpdateConversationActions r => Local ConvId -> Local UserId -> ConnId -> Public.ConversationAccessData -> - Galley (UpdateResult Event) + Galley r (UpdateResult Event) updateLocalConversationAccess lcnv lusr con target = getUpdateResult - . updateLocalConversation lcnv (unTagged lusr) (Just con) + . updateLocalConversation lcnv (qUntagged lusr) (Just con) . ConversationActionAccessUpdate $ target @@ -220,81 +235,81 @@ updateRemoteConversationAccess :: Local UserId -> ConnId -> Public.ConversationAccessData -> - Galley (UpdateResult Event) + Galley r (UpdateResult Event) updateRemoteConversationAccess _ _ _ _ = throwM federationNotImplemented performAccessUpdateAction :: + forall r. + Members '[BrigAccess, BotAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => Qualified UserId -> Data.Conversation -> ConversationAccessData -> - MaybeT Galley () + MaybeT (Galley r) () performAccessUpdateAction qusr conv target = do lcnv <- qualifyLocal (Data.convId conv) guard $ Data.convAccessData conv /= target - let (bots, users) = localBotsAndUsers (Data.convLocalMembers conv) -- Remove conversation codes if CodeAccess is revoked when ( CodeAccess `elem` Data.convAccess conv && CodeAccess `notElem` cupAccess target ) $ lift $ do - key <- mkKey (lUnqualified lcnv) + key <- mkKey (tUnqualified lcnv) Data.deleteCode key ReusableCode - -- Depending on a variety of things, some bots and users have to be - -- removed from the conversation. We keep track of them using 'State'. - (newUsers, newBots) <- lift . flip execStateT (users, bots) $ do - -- We might have to remove non-activated members - -- TODO(akshay): Remove Ord instance for AccessRole. It is dangerous - -- to make assumption about the order of roles and implement policy - -- based on those assumptions. - when - ( Data.convAccessRole conv > ActivatedAccessRole - && cupAccessRole target <= ActivatedAccessRole - ) - $ do - mIds <- map lmId <$> use usersL - activated <- fmap User.userId <$> lift (lookupActivatedUsers mIds) - let isActivated user = lmId user `elem` activated - usersL %= filter isActivated - -- In a team-only conversation we also want to remove bots and guests - case (cupAccessRole target, Data.convTeam conv) of - (TeamAccessRole, Just tid) -> do - currentUsers <- use usersL - onlyTeamUsers <- flip filterM currentUsers $ \user -> - lift $ isJust <$> Data.teamMember tid (lmId user) - assign usersL onlyTeamUsers - botsL .= [] - _ -> return () + + -- Determine bots and members to be removed + let filterBotsAndMembers = filterActivated >=> filterTeammates + let current = convBotsAndMembers conv -- initial bots and members + desired <- lift $ filterBotsAndMembers current -- desired bots and members + let toRemove = bmDiff current desired -- bots and members to be removed + -- Update Cassandra - lift $ Data.updateConversationAccess (lUnqualified lcnv) target - -- Remove users and bots - lift . void . forkIO $ do - let removedUsers = map lmId users \\ map lmId newUsers - removedBots = map botMemId bots \\ map botMemId newBots - mapM_ (deleteBot (lUnqualified lcnv)) removedBots - for_ (nonEmpty removedUsers) $ \victims -> do - -- FUTUREWORK: deal with remote members, too, see updateLocalConversation (Jira SQCORE-903) - Data.removeLocalMembersFromLocalConv (lUnqualified lcnv) victims - now <- liftIO getCurrentTime - let qvictims = QualifiedUserIdList . map (unTagged . qualifyAs lcnv) . toList $ victims - let e = Event MemberLeave (unTagged lcnv) qusr now (EdMembersLeave qvictims) - -- push event to all clients, including zconn - -- since updateConversationAccess generates a second (member removal) event here - traverse_ push1 $ - newPushLocal ListComplete (qUnqualified qusr) (ConvEvent e) (recipient <$> users) - void . forkIO $ void $ External.deliver (newBots `zip` repeat e) + lift $ Data.updateConversationAccess (tUnqualified lcnv) target + lift . fireAndForget $ do + -- Remove bots + traverse_ (deleteBot (tUnqualified lcnv)) (map botMemId (toList (bmBots toRemove))) + + -- Update current bots and members + let current' = current {bmBots = bmBots desired} + + -- Remove users and notify everyone + void . for_ (nonEmpty (bmQualifiedMembers lcnv toRemove)) $ \usersToRemove -> do + let action = ConversationActionRemoveMembers usersToRemove + void . runMaybeT $ performAction qusr conv action + notifyConversationMetadataUpdate qusr Nothing lcnv current' action where - usersL :: Lens' ([LocalMember], [BotMember]) [LocalMember] - usersL = _1 - botsL :: Lens' ([LocalMember], [BotMember]) [BotMember] - botsL = _2 + filterActivated :: BotsAndMembers -> Galley r BotsAndMembers + filterActivated bm + | ( Data.convAccessRole conv > ActivatedAccessRole + && cupAccessRole target <= ActivatedAccessRole + ) = do + activated <- map User.userId <$> lookupActivatedUsers (toList (bmLocals bm)) + -- FUTUREWORK: should we also remove non-activated remote users? + pure $ bm {bmLocals = Set.fromList activated} + | otherwise = pure bm + + filterTeammates :: BotsAndMembers -> Galley r BotsAndMembers + filterTeammates bm = do + -- In a team-only conversation we also want to remove bots and guests + case (cupAccessRole target, Data.convTeam conv) of + (TeamAccessRole, Just tid) -> do + onlyTeamUsers <- flip filterM (toList (bmLocals bm)) $ \user -> + isJust <$> Data.teamMember tid user + pure $ + BotsAndMembers + { bmLocals = Set.fromList onlyTeamUsers, + bmBots = mempty, + bmRemotes = mempty + } + _ -> pure bm updateConversationReceiptMode :: + Members UpdateConversationActions r => UserId -> ConnId -> Qualified ConvId -> Public.ConversationReceiptModeUpdate -> - Galley (UpdateResult Event) + Galley r (UpdateResult Event) updateConversationReceiptMode usr zcon qcnv update = do lusr <- qualifyLocal usr let doUpdate = @@ -305,25 +320,27 @@ updateConversationReceiptMode usr zcon qcnv update = do doUpdate qcnv lusr zcon update updateConversationReceiptModeUnqualified :: + Members UpdateConversationActions r => UserId -> ConnId -> ConvId -> Public.ConversationReceiptModeUpdate -> - Galley (UpdateResult Event) + Galley r (UpdateResult Event) updateConversationReceiptModeUnqualified usr zcon cnv update = do lusr <- qualifyLocal usr lcnv <- qualifyLocal cnv updateLocalConversationReceiptMode lcnv lusr zcon update updateLocalConversationReceiptMode :: + Members UpdateConversationActions r => Local ConvId -> Local UserId -> ConnId -> Public.ConversationReceiptModeUpdate -> - Galley (UpdateResult Event) + Galley r (UpdateResult Event) updateLocalConversationReceiptMode lcnv lusr con update = getUpdateResult $ - updateLocalConversation lcnv (unTagged lusr) (Just con) $ + updateLocalConversation lcnv (qUntagged lusr) (Just con) $ ConversationActionReceiptModeUpdate update updateRemoteConversationReceiptMode :: @@ -331,51 +348,76 @@ updateRemoteConversationReceiptMode :: Local UserId -> ConnId -> Public.ConversationReceiptModeUpdate -> - Galley (UpdateResult Event) + Galley r (UpdateResult Event) updateRemoteConversationReceiptMode _ _ _ _ = throwM federationNotImplemented updateConversationMessageTimerUnqualified :: + Members UpdateConversationActions r => UserId -> ConnId -> ConvId -> Public.ConversationMessageTimerUpdate -> - Galley (UpdateResult Event) + Galley r (UpdateResult Event) updateConversationMessageTimerUnqualified usr zcon cnv update = do lusr <- qualifyLocal usr lcnv <- qualifyLocal cnv updateLocalConversationMessageTimer lusr zcon lcnv update updateConversationMessageTimer :: + Members UpdateConversationActions r => UserId -> ConnId -> Qualified ConvId -> Public.ConversationMessageTimerUpdate -> - Galley (UpdateResult Event) + Galley r (UpdateResult Event) updateConversationMessageTimer usr zcon qcnv update = do - localDomain <- viewFederationDomain lusr <- qualifyLocal usr - if qDomain qcnv == localDomain - then updateLocalConversationMessageTimer lusr zcon (toLocal qcnv) update - else throwM federationNotImplemented + foldQualified + lusr + (updateLocalConversationMessageTimer lusr zcon) + (\_ _ -> throwM federationNotImplemented) + qcnv + update updateLocalConversationMessageTimer :: + Members UpdateConversationActions r => Local UserId -> ConnId -> Local ConvId -> Public.ConversationMessageTimerUpdate -> - Galley (UpdateResult Event) + Galley r (UpdateResult Event) updateLocalConversationMessageTimer lusr con lcnv update = getUpdateResult $ - updateLocalConversation lcnv (unTagged lusr) (Just con) $ + updateLocalConversation lcnv (qUntagged lusr) (Just con) $ ConversationActionMessageTimerUpdate update +deleteLocalConversation :: + Members UpdateConversationActions r => + Local UserId -> + ConnId -> + Local ConvId -> + Galley r (UpdateResult Event) +deleteLocalConversation lusr con lcnv = + getUpdateResult $ + updateLocalConversation lcnv (qUntagged lusr) (Just con) ConversationActionDelete + +type UpdateConversationActions = + '[ BotAccess, + BrigAccess, + ExternalAccess, + FederatorAccess, + FireAndForget, + GundeckAccess + ] + -- | Update a local conversation, and notify all local and remote members. updateLocalConversation :: + Members UpdateConversationActions r => Local ConvId -> Qualified UserId -> Maybe ConnId -> ConversationAction -> - MaybeT Galley Event + MaybeT (Galley r) Event updateLocalConversation lcnv qusr con action = do -- retrieve conversation (conv, self) <- @@ -383,7 +425,7 @@ updateLocalConversation lcnv qusr con action = do getConversationAndMemberWithError (errorDescriptionTypeToWai @ConvNotFound) qusr - (lUnqualified lcnv) + (tUnqualified lcnv) -- perform checks lift $ ensureConversationActionAllowed action conv self @@ -397,7 +439,7 @@ updateLocalConversation lcnv qusr con action = do qusr con lcnv - (convTargets conv <> extraTargets) + (convBotsAndMembers conv <> extraTargets) action' getUpdateResult :: Functor m => MaybeT m a -> m (UpdateResult a) @@ -406,15 +448,16 @@ getUpdateResult = fmap (maybe Unchanged Updated) . runMaybeT -- | Perform a conversation action, and return extra notification targets and -- an updated action. performAction :: + Members UpdateConversationActions r => Qualified UserId -> Data.Conversation -> ConversationAction -> - MaybeT Galley (NotificationTargets, ConversationAction) + MaybeT (Galley r) (BotsAndMembers, ConversationAction) performAction qusr conv action = case action of ConversationActionAddMembers members role -> performAddMemberAction qusr conv members role - ConversationActionRemoveMember member -> do - performRemoveMemberAction conv member + ConversationActionRemoveMembers members -> do + performRemoveMemberAction conv (toList members) pure (mempty, action) ConversationActionRename rename -> lift $ do cn <- rangeChecked (cupName rename) @@ -436,8 +479,18 @@ performAction qusr conv action = case action of ConversationActionAccessUpdate update -> do performAccessUpdateAction qusr conv update pure (mempty, action) + ConversationActionDelete -> lift $ do + let cid = Data.convId conv + (`Data.deleteCode` ReusableCode) =<< mkKey cid + case Data.convTeam conv of + Nothing -> Data.deleteConversation cid + Just tid -> Data.removeTeamConv tid cid + pure (mempty, action) -addCodeH :: UserId ::: ConnId ::: ConvId -> Galley Response +addCodeH :: + Members '[ExternalAccess, GundeckAccess] r => + UserId ::: ConnId ::: ConvId -> + Galley r Response addCodeH (usr ::: zcon ::: cnv) = addCode usr zcon cnv <&> \case CodeAdded event -> json event & setStatus status201 @@ -447,7 +500,13 @@ data AddCodeResult = CodeAdded Public.Event | CodeAlreadyExisted Public.ConversationCode -addCode :: UserId -> ConnId -> ConvId -> Galley AddCodeResult +addCode :: + forall r. + Members '[ExternalAccess, GundeckAccess] r => + UserId -> + ConnId -> + ConvId -> + Galley r AddCodeResult addCode usr zcon cnv = do localDomain <- viewFederationDomain let qcnv = Qualified cnv localDomain @@ -471,16 +530,24 @@ addCode usr zcon cnv = do conversationCode <- createCode code pure $ CodeAlreadyExisted conversationCode where - createCode :: Code -> Galley ConversationCode + createCode :: Code -> Galley r ConversationCode createCode code = do urlPrefix <- view $ options . optSettings . setConversationCodeURI return $ mkConversationCode (codeKey code) (codeValue code) urlPrefix -rmCodeH :: UserId ::: ConnId ::: ConvId -> Galley Response +rmCodeH :: + Members '[ExternalAccess, GundeckAccess] r => + UserId ::: ConnId ::: ConvId -> + Galley r Response rmCodeH (usr ::: zcon ::: cnv) = setStatus status200 . json <$> rmCode usr zcon cnv -rmCode :: UserId -> ConnId -> ConvId -> Galley Public.Event +rmCode :: + Members '[ExternalAccess, GundeckAccess] r => + UserId -> + ConnId -> + ConvId -> + Galley r Public.Event rmCode usr zcon cnv = do localDomain <- viewFederationDomain let qcnv = Qualified cnv localDomain @@ -496,11 +563,11 @@ rmCode usr zcon cnv = do pushConversationEvent (Just zcon) event (map lmId users) bots pure event -getCodeH :: UserId ::: ConvId -> Galley Response +getCodeH :: UserId ::: ConvId -> Galley r Response getCodeH (usr ::: cnv) = setStatus status200 . json <$> getCode usr cnv -getCode :: UserId -> ConvId -> Galley Public.ConversationCode +getCode :: UserId -> ConvId -> Galley r Public.ConversationCode getCode usr cnv = do conv <- Data.conversation cnv >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) ensureAccess conv CodeAccess @@ -511,40 +578,62 @@ getCode usr cnv = do >>= ifNothing (errorDescriptionTypeToWai @CodeNotFound) returnCode c -returnCode :: Code -> Galley Public.ConversationCode +returnCode :: Code -> Galley r Public.ConversationCode returnCode c = do urlPrefix <- view $ options . optSettings . setConversationCodeURI pure $ Public.mkConversationCode (codeKey c) (codeValue c) urlPrefix -checkReusableCodeH :: JsonRequest Public.ConversationCode -> Galley Response +checkReusableCodeH :: JsonRequest Public.ConversationCode -> Galley r Response checkReusableCodeH req = do convCode <- fromJsonBody req checkReusableCode convCode pure empty -checkReusableCode :: Public.ConversationCode -> Galley () +checkReusableCode :: Public.ConversationCode -> Galley r () checkReusableCode convCode = void $ verifyReusableCode convCode -joinConversationByReusableCodeH :: UserId ::: ConnId ::: JsonRequest Public.ConversationCode -> Galley Response +joinConversationByReusableCodeH :: + Members '[BrigAccess, FederatorAccess, ExternalAccess, GundeckAccess] r => + UserId ::: ConnId ::: JsonRequest Public.ConversationCode -> + Galley r Response joinConversationByReusableCodeH (zusr ::: zcon ::: req) = do convCode <- fromJsonBody req handleUpdateResult <$> joinConversationByReusableCode zusr zcon convCode -joinConversationByReusableCode :: UserId -> ConnId -> Public.ConversationCode -> Galley (UpdateResult Event) +joinConversationByReusableCode :: + Members '[BrigAccess, FederatorAccess, ExternalAccess, GundeckAccess] r => + UserId -> + ConnId -> + Public.ConversationCode -> + Galley r (UpdateResult Event) joinConversationByReusableCode zusr zcon convCode = do c <- verifyReusableCode convCode joinConversation zusr zcon (codeConversation c) CodeAccess -joinConversationByIdH :: UserId ::: ConnId ::: ConvId ::: JSON -> Galley Response +joinConversationByIdH :: + Members '[BrigAccess, FederatorAccess, ExternalAccess, GundeckAccess] r => + UserId ::: ConnId ::: ConvId ::: JSON -> + Galley r Response joinConversationByIdH (zusr ::: zcon ::: cnv ::: _) = handleUpdateResult <$> joinConversationById zusr zcon cnv -joinConversationById :: UserId -> ConnId -> ConvId -> Galley (UpdateResult Event) +joinConversationById :: + Members '[BrigAccess, FederatorAccess, ExternalAccess, GundeckAccess] r => + UserId -> + ConnId -> + ConvId -> + Galley r (UpdateResult Event) joinConversationById zusr zcon cnv = joinConversation zusr zcon cnv LinkAccess -joinConversation :: UserId -> ConnId -> ConvId -> Access -> Galley (UpdateResult Event) +joinConversation :: + Members '[BrigAccess, FederatorAccess, ExternalAccess, GundeckAccess] r => + UserId -> + ConnId -> + ConvId -> + Access -> + Galley r (UpdateResult Event) joinConversation zusr zcon cnv access = do lusr <- qualifyLocal zusr lcnv <- qualifyLocal cnv @@ -561,38 +650,33 @@ joinConversation zusr zcon cnv access = do addMembersToLocalConversation lcnv (UserList users []) roleNameWireMember lift $ notifyConversationMetadataUpdate - (unTagged lusr) + (qUntagged lusr) (Just zcon) lcnv - (convTargets conv <> extraTargets) + (convBotsAndMembers conv <> extraTargets) action -addMembersH :: UserId ::: ConnId ::: ConvId ::: JsonRequest Public.Invite -> Galley Response -addMembersH (zusr ::: zcon ::: cid ::: req) = do - (Invite u r) <- fromJsonBody req - domain <- viewFederationDomain - let qInvite = Public.InviteQualified (flip Qualified domain <$> toNonEmpty u) r - handleUpdateResult <$> addMembers zusr zcon cid qInvite - -- | Add users to a conversation without performing any checks. Return extra -- notification targets and the action performed. addMembersToLocalConversation :: Local ConvId -> UserList UserId -> RoleName -> - MaybeT Galley (NotificationTargets, ConversationAction) + MaybeT (Galley r) (BotsAndMembers, ConversationAction) addMembersToLocalConversation lcnv users role = do (lmems, rmems) <- lift $ Data.addMembers lcnv (fmap (,role) users) neUsers <- maybe mzero pure . nonEmpty . ulAll lcnv $ users let action = ConversationActionAddMembers neUsers role - pure (ntFromMembers lmems rmems, action) + pure (bmFromMembers lmems rmems, action) performAddMemberAction :: + forall r. + Members UpdateConversationActions r => Qualified UserId -> Data.Conversation -> NonEmpty (Qualified UserId) -> RoleName -> - MaybeT Galley (NotificationTargets, ConversationAction) + MaybeT (Galley r) (BotsAndMembers, ConversationAction) performAddMemberAction qusr conv invited role = do lcnv <- lift $ qualifyLocal (Data.convId conv) let newMembers = ulNewMembers lcnv conv . toUserList lcnv $ invited @@ -600,19 +684,19 @@ performAddMemberAction qusr conv invited role = do ensureMemberLimit (toList (Data.convLocalMembers conv)) newMembers ensureAccess conv InviteAccess checkLocals lcnv (Data.convTeam conv) (ulLocals newMembers) - checkRemoteUsersExist (ulRemotes newMembers) + checkRemotes (ulRemotes newMembers) checkLHPolicyConflictsLocal lcnv (ulLocals newMembers) checkLHPolicyConflictsRemote (FutureWork (ulRemotes newMembers)) addMembersToLocalConversation lcnv newMembers role where userIsMember u = (^. userId . to (== u)) - checkLocals :: Local ConvId -> Maybe TeamId -> [UserId] -> Galley () + checkLocals :: Local ConvId -> Maybe TeamId -> [UserId] -> Galley r () checkLocals lcnv (Just tid) newUsers = do tms <- Data.teamMembersLimited tid newUsers let userMembershipMap = map (\u -> (u, find (userIsMember u) tms)) newUsers ensureAccessRole (Data.convAccessRole conv) userMembershipMap - tcv <- Data.teamConversation tid (lUnqualified lcnv) + tcv <- Data.teamConversation tid (tUnqualified lcnv) when (maybe True (view managedConversation) tcv) $ throwM noAddToManaged ensureConnectedOrSameTeam qusr newUsers @@ -620,7 +704,24 @@ performAddMemberAction qusr conv invited role = do ensureAccessRole (Data.convAccessRole conv) (zip newUsers $ repeat Nothing) ensureConnectedOrSameTeam qusr newUsers - checkLHPolicyConflictsLocal :: Local ConvId -> [UserId] -> Galley () + checkRemotes :: [Remote UserId] -> Galley r () + checkRemotes remotes = do + -- if federator is not configured, we fail early, so we avoid adding + -- remote members to the database + unless (null remotes) $ do + endpoint <- federatorEndpoint + when (isNothing endpoint) $ + throwM federationNotConfigured + + loc <- qualifyLocal () + foldQualified + loc + ensureConnectedToRemotes + (\_ _ -> throwM federationNotImplemented) + qusr + remotes + + checkLHPolicyConflictsLocal :: Local ConvId -> [UserId] -> Galley r () checkLHPolicyConflictsLocal lcnv newUsers = do let convUsers = Data.convLocalMembers conv @@ -647,42 +748,65 @@ performAddMemberAction qusr conv invited role = do then do for_ convUsersLHStatus $ \(mem, status) -> when (consentGiven status == ConsentNotGiven) $ do - qvictim <- unTagged <$> qualifyLocal (lmId mem) + qvictim <- qUntagged <$> qualifyLocal (lmId mem) void . runMaybeT $ updateLocalConversation lcnv qvictim Nothing $ - ConversationActionRemoveMember qvictim + ConversationActionRemoveMembers (pure qvictim) else throwErrorDescriptionType @MissingLegalholdConsent - checkLHPolicyConflictsRemote :: FutureWork 'LegalholdPlusFederationNotImplemented [Remote UserId] -> Galley () + checkLHPolicyConflictsRemote :: FutureWork 'LegalholdPlusFederationNotImplemented [Remote UserId] -> Galley r () checkLHPolicyConflictsRemote _remotes = pure () -addMembers :: UserId -> ConnId -> ConvId -> Public.InviteQualified -> Galley (UpdateResult Event) +addMembersUnqualified :: + Members UpdateConversationActions r => + UserId -> + ConnId -> + ConvId -> + Public.Invite -> + Galley r (UpdateResult Event) +addMembersUnqualified zusr zcon cnv (Public.Invite users role) = do + qusers <- traverse (fmap qUntagged . qualifyLocal) (toNonEmpty users) + addMembers zusr zcon cnv (Public.InviteQualified qusers role) + +addMembers :: + Members UpdateConversationActions r => + UserId -> + ConnId -> + ConvId -> + Public.InviteQualified -> + Galley r (UpdateResult Event) addMembers zusr zcon cnv (Public.InviteQualified users role) = do lusr <- qualifyLocal zusr lcnv <- qualifyLocal cnv getUpdateResult $ - updateLocalConversation lcnv (unTagged lusr) (Just zcon) $ + updateLocalConversation lcnv (qUntagged lusr) (Just zcon) $ ConversationActionAddMembers users role -updateSelfMember :: UserId -> ConnId -> Qualified ConvId -> Public.MemberUpdate -> Galley () +updateSelfMember :: + Members '[GundeckAccess, ExternalAccess] r => + UserId -> + ConnId -> + Qualified ConvId -> + Public.MemberUpdate -> + Galley r () updateSelfMember zusr zcon qcnv update = do lusr <- qualifyLocal zusr exists <- foldQualified lusr checkLocalMembership checkRemoteMembership qcnv lusr unless exists (throwErrorDescriptionType @ConvNotFound) Data.updateSelfMember lusr qcnv lusr update now <- liftIO getCurrentTime - let e = Event MemberStateUpdate qcnv (unTagged lusr) now (EdMemberUpdate (updateData lusr)) + let e = Event MemberStateUpdate qcnv (qUntagged lusr) now (EdMemberUpdate (updateData lusr)) pushConversationEvent (Just zcon) e [zusr] [] where checkLocalMembership lcnv lusr = - isMember (lUnqualified lusr) - <$> Data.members (lUnqualified lcnv) + isMember (tUnqualified lusr) + <$> Data.members (tUnqualified lcnv) checkRemoteMembership rcnv lusr = isJust . Map.lookup rcnv - <$> Data.remoteConversationStatus (lUnqualified lusr) [rcnv] + <$> Data.remoteConversationStatus (tUnqualified lusr) [rcnv] updateData luid = MemberUpdateData - { misTarget = unTagged luid, + { misTarget = qUntagged luid, misOtrMutedStatus = mupOtrMuteStatus update, misOtrMutedRef = mupOtrMuteRef update, misOtrArchived = mupOtrArchive update, @@ -692,47 +816,56 @@ updateSelfMember zusr zcon qcnv update = do misConvRoleName = Nothing } -updateUnqualifiedSelfMember :: UserId -> ConnId -> ConvId -> Public.MemberUpdate -> Galley () +updateUnqualifiedSelfMember :: + Members UpdateConversationActions r => + UserId -> + ConnId -> + ConvId -> + Public.MemberUpdate -> + Galley r () updateUnqualifiedSelfMember zusr zcon cnv update = do lcnv <- qualifyLocal cnv - updateSelfMember zusr zcon (unTagged lcnv) update + updateSelfMember zusr zcon (qUntagged lcnv) update updateOtherMemberUnqualified :: + Members UpdateConversationActions r => UserId -> ConnId -> ConvId -> UserId -> Public.OtherMemberUpdate -> - Galley () + Galley r () updateOtherMemberUnqualified zusr zcon cnv victim update = do lusr <- qualifyLocal zusr lcnv <- qualifyLocal cnv lvictim <- qualifyLocal victim - updateOtherMemberLocalConv lcnv lusr zcon (unTagged lvictim) update + updateOtherMemberLocalConv lcnv lusr zcon (qUntagged lvictim) update updateOtherMember :: + Members UpdateConversationActions r => UserId -> ConnId -> Qualified ConvId -> Qualified UserId -> Public.OtherMemberUpdate -> - Galley () + Galley r () updateOtherMember zusr zcon qcnv qvictim update = do lusr <- qualifyLocal zusr let doUpdate = foldQualified lusr updateOtherMemberLocalConv updateOtherMemberRemoteConv doUpdate qcnv lusr zcon qvictim update updateOtherMemberLocalConv :: + Members UpdateConversationActions r => Local ConvId -> Local UserId -> ConnId -> Qualified UserId -> Public.OtherMemberUpdate -> - Galley () + Galley r () updateOtherMemberLocalConv lcnv lusr con qvictim update = void . getUpdateResult $ do - when (unTagged lusr == qvictim) $ + when (qUntagged lusr == qvictim) $ throwM invalidTargetUserOp - updateLocalConversation lcnv (unTagged lusr) (Just con) $ + updateLocalConversation lcnv (qUntagged lusr) (Just con) $ ConversationActionMemberUpdate qvictim update updateOtherMemberRemoteConv :: @@ -741,33 +874,41 @@ updateOtherMemberRemoteConv :: ConnId -> Qualified UserId -> Public.OtherMemberUpdate -> - Galley () + Galley r () updateOtherMemberRemoteConv _ _ _ _ _ = throwM federationNotImplemented -removeMemberUnqualified :: UserId -> ConnId -> ConvId -> UserId -> Galley RemoveFromConversationResponse +removeMemberUnqualified :: + Members UpdateConversationActions r => + UserId -> + ConnId -> + ConvId -> + UserId -> + Galley r RemoveFromConversationResponse removeMemberUnqualified zusr con cnv victim = do lcnv <- qualifyLocal cnv lvictim <- qualifyLocal victim - removeMemberQualified zusr con (unTagged lcnv) (unTagged lvictim) + removeMemberQualified zusr con (qUntagged lcnv) (qUntagged lvictim) removeMemberQualified :: + Members UpdateConversationActions r => UserId -> ConnId -> Qualified ConvId -> Qualified UserId -> - Galley RemoveFromConversationResponse + Galley r RemoveFromConversationResponse removeMemberQualified zusr con qcnv victim = do lusr <- qualifyLocal zusr foldQualified lusr removeMemberFromLocalConv removeMemberFromRemoteConv qcnv lusr (Just con) victim removeMemberFromRemoteConv :: + Member FederatorAccess r => Remote ConvId -> Local UserId -> Maybe ConnId -> Qualified UserId -> - Galley RemoveFromConversationResponse -removeMemberFromRemoteConv (unTagged -> qcnv) lusr _ victim - | unTagged lusr == victim = + Galley r RemoveFromConversationResponse +removeMemberFromRemoteConv (qUntagged -> qcnv) lusr _ victim + | qUntagged lusr == victim = do let lc = FederatedGalley.LeaveConversationRequest (qUnqualified qcnv) (qUnqualified victim) let rpc = @@ -777,35 +918,39 @@ removeMemberFromRemoteConv (unTagged -> qcnv) lusr _ victim lc t <- liftIO getCurrentTime let successEvent = - Event MemberLeave qcnv (unTagged lusr) t $ + Event MemberLeave qcnv (qUntagged lusr) t $ EdMembersLeave (QualifiedUserIdList [victim]) mapRight (const successEvent) . FederatedGalley.leaveResponse <$> runFederated (qDomain qcnv) rpc | otherwise = pure . Left $ RemoveFromConversationErrorRemovalNotAllowed performRemoveMemberAction :: Data.Conversation -> - Qualified UserId -> - MaybeT Galley () -performRemoveMemberAction conv victim = do + [Qualified UserId] -> + MaybeT (Galley r) () +performRemoveMemberAction conv victims = do loc <- qualifyLocal () - guard $ isConvMember loc conv victim - let removeLocal u c = Data.removeLocalMembersFromLocalConv c (pure (lUnqualified u)) - removeRemote u c = Data.removeRemoteMembersFromLocalConv c (pure u) - lift $ foldQualified loc removeLocal removeRemote victim (Data.convId conv) + let presentVictims = filter (isConvMember loc conv) victims + guard . not . null $ presentVictims + + let (lvictims, rvictims) = partitionQualified loc presentVictims + traverse_ (lift . Data.removeLocalMembersFromLocalConv (Data.convId conv)) (nonEmpty lvictims) + traverse_ (lift . Data.removeRemoteMembersFromLocalConv (Data.convId conv)) (nonEmpty rvictims) -- | Remove a member from a local conversation. removeMemberFromLocalConv :: + Members UpdateConversationActions r => Local ConvId -> Local UserId -> Maybe ConnId -> Qualified UserId -> - Galley RemoveFromConversationResponse + Galley r RemoveFromConversationResponse removeMemberFromLocalConv lcnv lusr con victim = -- FUTUREWORK: actually return errors as part of the response instead of throwing fmap (maybe (Left RemoveFromConversationErrorUnchanged) Right) . runMaybeT - . updateLocalConversation lcnv (unTagged lusr) con - . ConversationActionRemoveMember + . updateLocalConversation lcnv (qUntagged lusr) con + . ConversationActionRemoveMembers + . pure $ victim -- OTR @@ -816,24 +961,39 @@ data OtrResult | OtrUnknownClient !Public.UnknownClient | OtrConversationNotFound !Public.ConvNotFound -handleOtrResult :: OtrResult -> Galley Response +handleOtrResult :: OtrResult -> Galley r Response handleOtrResult = \case OtrSent m -> pure $ json m & setStatus status201 OtrMissingRecipients m -> pure $ json m & setStatus status412 OtrUnknownClient _ -> throwErrorDescriptionType @UnknownClient OtrConversationNotFound _ -> throwErrorDescriptionType @ConvNotFound -postBotMessageH :: BotId ::: ConvId ::: Public.OtrFilterMissing ::: JsonRequest Public.NewOtrMessage ::: JSON -> Galley Response +postBotMessageH :: + Members '[BotAccess, BrigAccess, FederatorAccess, GundeckAccess, ExternalAccess] r => + BotId ::: ConvId ::: Public.OtrFilterMissing ::: JsonRequest Public.NewOtrMessage ::: JSON -> + Galley r Response postBotMessageH (zbot ::: zcnv ::: val ::: req ::: _) = do message <- fromJsonBody req let val' = allowOtrFilterMissingInBody val message handleOtrResult =<< postBotMessage zbot zcnv val' message -postBotMessage :: BotId -> ConvId -> Public.OtrFilterMissing -> Public.NewOtrMessage -> Galley OtrResult +postBotMessage :: + Members '[BotAccess, BrigAccess, FederatorAccess, GundeckAccess, ExternalAccess] r => + BotId -> + ConvId -> + Public.OtrFilterMissing -> + Public.NewOtrMessage -> + Galley r OtrResult postBotMessage zbot zcnv val message = postNewOtrMessage Bot (botUserId zbot) Nothing zcnv val message -postProteusMessage :: UserId -> ConnId -> Qualified ConvId -> RawProto Public.QualifiedNewOtrMessage -> Galley (Public.PostOtrResponse Public.MessageSendingStatus) +postProteusMessage :: + Members '[BotAccess, BrigAccess, FederatorAccess, GundeckAccess, ExternalAccess] r => + UserId -> + ConnId -> + Qualified ConvId -> + RawProto Public.QualifiedNewOtrMessage -> + Galley r (Public.PostOtrResponse Public.MessageSendingStatus) postProteusMessage zusr zcon conv msg = do localDomain <- viewFederationDomain let sender = Qualified zusr localDomain @@ -841,7 +1001,15 @@ postProteusMessage zusr zcon conv msg = do then postRemoteOtrMessage sender conv (rpRaw msg) else postQualifiedOtrMessage User sender (Just zcon) (qUnqualified conv) (rpValue msg) -postOtrMessageUnqualified :: UserId -> ConnId -> ConvId -> Maybe Public.IgnoreMissing -> Maybe Public.ReportMissing -> Public.NewOtrMessage -> Galley (Public.PostOtrResponse Public.ClientMismatch) +postOtrMessageUnqualified :: + Members '[BotAccess, BrigAccess, FederatorAccess, GundeckAccess, ExternalAccess] r => + UserId -> + ConnId -> + ConvId -> + Maybe Public.IgnoreMissing -> + Maybe Public.ReportMissing -> + Public.NewOtrMessage -> + Galley r (Public.PostOtrResponse Public.ClientMismatch) postOtrMessageUnqualified zusr zcon cnv ignoreMissing reportMissing message = do localDomain <- viewFederationDomain let sender = Qualified zusr localDomain @@ -868,19 +1036,31 @@ postOtrMessageUnqualified zusr zcon cnv ignoreMissing reportMissing message = do unqualify localDomain <$> postQualifiedOtrMessage User sender (Just zcon) cnv qualifiedMessage -postProtoOtrBroadcastH :: UserId ::: ConnId ::: Public.OtrFilterMissing ::: Request ::: JSON -> Galley Response +postProtoOtrBroadcastH :: + Members '[BrigAccess, GundeckAccess] r => + UserId ::: ConnId ::: Public.OtrFilterMissing ::: Request ::: JSON -> + Galley r Response postProtoOtrBroadcastH (zusr ::: zcon ::: val ::: req ::: _) = do message <- Public.protoToNewOtrMessage <$> fromProtoBody req let val' = allowOtrFilterMissingInBody val message handleOtrResult =<< postOtrBroadcast zusr zcon val' message -postOtrBroadcastH :: UserId ::: ConnId ::: Public.OtrFilterMissing ::: JsonRequest Public.NewOtrMessage -> Galley Response +postOtrBroadcastH :: + Members '[BrigAccess, GundeckAccess] r => + UserId ::: ConnId ::: Public.OtrFilterMissing ::: JsonRequest Public.NewOtrMessage -> + Galley r Response postOtrBroadcastH (zusr ::: zcon ::: val ::: req) = do message <- fromJsonBody req let val' = allowOtrFilterMissingInBody val message handleOtrResult =<< postOtrBroadcast zusr zcon val' message -postOtrBroadcast :: UserId -> ConnId -> Public.OtrFilterMissing -> Public.NewOtrMessage -> Galley OtrResult +postOtrBroadcast :: + Members '[BrigAccess, GundeckAccess] r => + UserId -> + ConnId -> + Public.OtrFilterMissing -> + Public.NewOtrMessage -> + Galley r OtrResult postOtrBroadcast zusr zcon = postNewOtrBroadcast zusr (Just zcon) -- internal OTR helpers @@ -894,7 +1074,13 @@ allowOtrFilterMissingInBody val (NewOtrMessage _ _ _ _ _ _ mrepmiss) = case mrep Just uids -> OtrReportMissing $ Set.fromList uids -- | bots are not supported on broadcast -postNewOtrBroadcast :: UserId -> Maybe ConnId -> OtrFilterMissing -> NewOtrMessage -> Galley OtrResult +postNewOtrBroadcast :: + Members '[BrigAccess, GundeckAccess] r => + UserId -> + Maybe ConnId -> + OtrFilterMissing -> + NewOtrMessage -> + Galley r OtrResult postNewOtrBroadcast usr con val msg = do localDomain <- viewFederationDomain let qusr = Qualified usr localDomain @@ -905,7 +1091,15 @@ postNewOtrBroadcast usr con val msg = do let (_, toUsers) = foldr (newMessage qusr con Nothing msg now) ([], []) rs pushSome (catMaybes toUsers) -postNewOtrMessage :: UserType -> UserId -> Maybe ConnId -> ConvId -> OtrFilterMissing -> NewOtrMessage -> Galley OtrResult +postNewOtrMessage :: + Members '[BotAccess, BrigAccess, ExternalAccess, GundeckAccess] r => + UserType -> + UserId -> + Maybe ConnId -> + ConvId -> + OtrFilterMissing -> + NewOtrMessage -> + Galley r OtrResult postNewOtrMessage utype usr con cnv val msg = do localDomain <- viewFederationDomain let qusr = Qualified usr localDomain @@ -916,9 +1110,7 @@ postNewOtrMessage utype usr con cnv val msg = do withValidOtrRecipients utype usr sender cnv recvrs val now $ \rs -> do let (toBots, toUsers) = foldr (newMessage qusr con (Just qcnv) msg now) ([], []) rs pushSome (catMaybes toUsers) - void . forkIO $ do - gone <- External.deliver toBots - mapM_ (deleteBot cnv . botMemId) gone + External.deliverAndDeleteAsync cnv toBots newMessage :: Qualified UserId -> @@ -956,84 +1148,95 @@ newMessage qusr con qcnv msg now (m, c, t) ~(toBots, toUsers) = in (toBots, p : toUsers) updateConversationName :: + Members UpdateConversationActions r => UserId -> ConnId -> Qualified ConvId -> Public.ConversationRename -> - Galley (Maybe Public.Event) + Galley r (Maybe Public.Event) updateConversationName zusr zcon qcnv convRename = do lusr <- qualifyLocal zusr - if qDomain qcnv == lDomain lusr - then updateLocalConversationName lusr zcon (toLocal qcnv) convRename - else throwM federationNotImplemented + foldQualified + lusr + (updateLocalConversationName lusr zcon) + (\_ _ -> throwM federationNotImplemented) + qcnv + convRename updateUnqualifiedConversationName :: + Members UpdateConversationActions r => UserId -> ConnId -> ConvId -> Public.ConversationRename -> - Galley (Maybe Public.Event) + Galley r (Maybe Public.Event) updateUnqualifiedConversationName zusr zcon cnv rename = do lusr <- qualifyLocal zusr lcnv <- qualifyLocal cnv updateLocalConversationName lusr zcon lcnv rename updateLocalConversationName :: + Members UpdateConversationActions r => Local UserId -> ConnId -> Local ConvId -> Public.ConversationRename -> - Galley (Maybe Public.Event) + Galley r (Maybe Public.Event) updateLocalConversationName lusr zcon lcnv convRename = do - alive <- Data.isConvAlive (lUnqualified lcnv) + alive <- Data.isConvAlive (tUnqualified lcnv) if alive then updateLiveLocalConversationName lusr zcon lcnv convRename - else Nothing <$ Data.deleteConversation (lUnqualified lcnv) + else Nothing <$ Data.deleteConversation (tUnqualified lcnv) updateLiveLocalConversationName :: + Members UpdateConversationActions r => Local UserId -> ConnId -> Local ConvId -> Public.ConversationRename -> - Galley (Maybe Public.Event) + Galley r (Maybe Public.Event) updateLiveLocalConversationName lusr con lcnv rename = runMaybeT $ - updateLocalConversation lcnv (unTagged lusr) (Just con) $ + updateLocalConversation lcnv (qUntagged lusr) (Just con) $ ConversationActionRename rename notifyConversationMetadataUpdate :: + Members '[FederatorAccess, ExternalAccess, GundeckAccess] r => Qualified UserId -> Maybe ConnId -> Local ConvId -> - NotificationTargets -> + BotsAndMembers -> ConversationAction -> - Galley Event -notifyConversationMetadataUpdate quid con (Tagged qcnv) targets action = do + Galley r Event +notifyConversationMetadataUpdate quid con (qUntagged -> qcnv) targets action = do localDomain <- viewFederationDomain now <- liftIO getCurrentTime let e = conversationActionToEvent now quid qcnv action -- notify remote participants - let rusersByDomain = partitionRemote (toList (ntRemotes targets)) - void . pooledForConcurrentlyN 8 rusersByDomain $ \(domain, uids) -> do - let req = FederatedGalley.ConversationUpdate now quid (qUnqualified qcnv) uids action - rpc = - FederatedGalley.onConversationUpdated - FederatedGalley.clientRoutes - localDomain - req - runFederatedGalley domain rpc + runFederatedConcurrently_ (toList (bmRemotes targets)) $ \ruids -> + FederatedGalley.onConversationUpdated FederatedGalley.clientRoutes localDomain $ + FederatedGalley.ConversationUpdate now quid (qUnqualified qcnv) (tUnqualified ruids) action -- notify local participants and bots - pushConversationEvent con e (ntLocals targets) (ntBots targets) $> e + pushConversationEvent con e (bmLocals targets) (bmBots targets) $> e -isTypingH :: UserId ::: ConnId ::: ConvId ::: JsonRequest Public.TypingData -> Galley Response +isTypingH :: + Member GundeckAccess r => + UserId ::: ConnId ::: ConvId ::: JsonRequest Public.TypingData -> + Galley r Response isTypingH (zusr ::: zcon ::: cnv ::: req) = do typingData <- fromJsonBody req isTyping zusr zcon cnv typingData pure empty -isTyping :: UserId -> ConnId -> ConvId -> Public.TypingData -> Galley () +isTyping :: + Member GundeckAccess r => + UserId -> + ConnId -> + ConvId -> + Public.TypingData -> + Galley r () isTyping zusr zcon cnv typingData = do localDomain <- viewFederationDomain let qcnv = Qualified cnv localDomain @@ -1050,22 +1253,30 @@ isTyping zusr zcon cnv typingData = do & pushRoute .~ RouteDirect & pushTransient .~ True -addServiceH :: JsonRequest Service -> Galley Response +addServiceH :: JsonRequest Service -> Galley r Response addServiceH req = do Data.insertService =<< fromJsonBody req return empty -rmServiceH :: JsonRequest ServiceRef -> Galley Response +rmServiceH :: JsonRequest ServiceRef -> Galley r Response rmServiceH req = do Data.deleteService =<< fromJsonBody req return empty -addBotH :: UserId ::: ConnId ::: JsonRequest AddBot -> Galley Response +addBotH :: + Members '[ExternalAccess, GundeckAccess] r => + UserId ::: ConnId ::: JsonRequest AddBot -> + Galley r Response addBotH (zusr ::: zcon ::: req) = do bot <- fromJsonBody req json <$> addBot zusr zcon bot -addBot :: UserId -> ConnId -> AddBot -> Galley Event +addBot :: + Members '[ExternalAccess, GundeckAccess] r => + UserId -> + ConnId -> + AddBot -> + Galley r Event addBot zusr zcon b = do lusr <- qualifyLocal zusr c <- Data.conversation (b ^. addBotConv) >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) @@ -1074,10 +1285,10 @@ addBot zusr zcon b = do (bots, users) <- regularConvChecks lusr c t <- liftIO getCurrentTime Data.updateClient True (botUserId (b ^. addBotId)) (b ^. addBotClient) - (e, bm) <- Data.addBotMember (unTagged lusr) (b ^. addBotService) (b ^. addBotId) (b ^. addBotConv) t + (e, bm) <- Data.addBotMember (qUntagged lusr) (b ^. addBotService) (b ^. addBotId) (b ^. addBotConv) t for_ (newPushLocal ListComplete zusr (ConvEvent e) (recipient <$> users)) $ \p -> push1 $ p & pushConn ?~ zcon - void . forkIO $ void $ External.deliver ((bm : bots) `zip` repeat e) + External.deliverAsync ((bm : bots) `zip` repeat e) pure e where regularConvChecks lusr c = do @@ -1088,19 +1299,27 @@ addBot zusr zcon b = do ensureActionAllowed AddConversationMember =<< getSelfMemberFromLocalsLegacy zusr users unless (any ((== b ^. addBotId) . botMemId) bots) $ do let botId = qualifyAs lusr (botUserId (b ^. addBotId)) - ensureMemberLimit (toList $ Data.convLocalMembers c) [unTagged botId] + ensureMemberLimit (toList $ Data.convLocalMembers c) [qUntagged botId] return (bots, users) teamConvChecks cid tid = do tcv <- Data.teamConversation tid cid when (maybe True (view managedConversation) tcv) $ throwM noAddToManaged -rmBotH :: UserId ::: Maybe ConnId ::: JsonRequest RemoveBot -> Galley Response +rmBotH :: + Members '[ExternalAccess, GundeckAccess] r => + UserId ::: Maybe ConnId ::: JsonRequest RemoveBot -> + Galley r Response rmBotH (zusr ::: zcon ::: req) = do bot <- fromJsonBody req handleUpdateResult <$> rmBot zusr zcon bot -rmBot :: UserId -> Maybe ConnId -> RemoveBot -> Galley (UpdateResult Event) +rmBot :: + Members '[ExternalAccess, GundeckAccess] r => + UserId -> + Maybe ConnId -> + RemoveBot -> + Galley r (UpdateResult Event) rmBot zusr zcon b = do c <- Data.conversation (b ^. rmBotConv) >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) localDomain <- viewFederationDomain @@ -1119,20 +1338,20 @@ rmBot zusr zcon b = do push1 $ p & pushConn .~ zcon Data.removeMember (botUserId (b ^. rmBotId)) (Data.convId c) Data.eraseClients (botUserId (b ^. rmBotId)) - void . forkIO $ void $ External.deliver (bots `zip` repeat e) + External.deliverAsync (bots `zip` repeat e) pure $ Updated e ------------------------------------------------------------------------------- -- Helpers -ensureMemberLimit :: Foldable f => [LocalMember] -> f a -> Galley () +ensureMemberLimit :: Foldable f => [LocalMember] -> f a -> Galley r () ensureMemberLimit old new = do o <- view options let maxSize = fromIntegral (o ^. optSettings . setMaxConvSize) when (length old + length new > maxSize) $ throwM tooManyMembers -ensureConvMember :: [LocalMember] -> UserId -> Galley () +ensureConvMember :: [LocalMember] -> UserId -> Galley r () ensureConvMember users usr = unless (usr `isMember` users) $ throwErrorDescriptionType @ConvNotFound @@ -1153,13 +1372,14 @@ data CheckedOtrRecipients -- | bots are not supported on broadcast withValidOtrBroadcastRecipients :: + Member BrigAccess r => UserId -> ClientId -> OtrRecipients -> OtrFilterMissing -> UTCTime -> - ([(LocalMember, ClientId, Text)] -> Galley ()) -> - Galley OtrResult + ([(LocalMember, ClientId, Text)] -> Galley r ()) -> + Galley r OtrResult withValidOtrBroadcastRecipients usr clt rcps val now go = withBindingTeam usr $ \tid -> do limit <- fromIntegral . fromRange <$> fanoutLimit -- If we are going to fan this out to more than limit, we want to fail early @@ -1197,6 +1417,7 @@ withValidOtrBroadcastRecipients usr clt rcps val now go = withBindingTeam usr $ pure (mems ^. teamMembers) withValidOtrRecipients :: + Member BrigAccess r => UserType -> UserId -> ClientId -> @@ -1204,8 +1425,8 @@ withValidOtrRecipients :: OtrRecipients -> OtrFilterMissing -> UTCTime -> - ([(LocalMember, ClientId, Text)] -> Galley ()) -> - Galley OtrResult + ([(LocalMember, ClientId, Text)] -> Galley r ()) -> + Galley r OtrResult withValidOtrRecipients utype usr clt cnv rcps val now go = do alive <- Data.isConvAlive cnv if not alive @@ -1223,6 +1444,7 @@ withValidOtrRecipients utype usr clt cnv rcps val now go = do handleOtrResponse utype usr clt rcps localMembers clts val now go handleOtrResponse :: + Member BrigAccess r => -- | Type of proposed sender (user / bot) UserType -> -- | Proposed sender (user) @@ -1240,8 +1462,8 @@ handleOtrResponse :: -- | The current timestamp. UTCTime -> -- | Callback if OtrRecipients are valid - ([(LocalMember, ClientId, Text)] -> Galley ()) -> - Galley OtrResult + ([(LocalMember, ClientId, Text)] -> Galley r ()) -> + Galley r OtrResult handleOtrResponse utype usr clt rcps membs clts val now go = case checkOtrRecipients usr clt rcps membs clts val now of ValidOtrRecipients m r -> go r >> pure (OtrSent m) MissingOtrRecipients m -> do @@ -1334,7 +1556,7 @@ checkOtrRecipients usr sid prs vms vcs val now OtrIgnoreMissing us -> Clients.filter (`Set.notMember` us) miss -- Copied from 'Galley.API.Team' to break import cycles -withBindingTeam :: UserId -> (TeamId -> Galley b) -> Galley b +withBindingTeam :: UserId -> (TeamId -> Galley r b) -> Galley r b withBindingTeam zusr callback = do tid <- Data.oneUserTeam zusr >>= ifNothing teamNotFound binding <- Data.teamBinding tid >>= ifNothing teamNotFound diff --git a/services/galley/src/Galley/API/Util.hs b/services/galley/src/Galley/API/Util.hs index bd21ee4f92..bbcf15950d 100644 --- a/services/galley/src/Galley/API/Util.hs +++ b/services/galley/src/Galley/API/Util.hs @@ -36,7 +36,6 @@ import qualified Data.Map as Map import Data.Misc (PlainTextPassword (..)) import Data.Qualified import qualified Data.Set as Set -import Data.Tagged import qualified Data.Text.Lazy as LT import Data.Time import Galley.API.Error @@ -45,6 +44,7 @@ import qualified Galley.Data as Data import Galley.Data.LegalHold (isTeamLegalholdWhitelisted) import Galley.Data.Services (BotMember, newBotMember) import qualified Galley.Data.Types as DataTypes +import Galley.Effects import qualified Galley.External as External import Galley.Intra.Push import Galley.Intra.User @@ -54,25 +54,25 @@ import Galley.Types.Conversations.Members (localMemberToOther, remoteMemberToOth import Galley.Types.Conversations.Roles import Galley.Types.Teams hiding (Event, MemberJoin, self) import Galley.Types.UserList -import Imports +import Imports hiding (forkIO) import Network.HTTP.Types import Network.Wai import Network.Wai.Predicate hiding (Error) import Network.Wai.Utilities -import UnliftIO (concurrently) +import UnliftIO.Async (concurrently, pooledForConcurrentlyN) import qualified Wire.API.Conversation as Public import Wire.API.Conversation.Action (ConversationAction (..), conversationActionTag) import Wire.API.ErrorDescription import qualified Wire.API.Federation.API.Brig as FederatedBrig import Wire.API.Federation.API.Galley as FederatedGalley import Wire.API.Federation.Client (FederationClientFailure, FederatorClient, executeFederated) -import Wire.API.Federation.Error (federationErrorToWai) +import Wire.API.Federation.Error (federationErrorToWai, federationNotImplemented) import Wire.API.Federation.GRPC.Types (Component (..)) import qualified Wire.API.User as User type JSON = Media "application" "json" -ensureAccessRole :: AccessRole -> [(UserId, Maybe TeamMember)] -> Galley () +ensureAccessRole :: Member BrigAccess r => AccessRole -> [(UserId, Maybe TeamMember)] -> Galley r () ensureAccessRole role users = case role of PrivateAccessRole -> throwErrorDescriptionType @ConvAccessDenied TeamAccessRole -> @@ -89,7 +89,7 @@ ensureAccessRole role users = case role of -- -- Team members are always considered connected, so we only check 'ensureConnected' -- for non-team-members of the _given_ user -ensureConnectedOrSameTeam :: Qualified UserId -> [UserId] -> Galley () +ensureConnectedOrSameTeam :: Member BrigAccess r => Qualified UserId -> [UserId] -> Galley r () ensureConnectedOrSameTeam _ [] = pure () ensureConnectedOrSameTeam (Qualified u domain) uids = do -- FUTUREWORK(federation, #1262): handle remote users (can't be part of the same team, just check connections) @@ -100,29 +100,35 @@ ensureConnectedOrSameTeam (Qualified u domain) uids = do sameTeamUids <- forM uTeams $ \team -> fmap (view userId) <$> Data.teamMembersLimited team uids -- Do not check connections for users that are on the same team - ensureConnected u (uids \\ join sameTeamUids) + ensureConnectedToLocals u (uids \\ join sameTeamUids) -- | Check that the user is connected to everybody else. -- -- The connection has to be bidirectional (e.g. if A connects to B and later -- B blocks A, the status of A-to-B is still 'Accepted' but it doesn't mean -- that they are connected). -ensureConnected :: UserId -> [UserId] -> Galley () -ensureConnected _ [] = pure () -ensureConnected u localUserIds = do - -- FUTUREWORK(federation, #1262): check remote connections - ensureConnectedToLocals u localUserIds +ensureConnected :: Member BrigAccess r => Local UserId -> UserList UserId -> Galley r () +ensureConnected self others = do + ensureConnectedToLocals (tUnqualified self) (ulLocals others) + ensureConnectedToRemotes self (ulRemotes others) -ensureConnectedToLocals :: UserId -> [UserId] -> Galley () +ensureConnectedToLocals :: Member BrigAccess r => UserId -> [UserId] -> Galley r () ensureConnectedToLocals _ [] = pure () -ensureConnectedToLocals u uids = do +ensureConnectedToLocals u uids = liftGalley0 $ do (connsFrom, connsTo) <- - getConnections [u] (Just uids) (Just Accepted) - `concurrently` getConnections uids (Just [u]) (Just Accepted) + getConnectionsUnqualified0 [u] (Just uids) (Just Accepted) + `concurrently` getConnectionsUnqualified0 uids (Just [u]) (Just Accepted) unless (length connsFrom == length uids && length connsTo == length uids) $ throwErrorDescriptionType @NotConnected -ensureReAuthorised :: UserId -> Maybe PlainTextPassword -> Galley () +ensureConnectedToRemotes :: Member BrigAccess r => Local UserId -> [Remote UserId] -> Galley r () +ensureConnectedToRemotes _ [] = pure () +ensureConnectedToRemotes u remotes = do + acceptedConns <- getConnections [tUnqualified u] (Just $ map qUntagged remotes) (Just Accepted) + when (length acceptedConns /= length remotes) $ + throwErrorDescriptionType @NotConnected + +ensureReAuthorised :: Member BrigAccess r => UserId -> Maybe PlainTextPassword -> Galley r () ensureReAuthorised u secret = do reAuthed <- reAuthUser u (ReAuthUser secret) unless reAuthed $ @@ -131,7 +137,7 @@ ensureReAuthorised u secret = do -- | Given a member in a conversation, check if the given action -- is permitted. If the user does not have the given permission, throw -- 'operationDenied'. -ensureActionAllowed :: IsConvMember mem => Action -> mem -> Galley () +ensureActionAllowed :: IsConvMember mem => Action -> mem -> Galley r () ensureActionAllowed action self = case isActionAllowed action (convMemberRole self) of Just True -> pure () Just False -> throwErrorDescription (actionDenied action) @@ -145,7 +151,7 @@ ensureConversationActionAllowed :: ConversationAction -> Data.Conversation -> mem -> - Galley () + Galley r () ensureConversationActionAllowed action conv self = do loc <- qualifyLocal () let tag = conversationActionTag (convMemberId loc self) action @@ -157,6 +163,19 @@ ensureConversationActionAllowed action conv self = do -- extra action-specific checks case action of ConversationActionAddMembers _ role -> ensureConvRoleNotElevated self role + ConversationActionDelete -> do + case Data.convTeam conv of + Just tid -> do + foldQualified + loc + ( \lusr -> do + void $ + Data.teamMember tid (tUnqualified lusr) + >>= ifNothing (errorDescriptionTypeToWai @NotATeamMember) + ) + (\_ -> throwM federationNotImplemented) + (convMemberId loc self) + Nothing -> pure () ConversationActionAccessUpdate target -> do -- 'PrivateAccessRole' is for self-conversations, 1:1 conversations and -- so on; users are not supposed to be able to make other conversations @@ -181,7 +200,7 @@ ensureConversationActionAllowed action conv self = do throwErrorDescriptionType @InvalidTargetAccess _ -> pure () -ensureGroupConvThrowing :: Data.Conversation -> Galley () +ensureGroupConvThrowing :: Data.Conversation -> Galley r () ensureGroupConvThrowing conv = case Data.convType conv of SelfConv -> throwM invalidSelfOp One2OneConv -> throwM invalidOne2OneOp @@ -192,7 +211,7 @@ ensureGroupConvThrowing conv = case Data.convType conv of -- own. This is used to ensure users cannot "elevate" allowed actions -- This function needs to be review when custom roles are introduced since only -- custom roles can cause `roleNameToActions` to return a Nothing -ensureConvRoleNotElevated :: IsConvMember mem => mem -> RoleName -> Galley () +ensureConvRoleNotElevated :: IsConvMember mem => mem -> RoleName -> Galley r () ensureConvRoleNotElevated origMember targetRole = do case (roleNameToActions targetRole, roleNameToActions (convMemberRole origMember)) of (Just targetActions, Just memberActions) -> @@ -204,7 +223,7 @@ ensureConvRoleNotElevated origMember targetRole = do -- | If a team member is not given throw 'notATeamMember'; if the given team -- member does not have the given permission, throw 'operationDenied'. -- Otherwise, return the team member. -permissionCheck :: (IsPerm perm, Show perm) => perm -> Maybe TeamMember -> Galley TeamMember +permissionCheck :: (IsPerm perm, Show perm) => perm -> Maybe TeamMember -> Galley r TeamMember permissionCheck p = \case Just m -> do if m `hasPermission` p @@ -212,14 +231,14 @@ permissionCheck p = \case else throwErrorDescription (operationDenied p) Nothing -> throwErrorDescriptionType @NotATeamMember -assertTeamExists :: TeamId -> Galley () +assertTeamExists :: TeamId -> Galley r () assertTeamExists tid = do teamExists <- isJust <$> Data.team tid if teamExists then pure () else throwM teamNotFound -assertOnTeam :: UserId -> TeamId -> Galley () +assertOnTeam :: UserId -> TeamId -> Galley r () assertOnTeam uid tid = do Data.teamMember tid uid >>= \case Nothing -> throwErrorDescriptionType @NotATeamMember @@ -227,7 +246,7 @@ assertOnTeam uid tid = do -- | If the conversation is in a team, throw iff zusr is a team member and does not have named -- permission. If the conversation is not in a team, do nothing (no error). -permissionCheckTeamConv :: UserId -> ConvId -> Perm -> Galley () +permissionCheckTeamConv :: UserId -> ConvId -> Perm -> Galley r () permissionCheckTeamConv zusr cnv perm = Data.conversation cnv >>= \case Just cnv' -> case Data.convTeam cnv' of @@ -236,7 +255,12 @@ permissionCheckTeamConv zusr cnv perm = Nothing -> throwErrorDescriptionType @ConvNotFound -- | Try to accept a 1-1 conversation, promoting connect conversations as appropriate. -acceptOne2One :: UserId -> Data.Conversation -> Maybe ConnId -> Galley Data.Conversation +acceptOne2One :: + Member GundeckAccess r => + UserId -> + Data.Conversation -> + Maybe ConnId -> + Galley r Data.Conversation acceptOne2One usr conv conn = do lusr <- qualifyLocal usr lcid <- qualifyLocal cid @@ -255,7 +279,7 @@ acceptOne2One usr conv conn = do throwM badConvState now <- liftIO getCurrentTime mm <- Data.addMember lcid lusr - let e = memberJoinEvent lusr (unTagged lcid) now mm [] + let e = memberJoinEvent lusr (qUntagged lcid) now mm [] conv' <- if isJust (find ((usr /=) . lmId) mems) then promote else pure conv let mems' = mems <> toList mm for_ (newPushLocal ListComplete usr (ConvEvent e) (recipient <$> mems')) $ \p -> @@ -281,11 +305,11 @@ memberJoinEvent :: [RemoteMember] -> Event memberJoinEvent lorig qconv t lmems rmems = - Event MemberJoin qconv (unTagged lorig) t $ + Event MemberJoin qconv (qUntagged lorig) t $ EdMembersJoin (SimpleMembers (map localToSimple lmems <> map remoteToSimple rmems)) where - localToSimple u = SimpleMember (unTagged (qualifyAs lorig (lmId u))) (lmConvRoleName u) - remoteToSimple u = SimpleMember (unTagged (rmId u)) (rmConvRoleName u) + localToSimple u = SimpleMember (qUntagged (qualifyAs lorig (lmId u))) (lmConvRoleName u) + remoteToSimple u = SimpleMember (qUntagged (rmId u)) (rmConvRoleName u) isBot :: LocalMember -> Bool isBot = isJust . lmService @@ -309,7 +333,7 @@ instance IsConvMemberId UserId LocalMember where getConvMember _ conv u = find ((u ==) . lmId) (Data.convLocalMembers conv) instance IsConvMemberId (Local UserId) LocalMember where - getConvMember loc conv = getConvMember loc conv . lUnqualified + getConvMember loc conv = getConvMember loc conv . tUnqualified instance IsConvMemberId (Remote UserId) RemoteMember where getConvMember _ conv u = find ((u ==) . rmId) (Data.convRemoteMembers conv) @@ -327,11 +351,11 @@ class IsConvMember mem where instance IsConvMember LocalMember where convMemberRole = lmConvRoleName - convMemberId loc mem = unTagged (qualifyAs loc (lmId mem)) + convMemberId loc mem = qUntagged (qualifyAs loc (lmId mem)) instance IsConvMember RemoteMember where convMemberRole = rmConvRoleName - convMemberId _ = unTagged . rmId + convMemberId _ = qUntagged . rmId instance IsConvMember (Either LocalMember RemoteMember) where convMemberRole = either convMemberRole convMemberRole @@ -348,47 +372,60 @@ ulNewMembers loc conv (UserList locals remotes) = -- of the user id. Local user IDs get added to the local targets, remote user IDs -- to remote targets, and qualified user IDs get added to the appropriate list -- according to whether they are local or remote, by making a runtime check. -class IsNotificationTarget uid where - ntAdd :: Local x -> uid -> NotificationTargets -> NotificationTargets +class IsBotOrMember uid where + bmAdd :: Local x -> uid -> BotsAndMembers -> BotsAndMembers -data NotificationTargets = NotificationTargets - { ntLocals :: Set UserId, - ntRemotes :: Set (Remote UserId), - ntBots :: Set BotMember +data BotsAndMembers = BotsAndMembers + { bmLocals :: Set UserId, + bmRemotes :: Set (Remote UserId), + bmBots :: Set BotMember } -instance Semigroup NotificationTargets where - NotificationTargets locals1 remotes1 bots1 - <> NotificationTargets locals2 remotes2 bots2 = - NotificationTargets +bmQualifiedMembers :: Local x -> BotsAndMembers -> [Qualified UserId] +bmQualifiedMembers loc bm = + map (qUntagged . qualifyAs loc) (toList (bmLocals bm)) + <> map qUntagged (toList (bmRemotes bm)) + +instance Semigroup BotsAndMembers where + BotsAndMembers locals1 remotes1 bots1 + <> BotsAndMembers locals2 remotes2 bots2 = + BotsAndMembers (locals1 <> locals2) (remotes1 <> remotes2) (bots1 <> bots2) -instance Monoid NotificationTargets where - mempty = NotificationTargets mempty mempty mempty +instance Monoid BotsAndMembers where + mempty = BotsAndMembers mempty mempty mempty + +instance IsBotOrMember (Local UserId) where + bmAdd _ luid bm = + bm {bmLocals = Set.insert (tUnqualified luid) (bmLocals bm)} -instance IsNotificationTarget (Local UserId) where - ntAdd _ luid nt = - nt {ntLocals = Set.insert (lUnqualified luid) (ntLocals nt)} +instance IsBotOrMember (Remote UserId) where + bmAdd _ ruid bm = bm {bmRemotes = Set.insert ruid (bmRemotes bm)} -instance IsNotificationTarget (Remote UserId) where - ntAdd _ ruid nt = nt {ntRemotes = Set.insert ruid (ntRemotes nt)} +instance IsBotOrMember (Qualified UserId) where + bmAdd loc = foldQualified loc (bmAdd loc) (bmAdd loc) -instance IsNotificationTarget (Qualified UserId) where - ntAdd loc = foldQualified loc (ntAdd loc) (ntAdd loc) +bmDiff :: BotsAndMembers -> BotsAndMembers -> BotsAndMembers +bmDiff bm1 bm2 = + BotsAndMembers + { bmLocals = Set.difference (bmLocals bm1) (bmLocals bm2), + bmRemotes = Set.difference (bmRemotes bm1) (bmRemotes bm2), + bmBots = Set.difference (bmBots bm1) (bmBots bm2) + } -ntFromMembers :: [LocalMember] -> [RemoteMember] -> NotificationTargets -ntFromMembers lmems rusers = case localBotsAndUsers lmems of +bmFromMembers :: [LocalMember] -> [RemoteMember] -> BotsAndMembers +bmFromMembers lmems rusers = case localBotsAndUsers lmems of (bots, lusers) -> - NotificationTargets - { ntLocals = Set.fromList (map lmId lusers), - ntRemotes = Set.fromList (map rmId rusers), - ntBots = Set.fromList bots + BotsAndMembers + { bmLocals = Set.fromList (map lmId lusers), + bmRemotes = Set.fromList (map rmId rusers), + bmBots = Set.fromList bots } -convTargets :: Data.Conversation -> NotificationTargets -convTargets conv = ntFromMembers (Data.convLocalMembers conv) (Data.convRemoteMembers conv) +convBotsAndMembers :: Data.Conversation -> BotsAndMembers +convBotsAndMembers conv = bmFromMembers (Data.convLocalMembers conv) (Data.convRemoteMembers conv) localBotsAndUsers :: Foldable f => f LocalMember -> ([BotMember], [LocalMember]) localBotsAndUsers = foldMap botOrUser @@ -429,12 +466,12 @@ getSelfMemberFromLocals :: ExceptT ConvNotFound m LocalMember getSelfMemberFromLocals = getLocalMember (mkErrorDescription :: ConvNotFound) --- | A legacy version of 'getSelfMemberFromLocals' that runs in the Galley monad. +-- | A legacy version of 'getSelfMemberFromLocals' that runs in the Galley r monad. getSelfMemberFromLocalsLegacy :: Foldable t => UserId -> t LocalMember -> - Galley LocalMember + Galley r LocalMember getSelfMemberFromLocalsLegacy usr lmems = eitherM throwErrorDescription pure . runExceptT $ getSelfMemberFromLocals usr lmems @@ -444,27 +481,11 @@ ensureOtherMember :: Local a -> Qualified UserId -> Data.Conversation -> - Galley (Either LocalMember RemoteMember) + Galley r (Either LocalMember RemoteMember) ensureOtherMember loc quid conv = maybe (throwErrorDescriptionType @ConvMemberNotFound) pure $ - (Left <$> find ((== quid) . (`Qualified` lDomain loc) . lmId) (Data.convLocalMembers conv)) - <|> (Right <$> find ((== quid) . unTagged . rmId) (Data.convRemoteMembers conv)) - --- | Note that we use 2 nearly identical functions but slightly different --- semantics; when using `getSelfMemberQualified`, if that user is _not_ part of --- the conversation, we don't want to disclose that such a conversation with --- that id exists. -getSelfMemberQualified :: - (Foldable t, Monad m) => - Domain -> - Qualified UserId -> - t LocalMember -> - t RemoteMember -> - ExceptT ConvNotFound m (Either LocalMember RemoteMember) -getSelfMemberQualified localDomain qusr@(Qualified usr userDomain) lmems rmems = do - if localDomain == userDomain - then Left <$> getSelfMemberFromLocals usr lmems - else Right <$> getSelfMemberFromRemotes (toRemote qusr) rmems + (Left <$> find ((== quid) . qUntagged . qualifyAs loc . lmId) (Data.convLocalMembers conv)) + <|> (Right <$> find ((== quid) . qUntagged . rmId) (Data.convRemoteMembers conv)) getSelfMemberFromRemotes :: (Foldable t, Monad m) => @@ -473,7 +494,7 @@ getSelfMemberFromRemotes :: ExceptT ConvNotFound m RemoteMember getSelfMemberFromRemotes = getRemoteMember (mkErrorDescription :: ConvNotFound) -getSelfMemberFromRemotesLegacy :: Foldable t => Remote UserId -> t RemoteMember -> Galley RemoteMember +getSelfMemberFromRemotesLegacy :: Foldable t => Remote UserId -> t RemoteMember -> Galley r RemoteMember getSelfMemberFromRemotesLegacy usr rmems = eitherM throwErrorDescription pure . runExceptT $ getSelfMemberFromRemotes usr rmems @@ -506,7 +527,7 @@ getQualifiedMember :: getQualifiedMember loc e qusr conv = foldQualified loc - (\lusr -> Left <$> getLocalMember e (lUnqualified lusr) (Data.convLocalMembers conv)) + (\lusr -> Left <$> getLocalMember e (tUnqualified lusr) (Data.convLocalMembers conv)) (\rusr -> Right <$> getRemoteMember e rusr (Data.convRemoteMembers conv)) qusr @@ -523,7 +544,10 @@ getMember :: ExceptT e m mem getMember p ex u = hoistEither . note ex . find ((u ==) . p) -getConversationAndCheckMembership :: UserId -> ConvId -> Galley Data.Conversation +getConversationAndCheckMembership :: + UserId -> + ConvId -> + Galley r Data.Conversation getConversationAndCheckMembership uid cnv = do (conv, _) <- getConversationAndMemberWithError @@ -537,7 +561,7 @@ getConversationAndMemberWithError :: Error -> uid -> ConvId -> - Galley (Data.Conversation, mem) + Galley r (Data.Conversation, mem) getConversationAndMemberWithError ex usr convId = do c <- Data.conversation convId >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) when (DataTypes.isConvDeleted c) $ do @@ -567,14 +591,20 @@ canDeleteMember deleter deletee getRole mem = fromMaybe RoleMember $ permissionsRole $ mem ^. permissions -- | Send an event to local users and bots -pushConversationEvent :: Foldable f => Maybe ConnId -> Event -> f UserId -> f BotMember -> Galley () +pushConversationEvent :: + (Members '[GundeckAccess, ExternalAccess] r, Foldable f) => + Maybe ConnId -> + Event -> + f UserId -> + f BotMember -> + Galley r () pushConversationEvent conn e users bots = do localDomain <- viewFederationDomain for_ (newConversationEventPush localDomain e (toList users)) $ \p -> push1 $ p & set pushConn conn - void . forkIO $ void $ External.deliver (toList bots `zip` repeat e) + External.deliverAsync (toList bots `zip` repeat e) -verifyReusableCode :: ConversationCode -> Galley DataTypes.Code +verifyReusableCode :: ConversationCode -> Galley r DataTypes.Code verifyReusableCode convCode = do c <- Data.lookupCode (conversationKey convCode) DataTypes.ReusableCode @@ -583,7 +613,7 @@ verifyReusableCode convCode = do throwM (errorDescriptionTypeToWai @CodeNotFound) return c -ensureConversationAccess :: UserId -> ConvId -> Access -> Galley Data.Conversation +ensureConversationAccess :: Member BrigAccess r => UserId -> ConvId -> Access -> Galley r Data.Conversation ensureConversationAccess zusr cnv access = do conv <- Data.conversation cnv >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) ensureAccess conv access @@ -591,7 +621,7 @@ ensureConversationAccess zusr cnv access = do ensureAccessRole (Data.convAccessRole conv) [(zusr, zusrMembership)] pure conv -ensureAccess :: Data.Conversation -> Access -> Galley () +ensureAccess :: Data.Conversation -> Access -> Galley r () ensureAccess conv access = unless (access `elem` Data.convAccess conv) $ throwErrorDescriptionType @ConvAccessDenied @@ -603,16 +633,18 @@ viewFederationDomain :: MonadReader Env m => m Domain viewFederationDomain = view (options . optSettings . setFederationDomain) qualifyLocal :: MonadReader Env m => a -> m (Local a) -qualifyLocal a = fmap (toLocal . Qualified a) viewFederationDomain +qualifyLocal a = toLocalUnsafe <$> viewFederationDomain <*> pure a -checkRemoteUsersExist :: (Functor f, Foldable f) => f (Remote UserId) -> Galley () +checkRemoteUsersExist :: + (Member FederatorAccess r, Functor f, Foldable f) => + f (Remote UserId) -> + Galley r () checkRemoteUsersExist = -- FUTUREWORK: pooledForConcurrentlyN_ instead of sequential checks per domain - traverse_ (uncurry checkRemotesFor) - . partitionRemote + traverse_ checkRemotesFor . bucketRemote -checkRemotesFor :: Domain -> [UserId] -> Galley () -checkRemotesFor domain uids = do +checkRemotesFor :: Member FederatorAccess r => Remote [UserId] -> Galley r () +checkRemotesFor (qUntagged -> Qualified uids domain) = do let rpc = FederatedBrig.getUsersByIds FederatedBrig.clientRoutes uids users <- runFederatedBrig domain rpc let uids' = @@ -622,23 +654,61 @@ checkRemotesFor domain uids = do unless (Set.fromList uids == Set.fromList uids') $ throwM unknownRemoteUser -type FederatedGalleyRPC c a = FederatorClient c (ExceptT FederationClientFailure Galley) a - -runFederatedGalley :: Domain -> FederatedGalleyRPC 'Galley a -> Galley a -runFederatedGalley = runFederated @'Galley +type FederatedGalleyRPC c a = FederatorClient c (ExceptT FederationClientFailure Galley0) a -runFederatedBrig :: Domain -> FederatedGalleyRPC 'Brig a -> Galley a -runFederatedBrig = runFederated @'Brig - -runFederated :: forall (c :: Component) a. Domain -> FederatorClient c (ExceptT FederationClientFailure Galley) a -> Galley a -runFederated remoteDomain rpc = do +runFederated0 :: + forall (c :: Component) a. + Domain -> + FederatedGalleyRPC c a -> + Galley0 a +runFederated0 remoteDomain rpc = do runExceptT (executeFederated remoteDomain rpc) >>= either (throwM . federationErrorToWai) pure +runFederatedGalley :: + Member FederatorAccess r => + Domain -> + FederatedGalleyRPC 'Galley a -> + Galley r a +runFederatedGalley = runFederated + +runFederatedBrig :: + Member FederatorAccess r => + Domain -> + FederatedGalleyRPC 'Brig a -> + Galley r a +runFederatedBrig = runFederated + +runFederated :: + forall (c :: Component) r a. + Member FederatorAccess r => + Domain -> + FederatedGalleyRPC c a -> + Galley r a +runFederated remoteDomain = liftGalley0 . runFederated0 remoteDomain + +runFederatedConcurrently :: + Member FederatorAccess r => + (Foldable f, Functor f) => + f (Remote a) -> + (Remote [a] -> FederatedGalleyRPC c b) -> + Galley r [Remote b] +runFederatedConcurrently xs rpc = liftGalley0 $ + pooledForConcurrentlyN 8 (bucketRemote xs) $ \r -> + qualifyAs r <$> runFederated0 (tDomain r) (rpc r) + +runFederatedConcurrently_ :: + Member FederatorAccess r => + (Foldable f, Functor f) => + f (Remote a) -> + (Remote [a] -> FederatedGalleyRPC c ()) -> + Galley r () +runFederatedConcurrently_ xs = void . runFederatedConcurrently xs + -- | Convert an internal conversation representation 'Data.Conversation' to -- 'NewRemoteConversation' to be sent over the wire to a remote backend that will -- reconstruct this into multiple public-facing --- 'Wire.API.Conversation.Convevrsation' values, one per user from that remote +-- 'Wire.API.Conversation.Conversation' values, one per user from that remote -- backend. -- -- FUTUREWORK: Include the team ID as well once it becomes qualified. @@ -654,13 +724,13 @@ toNewRemoteConversation :: toNewRemoteConversation now localDomain Data.Conversation {..} = NewRemoteConversation { rcTime = now, - rcOrigUserId = Qualified convCreator localDomain, + rcOrigUserId = convCreator, rcCnvId = convId, rcCnvType = convType, rcCnvAccess = convAccess, rcCnvAccessRole = convAccessRole, rcCnvName = convName, - rcMembers = toMembers convLocalMembers convRemoteMembers, + rcNonCreatorMembers = toMembers (filter (\lm -> lmId lm /= convCreator) convLocalMembers) convRemoteMembers, rcMessageTimer = convMessageTimer, rcReceiptMode = convReceiptMode } @@ -680,19 +750,24 @@ toNewRemoteConversation now localDomain Data.Conversation {..} = -- be sent out to users informing them that they were added to a new -- conversation. fromNewRemoteConversation :: - Domain -> - NewRemoteConversation (Qualified ConvId) -> + Local x -> + NewRemoteConversation (Remote ConvId) -> [(Public.Member, Public.Conversation)] -fromNewRemoteConversation d NewRemoteConversation {..} = - let membersView = fmap (second Set.toList) . setHoles $ rcMembers +fromNewRemoteConversation loc rc@NewRemoteConversation {..} = + let membersView = fmap (second Set.toList) . setHoles $ rcNonCreatorMembers + creatorOther = + OtherMember + (qUntagged (rcRemoteOrigUserId rc)) + Nothing + roleNameWireAdmin in foldMap ( \(me, others) -> - guard (inDomain me) $> let mem = toMember me in (mem, conv mem others) + guard (inDomain me) $> let mem = toMember me in (mem, conv mem (creatorOther : others)) ) membersView where inDomain :: OtherMember -> Bool - inDomain = (== d) . qDomain . omQualifiedId + inDomain = (== tDomain loc) . qDomain . omQualifiedId setHoles :: Ord a => Set a -> [(a, Set a)] setHoles s = foldMap (\x -> [(x, Set.delete x s)]) s -- Currently this function creates a Member with default conversation attributes @@ -700,7 +775,7 @@ fromNewRemoteConversation d NewRemoteConversation {..} = toMember :: OtherMember -> Public.Member toMember m = Public.Member - { memId = qUnqualified . omQualifiedId $ m, + { memId = omQualifiedId m, memService = omService m, memOtrMutedStatus = Nothing, memOtrMutedRef = Nothing, @@ -713,12 +788,12 @@ fromNewRemoteConversation d NewRemoteConversation {..} = conv :: Public.Member -> [OtherMember] -> Public.Conversation conv this others = Public.Conversation + (qUntagged rcCnvId) ConversationMetadata - { cnvmQualifiedId = rcCnvId, - cnvmType = rcCnvType, + { cnvmType = rcCnvType, -- FUTUREWORK: Document this is the same domain as the conversation -- domain - cnvmCreator = qUnqualified rcOrigUserId, + cnvmCreator = rcOrigUserId, cnvmAccess = rcCnvAccess, cnvmAccessRole = rcCnvAccessRole, cnvmName = rcCnvName, @@ -732,30 +807,18 @@ fromNewRemoteConversation d NewRemoteConversation {..} = -- | Notify remote users of being added to a new conversation registerRemoteConversationMemberships :: + Member FederatorAccess r => -- | The time stamp when the conversation was created UTCTime -> -- | The domain of the user that created the conversation Domain -> Data.Conversation -> - Galley () + Galley r () registerRemoteConversationMemberships now localDomain c = do - let rc = toNewRemoteConversation now localDomain c - -- FUTUREWORK: parallelise federated requests - traverse_ (registerRemoteConversations rc) - . Map.keys - . partitionQualified - . nubOrd - . map (unTagged . rmId) - . Data.convRemoteMembers - $ c - where - registerRemoteConversations :: - NewRemoteConversation ConvId -> - Domain -> - Galley () - registerRemoteConversations rc domain = do - let rpc = FederatedGalley.onConversationCreated FederatedGalley.clientRoutes localDomain rc - runFederated domain rpc + let allRemoteMembers = nubOrd (map rmId (Data.convRemoteMembers c)) + rc = toNewRemoteConversation now localDomain c + runFederatedConcurrently_ allRemoteMembers $ \_ -> + FederatedGalley.onConversationCreated FederatedGalley.clientRoutes localDomain rc -------------------------------------------------------------------------------- -- Legalhold @@ -777,13 +840,13 @@ consentGiven = \case UserLegalHoldEnabled -> ConsentGiven UserLegalHoldNoConsent -> ConsentNotGiven -checkConsent :: Map UserId TeamId -> UserId -> Galley ConsentGiven +checkConsent :: Map UserId TeamId -> UserId -> Galley r ConsentGiven checkConsent teamsOfUsers other = do consentGiven <$> getLHStatus (Map.lookup other teamsOfUsers) other -- Get legalhold status of user. Defaults to 'defUserLegalHoldStatus' if user -- doesn't belong to a team. -getLHStatus :: Maybe TeamId -> UserId -> Galley UserLegalHoldStatus +getLHStatus :: Maybe TeamId -> UserId -> Galley r UserLegalHoldStatus getLHStatus teamOfUser other = do case teamOfUser of Nothing -> pure defUserLegalHoldStatus @@ -791,7 +854,7 @@ getLHStatus teamOfUser other = do mMember <- Data.teamMember team other pure $ maybe defUserLegalHoldStatus (view legalHoldStatus) mMember -anyLegalholdActivated :: [UserId] -> Galley Bool +anyLegalholdActivated :: [UserId] -> Galley r Bool anyLegalholdActivated uids = do view (options . optSettings . setFeatureFlags . flagLegalHold) >>= \case FeatureLegalHoldDisabledPermanently -> pure False @@ -803,7 +866,7 @@ anyLegalholdActivated uids = do teamsOfUsers <- Data.usersTeams uidsPage anyM (\uid -> userLHEnabled <$> getLHStatus (Map.lookup uid teamsOfUsers) uid) uidsPage -allLegalholdConsentGiven :: [UserId] -> Galley Bool +allLegalholdConsentGiven :: [UserId] -> Galley r Bool allLegalholdConsentGiven uids = do view (options . optSettings . setFeatureFlags . flagLegalHold) >>= \case FeatureLegalHoldDisabledPermanently -> pure False @@ -820,7 +883,7 @@ allLegalholdConsentGiven uids = do allM isTeamLegalholdWhitelisted teamsPage -- | Add to every uid the legalhold status -getLHStatusForUsers :: [UserId] -> Galley [(UserId, UserLegalHoldStatus)] +getLHStatusForUsers :: [UserId] -> Galley r [(UserId, UserLegalHoldStatus)] getLHStatusForUsers uids = mconcat <$> ( for (chunksOf 32 uids) $ \uidsChunk -> do diff --git a/services/galley/src/Galley/App.hs b/services/galley/src/Galley/App.hs index 3d938a8241..10ba472499 100644 --- a/services/galley/src/Galley/App.hs +++ b/services/galley/src/Galley/App.hs @@ -38,6 +38,8 @@ module Galley.App -- * Galley monad Galley, + GalleyEffects, + Galley0, runGalley, evalGalley, ask, @@ -52,6 +54,13 @@ module Galley.App initExtEnv, fanoutLimit, currentFanoutLimit, + + -- * MonadUnliftIO / Sem compatibility + fireAndForget, + spawnMany, + liftGalley0, + liftSem, + interpretGalleyToGalley0, ) where @@ -61,8 +70,9 @@ import Cassandra hiding (Set) import qualified Cassandra as C import qualified Cassandra.Settings as C import Control.Error +import qualified Control.Exception import Control.Lens hiding ((.=)) -import Control.Monad.Catch hiding (tryJust) +import Control.Monad.Catch (MonadCatch (..), MonadMask (..), MonadThrow (..)) import Data.Aeson (FromJSON) import qualified Data.Aeson as Aeson import Data.ByteString.Conversion (toByteString') @@ -80,26 +90,32 @@ import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import Galley.API.Error import qualified Galley.Aws as Aws +import Galley.Effects +import qualified Galley.Effects.FireAndForget as E import Galley.Options import qualified Galley.Queue as Q import qualified Galley.Types.Teams as Teams -import Imports +import Imports hiding (forkIO) import Network.HTTP.Client (responseTimeoutMicro) import Network.HTTP.Client.OpenSSL import Network.HTTP.Media.RenderHeader (RenderHeader (..)) import Network.HTTP.Types (hContentType) import Network.HTTP.Types.Status (statusCode, statusMessage) import Network.Wai -import Network.Wai.Utilities +import Network.Wai.Utilities hiding (Error) import qualified Network.Wai.Utilities as WaiError import qualified Network.Wai.Utilities.Server as Server import OpenSSL.EVP.Digest (getDigestByName) import OpenSSL.Session as Ssl import qualified OpenSSL.X509.SystemStore as Ssl +import Polysemy +import Polysemy.Internal (Append) +import qualified Polysemy.Reader as P import qualified Servant import Ssl.Util import System.Logger.Class hiding (Error, info) import qualified System.Logger.Extended as Logger +import qualified UnliftIO.Exception as UnliftIO import Util.Options import Wire.API.Federation.Client (HasFederatorConfig (..)) @@ -131,26 +147,48 @@ makeLenses ''Env makeLenses ''ExtEnv -newtype Galley a = Galley - { unGalley :: ReaderT Env Client a - } - deriving - ( Functor, - Applicative, - Monad, - MonadIO, - MonadThrow, - MonadCatch, - MonadMask, - MonadReader Env, - MonadClient - ) +-- MTL-style effects derived from the old implementation of the Galley monad. +-- They will disappear as we introduce more high-level effects into Galley. +type GalleyEffects0 = '[P.Reader ClientState, P.Reader Env, Embed IO, Final IO] + +type GalleyEffects = Append GalleyEffects1 GalleyEffects0 + +type Galley0 = Galley GalleyEffects0 + +newtype Galley r a = Galley {unGalley :: Members GalleyEffects0 r => Sem r a} + +instance Functor (Galley r) where + fmap f (Galley x) = Galley (fmap f x) + +instance Applicative (Galley r) where + pure x = Galley (pure x) + (<*>) = ap -instance HasFederatorConfig Galley where +instance Monad (Galley r) where + return = pure + Galley m >>= f = Galley (m >>= unGalley . f) + +instance MonadIO (Galley r) where + liftIO action = Galley (liftIO action) + +instance MonadThrow (Galley r) where + throwM e = Galley (embed @IO (throwM e)) + +instance MonadReader Env (Galley r) where + ask = Galley $ P.ask @Env + local f m = Galley $ P.local f (unGalley m) + +instance MonadClient (Galley r) where + liftClient m = Galley $ do + cs <- P.ask @ClientState + embed @IO $ runClient cs m + localState f m = Galley $ P.local f (unGalley m) + +instance HasFederatorConfig (Galley r) where federatorEndpoint = view federator federationDomain = view (options . optSettings . setFederationDomain) -fanoutLimit :: Galley (Range 1 Teams.HardTruncationLimit Int32) +fanoutLimit :: Galley r (Range 1 Teams.HardTruncationLimit Int32) fanoutLimit = view options >>= return . currentFanoutLimit currentFanoutLimit :: Opts -> Range 1 Teams.HardTruncationLimit Int32 @@ -182,23 +220,17 @@ validateOptions l o = do when (settings ^. setMaxTeamSize < optFanoutLimit) $ error "setMaxTeamSize cannot be < setTruncationLimit" -instance MonadUnliftIO Galley where - askUnliftIO = - Galley . ReaderT $ \r -> - withUnliftIO $ \u -> - return (UnliftIO (unliftIO u . flip runReaderT r . unGalley)) - -instance MonadLogger Galley where +instance MonadLogger (Galley r) where log l m = do e <- ask Logger.log (e ^. applog) l (reqIdMsg (e ^. reqId) . m) -instance MonadHttp Galley where +instance MonadHttp (Galley r) where handleRequestWithCont req handler = do httpManager <- view manager liftIO $ withResponse req httpManager handler -instance HasRequestId Galley where +instance HasRequestId (Galley r) where getRequestId = view reqId createEnv :: Metrics -> Opts -> IO Env @@ -271,13 +303,20 @@ initExtEnv = do let pinset = map toByteString' fprs in verifyRsaFingerprint sha pinset -runGalley :: Env -> Request -> Galley a -> IO a +runGalley :: Env -> Request -> Galley GalleyEffects a -> IO a runGalley e r m = let e' = reqId .~ lookupReqId r $ e in evalGalley e' m -evalGalley :: Env -> Galley a -> IO a -evalGalley e m = runClient (e ^. cstate) (runReaderT (unGalley m) e) +evalGalley0 :: Env -> Sem GalleyEffects0 a -> IO a +evalGalley0 e = + runFinal @IO + . embedToFinal @IO + . P.runReader e + . P.runReader (e ^. cstate) + +evalGalley :: Env -> Galley GalleyEffects a -> IO a +evalGalley e = evalGalley0 e . unGalley . interpretGalleyToGalley0 lookupReqId :: Request -> RequestId lookupReqId = maybe def RequestId . lookup requestIdName . requestHeaders @@ -286,33 +325,33 @@ reqIdMsg :: RequestId -> Msg -> Msg reqIdMsg = ("request" .=) . unRequestId {-# INLINE reqIdMsg #-} -fromJsonBody :: FromJSON a => JsonRequest a -> Galley a +fromJsonBody :: FromJSON a => JsonRequest a -> Galley r a fromJsonBody r = exceptT (throwM . invalidPayload) return (parseBody r) {-# INLINE fromJsonBody #-} -fromOptionalJsonBody :: FromJSON a => OptionalJsonRequest a -> Galley (Maybe a) +fromOptionalJsonBody :: FromJSON a => OptionalJsonRequest a -> Galley r (Maybe a) fromOptionalJsonBody r = exceptT (throwM . invalidPayload) return (parseOptionalBody r) {-# INLINE fromOptionalJsonBody #-} -fromProtoBody :: Proto.Decode a => Request -> Galley a +fromProtoBody :: Proto.Decode a => Request -> Galley r a fromProtoBody r = do b <- readBody r either (throwM . invalidPayload . fromString) return (runGetLazy Proto.decodeMessage b) {-# INLINE fromProtoBody #-} -ifNothing :: Error -> Maybe a -> Galley a +ifNothing :: WaiError.Error -> Maybe a -> Galley r a ifNothing e = maybe (throwM e) return {-# INLINE ifNothing #-} -toServantHandler :: Env -> Galley a -> Servant.Handler a +toServantHandler :: Env -> Galley GalleyEffects a -> Servant.Handler a toServantHandler env galley = do - eith <- liftIO $ try (evalGalley env galley) + eith <- liftIO $ Control.Exception.try (evalGalley env galley) case eith of Left werr -> handleWaiErrors (view applog env) (unRequestId (view reqId env)) werr Right result -> pure result where - handleWaiErrors :: Logger -> ByteString -> Error -> Servant.Handler a + handleWaiErrors :: Logger -> ByteString -> WaiError.Error -> Servant.Handler a handleWaiErrors logger reqId' werr = do Server.logError' logger (Just reqId') werr Servant.throwError $ @@ -320,3 +359,50 @@ toServantHandler env galley = do mkCode = statusCode . WaiError.code mkPhrase = Text.unpack . Text.decodeUtf8 . statusMessage . WaiError.code + +---------------------------------------------------------------------------------- +---- temporary MonadUnliftIO support code for the polysemy refactoring + +fireAndForget :: Member FireAndForget r => Galley r () -> Galley r () +fireAndForget (Galley m) = Galley $ E.fireAndForget m + +spawnMany :: Member FireAndForget r => [Galley r ()] -> Galley r () +spawnMany ms = Galley $ E.spawnMany (map unGalley ms) + +instance MonadUnliftIO Galley0 where + askUnliftIO = Galley $ do + env <- P.ask @Env + pure $ UnliftIO $ evalGalley0 env . unGalley + +instance MonadMask Galley0 where + mask = UnliftIO.mask + uninterruptibleMask = UnliftIO.uninterruptibleMask + generalBracket acquire release useB = Galley $ do + env <- P.ask @Env + embed @IO $ + generalBracket + (evalGalley0 env (unGalley acquire)) + (\resource exitCase -> evalGalley0 env (unGalley (release resource exitCase))) + (\resource -> evalGalley0 env (unGalley (useB resource))) + +instance MonadCatch Galley0 where + catch = UnliftIO.catch + +liftGalley0 :: Galley0 a -> Galley r a +liftGalley0 (Galley m) = Galley $ subsume_ m + +liftSem :: Sem r a -> Galley r a +liftSem m = Galley m + +interpretGalleyToGalley0 :: Galley GalleyEffects a -> Galley0 a +interpretGalleyToGalley0 = + Galley + . interpretFireAndForget + . interpretIntra + . interpretBot + . interpretFederator + . interpretExternal + . interpretSpar + . interpretGundeck + . interpretBrig + . unGalley diff --git a/services/galley/src/Galley/Data.hs b/services/galley/src/Galley/Data.hs index afb7d87713..4d2e02de64 100644 --- a/services/galley/src/Galley/Data.hs +++ b/services/galley/src/Galley/Data.hs @@ -68,7 +68,9 @@ module Galley.Data conversationMeta, conversationsRemote, createConnectConversation, + createConnectConversationWithRemote, createConversation, + createLegacyOne2OneConversation, createOne2OneConversation, createSelfConversation, isConvAlive, @@ -109,10 +111,11 @@ module Galley.Data -- * Clients eraseClients, lookupClients, + lookupClients', updateClient, -- * Utilities - one2OneConvId, + localOne2OneConvId, newMember, -- * Defaults @@ -122,12 +125,12 @@ module Galley.Data where import Brig.Types.Code -import Cassandra hiding (Tagged) +import Cassandra import Cassandra.Util import Control.Arrow (second) import Control.Exception (ErrorCall (ErrorCall)) import Control.Lens hiding ((<|)) -import Control.Monad.Catch (MonadThrow, throwM) +import Control.Monad.Catch (throwM) import Control.Monad.Extra (ifM) import Data.ByteString.Conversion hiding (parser) import Data.Domain (Domain) @@ -135,7 +138,7 @@ import Data.Id as Id import Data.Json.Util (UTCTimeMillis (..)) import Data.LegalHold (UserLegalHoldStatus (..), defUserLegalHoldStatus) import qualified Data.List.Extra as List -import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty (NonEmpty, nonEmpty) import Data.List.Split (chunksOf) import qualified Data.Map.Strict as Map import Data.Misc (Milliseconds) @@ -143,7 +146,6 @@ import qualified Data.Monoid import Data.Qualified import Data.Range import qualified Data.Set as Set -import Data.Tagged import qualified Data.UUID.Tagged as U import Data.UUID.V4 (nextRandom) import Galley.App @@ -157,15 +159,20 @@ import Galley.Types.Clients (Clients) import qualified Galley.Types.Clients as Clients import Galley.Types.Conversations.Members import Galley.Types.Conversations.Roles -import Galley.Types.Teams hiding (Event, EventType (..), teamConversations, teamMembers) +import Galley.Types.Teams hiding + ( Event, + EventType (..), + self, + teamConversations, + teamMembers, + ) +import qualified Galley.Types.Teams as Teams import Galley.Types.Teams.Intra import Galley.Types.UserList import Galley.Validation import Imports hiding (Set, max) -import System.Logger.Class (MonadLogger) import qualified System.Logger.Class as Log -import UnliftIO (async, mapConcurrently, wait) -import UnliftIO.Async (pooledMapConcurrentlyN) +import qualified UnliftIO import Wire.API.Team.Member -- We use this newtype to highlight the fact that the 'Page' wrapped in here @@ -202,7 +209,7 @@ schemaVersion :: Int32 schemaVersion = 53 -- | Insert a conversation code -insertCode :: MonadClient m => Code -> m () +insertCode :: Code -> Galley r () insertCode c = do let k = codeKey c let v = codeValue c @@ -212,16 +219,16 @@ insertCode c = do retry x5 (write Cql.insertCode (params Quorum (k, v, cnv, s, t))) -- | Lookup a conversation by code. -lookupCode :: MonadClient m => Key -> Scope -> m (Maybe Code) +lookupCode :: Key -> Scope -> Galley r (Maybe Code) lookupCode k s = fmap (toCode k s) <$> retry x1 (query1 Cql.lookupCode (params Quorum (k, s))) -- | Delete a code associated with the given conversation key -deleteCode :: MonadClient m => Key -> Scope -> m () +deleteCode :: Key -> Scope -> Galley r () deleteCode k s = retry x5 $ write Cql.deleteCode (params Quorum (k, s)) -- Teams -------------------------------------------------------------------- -team :: MonadClient m => TeamId -> m (Maybe TeamData) +team :: TeamId -> Galley r (Maybe TeamData) team tid = fmap toTeam <$> retry x1 (query1 Cql.selectTeam (params Quorum (Identity tid))) where @@ -230,16 +237,16 @@ team tid = status = if d then PendingDelete else fromMaybe Active s in TeamData t status (writeTimeToUTC <$> st) -teamName :: MonadClient m => TeamId -> m (Maybe Text) +teamName :: TeamId -> Galley r (Maybe Text) teamName tid = fmap runIdentity <$> retry x1 (query1 Cql.selectTeamName (params Quorum (Identity tid))) -teamIdsOf :: MonadClient m => UserId -> Range 1 32 (List TeamId) -> m [TeamId] +teamIdsOf :: UserId -> Range 1 32 (List TeamId) -> Galley r [TeamId] teamIdsOf usr (fromList . fromRange -> tids) = map runIdentity <$> retry x1 (query Cql.selectUserTeamsIn (params Quorum (usr, tids))) -teamIdsFrom :: MonadClient m => UserId -> Maybe TeamId -> Range 1 100 Int32 -> m (ResultSet TeamId) +teamIdsFrom :: UserId -> Maybe TeamId -> Range 1 100 Int32 -> Galley r (ResultSet TeamId) teamIdsFrom usr range (fromRange -> max) = mkResultSet . fmap runIdentity . strip <$> case range of Just c -> paginate Cql.selectUserTeamsFrom (paramsP Quorum (usr, c) (max + 1)) @@ -247,32 +254,32 @@ teamIdsFrom usr range (fromRange -> max) = where strip p = p {result = take (fromIntegral max) (result p)} -teamIdsForPagination :: MonadClient m => UserId -> Maybe TeamId -> Range 1 100 Int32 -> m (Page TeamId) +teamIdsForPagination :: UserId -> Maybe TeamId -> Range 1 100 Int32 -> Galley r (Page TeamId) teamIdsForPagination usr range (fromRange -> max) = fmap runIdentity <$> case range of Just c -> paginate Cql.selectUserTeamsFrom (paramsP Quorum (usr, c) max) Nothing -> paginate Cql.selectUserTeams (paramsP Quorum (Identity usr) max) -teamConversation :: MonadClient m => TeamId -> ConvId -> m (Maybe TeamConversation) +teamConversation :: TeamId -> ConvId -> Galley r (Maybe TeamConversation) teamConversation t c = fmap (newTeamConversation c . runIdentity) <$> retry x1 (query1 Cql.selectTeamConv (params Quorum (t, c))) -teamConversations :: MonadClient m => TeamId -> m [TeamConversation] +teamConversations :: TeamId -> Galley r [TeamConversation] teamConversations t = map (uncurry newTeamConversation) <$> retry x1 (query Cql.selectTeamConvs (params Quorum (Identity t))) -teamConversationsForPagination :: MonadClient m => TeamId -> Maybe ConvId -> Range 1 HardTruncationLimit Int32 -> m (Page TeamConversation) +teamConversationsForPagination :: TeamId -> Maybe ConvId -> Range 1 HardTruncationLimit Int32 -> Galley r (Page TeamConversation) teamConversationsForPagination tid start (fromRange -> max) = fmap (uncurry newTeamConversation) <$> case start of Just c -> paginate Cql.selectTeamConvsFrom (paramsP Quorum (tid, c) max) Nothing -> paginate Cql.selectTeamConvs (paramsP Quorum (Identity tid) max) -teamMembersForFanout :: TeamId -> Galley TeamMemberList +teamMembersForFanout :: TeamId -> Galley r TeamMemberList teamMembersForFanout t = fanoutLimit >>= teamMembersWithLimit t -teamMembersWithLimit :: forall m. (MonadThrow m, MonadClient m, MonadReader Env m) => TeamId -> Range 1 HardTruncationLimit Int32 -> m TeamMemberList +teamMembersWithLimit :: TeamId -> Range 1 HardTruncationLimit Int32 -> Galley r TeamMemberList teamMembersWithLimit t (fromRange -> limit) = do -- NOTE: We use +1 as size and then trim it due to the semantics of C* when getting a page with the exact same size pageTuple <- retry x1 (paginate Cql.selectTeamMembers (paramsP Quorum (Identity t) (limit + 1))) @@ -285,7 +292,7 @@ teamMembersWithLimit t (fromRange -> limit) = do -- This function has a bit of a difficult type to work with because we don't have a pure function of type -- (UserId, Permissions, Maybe UserId, Maybe UTCTimeMillis, Maybe UserLegalHoldStatus) -> TeamMember so we -- cannot fmap over the ResultSet. We don't want to mess around with the Result size nextPage either otherwise -teamMembersForPagination :: MonadClient m => TeamId -> Maybe UserId -> Range 1 HardTruncationLimit Int32 -> m (Page (UserId, Permissions, Maybe UserId, Maybe UTCTimeMillis, Maybe UserLegalHoldStatus)) +teamMembersForPagination :: TeamId -> Maybe UserId -> Range 1 HardTruncationLimit Int32 -> Galley r (Page (UserId, Permissions, Maybe UserId, Maybe UTCTimeMillis, Maybe UserLegalHoldStatus)) teamMembersForPagination tid start (fromRange -> max) = case start of Just u -> paginate Cql.selectTeamMembersFrom (paramsP Quorum (tid, u) max) @@ -293,7 +300,7 @@ teamMembersForPagination tid start (fromRange -> max) = -- NOTE: Use this function with care... should only be required when deleting a team! -- Maybe should be left explicitly for the caller? -teamMembersCollectedWithPagination :: TeamId -> Galley [TeamMember] +teamMembersCollectedWithPagination :: TeamId -> Galley r [TeamMember] teamMembersCollectedWithPagination tid = do mems <- teamMembersForPagination tid Nothing (unsafeRange 2000) collectTeamMembersPaginated [] mems @@ -307,38 +314,43 @@ teamMembersCollectedWithPagination tid = do -- Lookup only specific team members: this is particularly useful for large teams when -- needed to look up only a small subset of members (typically 2, user to perform the action -- and the target user) -teamMembersLimited :: forall m. (MonadThrow m, MonadClient m, MonadReader Env m) => TeamId -> [UserId] -> m [TeamMember] +teamMembersLimited :: TeamId -> [UserId] -> Galley r [TeamMember] teamMembersLimited t u = mapM (newTeamMember' t) =<< retry x1 (query Cql.selectTeamMembers' (params Quorum (t, u))) -teamMember :: forall m. (MonadThrow m, MonadClient m, MonadReader Env m) => TeamId -> UserId -> m (Maybe TeamMember) +teamMember :: TeamId -> UserId -> Galley r (Maybe TeamMember) teamMember t u = newTeamMember'' u =<< retry x1 (query1 Cql.selectTeamMember (params Quorum (t, u))) where newTeamMember'' :: UserId -> Maybe (Permissions, Maybe UserId, Maybe UTCTimeMillis, Maybe UserLegalHoldStatus) -> - m (Maybe TeamMember) + Galley r (Maybe TeamMember) newTeamMember'' _ Nothing = pure Nothing newTeamMember'' uid (Just (perms, minvu, minvt, mulhStatus)) = Just <$> newTeamMember' t (uid, perms, minvu, minvt, mulhStatus) -userTeams :: MonadClient m => UserId -> m [TeamId] +userTeams :: UserId -> Galley r [TeamId] userTeams u = map runIdentity <$> retry x1 (query Cql.selectUserTeams (params Quorum (Identity u))) -usersTeams :: (MonadUnliftIO m, MonadClient m) => [UserId] -> m (Map UserId TeamId) -usersTeams uids = do - pairs :: [(UserId, TeamId)] <- catMaybes <$> pooledMapConcurrentlyN 8 (\uid -> (uid,) <$$> oneUserTeam uid) uids +usersTeams :: [UserId] -> Galley r (Map UserId TeamId) +usersTeams uids = liftClient $ do + pairs :: [(UserId, TeamId)] <- + catMaybes + <$> UnliftIO.pooledMapConcurrentlyN 8 (\uid -> (uid,) <$$> oneUserTeamC uid) uids pure $ foldl' (\m (k, v) -> Map.insert k v m) Map.empty pairs -oneUserTeam :: MonadClient m => UserId -> m (Maybe TeamId) -oneUserTeam u = +oneUserTeam :: UserId -> Galley r (Maybe TeamId) +oneUserTeam = liftClient . oneUserTeamC + +oneUserTeamC :: UserId -> Client (Maybe TeamId) +oneUserTeamC u = fmap runIdentity <$> retry x1 (query1 Cql.selectOneUserTeam (params Quorum (Identity u))) -teamCreationTime :: MonadClient m => TeamId -> m (Maybe TeamCreationTime) +teamCreationTime :: TeamId -> Galley r (Maybe TeamCreationTime) teamCreationTime t = checkCreation . fmap runIdentity <$> retry x1 (query1 Cql.selectTeamBindingWritetime (params Quorum (Identity t))) @@ -346,20 +358,19 @@ teamCreationTime t = checkCreation (Just (Just ts)) = Just $ TeamCreationTime ts checkCreation _ = Nothing -teamBinding :: MonadClient m => TeamId -> m (Maybe TeamBinding) +teamBinding :: TeamId -> Galley r (Maybe TeamBinding) teamBinding t = fmap (fromMaybe NonBinding . runIdentity) <$> retry x1 (query1 Cql.selectTeamBinding (params Quorum (Identity t))) createTeam :: - MonadClient m => Maybe TeamId -> UserId -> Range 1 256 Text -> Range 1 256 Text -> Maybe (Range 1 256 Text) -> TeamBinding -> - m Team + Galley r Team createTeam t uid (fromRange -> n) (fromRange -> i) k b = do tid <- maybe (Id <$> liftIO nextRandom) return t retry x5 $ write Cql.insertTeam (params Quorum (tid, uid, n, i, fromRange <$> k, initialStatus b, b)) @@ -368,7 +379,7 @@ createTeam t uid (fromRange -> n) (fromRange -> i) k b = do initialStatus Binding = PendingActive -- Team becomes Active after User account activation initialStatus NonBinding = Active -deleteTeam :: forall m. (MonadClient m, Log.MonadLogger m, MonadThrow m) => TeamId -> m () +deleteTeam :: TeamId -> Galley r () deleteTeam tid = do -- TODO: delete service_whitelist records that mention this team retry x5 $ write Cql.markTeamDeleted (params Quorum (PendingDelete, tid)) @@ -378,7 +389,7 @@ deleteTeam tid = do removeConvs cnvs retry x5 $ write Cql.deleteTeam (params Quorum (Deleted, tid)) where - removeConvs :: Page TeamConversation -> m () + removeConvs :: Page TeamConversation -> Galley r () removeConvs cnvs = do for_ (result cnvs) $ removeTeamConv tid . view conversationId unless (null $ result cnvs) $ @@ -392,13 +403,13 @@ deleteTeam tid = do Maybe UTCTimeMillis, Maybe UserLegalHoldStatus ) -> - m () + Galley r () removeTeamMembers mems = do mapM_ (removeTeamMember tid . view _1) (result mems) unless (null $ result mems) $ removeTeamMembers =<< liftClient (nextPage mems) -addTeamMember :: MonadClient m => TeamId -> TeamMember -> m () +addTeamMember :: TeamId -> TeamMember -> Galley r () addTeamMember t m = retry x5 . batch $ do setType BatchLogged @@ -416,14 +427,13 @@ addTeamMember t m = addPrepQuery Cql.insertBillingTeamMember (t, m ^. userId) updateTeamMember :: - MonadClient m => -- | Old permissions, used for maintaining 'billing_team_member' table Permissions -> TeamId -> UserId -> -- | New permissions Permissions -> - m () + Galley r () updateTeamMember oldPerms tid uid newPerms = do retry x5 . batch $ do setType BatchLogged @@ -436,11 +446,11 @@ updateTeamMember oldPerms tid uid newPerms = do when (SetBilling `Set.member` lostPerms) $ addPrepQuery Cql.deleteBillingTeamMember (tid, uid) where - permDiff = Set.difference `on` view self + permDiff = Set.difference `on` view Teams.self acquiredPerms = newPerms `permDiff` oldPerms lostPerms = oldPerms `permDiff` newPerms -removeTeamMember :: MonadClient m => TeamId -> UserId -> m () +removeTeamMember :: TeamId -> UserId -> Galley r () removeTeamMember t m = retry x5 . batch $ do setType BatchLogged @@ -449,12 +459,12 @@ removeTeamMember t m = addPrepQuery Cql.deleteUserTeam (m, t) addPrepQuery Cql.deleteBillingTeamMember (t, m) -listBillingTeamMembers :: MonadClient m => TeamId -> m [UserId] +listBillingTeamMembers :: TeamId -> Galley r [UserId] listBillingTeamMembers tid = fmap runIdentity <$> retry x1 (query Cql.listBillingTeamMembers (params Quorum (Identity tid))) -removeTeamConv :: (MonadClient m, Log.MonadLogger m, MonadThrow m) => TeamId -> ConvId -> m () +removeTeamConv :: TeamId -> ConvId -> Galley r () removeTeamConv tid cid = do retry x5 . batch $ do setType BatchLogged @@ -463,10 +473,10 @@ removeTeamConv tid cid = do addPrepQuery Cql.deleteTeamConv (tid, cid) deleteConversation cid -updateTeamStatus :: MonadClient m => TeamId -> TeamStatus -> m () +updateTeamStatus :: TeamId -> TeamStatus -> Galley r () updateTeamStatus t s = retry x5 $ write Cql.updateTeamStatus (params Quorum (s, t)) -updateTeam :: MonadClient m => TeamId -> TeamUpdateData -> m () +updateTeam :: TeamId -> TeamUpdateData -> Galley r () updateTeam tid u = retry x5 . batch $ do setType BatchLogged setConsistency Quorum @@ -479,7 +489,7 @@ updateTeam tid u = retry x5 . batch $ do -- Conversations ------------------------------------------------------------ -isConvAlive :: MonadClient m => ConvId -> m Bool +isConvAlive :: ConvId -> Galley r Bool isConvAlive cid = do result <- retry x1 (query1 Cql.isConvDeleted (params Quorum (Identity cid))) case runIdentity <$> result of @@ -488,38 +498,39 @@ isConvAlive cid = do Just (Just True) -> pure False Just (Just False) -> pure True -conversation :: - (MonadUnliftIO m, MonadClient m, Log.MonadLogger m, MonadThrow m) => - ConvId -> - m (Maybe Conversation) -conversation conv = do - cdata <- async $ retry x1 (query1 Cql.selectConv (params Quorum (Identity conv))) - remoteMems <- async $ lookupRemoteMembers conv - mbConv <- toConv conv <$> members conv <*> wait remoteMems <*> wait cdata +conversation :: ConvId -> Galley r (Maybe Conversation) +conversation conv = liftClient $ do + cdata <- UnliftIO.async $ retry x1 (query1 Cql.selectConv (params Quorum (Identity conv))) + remoteMems <- UnliftIO.async $ lookupRemoteMembersC conv + mbConv <- + toConv conv + <$> membersC conv + <*> UnliftIO.wait remoteMems + <*> UnliftIO.wait cdata return mbConv >>= conversationGC {- "Garbage collect" the conversation, i.e. the conversation may be marked as deleted, in which case we delete it and return Nothing -} conversationGC :: - (MonadClient m, Log.MonadLogger m, MonadThrow m) => Maybe Conversation -> - m (Maybe Conversation) + Client (Maybe Conversation) conversationGC conv = case join (convDeleted <$> conv) of (Just True) -> do - sequence_ $ deleteConversation . convId <$> conv + sequence_ $ deleteConversationC . convId <$> conv return Nothing _ -> return conv -localConversations :: - (MonadLogger m, MonadUnliftIO m, MonadClient m) => - [ConvId] -> - m [Conversation] +localConversations :: [ConvId] -> Galley r [Conversation] localConversations [] = return [] localConversations ids = do - convs <- async fetchConvs - mems <- async $ memberLists ids - remoteMems <- async $ remoteMemberLists ids - cs <- zipWith4 toConv ids <$> wait mems <*> wait remoteMems <*> wait convs + cs <- liftClient $ do + convs <- UnliftIO.async fetchConvs + mems <- UnliftIO.async $ memberLists ids + remoteMems <- UnliftIO.async $ remoteMemberLists ids + zipWith4 toConv ids + <$> UnliftIO.wait mems + <*> UnliftIO.wait remoteMems + <*> UnliftIO.wait convs foldrM flatten [] (zip ids cs) where fetchConvs = do @@ -543,14 +554,13 @@ toConv cid mms remoteMems conv = where f ms (cty, uid, acc, role, nme, ti, del, timer, rm) = Conversation cid cty uid nme (defAccess cty acc) (maybeRole cty role) ms remoteMems ti del timer rm -conversationMeta :: MonadClient m => Domain -> ConvId -> m (Maybe ConversationMetadata) -conversationMeta localDomain conv = +conversationMeta :: Domain -> ConvId -> Galley r (Maybe ConversationMetadata) +conversationMeta _localDomain conv = fmap toConvMeta <$> retry x1 (query1 Cql.selectConv (params Quorum (Identity conv))) where toConvMeta (t, c, a, r, n, i, _, mt, rm) = ConversationMetadata - (Qualified conv localDomain) t c (defAccess t a) @@ -562,11 +572,10 @@ conversationMeta localDomain conv = -- | Deprecated, use 'localConversationIdsPageFrom' conversationIdsFrom :: - (MonadClient m) => UserId -> Maybe ConvId -> Range 1 1000 Int32 -> - m (ResultSet ConvId) + Galley r (ResultSet ConvId) conversationIdsFrom usr start (fromRange -> max) = mkResultSet . strip . fmap runIdentity <$> case start of Just c -> paginate Cql.selectUserConvsFrom (paramsP Quorum (usr, c) (max + 1)) @@ -575,19 +584,18 @@ conversationIdsFrom usr start (fromRange -> max) = strip p = p {result = take (fromIntegral max) (result p)} localConversationIdsPageFrom :: - (MonadClient m) => UserId -> Maybe PagingState -> Range 1 1000 Int32 -> - m (PageWithState ConvId) + Galley r (PageWithState ConvId) localConversationIdsPageFrom usr pagingState (fromRange -> max) = fmap runIdentity <$> paginateWithState Cql.selectUserConvs (paramsPagingState Quorum (Identity usr) max pagingState) -remoteConversationIdsPageFrom :: (MonadClient m) => UserId -> Maybe PagingState -> Int32 -> m (PageWithState (Qualified ConvId)) +remoteConversationIdsPageFrom :: UserId -> Maybe PagingState -> Int32 -> Galley r (PageWithState (Qualified ConvId)) remoteConversationIdsPageFrom usr pagingState max = uncurry (flip Qualified) <$$> paginateWithState Cql.selectUserRemoteConvs (paramsPagingState Quorum (Identity usr) max pagingState) -localConversationIdRowsForPagination :: MonadClient m => UserId -> Maybe ConvId -> Range 1 1000 Int32 -> m (Page ConvId) +localConversationIdRowsForPagination :: UserId -> Maybe ConvId -> Range 1 1000 Int32 -> Galley r (Page ConvId) localConversationIdRowsForPagination usr start (fromRange -> max) = runIdentity <$$> case start of @@ -596,38 +604,37 @@ localConversationIdRowsForPagination usr start (fromRange -> max) = -- | Takes a list of conversation ids and returns those found for the given -- user. -localConversationIdsOf :: forall m. (MonadClient m, MonadUnliftIO m) => UserId -> [ConvId] -> m [ConvId] +localConversationIdsOf :: UserId -> [ConvId] -> Galley r [ConvId] localConversationIdsOf usr cids = do runIdentity <$$> retry x1 (query Cql.selectUserConvsIn (params Quorum (usr, cids))) -- | Takes a list of remote conversation ids and fetches member status flags -- for the given user remoteConversationStatus :: - (MonadClient m, MonadUnliftIO m) => UserId -> [Remote ConvId] -> - m (Map (Remote ConvId) MemberStatus) + Galley r (Map (Remote ConvId) MemberStatus) remoteConversationStatus uid = - fmap mconcat - . pooledMapConcurrentlyN 8 (uncurry (remoteConversationStatusOnDomain uid)) - . partitionRemote + liftClient + . fmap mconcat + . UnliftIO.pooledMapConcurrentlyN 8 (remoteConversationStatusOnDomainC uid) + . bucketRemote -remoteConversationStatusOnDomain :: MonadClient m => UserId -> Domain -> [ConvId] -> m (Map (Remote ConvId) MemberStatus) -remoteConversationStatusOnDomain uid domain convs = +remoteConversationStatusOnDomainC :: UserId -> Remote [ConvId] -> Client (Map (Remote ConvId) MemberStatus) +remoteConversationStatusOnDomainC uid rconvs = Map.fromList . map toPair - <$> query Cql.selectRemoteConvMemberStatuses (params Quorum (uid, domain, convs)) + <$> query Cql.selectRemoteConvMemberStatuses (params Quorum (uid, tDomain rconvs, tUnqualified rconvs)) where toPair (conv, omus, omur, oar, oarr, hid, hidr) = - ( toRemote (Qualified conv domain), + ( qualifyAs rconvs conv, toMemberStatus (omus, omur, oar, oarr, hid, hidr) ) -conversationsRemote :: (MonadClient m) => UserId -> m [Remote ConvId] +conversationsRemote :: UserId -> Galley r [Remote ConvId] conversationsRemote usr = do - (\(d, c) -> toRemote $ Qualified c d) <$$> retry x1 (query Cql.selectUserRemoteConvs (params Quorum (Identity usr))) + uncurry toRemoteUnsafe <$$> retry x1 (query Cql.selectUserRemoteConvs (params Quorum (Identity usr))) createConversation :: - MonadClient m => Local UserId -> Maybe (Range 1 256 Text) -> [Access] -> @@ -638,11 +645,11 @@ createConversation :: Maybe Milliseconds -> Maybe ReceiptMode -> RoleName -> - m Conversation + Galley r Conversation createConversation lusr name acc role others tinfo mtimer recpt othersConversationRole = do conv <- Id <$> liftIO nextRandom let lconv = qualifyAs lusr conv - usr = lUnqualified lusr + usr = tUnqualified lusr retry x5 $ case tinfo of Nothing -> write Cql.insertConv (params Quorum (conv, RegularConv, usr, Set (toList acc), role, fromRange <$> name, Nothing, mtimer, recpt)) @@ -652,28 +659,27 @@ createConversation lusr name acc role others tinfo mtimer recpt othersConversati addPrepQuery Cql.insertConv (conv, RegularConv, usr, Set (toList acc), role, fromRange <$> name, Just (cnvTeamId ti), mtimer, recpt) addPrepQuery Cql.insertTeamConv (cnvTeamId ti, conv, cnvManaged ti) let newUsers = fmap (,othersConversationRole) (fromConvSize others) - (lmems, rmems) <- addMembers lconv (ulAddLocal (lUnqualified lusr, roleNameWireAdmin) newUsers) + (lmems, rmems) <- addMembers lconv (ulAddLocal (tUnqualified lusr, roleNameWireAdmin) newUsers) pure $ newConv conv RegularConv usr lmems rmems acc role name (cnvTeamId <$> tinfo) mtimer recpt -createSelfConversation :: MonadClient m => Local UserId -> Maybe (Range 1 256 Text) -> m Conversation +createSelfConversation :: Local UserId -> Maybe (Range 1 256 Text) -> Galley r Conversation createSelfConversation lusr name = do - let usr = lUnqualified lusr + let usr = tUnqualified lusr conv = selfConv usr lconv = qualifyAs lusr conv retry x5 $ write Cql.insertConv (params Quorum (conv, SelfConv, usr, privateOnly, privateRole, fromRange <$> name, Nothing, Nothing, Nothing)) - (lmems, rmems) <- addMembers lconv (UserList [lUnqualified lusr] []) + (lmems, rmems) <- addMembers lconv (UserList [tUnqualified lusr] []) pure $ newConv conv SelfConv usr lmems rmems [PrivateAccess] privateRole name Nothing Nothing Nothing createConnectConversation :: - MonadClient m => Local x -> U.UUID U.V4 -> U.UUID U.V4 -> Maybe (Range 1 256 Text) -> - m Conversation + Galley r Conversation createConnectConversation loc a b name = do - let conv = one2OneConvId a b + let conv = localOne2OneConvId a b lconv = qualifyAs loc conv a' = Id . U.unpack $ a retry x5 $ @@ -683,63 +689,98 @@ createConnectConversation loc a b name = do (lmems, rmems) <- addMembers lconv (UserList [a'] []) pure $ newConv conv ConnectConv a' lmems rmems [PrivateAccess] privateRole name Nothing Nothing Nothing -createOne2OneConversation :: - MonadClient m => +createConnectConversationWithRemote :: + Local ConvId -> + Local UserId -> + UserList UserId -> + Galley r () +createConnectConversationWithRemote lconvId creator m = do + retry x5 $ + write Cql.insertConv (params Quorum (tUnqualified lconvId, ConnectConv, tUnqualified creator, privateOnly, privateRole, Nothing, Nothing, Nothing, Nothing)) + -- We add only one member, second one gets added later, + -- when the other user accepts the connection request. + void $ addMembers lconvId m + +createLegacyOne2OneConversation :: Local x -> U.UUID U.V4 -> U.UUID U.V4 -> Maybe (Range 1 256 Text) -> Maybe TeamId -> - m Conversation -createOne2OneConversation loc a b name ti = do - let conv = one2OneConvId a b + Galley r Conversation +createLegacyOne2OneConversation loc a b name ti = do + let conv = localOne2OneConvId a b lconv = qualifyAs loc conv a' = Id (U.unpack a) b' = Id (U.unpack b) - retry x5 $ case ti of - Nothing -> write Cql.insertConv (params Quorum (conv, One2OneConv, a', privateOnly, privateRole, fromRange <$> name, Nothing, Nothing, Nothing)) + createOne2OneConversation + lconv + (qualifyAs loc a') + (qUntagged (qualifyAs loc b')) + name + ti + +createOne2OneConversation :: + Local ConvId -> + Local UserId -> + Qualified UserId -> + Maybe (Range 1 256 Text) -> + Maybe TeamId -> + Galley r Conversation +createOne2OneConversation lconv self other name mtid = do + retry x5 $ case mtid of + Nothing -> write Cql.insertConv (params Quorum (tUnqualified lconv, One2OneConv, tUnqualified self, privateOnly, privateRole, fromRange <$> name, Nothing, Nothing, Nothing)) Just tid -> batch $ do setType BatchLogged setConsistency Quorum - addPrepQuery Cql.insertConv (conv, One2OneConv, a', privateOnly, privateRole, fromRange <$> name, Just tid, Nothing, Nothing) - addPrepQuery Cql.insertTeamConv (tid, conv, False) - -- FUTUREWORK: federated one2one - (lmems, rmems) <- addMembers lconv (UserList [a', b'] []) - pure $ newConv conv One2OneConv a' lmems rmems [PrivateAccess] privateRole name ti Nothing Nothing + addPrepQuery Cql.insertConv (tUnqualified lconv, One2OneConv, tUnqualified self, privateOnly, privateRole, fromRange <$> name, Just tid, Nothing, Nothing) + addPrepQuery Cql.insertTeamConv (tid, tUnqualified lconv, False) + (lmems, rmems) <- addMembers lconv (toUserList self [qUntagged self, other]) + pure $ newConv (tUnqualified lconv) One2OneConv (tUnqualified self) lmems rmems [PrivateAccess] privateRole name mtid Nothing Nothing -updateConversation :: MonadClient m => ConvId -> Range 1 256 Text -> m () +updateConversation :: ConvId -> Range 1 256 Text -> Galley r () updateConversation cid name = retry x5 $ write Cql.updateConvName (params Quorum (fromRange name, cid)) -updateConversationAccess :: MonadClient m => ConvId -> ConversationAccessData -> m () +updateConversationAccess :: ConvId -> ConversationAccessData -> Galley r () updateConversationAccess cid (ConversationAccessData acc role) = retry x5 $ write Cql.updateConvAccess (params Quorum (Set (toList acc), role, cid)) -updateConversationReceiptMode :: MonadClient m => ConvId -> ReceiptMode -> m () +updateConversationReceiptMode :: ConvId -> ReceiptMode -> Galley r () updateConversationReceiptMode cid receiptMode = retry x5 $ write Cql.updateConvReceiptMode (params Quorum (receiptMode, cid)) -lookupReceiptMode :: MonadClient m => ConvId -> m (Maybe ReceiptMode) +lookupReceiptMode :: ConvId -> Galley r (Maybe ReceiptMode) lookupReceiptMode cid = join . fmap runIdentity <$> retry x1 (query1 Cql.selectReceiptMode (params Quorum (Identity cid))) -updateConversationMessageTimer :: MonadClient m => ConvId -> Maybe Milliseconds -> m () +updateConversationMessageTimer :: ConvId -> Maybe Milliseconds -> Galley r () updateConversationMessageTimer cid mtimer = retry x5 $ write Cql.updateConvMessageTimer (params Quorum (mtimer, cid)) -deleteConversation :: (MonadClient m, Log.MonadLogger m, MonadThrow m) => ConvId -> m () -deleteConversation cid = do +deleteConversation :: ConvId -> Galley r () +deleteConversation = liftClient . deleteConversationC + +deleteConversationC :: ConvId -> Client () +deleteConversationC cid = do retry x5 $ write Cql.markConvDeleted (params Quorum (Identity cid)) - mm <- members cid - for_ mm $ \m -> removeMember (lmId m) cid + + localMembers <- membersC cid + for_ (nonEmpty localMembers) $ \ms -> + removeLocalMembersFromLocalConvC cid (lmId <$> ms) + + remoteMembers <- lookupRemoteMembersC cid + for_ (nonEmpty remoteMembers) $ \ms -> + removeRemoteMembersFromLocalConvC cid (rmId <$> ms) + retry x5 $ write Cql.deleteConv (params Quorum (Identity cid)) -acceptConnect :: MonadClient m => ConvId -> m () +acceptConnect :: ConvId -> Galley r () acceptConnect cid = retry x5 $ write Cql.updateConvType (params Quorum (One2OneConv, cid)) -- | We deduce the conversation ID by adding the 4 components of the V4 UUID -- together pairwise, and then setting the version bits (v4) and variant bits -- (variant 2). This means that we always know what the UUID is for a -- one-to-one conversation which hopefully makes them unique. -one2OneConvId :: U.UUID U.V4 -> U.UUID U.V4 -> ConvId -one2OneConvId a b = Id . U.unpack $ U.addv4 a b +localOne2OneConvId :: U.UUID U.V4 -> U.UUID U.V4 -> ConvId +localOne2OneConvId a b = Id . U.unpack $ U.addv4 a b newConv :: ConvId -> @@ -770,10 +811,9 @@ newConv cid ct usr mems rMems acc role name tid mtimer rMode = convReceiptMode = rMode } -convMetadata :: Domain -> Conversation -> ConversationMetadata -convMetadata localDomain c = +convMetadata :: Conversation -> ConversationMetadata +convMetadata c = ConversationMetadata - (Qualified (convId c) localDomain) (convType c) (convCreator c) (convAccess c) @@ -822,18 +862,14 @@ privateOnly = Set [PrivateAccess] -- Conversation Members ----------------------------------------------------- member :: - (MonadClient m, Log.MonadLogger m, MonadThrow m) => ConvId -> UserId -> - m (Maybe LocalMember) + Galley r (Maybe LocalMember) member cnv usr = (toMember =<<) <$> retry x1 (query1 Cql.selectMember (params Quorum (cnv, usr))) -remoteMemberLists :: - (MonadClient m) => - [ConvId] -> - m [[RemoteMember]] +remoteMemberLists :: [ConvId] -> Client [[RemoteMember]] remoteMemberLists convs = do mems <- retry x1 $ query Cql.selectRemoteMembers (params Quorum (Identity convs)) let convMembers = foldr (insert . mkMem) Map.empty mems @@ -845,12 +881,9 @@ remoteMemberLists convs = do mkMem (cnv, domain, usr, role) = (cnv, toRemoteMember usr domain role) toRemoteMember :: UserId -> Domain -> RoleName -> RemoteMember -toRemoteMember u d = RemoteMember (toRemote (Qualified u d)) +toRemoteMember u d = RemoteMember (toRemoteUnsafe d u) -memberLists :: - (MonadClient m, Log.MonadLogger m, MonadThrow m) => - [ConvId] -> - m [[LocalMember]] +memberLists :: [ConvId] -> Client [[LocalMember]] memberLists convs = do mems <- retry x1 $ query Cql.selectMembers (params Quorum (Identity convs)) let convMembers = foldr (\m acc -> insert (mkMem m) acc) mempty mems @@ -863,15 +896,21 @@ memberLists convs = do mkMem (cnv, usr, srv, prv, st, omus, omur, oar, oarr, hid, hidr, crn) = (cnv, toMember (usr, srv, prv, st, omus, omur, oar, oarr, hid, hidr, crn)) -members :: (MonadClient m, Log.MonadLogger m, MonadThrow m) => ConvId -> m [LocalMember] -members conv = join <$> memberLists [conv] +members :: ConvId -> Galley r [LocalMember] +members = liftClient . membersC + +membersC :: ConvId -> Client [LocalMember] +membersC = fmap concat . liftClient . memberLists . pure -lookupRemoteMembers :: (MonadClient m) => ConvId -> m [RemoteMember] -lookupRemoteMembers conv = join <$> remoteMemberLists [conv] +lookupRemoteMembers :: ConvId -> Galley r [RemoteMember] +lookupRemoteMembers = liftClient . lookupRemoteMembersC + +lookupRemoteMembersC :: ConvId -> Client [RemoteMember] +lookupRemoteMembersC conv = join <$> remoteMemberLists [conv] -- | Add a member to a local conversation, as an admin. -addMember :: MonadClient m => Local ConvId -> Local UserId -> m [LocalMember] -addMember c u = fst <$> addMembers c (UserList [lUnqualified u] []) +addMember :: Local ConvId -> Local UserId -> Galley r [LocalMember] +addMember c u = fst <$> addMembers c (UserList [tUnqualified u] []) class ToUserRole a where toUserRole :: a -> (UserId, RoleName) @@ -891,13 +930,8 @@ toQualifiedUserRole = requalify . fmap toUserRole -- Conversation is local, so we can add any member to it (including remote ones). -- When the role is not specified, it defaults to admin. -- Please make sure the conversation doesn't exceed the maximum size! -addMembers :: - forall m a. - (MonadClient m, ToUserRole a) => - Local ConvId -> - UserList a -> - m ([LocalMember], [RemoteMember]) -addMembers (lUnqualified -> conv) (fmap toUserRole -> UserList lusers rusers) = do +addMembers :: ToUserRole a => Local ConvId -> UserList a -> Galley r ([LocalMember], [RemoteMember]) +addMembers (tUnqualified -> conv) (fmap toUserRole -> UserList lusers rusers) = do -- batch statement with 500 users are known to be above the batch size limit -- and throw "Batch too large" errors. Therefor we chunk requests and insert -- sequentially. (parallelizing would not aid performance as the partition @@ -920,7 +954,7 @@ addMembers (lUnqualified -> conv) (fmap toUserRole -> UserList lusers rusers) = retry x5 . batch $ do setType BatchLogged setConsistency Quorum - for_ chunk $ \(unTagged -> Qualified (uid, role) domain) -> do + for_ chunk $ \(qUntagged -> Qualified (uid, role) domain) -> do -- User is remote, so we only add it to the member_remote_user -- table, but the reverse mapping has to be done on the remote -- backend; so we assume an additional call to their backend has @@ -932,9 +966,9 @@ addMembers (lUnqualified -> conv) (fmap toUserRole -> UserList lusers rusers) = -- | Set local users as belonging to a remote conversation. This is invoked by a -- remote galley when users from the current backend are added to conversations -- on the remote end. -addLocalMembersToRemoteConv :: MonadClient m => Qualified ConvId -> [UserId] -> m () +addLocalMembersToRemoteConv :: Remote ConvId -> [UserId] -> Galley r () addLocalMembersToRemoteConv _ [] = pure () -addLocalMembersToRemoteConv qconv users = do +addLocalMembersToRemoteConv rconv users = do -- FUTUREWORK: consider using pooledMapConcurrentlyN for_ (List.chunksOf 32 users) $ \chunk -> retry x5 . batch $ do @@ -943,23 +977,21 @@ addLocalMembersToRemoteConv qconv users = do for_ chunk $ \u -> addPrepQuery Cql.insertUserRemoteConv - (u, qDomain qconv, qUnqualified qconv) + (u, tDomain rconv, tUnqualified rconv) updateSelfMember :: - MonadClient m => Local x -> Qualified ConvId -> Local UserId -> MemberUpdate -> - m () + Galley r () updateSelfMember loc = foldQualified loc updateSelfMemberLocalConv updateSelfMemberRemoteConv updateSelfMemberLocalConv :: - MonadClient m => Local ConvId -> Local UserId -> MemberUpdate -> - m () + Galley r () updateSelfMemberLocalConv lcid luid mup = do retry x5 . batch $ do setType BatchUnLogged @@ -967,65 +999,62 @@ updateSelfMemberLocalConv lcid luid mup = do for_ (mupOtrMuteStatus mup) $ \ms -> addPrepQuery Cql.updateOtrMemberMutedStatus - (ms, mupOtrMuteRef mup, lUnqualified lcid, lUnqualified luid) + (ms, mupOtrMuteRef mup, tUnqualified lcid, tUnqualified luid) for_ (mupOtrArchive mup) $ \a -> addPrepQuery Cql.updateOtrMemberArchived - (a, mupOtrArchiveRef mup, lUnqualified lcid, lUnqualified luid) + (a, mupOtrArchiveRef mup, tUnqualified lcid, tUnqualified luid) for_ (mupHidden mup) $ \h -> addPrepQuery Cql.updateMemberHidden - (h, mupHiddenRef mup, lUnqualified lcid, lUnqualified luid) + (h, mupHiddenRef mup, tUnqualified lcid, tUnqualified luid) updateSelfMemberRemoteConv :: - MonadClient m => Remote ConvId -> Local UserId -> MemberUpdate -> - m () -updateSelfMemberRemoteConv (Tagged (Qualified cid domain)) luid mup = do + Galley r () +updateSelfMemberRemoteConv (qUntagged -> Qualified cid domain) luid mup = do retry x5 . batch $ do setType BatchUnLogged setConsistency Quorum for_ (mupOtrMuteStatus mup) $ \ms -> addPrepQuery Cql.updateRemoteOtrMemberMutedStatus - (ms, mupOtrMuteRef mup, domain, cid, lUnqualified luid) + (ms, mupOtrMuteRef mup, domain, cid, tUnqualified luid) for_ (mupOtrArchive mup) $ \a -> addPrepQuery Cql.updateRemoteOtrMemberArchived - (a, mupOtrArchiveRef mup, domain, cid, lUnqualified luid) + (a, mupOtrArchiveRef mup, domain, cid, tUnqualified luid) for_ (mupHidden mup) $ \h -> addPrepQuery Cql.updateRemoteMemberHidden - (h, mupHiddenRef mup, domain, cid, lUnqualified luid) + (h, mupHiddenRef mup, domain, cid, tUnqualified luid) updateOtherMember :: - MonadClient m => Local x -> Qualified ConvId -> Qualified UserId -> OtherMemberUpdate -> - m () + Galley r () updateOtherMember loc = foldQualified loc updateOtherMemberLocalConv updateOtherMemberRemoteConv updateOtherMemberLocalConv :: - MonadClient m => Local ConvId -> Qualified UserId -> OtherMemberUpdate -> - m () + Galley r () updateOtherMemberLocalConv lcid quid omu = do let addQuery r - | lDomain lcid == qDomain quid = + | tDomain lcid == qDomain quid = addPrepQuery Cql.updateMemberConvRoleName - (r, lUnqualified lcid, qUnqualified quid) + (r, tUnqualified lcid, qUnqualified quid) | otherwise = addPrepQuery Cql.updateRemoteMemberConvRoleName - (r, lUnqualified lcid, qDomain quid, qUnqualified quid) + (r, tUnqualified lcid, qDomain quid, qUnqualified quid) retry x5 . batch $ do setType BatchUnLogged setConsistency Quorum @@ -1033,34 +1062,36 @@ updateOtherMemberLocalConv lcid quid omu = -- FUTUREWORK: https://wearezeta.atlassian.net/browse/SQCORE-887 updateOtherMemberRemoteConv :: - MonadClient m => Remote ConvId -> Qualified UserId -> OtherMemberUpdate -> - m () + Galley r () updateOtherMemberRemoteConv _ _ _ = pure () -- | Select only the members of a remote conversation from a list of users. -- Return the filtered list and a boolean indicating whether the all the input -- users are members. -filterRemoteConvMembers :: (MonadUnliftIO m, MonadClient m) => [UserId] -> Qualified ConvId -> m ([UserId], Bool) +filterRemoteConvMembers :: + [UserId] -> + Qualified ConvId -> + Galley r ([UserId], Bool) filterRemoteConvMembers users (Qualified conv dom) = - fmap Data.Monoid.getAll - . foldMap (\muser -> (muser, Data.Monoid.All (not (null muser)))) - <$> pooledMapConcurrentlyN 8 filterMember users + liftClient $ + fmap Data.Monoid.getAll + . foldMap (\muser -> (muser, Data.Monoid.All (not (null muser)))) + <$> UnliftIO.pooledMapConcurrentlyN 8 filterMember users where - filterMember :: MonadClient m => UserId -> m [UserId] + filterMember :: UserId -> Client [UserId] filterMember user = fmap (map runIdentity) . retry x1 $ query Cql.selectRemoteConvMembers (params Quorum (user, dom, conv)) -removeLocalMembersFromLocalConv :: - MonadClient m => - ConvId -> - NonEmpty UserId -> - m () -removeLocalMembersFromLocalConv cnv victims = do +removeLocalMembersFromLocalConv :: ConvId -> NonEmpty UserId -> Galley r () +removeLocalMembersFromLocalConv cnv = liftClient . removeLocalMembersFromLocalConvC cnv + +removeLocalMembersFromLocalConvC :: ConvId -> NonEmpty UserId -> Client () +removeLocalMembersFromLocalConvC cnv victims = do retry x5 . batch $ do setType BatchLogged setConsistency Quorum @@ -1068,33 +1099,31 @@ removeLocalMembersFromLocalConv cnv victims = do addPrepQuery Cql.removeMember (cnv, victim) addPrepQuery Cql.deleteUserConv (victim, cnv) -removeRemoteMembersFromLocalConv :: - MonadClient m => - ConvId -> - NonEmpty (Remote UserId) -> - m () -removeRemoteMembersFromLocalConv cnv victims = do +removeRemoteMembersFromLocalConv :: ConvId -> NonEmpty (Remote UserId) -> Galley r () +removeRemoteMembersFromLocalConv cnv = liftClient . removeRemoteMembersFromLocalConvC cnv + +removeRemoteMembersFromLocalConvC :: ConvId -> NonEmpty (Remote UserId) -> Client () +removeRemoteMembersFromLocalConvC cnv victims = do retry x5 . batch $ do setType BatchLogged setConsistency Quorum - for_ victims $ \(unTagged -> Qualified uid domain) -> + for_ victims $ \(qUntagged -> Qualified uid domain) -> addPrepQuery Cql.removeRemoteMember (cnv, domain, uid) removeLocalMembersFromRemoteConv :: - MonadClient m => -- | The conversation to remove members from - Qualified ConvId -> + Remote ConvId -> -- | Members to remove local to this backend [UserId] -> - m () + Galley r () removeLocalMembersFromRemoteConv _ [] = pure () -removeLocalMembersFromRemoteConv (Qualified conv convDomain) victims = +removeLocalMembersFromRemoteConv (qUntagged -> Qualified conv convDomain) victims = retry x5 . batch $ do setType BatchLogged setConsistency Quorum for_ victims $ \u -> addPrepQuery Cql.deleteUserRemoteConv (u, convDomain, conv) -removeMember :: MonadClient m => UserId -> ConvId -> m () +removeMember :: UserId -> ConvId -> Galley r () removeMember usr cnv = retry x5 . batch $ do setType BatchLogged setConsistency Quorum @@ -1114,7 +1143,7 @@ newMemberWithRole (u, r) = } newRemoteMemberWithRole :: Remote (UserId, RoleName) -> RemoteMember -newRemoteMemberWithRole ur@(unTagged -> (Qualified (u, r) _)) = +newRemoteMemberWithRole ur@(qUntagged -> (Qualified (u, r) _)) = RemoteMember { rmId = qualifyAs ur u, rmConvRoleName = r @@ -1172,25 +1201,26 @@ toMember _ = Nothing -- Clients ------------------------------------------------------------------ -updateClient :: MonadClient m => Bool -> UserId -> ClientId -> m () +updateClient :: Bool -> UserId -> ClientId -> Galley r () updateClient add usr cls = do let q = if add then Cql.addMemberClient else Cql.rmMemberClient retry x5 $ write (q cls) (params Quorum (Identity usr)) -- Do, at most, 16 parallel lookups of up to 128 users each -lookupClients :: - (MonadClient m, MonadUnliftIO m) => - [UserId] -> - m Clients -lookupClients users = +lookupClients :: [UserId] -> Galley r Clients +lookupClients = liftClient . lookupClients' + +-- This is only used by tests +lookupClients' :: [UserId] -> Client Clients +lookupClients' users = Clients.fromList . concat . concat - <$> forM (chunksOf 2048 users) (mapConcurrently getClients . chunksOf 128) + <$> forM (chunksOf 2048 users) (UnliftIO.mapConcurrently getClients . chunksOf 128) where getClients us = map (second fromSet) <$> retry x1 (query Cql.selectClients (params Quorum (Identity us))) -eraseClients :: MonadClient m => UserId -> m () +eraseClients :: UserId -> Galley r () eraseClients user = retry x5 (write Cql.rmClients (params Quorum (Identity user))) -- Internal utilities @@ -1201,11 +1231,11 @@ eraseClients user = retry x5 (write Cql.rmClients (params Quorum (Identity user) -- -- Throw an exception if one of invitation timestamp and inviter is 'Nothing' and the -- other is 'Just', which can only be caused by inconsistent database content. -newTeamMember' :: (MonadIO m, MonadThrow m, MonadClient m, MonadReader Env m) => TeamId -> (UserId, Permissions, Maybe UserId, Maybe UTCTimeMillis, Maybe UserLegalHoldStatus) -> m TeamMember +newTeamMember' :: TeamId -> (UserId, Permissions, Maybe UserId, Maybe UTCTimeMillis, Maybe UserLegalHoldStatus) -> Galley r TeamMember newTeamMember' tid (uid, perms, minvu, minvt, fromMaybe defUserLegalHoldStatus -> lhStatus) = do mk minvu minvt >>= maybeGrant where - maybeGrant :: (MonadClient m, MonadReader Env m) => TeamMember -> m TeamMember + maybeGrant :: TeamMember -> Galley r TeamMember maybeGrant m = ifM (isTeamLegalholdWhitelisted tid) @@ -1230,8 +1260,8 @@ newTeamMember' tid (uid, perms, minvu, minvt, fromMaybe defUserLegalHoldStatus - -- which are looked up based on: withTeamMembersWithChunks :: TeamId -> - ([TeamMember] -> Galley ()) -> - Galley () + ([TeamMember] -> Galley r ()) -> + Galley r () withTeamMembersWithChunks tid action = do mems <- teamMembersForPagination tid Nothing (unsafeRange hardTruncationLimit) handleMembers mems diff --git a/services/galley/src/Galley/Data/Services.hs b/services/galley/src/Galley/Data/Services.hs index 3d4f01108e..f47bf12364 100644 --- a/services/galley/src/Galley/Data/Services.hs +++ b/services/galley/src/Galley/Data/Services.hs @@ -67,7 +67,7 @@ botMemId = BotId . lmId . fromBotMember botMemService :: BotMember -> ServiceRef botMemService = fromJust . lmService . fromBotMember -addBotMember :: Qualified UserId -> ServiceRef -> BotId -> ConvId -> UTCTime -> Galley (Event, BotMember) +addBotMember :: Qualified UserId -> ServiceRef -> BotId -> ConvId -> UTCTime -> Galley r (Event, BotMember) addBotMember qorig s bot cnv now = do retry x5 . batch $ do setType BatchLogged diff --git a/services/galley/src/Galley/Data/TeamNotifications.hs b/services/galley/src/Galley/Data/TeamNotifications.hs index 1922c1580a..d5c7689538 100644 --- a/services/galley/src/Galley/Data/TeamNotifications.hs +++ b/services/galley/src/Galley/Data/TeamNotifications.hs @@ -37,6 +37,7 @@ import Data.List1 (List1) import Data.Range (Range, fromRange) import Data.Sequence (Seq, ViewL (..), ViewR (..), (<|), (><)) import qualified Data.Sequence as Seq +import Galley.App import Gundeck.Types.Notification import Imports @@ -51,11 +52,10 @@ data ResultPage = ResultPage -- FUTUREWORK: the magic 32 should be made configurable, so it can be tuned add :: - (MonadClient m, MonadUnliftIO m) => TeamId -> NotificationId -> List1 JSON.Object -> - m () + Galley r () add tid nid (Blob . JSON.encode -> payload) = write cqlInsert (params Quorum (tid, nid, payload, notificationTTLSeconds)) & retry x5 where @@ -69,7 +69,7 @@ add tid nid (Blob . JSON.encode -> payload) = notificationTTLSeconds :: Int32 notificationTTLSeconds = 24192200 -fetch :: forall m. MonadClient m => TeamId -> Maybe NotificationId -> Range 1 10000 Int32 -> m ResultPage +fetch :: TeamId -> Maybe NotificationId -> Range 1 10000 Int32 -> Galley r ResultPage fetch tid since (fromRange -> size) = do -- We always need to look for one more than requested in order to correctly -- report whether there are more results. @@ -90,7 +90,11 @@ fetch tid since (fromRange -> size) = do EmptyL -> ResultPage Seq.empty False (x :< xs) -> ResultPage (x <| xs) more where - collect :: Seq QueuedNotification -> Int -> Page (TimeUuid, Blob) -> m (Seq QueuedNotification, Bool) + collect :: + Seq QueuedNotification -> + Int -> + Page (TimeUuid, Blob) -> + Galley r (Seq QueuedNotification, Bool) collect acc num page = let ns = splitAt num $ foldr toNotif [] (result page) nseq = Seq.fromList (fst ns) diff --git a/services/galley/src/Galley/Effects.hs b/services/galley/src/Galley/Effects.hs new file mode 100644 index 0000000000..78aceb6954 --- /dev/null +++ b/services/galley/src/Galley/Effects.hs @@ -0,0 +1,109 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Effects + ( -- * Effects needed in Galley + GalleyEffects1, + + -- * Internal services + Intra, + interpretIntra, + + -- * Brig + BrigAccess, + interpretBrig, + + -- * Federator + FederatorAccess, + interpretFederator, + + -- * Spar + SparAccess, + interpretSpar, + + -- * Gundeck + GundeckAccess, + interpretGundeck, + + -- * External services + ExternalAccess, + interpretExternal, + + -- * Bot API + BotAccess, + interpretBot, + + -- * Fire-and-forget async + FireAndForget, + interpretFireAndForget, + + -- * Polysemy re-exports + Member, + Members, + ) +where + +import Galley.Effects.FireAndForget +import Imports +import Polysemy + +data Intra m a + +interpretIntra :: Sem (Intra ': r) a -> Sem r a +interpretIntra = interpret $ \case + +data BrigAccess m a + +interpretBrig :: Sem (BrigAccess ': r) a -> Sem r a +interpretBrig = interpret $ \case + +data GundeckAccess m a + +interpretGundeck :: Sem (GundeckAccess ': r) a -> Sem r a +interpretGundeck = interpret $ \case + +data ExternalAccess m a + +interpretExternal :: Sem (ExternalAccess ': r) a -> Sem r a +interpretExternal = interpret $ \case + +data FederatorAccess m a + +interpretFederator :: Sem (FederatorAccess ': r) a -> Sem r a +interpretFederator = interpret $ \case + +data SparAccess m a + +interpretSpar :: Sem (SparAccess ': r) a -> Sem r a +interpretSpar = interpret $ \case + +data BotAccess m a + +interpretBot :: Sem (BotAccess ': r) a -> Sem r a +interpretBot = interpret $ \case + +-- All the possible high-level effects. +type GalleyEffects1 = + '[ BrigAccess, + GundeckAccess, + SparAccess, + ExternalAccess, + FederatorAccess, + BotAccess, + Intra, + FireAndForget + ] diff --git a/services/galley/src/Galley/Effects/FireAndForget.hs b/services/galley/src/Galley/Effects/FireAndForget.hs new file mode 100644 index 0000000000..4b614862a3 --- /dev/null +++ b/services/galley/src/Galley/Effects/FireAndForget.hs @@ -0,0 +1,48 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Effects.FireAndForget + ( FireAndForget, + fireAndForget, + spawnMany, + interpretFireAndForget, + ) +where + +import Imports +import Polysemy +import Polysemy.Final +import UnliftIO.Async (pooledMapConcurrentlyN_) + +data FireAndForget m a where + FireAndForgetOne :: m () -> FireAndForget m () + SpawnMany :: [m ()] -> FireAndForget m () + +makeSem ''FireAndForget + +fireAndForget :: Member FireAndForget r => Sem r () -> Sem r () +fireAndForget = fireAndForgetOne + +interpretFireAndForget :: Member (Final IO) r => Sem (FireAndForget ': r) a -> Sem r a +interpretFireAndForget = interpretFinal @IO $ \case + FireAndForgetOne action -> do + action' <- runS action + liftS $ void . forkIO . void $ action' + SpawnMany actions -> do + actions' <- traverse runS actions + -- I picked this number by fair dice roll, feel free to change it :P + liftS $ pooledMapConcurrentlyN_ 8 void actions' diff --git a/services/galley/src/Galley/External.hs b/services/galley/src/Galley/External.hs index 4b8b7994a8..eb2024ee2d 100644 --- a/services/galley/src/Galley/External.hs +++ b/services/galley/src/Galley/External.hs @@ -17,6 +17,8 @@ module Galley.External ( deliver, + deliverAndDeleteAsync, + deliverAsync, ) where @@ -25,10 +27,13 @@ import Bilge.Retry (httpHandlers) import Control.Lens import Control.Retry import Data.ByteString.Conversion.To +import Data.Id import Data.Misc import Galley.App import Galley.Data.Services (BotMember, botMemId, botMemService) import qualified Galley.Data.Services as Data +import Galley.Effects +import Galley.Intra.User import Galley.Types (Event) import Galley.Types.Bot import Imports @@ -41,22 +46,41 @@ import System.Logger.Message (field, msg, val, (~~)) import URI.ByteString import UnliftIO (Async, async, waitCatch) +-- | Like deliver, but ignore orphaned bots and return immediately. +-- +-- FUTUREWORK: Check if this can be removed. +deliverAsync :: Member ExternalAccess r => [(BotMember, Event)] -> Galley r () +deliverAsync = liftGalley0 . void . forkIO . void . deliver0 + +-- | Like deliver, but remove orphaned bots and return immediately. +deliverAndDeleteAsync :: + Members '[ExternalAccess, BotAccess] r => + ConvId -> + [(BotMember, Event)] -> + Galley r () +deliverAndDeleteAsync cnv pushes = liftGalley0 . void . forkIO $ do + gone <- liftGalley0 $ deliver0 pushes + mapM_ (deleteBot0 cnv . botMemId) gone + -- | Deliver events to external (bot) services. -- -- Returns those bots which are found to be orphaned by the external -- service, e.g. when the service tells us that it no longer knows about the -- bot. -deliver :: [(BotMember, Event)] -> Galley [BotMember] -deliver pp = mapM (async . exec) pp >>= foldM eval [] . zip (map fst pp) +deliver :: Member ExternalAccess r => [(BotMember, Event)] -> Galley r [BotMember] +deliver = liftGalley0 . deliver0 + +deliver0 :: [(BotMember, Event)] -> Galley0 [BotMember] +deliver0 pp = mapM (async . exec) pp >>= foldM eval [] . zip (map fst pp) where - exec :: (BotMember, Event) -> Galley Bool + exec :: (BotMember, Event) -> Galley0 Bool exec (b, e) = Data.lookupService (botMemService b) >>= \case Nothing -> return False Just s -> do deliver1 s b e return True - eval :: [BotMember] -> (BotMember, Async Bool) -> Galley [BotMember] + eval :: [BotMember] -> (BotMember, Async Bool) -> Galley r [BotMember] eval gone (b, a) = do let s = botMemService b r <- waitCatch a @@ -95,7 +119,7 @@ deliver pp = mapM (async . exec) pp >>= foldM eval [] . zip (map fst pp) -- Internal ------------------------------------------------------------------- -deliver1 :: Service -> BotMember -> Event -> Galley () +deliver1 :: Service -> BotMember -> Event -> Galley0 () deliver1 s bm e | s ^. serviceEnabled = do let t = toByteString' (s ^. serviceToken) @@ -125,7 +149,7 @@ urlPort (HttpsUrl u) = do p <- a ^. authorityPortL return (fromIntegral (p ^. portNumberL)) -sendMessage :: [Fingerprint Rsa] -> (Request -> Request) -> Galley () +sendMessage :: [Fingerprint Rsa] -> (Request -> Request) -> Galley r () sendMessage fprs reqBuilder = do (man, verifyFingerprints) <- view (extEnv . extGetManager) liftIO . withVerifiedSslConnection (verifyFingerprints fprs) man reqBuilder $ \req -> diff --git a/services/galley/src/Galley/External/LegalHoldService.hs b/services/galley/src/Galley/External/LegalHoldService.hs index 67d2f6bd9a..133b4cf413 100644 --- a/services/galley/src/Galley/External/LegalHoldService.hs +++ b/services/galley/src/Galley/External/LegalHoldService.hs @@ -67,7 +67,7 @@ import URI.ByteString (uriPath) -- api -- | Get /status from legal hold service; throw 'Wai.Error' if things go wrong. -checkLegalHoldServiceStatus :: Fingerprint Rsa -> HttpsUrl -> Galley () +checkLegalHoldServiceStatus :: Fingerprint Rsa -> HttpsUrl -> Galley r () checkLegalHoldServiceStatus fpr url = do resp <- makeVerifiedRequestFreshManager fpr url reqBuilder if @@ -83,7 +83,7 @@ checkLegalHoldServiceStatus fpr url = do . Bilge.expect2xx -- | @POST /initiate@. -requestNewDevice :: TeamId -> UserId -> Galley NewLegalHoldClient +requestNewDevice :: TeamId -> UserId -> Galley r NewLegalHoldClient requestNewDevice tid uid = do resp <- makeLegalHoldServiceRequest tid reqParams case eitherDecode (responseBody resp) of @@ -107,7 +107,7 @@ confirmLegalHold :: UserId -> -- | TODO: Replace with 'LegalHold' token type OpaqueAuthToken -> - Galley () + Galley r () confirmLegalHold clientId tid uid legalHoldAuthToken = do void $ makeLegalHoldServiceRequest tid reqParams where @@ -123,7 +123,7 @@ confirmLegalHold clientId tid uid legalHoldAuthToken = do removeLegalHold :: TeamId -> UserId -> - Galley () + Galley r () removeLegalHold tid uid = do void $ makeLegalHoldServiceRequest tid reqParams where @@ -140,7 +140,7 @@ removeLegalHold tid uid = do -- | Lookup legal hold service settings for a team and make a request to the service. Pins -- the TSL fingerprint via 'makeVerifiedRequest' and passes the token so the service can -- authenticate the request. -makeLegalHoldServiceRequest :: TeamId -> (Http.Request -> Http.Request) -> Galley (Http.Response LC8.ByteString) +makeLegalHoldServiceRequest :: TeamId -> (Http.Request -> Http.Request) -> Galley r (Http.Response LC8.ByteString) makeLegalHoldServiceRequest tid reqBuilder = do maybeLHSettings <- LegalHoldData.getSettings tid lhSettings <- case maybeLHSettings of @@ -157,7 +157,7 @@ makeLegalHoldServiceRequest tid reqBuilder = do reqBuilder . Bilge.header "Authorization" ("Bearer " <> toByteString' token) -makeVerifiedRequest :: Fingerprint Rsa -> HttpsUrl -> (Http.Request -> Http.Request) -> Galley (Http.Response LC8.ByteString) +makeVerifiedRequest :: Fingerprint Rsa -> HttpsUrl -> (Http.Request -> Http.Request) -> Galley r (Http.Response LC8.ByteString) makeVerifiedRequest fpr url reqBuilder = do (mgr, verifyFingerprints) <- view (extEnv . extGetManager) makeVerifiedRequestWithManager mgr verifyFingerprints fpr url reqBuilder @@ -166,23 +166,24 @@ makeVerifiedRequest fpr url reqBuilder = do -- We should really _only_ use it in `checkLegalHoldServiceStatus` for the time being because -- this is where we check for signatures, etc. If we reuse the manager, we are likely to reuse -- an existing connection which will _not_ cause the new public key to be verified. -makeVerifiedRequestFreshManager :: Fingerprint Rsa -> HttpsUrl -> (Http.Request -> Http.Request) -> Galley (Http.Response LC8.ByteString) +makeVerifiedRequestFreshManager :: Fingerprint Rsa -> HttpsUrl -> (Http.Request -> Http.Request) -> Galley r (Http.Response LC8.ByteString) makeVerifiedRequestFreshManager fpr url reqBuilder = do ExtEnv (mgr, verifyFingerprints) <- liftIO initExtEnv makeVerifiedRequestWithManager mgr verifyFingerprints fpr url reqBuilder -- | Check that the given fingerprint is valid and make the request over ssl. -- If the team has a device registered use 'makeLegalHoldServiceRequest' instead. -makeVerifiedRequestWithManager :: Http.Manager -> ([Fingerprint Rsa] -> SSL.SSL -> IO ()) -> Fingerprint Rsa -> HttpsUrl -> (Http.Request -> Http.Request) -> Galley (Http.Response LC8.ByteString) +makeVerifiedRequestWithManager :: Http.Manager -> ([Fingerprint Rsa] -> SSL.SSL -> IO ()) -> Fingerprint Rsa -> HttpsUrl -> (Http.Request -> Http.Request) -> Galley r (Http.Response LC8.ByteString) makeVerifiedRequestWithManager mgr verifyFingerprints fpr (HttpsUrl url) reqBuilder = do let verified = verifyFingerprints [fpr] - extHandleAll errHandler $ do - recovering x3 httpHandlers $ - const $ - liftIO $ - withVerifiedSslConnection verified mgr (reqBuilderMods . reqBuilder) $ - \req -> - Http.httpLbs req mgr + liftGalley0 $ + extHandleAll errHandler $ do + recovering x3 httpHandlers $ + const $ + liftIO $ + withVerifiedSslConnection verified mgr (reqBuilderMods . reqBuilder) $ + \req -> + Http.httpLbs req mgr where reqBuilderMods = maybe id Bilge.host (Bilge.extHost url) diff --git a/services/galley/src/Galley/Intra/Client.hs b/services/galley/src/Galley/Intra/Client.hs index b45043dac8..f0a941d0a3 100644 --- a/services/galley/src/Galley/Intra/Client.hs +++ b/services/galley/src/Galley/Intra/Client.hs @@ -39,6 +39,7 @@ import qualified Data.Set as Set import Data.Text.Encoding import Galley.API.Error import Galley.App +import Galley.Effects import Galley.External.LegalHoldService import Galley.Intra.Util import Imports @@ -49,11 +50,11 @@ import qualified System.Logger.Class as Logger import Wire.API.User.Client (UserClients, UserClientsFull, filterClients, filterClientsFull) -- | Calls 'Brig.API.internalListClientsH'. -lookupClients :: [UserId] -> Galley UserClients +lookupClients :: Member BrigAccess r => [UserId] -> Galley r UserClients lookupClients uids = do (brigHost, brigPort) <- brigReq r <- - call "brig" $ + callBrig $ method POST . host brigHost . port brigPort . path "/i/clients" . json (UserSet $ Set.fromList uids) @@ -62,11 +63,14 @@ lookupClients uids = do return $ filterClients (not . Set.null) clients -- | Calls 'Brig.API.internalListClientsFullH'. -lookupClientsFull :: [UserId] -> Galley UserClientsFull +lookupClientsFull :: + Member BrigAccess r => + [UserId] -> + Galley r UserClientsFull lookupClientsFull uids = do (brigHost, brigPort) <- brigReq r <- - call "brig" $ + callBrig $ method POST . host brigHost . port brigPort . path "/i/clients/full" . json (UserSet $ Set.fromList uids) @@ -75,10 +79,15 @@ lookupClientsFull uids = do return $ filterClientsFull (not . Set.null) clients -- | Calls 'Brig.API.legalHoldClientRequestedH'. -notifyClientsAboutLegalHoldRequest :: UserId -> UserId -> LastPrekey -> Galley () +notifyClientsAboutLegalHoldRequest :: + Member BrigAccess r => + UserId -> + UserId -> + LastPrekey -> + Galley r () notifyClientsAboutLegalHoldRequest requesterUid targetUid lastPrekey' = do (brigHost, brigPort) <- brigReq - void . call "brig" $ + void . callBrig $ method POST . host brigHost . port brigPort @@ -87,11 +96,15 @@ notifyClientsAboutLegalHoldRequest requesterUid targetUid lastPrekey' = do . expect2xx -- | Calls 'Brig.User.API.Auth.legalHoldLoginH'. -getLegalHoldAuthToken :: UserId -> Maybe PlainTextPassword -> Galley OpaqueAuthToken +getLegalHoldAuthToken :: + Member BrigAccess r => + UserId -> + Maybe PlainTextPassword -> + Galley r OpaqueAuthToken getLegalHoldAuthToken uid pw = do (brigHost, brigPort) <- brigReq r <- - call "brig" $ + callBrig $ method POST . host brigHost . port brigPort @@ -106,7 +119,13 @@ getLegalHoldAuthToken uid pw = do Just c -> pure . OpaqueAuthToken . decodeUtf8 $ c -- | Calls 'Brig.API.addClientInternalH'. -addLegalHoldClientToUser :: UserId -> ConnId -> [Prekey] -> LastPrekey -> Galley ClientId +addLegalHoldClientToUser :: + Member BrigAccess r => + UserId -> + ConnId -> + [Prekey] -> + LastPrekey -> + Galley r ClientId addLegalHoldClientToUser uid connId prekeys lastPrekey' = do clientId <$> brigAddClient uid connId lhClient where @@ -123,10 +142,13 @@ addLegalHoldClientToUser uid connId prekeys lastPrekey' = do Nothing -- | Calls 'Brig.API.removeLegalHoldClientH'. -removeLegalHoldClientFromUser :: UserId -> Galley () +removeLegalHoldClientFromUser :: + Member BrigAccess r => + UserId -> + Galley r () removeLegalHoldClientFromUser targetUid = do (brigHost, brigPort) <- brigReq - void . call "brig" $ + void . callBrig $ method DELETE . host brigHost . port brigPort @@ -135,11 +157,11 @@ removeLegalHoldClientFromUser targetUid = do . expect2xx -- | Calls 'Brig.API.addClientInternalH'. -brigAddClient :: UserId -> ConnId -> NewClient -> Galley Client +brigAddClient :: Member BrigAccess r => UserId -> ConnId -> NewClient -> Galley r Client brigAddClient uid connId client = do (brigHost, brigPort) <- brigReq r <- - call "brig" $ + callBrig $ method POST . host brigHost . port brigPort diff --git a/services/galley/src/Galley/Intra/Journal.hs b/services/galley/src/Galley/Intra/Journal.hs index 234db9ebba..4cb9e07a3d 100644 --- a/services/galley/src/Galley/Intra/Journal.hs +++ b/services/galley/src/Galley/Intra/Journal.hs @@ -49,22 +49,22 @@ import qualified System.Logger.Class as Log -- Team journal operations to SQS are a no-op when the service -- is started without journaling arguments -teamActivate :: TeamId -> Natural -> Maybe Currency.Alpha -> Maybe TeamCreationTime -> Galley () +teamActivate :: TeamId -> Natural -> Maybe Currency.Alpha -> Maybe TeamCreationTime -> Galley r () teamActivate tid teamSize cur time = do billingUserIds <- getBillingUserIds tid Nothing journalEvent TeamEvent'TEAM_ACTIVATE tid (Just $ evData teamSize billingUserIds cur) time -teamUpdate :: TeamId -> Natural -> [UserId] -> Galley () +teamUpdate :: TeamId -> Natural -> [UserId] -> Galley r () teamUpdate tid teamSize billingUserIds = journalEvent TeamEvent'TEAM_UPDATE tid (Just $ evData teamSize billingUserIds Nothing) Nothing -teamDelete :: TeamId -> Galley () +teamDelete :: TeamId -> Galley r () teamDelete tid = journalEvent TeamEvent'TEAM_DELETE tid Nothing Nothing -teamSuspend :: TeamId -> Galley () +teamSuspend :: TeamId -> Galley r () teamSuspend tid = journalEvent TeamEvent'TEAM_SUSPEND tid Nothing Nothing -journalEvent :: TeamEvent'EventType -> TeamId -> Maybe TeamEvent'EventData -> Maybe TeamCreationTime -> Galley () +journalEvent :: TeamEvent'EventType -> TeamId -> Maybe TeamEvent'EventData -> Maybe TeamCreationTime -> Galley r () journalEvent typ tid dat tim = view aEnv >>= \mEnv -> for_ mEnv $ \e -> do -- writetime is in microseconds in cassandra 3.11 @@ -90,7 +90,7 @@ evData memberCount billingUserIds cur = -- FUTUREWORK: Remove this function and always get billing users ids using -- 'Data.listBillingTeamMembers'. This is required only until data is backfilled in the -- 'billing_team_user' table. -getBillingUserIds :: TeamId -> Maybe TeamMemberList -> Galley [UserId] +getBillingUserIds :: TeamId -> Maybe TeamMemberList -> Galley r [UserId] getBillingUserIds tid maybeMemberList = do enableIndexedBillingTeamMembers <- view (options . Opts.optSettings . Opts.setEnableIndexedBillingTeamMembers . to (fromMaybe False)) case maybeMemberList of @@ -100,14 +100,14 @@ getBillingUserIds tid maybeMemberList = do else handleList enableIndexedBillingTeamMembers =<< Data.teamMembersForFanout tid Just list -> handleList enableIndexedBillingTeamMembers list where - fetchFromDB :: Galley [UserId] + fetchFromDB :: Galley r [UserId] fetchFromDB = Data.listBillingTeamMembers tid - filterFromMembers :: TeamMemberList -> Galley [UserId] + filterFromMembers :: TeamMemberList -> Galley r [UserId] filterFromMembers list = pure $ map (view userId) $ filter (`hasPermission` SetBilling) (list ^. teamMembers) - handleList :: Bool -> TeamMemberList -> Galley [UserId] + handleList :: Bool -> TeamMemberList -> Galley r [UserId] handleList enableIndexedBillingTeamMembers list = case list ^. teamMemberListType of ListTruncated -> diff --git a/services/galley/src/Galley/Intra/Push.hs b/services/galley/src/Galley/Intra/Push.hs index 04c2e48b3e..15f6707614 100644 --- a/services/galley/src/Galley/Intra/Push.hs +++ b/services/galley/src/Galley/Intra/Push.hs @@ -71,16 +71,18 @@ import qualified Data.Set as Set import Data.Text.Encoding (encodeUtf8) import qualified Data.Text.Lazy as LT import Galley.App +import Galley.Effects import Galley.Options import Galley.Types import qualified Galley.Types.Teams as Teams import Gundeck.Types.Push.V2 (RecipientClients (..)) import qualified Gundeck.Types.Push.V2 as Gundeck -import Imports +import Imports hiding (forkIO) import Network.HTTP.Types.Method import Safe (headDef, tailDef) import System.Logger.Class hiding (new) -import UnliftIO (mapConcurrently) +import UnliftIO.Async (mapConcurrently) +import UnliftIO.Concurrent (forkIO) import Util.Options import qualified Wire.API.Event.FeatureConfig as FeatureConfig @@ -158,14 +160,14 @@ newConversationEventPush localDomain e users = -- | Asynchronously send a single push, chunking it into multiple -- requests if there are more than 128 recipients. -push1 :: Push -> Galley () +push1 :: Member GundeckAccess r => Push -> Galley r () push1 p = push (list1 p []) -pushSome :: [Push] -> Galley () +pushSome :: Member GundeckAccess r => [Push] -> Galley r () pushSome [] = return () pushSome (x : xs) = push (list1 x xs) -push :: List1 Push -> Galley () +push :: Member GundeckAccess r => List1 Push -> Galley r () push ps = do let (localPushes, remotePushes) = foldMap (bimap toList toList . splitPush) (toList ps) traverse_ (pushLocal . List1) (nonEmpty localPushes) @@ -185,13 +187,14 @@ push ps = do -- | Asynchronously send multiple pushes, aggregating them into as -- few requests as possible, such that no single request targets -- more than 128 recipients. -pushLocal :: List1 (PushTo UserId) -> Galley () +pushLocal :: Member GundeckAccess r => List1 (PushTo UserId) -> Galley r () pushLocal ps = do limit <- fanoutLimit + opts <- view options -- Do not fan out for very large teams - let (async, sync) = partition _pushAsync (removeIfLargeFanout limit $ toList ps) - forM_ (pushes async) $ gundeckReq >=> callAsync "gundeck" - void $ mapConcurrently (gundeckReq >=> call "gundeck") (pushes sync) + let (asyncs, sync) = partition _pushAsync (removeIfLargeFanout limit $ toList ps) + forM_ (pushes asyncs) $ callAsync "gundeck" . gundeckReq opts + void . liftGalley0 $ mapConcurrently (call0 "gundeck" . gundeckReq opts) (pushes sync) return () where pushes = fst . foldr chunk ([], 0) @@ -226,7 +229,7 @@ pushLocal ps = do ) -- instead of IdMapping, we could also just take qualified IDs -pushRemote :: List1 (PushTo UserId) -> Galley () +pushRemote :: List1 (PushTo UserId) -> Galley r () pushRemote _ps = do -- FUTUREWORK(federation, #1261): send these to the other backends pure () @@ -234,27 +237,25 @@ pushRemote _ps = do ----------------------------------------------------------------------------- -- Helpers -gundeckReq :: [Gundeck.Push] -> Galley (Request -> Request) -gundeckReq ps = do - o <- view options - return $ - host (encodeUtf8 $ o ^. optGundeck . epHost) - . port (portNumber $ fromIntegral (o ^. optGundeck . epPort)) - . method POST - . path "/i/push/v2" - . json ps - . expect2xx +gundeckReq :: Opts -> [Gundeck.Push] -> Request -> Request +gundeckReq o ps = + host (encodeUtf8 $ o ^. optGundeck . epHost) + . port (portNumber $ fromIntegral (o ^. optGundeck . epPort)) + . method POST + . path "/i/push/v2" + . json ps + . expect2xx -callAsync :: LT.Text -> (Request -> Request) -> Galley () -callAsync n r = void . forkIO $ void (call n r) `catches` handlers +callAsync :: Member GundeckAccess r => LT.Text -> (Request -> Request) -> Galley r () +callAsync n r = liftGalley0 . void . forkIO $ void (call0 n r) `catches` handlers where handlers = [ Handler $ \(x :: RPCException) -> err (rpcExceptionMsg x), Handler $ \(x :: SomeException) -> err $ "remote" .= n ~~ msg (show x) ] -call :: LT.Text -> (Request -> Request) -> Galley (Response (Maybe LByteString)) -call n r = recovering x3 rpcHandlers (const (rpc n r)) +call0 :: LT.Text -> (Request -> Request) -> Galley0 (Response (Maybe LByteString)) +call0 n r = recovering x3 rpcHandlers (const (rpc n r)) x3 :: RetryPolicy x3 = limitRetries 3 <> exponentialBackoff 100000 diff --git a/services/galley/src/Galley/Intra/Spar.hs b/services/galley/src/Galley/Intra/Spar.hs index 08ec54af70..c10f3109d3 100644 --- a/services/galley/src/Galley/Intra/Spar.hs +++ b/services/galley/src/Galley/Intra/Spar.hs @@ -24,16 +24,17 @@ import Bilge import Data.ByteString.Conversion import Data.Id import Galley.App +import Galley.Effects import Galley.Intra.Util import Imports import Network.HTTP.Types.Method -- | Notify Spar that a team is being deleted. -deleteTeam :: TeamId -> Galley () +deleteTeam :: Member SparAccess r => TeamId -> Galley r () deleteTeam tid = do (h, p) <- sparReq _ <- - call "spar" $ + callSpar $ method DELETE . host h . port p . paths ["i", "teams", toByteString' tid] . expect2xx diff --git a/services/galley/src/Galley/Intra/Team.hs b/services/galley/src/Galley/Intra/Team.hs index dbf56e2d6b..50cdcdd345 100644 --- a/services/galley/src/Galley/Intra/Team.hs +++ b/services/galley/src/Galley/Intra/Team.hs @@ -23,17 +23,18 @@ import Brig.Types.Team import Data.ByteString.Conversion import Data.Id import Galley.App +import Galley.Effects import Galley.Intra.Util import Imports import Network.HTTP.Types.Method import Network.HTTP.Types.Status import Network.Wai.Utilities.Error -getSize :: TeamId -> Galley TeamSize +getSize :: Member BrigAccess r => TeamId -> Galley r TeamSize getSize tid = do (h, p) <- brigReq r <- - call "brig" $ + callBrig $ method GET . host h . port p . paths ["/i/teams", toByteString' tid, "size"] . expect2xx diff --git a/services/galley/src/Galley/Intra/User.hs b/services/galley/src/Galley/Intra/User.hs index 3a8b52c3cf..faea13c43e 100644 --- a/services/galley/src/Galley/Intra/User.hs +++ b/services/galley/src/Galley/Intra/User.hs @@ -17,6 +17,8 @@ module Galley.Intra.User ( getConnections, + getConnectionsUnqualified0, + getConnectionsUnqualified, putConnectionInternal, deleteBot, reAuthUser, @@ -27,12 +29,15 @@ module Galley.Intra.User getContactList, chunkify, getRichInfoMultiUser, + + -- * Internal + deleteBot0, ) where import Bilge hiding (getHeader, options, statusCode) import Bilge.RPC -import Brig.Types.Connection (ConnectionsStatusRequest (..), Relation (..), UpdateConnectionsInternal (..), UserIds (..)) +import Brig.Types.Connection (Relation (..), UpdateConnectionsInternal (..), UserIds (..)) import Brig.Types.Intra import Brig.Types.User (User) import Control.Monad.Catch (throwM) @@ -40,7 +45,9 @@ import Data.ByteString.Char8 (pack) import qualified Data.ByteString.Char8 as BSC import Data.ByteString.Conversion import Data.Id +import Data.Qualified import Galley.App +import Galley.Effects import Galley.Intra.Util import Imports import Network.HTTP.Client (HttpExceptionContent (..)) @@ -48,6 +55,7 @@ import qualified Network.HTTP.Client.Internal as Http import Network.HTTP.Types.Method import Network.HTTP.Types.Status import Network.Wai.Utilities.Error +import Wire.API.Routes.Internal.Brig.Connection import Wire.API.User.RichInfo (RichInfo) -- | Get statuses of all connections between two groups of users (the usual @@ -55,12 +63,25 @@ import Wire.API.User.RichInfo (RichInfo) -- several users to one). -- -- When a connection does not exist, it is skipped. --- Calls 'Brig.API.getConnectionsStatusH'. -getConnections :: [UserId] -> Maybe [UserId] -> Maybe Relation -> Galley [ConnectionStatus] -getConnections uFrom uTo rlt = do +-- Calls 'Brig.API.Internal.getConnectionsStatusUnqualified'. +getConnectionsUnqualified :: + Member BrigAccess r => + [UserId] -> + Maybe [UserId] -> + Maybe Relation -> + Galley r [ConnectionStatus] +getConnectionsUnqualified uFrom uTo rlt = + liftGalley0 $ getConnectionsUnqualified0 uFrom uTo rlt + +getConnectionsUnqualified0 :: + [UserId] -> + Maybe [UserId] -> + Maybe Relation -> + Galley0 [ConnectionStatus] +getConnectionsUnqualified0 uFrom uTo rlt = do (h, p) <- brigReq r <- - call "brig" $ + call0 "brig" $ method POST . host h . port p . path "/i/users/connections-status" . maybe id rfilter rlt @@ -70,22 +91,39 @@ getConnections uFrom uTo rlt = do where rfilter = queryItem "filter" . (pack . map toLower . show) -putConnectionInternal :: UpdateConnectionsInternal -> Galley Status +-- | Get statuses of all connections between two groups of users (the usual +-- pattern is to check all connections from one user to several, or from +-- several users to one). +-- +-- When a connection does not exist, it is skipped. +-- Calls 'Brig.API.Internal.getConnectionsStatus'. +getConnections :: Member BrigAccess r => [UserId] -> Maybe [Qualified UserId] -> Maybe Relation -> Galley r [ConnectionStatusV2] +getConnections [] _ _ = pure [] +getConnections uFrom uTo rlt = do + (h, p) <- brigReq + r <- + callBrig $ + method POST . host h . port p + . path "/i/users/connections-status/v2" + . json (ConnectionsStatusRequestV2 uFrom uTo rlt) + . expect2xx + parseResponse (mkError status502 "server-error") r + +putConnectionInternal :: Member BrigAccess r => UpdateConnectionsInternal -> Galley r Status putConnectionInternal updateConn = do (h, p) <- brigReq response <- - call "brig" $ + callBrig $ method PUT . host h . port p . paths ["/i/connections/connection-update"] . json updateConn pure $ responseStatus response --- | Calls 'Brig.Provider.API.botGetSelfH'. -deleteBot :: ConvId -> BotId -> Galley () -deleteBot cid bot = do +deleteBot0 :: ConvId -> BotId -> Galley0 () +deleteBot0 cid bot = do (h, p) <- brigReq void $ - call "brig" $ + call0 "brig" $ method DELETE . host h . port p . path "/bot/self" . header "Z-Type" "bot" @@ -93,15 +131,19 @@ deleteBot cid bot = do . header "Z-Conversation" (toByteString' cid) . expect2xx +-- | Calls 'Brig.Provider.API.botGetSelfH'. +deleteBot :: Member BotAccess r => ConvId -> BotId -> Galley r () +deleteBot cid bot = liftGalley0 $ deleteBot0 cid bot + -- | Calls 'Brig.User.API.Auth.reAuthUserH'. -reAuthUser :: UserId -> ReAuthUser -> Galley Bool +reAuthUser :: Member BrigAccess r => UserId -> ReAuthUser -> Galley r Bool reAuthUser uid auth = do (h, p) <- brigReq let req = method GET . host h . port p . paths ["/i/users", toByteString' uid, "reauthenticate"] . json auth - st <- statusCode . responseStatus <$> call "brig" (check [status200, status403] . req) + st <- statusCode . responseStatus <$> callBrig (check [status200, status403] . req) return $ st == 200 check :: [Status] -> Request -> Request @@ -114,12 +156,12 @@ check allowed r = } -- | Calls 'Brig.API.listActivatedAccountsH'. -lookupActivatedUsers :: [UserId] -> Galley [User] +lookupActivatedUsers :: Member BrigAccess r => [UserId] -> Galley r [User] lookupActivatedUsers = chunkify $ \uids -> do (h, p) <- brigReq let users = BSC.intercalate "," $ toByteString' <$> uids r <- - call "brig" $ + callBrig $ method GET . host h . port p . path "/i/users" . queryItem "ids" users @@ -141,15 +183,15 @@ chunkify doChunk keys = mconcat <$> (doChunk `mapM` chunks keys) chunks uids = case splitAt maxSize uids of (h, t) -> h : chunks t -- | Calls 'Brig.API.listActivatedAccountsH'. -getUser :: UserId -> Galley (Maybe UserAccount) +getUser :: Member BrigAccess r => UserId -> Galley r (Maybe UserAccount) getUser uid = listToMaybe <$> getUsers [uid] -- | Calls 'Brig.API.listActivatedAccountsH'. -getUsers :: [UserId] -> Galley [UserAccount] +getUsers :: Member BrigAccess r => [UserId] -> Galley r [UserAccount] getUsers = chunkify $ \uids -> do (h, p) <- brigReq resp <- - call "brig" $ + callBrig $ method GET . host h . port p . path "/i/users" . queryItem "ids" (BSC.intercalate "," (toByteString' <$> uids)) @@ -157,32 +199,32 @@ getUsers = chunkify $ \uids -> do pure . fromMaybe [] . responseJsonMaybe $ resp -- | Calls 'Brig.API.deleteUserNoVerifyH'. -deleteUser :: UserId -> Galley () +deleteUser :: Member BrigAccess r => UserId -> Galley r () deleteUser uid = do (h, p) <- brigReq void $ - call "brig" $ + callBrig $ method DELETE . host h . port p . paths ["/i/users", toByteString' uid] . expect2xx -- | Calls 'Brig.API.getContactListH'. -getContactList :: UserId -> Galley [UserId] +getContactList :: Member BrigAccess r => UserId -> Galley r [UserId] getContactList uid = do (h, p) <- brigReq r <- - call "brig" $ + callBrig $ method GET . host h . port p . paths ["/i/users", toByteString' uid, "contacts"] . expect2xx cUsers <$> parseResponse (mkError status502 "server-error") r -- | Calls 'Brig.API.Internal.getRichInfoMultiH' -getRichInfoMultiUser :: [UserId] -> Galley [(UserId, RichInfo)] +getRichInfoMultiUser :: Member BrigAccess r => [UserId] -> Galley r [(UserId, RichInfo)] getRichInfoMultiUser = chunkify $ \uids -> do (h, p) <- brigReq resp <- - call "brig" $ + callBrig $ method GET . host h . port p . paths ["/i/users/rich-info"] . queryItem "ids" (toByteString' (List uids)) diff --git a/services/galley/src/Galley/Intra/Util.hs b/services/galley/src/Galley/Intra/Util.hs index 9416c8d68f..a9dc8ff882 100644 --- a/services/galley/src/Galley/Intra/Util.hs +++ b/services/galley/src/Galley/Intra/Util.hs @@ -18,7 +18,10 @@ module Galley.Intra.Util ( brigReq, sparReq, - call, + call0, + callBrig, + callSpar, + callBot, x1, ) where @@ -33,17 +36,18 @@ import Data.Misc (portNumber) import Data.Text.Encoding (encodeUtf8) import qualified Data.Text.Lazy as LT import Galley.App +import Galley.Effects import Galley.Options import Imports import Util.Options -brigReq :: Galley (ByteString, Word16) +brigReq :: Galley r (ByteString, Word16) brigReq = do h <- encodeUtf8 <$> view (options . optBrig . epHost) p <- portNumber . fromIntegral <$> view (options . optBrig . epPort) return (h, p) -sparReq :: Galley (ByteString, Word16) +sparReq :: Galley r (ByteString, Word16) sparReq = do h <- encodeUtf8 <$> view (options . optSpar . epHost) p <- portNumber . fromIntegral <$> view (options . optSpar . epPort) @@ -51,8 +55,17 @@ sparReq = do -- gundeckReq lives in Galley.Intra.Push -call :: LT.Text -> (Request -> Request) -> Galley (Response (Maybe LB.ByteString)) -call n r = recovering x1 rpcHandlers (const (rpc n r)) +call0 :: LT.Text -> (Request -> Request) -> Galley0 (Response (Maybe LB.ByteString)) +call0 n r = liftGalley0 $ recovering x1 rpcHandlers (const (rpc n r)) + +callBrig :: Member BrigAccess r => (Request -> Request) -> Galley r (Response (Maybe LB.ByteString)) +callBrig r = liftGalley0 $ call0 "brig" r + +callSpar :: Member SparAccess r => (Request -> Request) -> Galley r (Response (Maybe LB.ByteString)) +callSpar r = liftGalley0 $ call0 "spar" r + +callBot :: Member BotAccess r => (Request -> Request) -> Galley r (Response (Maybe LB.ByteString)) +callBot r = liftGalley0 $ call0 "brig" r x1 :: RetryPolicy x1 = limitRetries 1 diff --git a/services/galley/src/Galley/Run.hs b/services/galley/src/Galley/Run.hs index 742b32f971..7218a22c37 100644 --- a/services/galley/src/Galley/Run.hs +++ b/services/galley/src/Galley/Run.hs @@ -131,8 +131,8 @@ bodyParserErrorFormatter _ _ errMsg = type CombinedAPI = GalleyAPI.ServantAPI :<|> Internal.ServantAPI :<|> ToServantApi FederationGalley.Api :<|> Servant.Raw -refreshMetrics :: Galley () -refreshMetrics = do +refreshMetrics :: Galley r () +refreshMetrics = liftGalley0 $ do m <- view monitor q <- view deleteQueue Internal.safeForever "refreshMetrics" $ do diff --git a/services/galley/src/Galley/Types/UserList.hs b/services/galley/src/Galley/Types/UserList.hs index 59d31de155..c63148d6b9 100644 --- a/services/galley/src/Galley/Types/UserList.hs +++ b/services/galley/src/Galley/Types/UserList.hs @@ -24,7 +24,6 @@ module Galley.Types.UserList where import Data.Qualified -import Data.Tagged import Imports -- | A list of users, partitioned into locals and remotes @@ -34,11 +33,18 @@ data UserList a = UserList } deriving (Functor, Foldable, Traversable) +instance Semigroup (UserList a) where + UserList locals1 remotes1 <> UserList locals2 remotes2 = + UserList (locals1 <> locals2) (remotes1 <> remotes2) + +instance Monoid (UserList a) where + mempty = UserList mempty mempty + toUserList :: Foldable f => Local x -> f (Qualified a) -> UserList a -toUserList loc = uncurry (flip UserList) . partitionRemoteOrLocalIds' (lDomain loc) +toUserList loc = uncurry UserList . partitionQualified loc ulAddLocal :: a -> UserList a -> UserList a ulAddLocal x ul = ul {ulLocals = x : ulLocals ul} ulAll :: Local x -> UserList a -> [Qualified a] -ulAll loc ul = map (unTagged . qualifyAs loc) (ulLocals ul) <> map unTagged (ulRemotes ul) +ulAll loc ul = map (qUntagged . qualifyAs loc) (ulLocals ul) <> map qUntagged (ulRemotes ul) diff --git a/services/galley/src/Galley/Validation.hs b/services/galley/src/Galley/Validation.hs index dc4f17a31e..a533cdbd51 100644 --- a/services/galley/src/Galley/Validation.hs +++ b/services/galley/src/Galley/Validation.hs @@ -32,11 +32,11 @@ import Galley.App import Galley.Options import Imports -rangeChecked :: Within a n m => a -> Galley (Range n m a) +rangeChecked :: Within a n m => a -> Galley r (Range n m a) rangeChecked = either throwErr return . checkedEither {-# INLINE rangeChecked #-} -rangeCheckedMaybe :: Within a n m => Maybe a -> Galley (Maybe (Range n m a)) +rangeCheckedMaybe :: Within a n m => Maybe a -> Galley r (Maybe (Range n m a)) rangeCheckedMaybe Nothing = return Nothing rangeCheckedMaybe (Just a) = Just <$> rangeChecked a {-# INLINE rangeCheckedMaybe #-} @@ -45,7 +45,7 @@ rangeCheckedMaybe (Just a) = Just <$> rangeChecked a newtype ConvSizeChecked f a = ConvSizeChecked {fromConvSize :: f a} deriving (Functor, Foldable, Traversable) -checkedConvSize :: Foldable f => f a -> Galley (ConvSizeChecked f a) +checkedConvSize :: Foldable f => f a -> Galley r (ConvSizeChecked f a) checkedConvSize x = do o <- view options let minV :: Integer = 0 @@ -54,5 +54,5 @@ checkedConvSize x = do then return (ConvSizeChecked x) else throwErr (errorMsg minV limit "") -throwErr :: String -> Galley a +throwErr :: String -> Galley r a throwErr = throwM . invalidRange . fromString diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index 7758466072..3c2cf9e918 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -37,8 +37,9 @@ import Bilge hiding (timeout) import Bilge.Assert import Brig.Types import qualified Control.Concurrent.Async as Async -import Control.Lens (at, ix, preview, view, (.~), (?~), (^.)) +import Control.Lens (at, ix, preview, view, (.~), (?~)) import Control.Monad.Except (MonadError (throwError)) +import Control.Monad.Trans.Maybe import Data.Aeson hiding (json) import qualified Data.ByteString as BS import Data.ByteString.Conversion @@ -62,6 +63,7 @@ import Data.Time.Clock (getCurrentTime) import Galley.API.Mapping import Galley.Options (Opts, optFederator) import Galley.Types hiding (LocalMember (..)) +import Galley.Types.Conversations.Intra import Galley.Types.Conversations.Members import Galley.Types.Conversations.Roles import qualified Galley.Types.Teams as Teams @@ -83,7 +85,9 @@ import Wire.API.Conversation import Wire.API.Conversation.Action import qualified Wire.API.Federation.API.Brig as FederatedBrig import Wire.API.Federation.API.Galley - ( GetConversationsResponse (..), + ( Api (onConversationUpdated), + ConversationUpdate (cuAction, cuAlreadyPresentUsers, cuOrigUserId), + GetConversationsResponse (..), RemoteConvMembers (..), RemoteConversation (..), ) @@ -119,10 +123,9 @@ tests s = [ test s "status" status, test s "metrics" metrics, test s "create conversation" postConvOk, + test s "create conversation with remote users" postConvWithRemoteUsersOk, test s "get empty conversations" getConvsOk, - test s "list-conversations empty" listConvsOk, test s "get conversations by ids" getConvsOk2, - test s "list-conversations by ids" listConvsOk2, test s "fail to get >500 conversations" getConvsFailMaxSize, test s "get conversation ids" getConvIdsOk, test s "get conversation ids v2" listConvIdsOk, @@ -131,7 +134,6 @@ tests s = test s "paginate through /conversations/list-ids - page ending at locals and remote domain" paginateConvListIdsPageEndingAtLocalsAndDomain, test s "fail to get >1000 conversation ids" getConvIdsFailMaxSize, test s "page through conversations" getConvsPagingOk, - test s "page through list-conversations (local conversations only)" listConvsPagingOk, test s "fail to create conversation when not connected" postConvFailNotConnected, test s "fail to create conversation with qualified users when not connected" postConvQualifiedFailNotConnected, test s "M:N conversation creation with N - 1 invitees should be allowed" postConvLimitOk, @@ -139,8 +141,9 @@ tests s = test s "M:N conversation creation must have e "claimPrekeyBundle", FederatedBrig.claimMultiPrekeyBundle = \_ -> e "claimMultiPrekeyBundle", FederatedBrig.searchUsers = \_ -> e "searchUsers", - FederatedBrig.getUserClients = \_ -> e "getUserClients" + FederatedBrig.getUserClients = \_ -> e "getUserClients", + FederatedBrig.sendConnectionAction = \_ _ -> e "sendConnectionAction", + FederatedBrig.onUserDeleted = \_ _ -> e "onUserDeleted" } emptyFederatedGalley :: FederatedGalley.Api (AsServerT Handler) @@ -246,7 +253,8 @@ emptyFederatedGalley = FederatedGalley.onConversationUpdated = \_ _ -> e "onConversationUpdated", FederatedGalley.leaveConversation = \_ _ -> e "leaveConversation", FederatedGalley.onMessageSent = \_ _ -> e "onMessageSent", - FederatedGalley.sendMessage = \_ _ -> e "sendMessage" + FederatedGalley.sendMessage = \_ _ -> e "sendMessage", + FederatedGalley.onUserDeleted = \_ _ -> e "onUserDeleted" } ------------------------------------------------------------------------------- @@ -284,8 +292,7 @@ postConvOk = do rsp <- postConv alice [bob, jane] (Just nameMaxSize) [] Nothing Nothing assertConvEquals cnv c' _ -> assertFailure "Unexpected event data" +postConvWithRemoteUsersOk :: TestM () +postConvWithRemoteUsersOk = do + c <- view tsCannon + (alice, qAlice) <- randomUserTuple + (alex, qAlex) <- randomUserTuple + (amy, qAmy) <- randomUserTuple + connectUsers alice (list1 alex [amy]) + let cDomain = Domain "c.example.com" + dDomain = Domain "d.example.com" + qChad <- randomQualifiedId cDomain + qCharlie <- randomQualifiedId cDomain + qDee <- randomQualifiedId dDomain + mapM_ (connectWithRemoteUser alice) [qChad, qCharlie, qDee] + + -- Ensure name is within range, max size is 256 + postConvQualified alice defNewConv {newConvName = Just (T.replicate 257 "a"), newConvQualifiedUsers = [qAlex, qAmy, qChad, qCharlie, qDee]} + !!! const 400 === statusCode + + let nameMaxSize = T.replicate 256 "a" + WS.bracketR3 c alice alex amy $ \(wsAlice, wsAlex, wsAmy) -> do + (rsp, federatedRequests) <- + withTempMockFederator (const ()) $ + postConvQualified alice defNewConv {newConvName = Just nameMaxSize, newConvQualifiedUsers = [qAlex, qAmy, qChad, qCharlie, qDee]} + F.domain r == domainText cDomain) federatedRequests + cFedReqBody <- assertRight $ parseFedReqBody cFedReq + + dFedReq <- assertOne $ filter (\r -> F.domain r == domainText dDomain) federatedRequests + dFedReqBody <- assertRight $ parseFedReqBody dFedReq + + liftIO $ do + length federatedRequests @?= 2 + + FederatedGalley.rcOrigUserId cFedReqBody @?= alice + FederatedGalley.rcCnvId cFedReqBody @?= cid + FederatedGalley.rcCnvType cFedReqBody @?= RegularConv + FederatedGalley.rcCnvAccess cFedReqBody @?= [InviteAccess] + FederatedGalley.rcCnvAccessRole cFedReqBody @?= ActivatedAccessRole + FederatedGalley.rcCnvName cFedReqBody @?= Just nameMaxSize + FederatedGalley.rcNonCreatorMembers cFedReqBody @?= Set.fromList (toOtherMember <$> [qAlex, qAmy, qChad, qCharlie, qDee]) + FederatedGalley.rcMessageTimer cFedReqBody @?= Nothing + FederatedGalley.rcReceiptMode cFedReqBody @?= Nothing + + dFedReqBody @?= cFedReqBody + where + parseFedReqBody :: FromJSON a => F.FederatedRequest -> Either String a + parseFedReqBody fr = + case F.request fr of + Just r -> + (eitherDecode . cs) (F.body r) + Nothing -> Left "No request" + toOtherMember qid = OtherMember qid Nothing roleNameWireAdmin + convView cnv usr = responseJsonUnsafeWithMsg "conversation" <$> getConv usr cnv + checkWs qalice (cnv, ws) = WS.awaitMatch (5 # Second) ws $ \n -> do + ntfTransient n @?= False + let e = List1.head (WS.unpackPayload n) + evtConv e @?= cnvQualifiedId cnv + evtType e @?= ConvCreate + evtFrom e @?= qalice + case evtData e of + EdConversation c' -> assertConvEquals cnv c' + _ -> assertFailure "Unexpected event data" + -- | This test verifies whether a message actually gets sent all the way to -- cannon. postCryptoMessage1 :: TestM () @@ -535,9 +609,13 @@ postMessageQualifiedLocalOwningBackendSuccess = do chadUnqualified = qUnqualified chadOwningDomain connectLocalQualifiedUsers aliceUnqualified (list1 bobOwningDomain [chadOwningDomain]) + connectWithRemoteUser aliceUnqualified deeRemote -- FUTUREWORK: Do this test with more than one remote domains - resp <- postConvWithRemoteUser remoteDomain (mkProfile deeRemote (Name "Dee")) aliceUnqualified [bobOwningDomain, chadOwningDomain, deeRemote] + resp <- + postConvWithRemoteUsers + aliceUnqualified + defNewConv {newConvQualifiedUsers = [bobOwningDomain, chadOwningDomain, deeRemote]} let convId = (`Qualified` owningDomain) . decodeConvId $ resp WS.bracketR2 cannon bobUnqualified chadUnqualified $ \(wsBob, wsChad) -> do @@ -603,9 +681,13 @@ postMessageQualifiedLocalOwningBackendMissingClients = do chadUnqualified = qUnqualified chadOwningDomain connectLocalQualifiedUsers aliceUnqualified (list1 bobOwningDomain [chadOwningDomain]) + connectWithRemoteUser aliceUnqualified deeRemote -- FUTUREWORK: Do this test with more than one remote domains - resp <- postConvWithRemoteUser remoteDomain (mkProfile deeRemote (Name "Dee")) aliceUnqualified [bobOwningDomain, chadOwningDomain, deeRemote] + resp <- + postConvWithRemoteUsers + aliceUnqualified + defNewConv {newConvQualifiedUsers = [bobOwningDomain, chadOwningDomain, deeRemote]} let convId = (`Qualified` owningDomain) . decodeConvId $ resp -- Missing Bob, chadClient2 and Dee @@ -669,9 +751,13 @@ postMessageQualifiedLocalOwningBackendRedundantAndDeletedClients = do nonMemberRemoteUnqualified = qUnqualified nonMemberRemote connectLocalQualifiedUsers aliceUnqualified (list1 bobOwningDomain [chadOwningDomain]) + connectWithRemoteUser aliceUnqualified deeRemote -- FUTUREWORK: Do this test with more than one remote domains - resp <- postConvWithRemoteUser remoteDomain (mkProfile deeRemote (Name "Dee")) aliceUnqualified [bobOwningDomain, chadOwningDomain, deeRemote] + resp <- + postConvWithRemoteUsers + aliceUnqualified + defNewConv {newConvQualifiedUsers = [bobOwningDomain, chadOwningDomain, deeRemote]} let convId = (`Qualified` owningDomain) . decodeConvId $ resp WS.bracketR3 cannon bobUnqualified chadUnqualified nonMemberUnqualified $ \(wsBob, wsChad, wsNonMember) -> do @@ -756,9 +842,13 @@ postMessageQualifiedLocalOwningBackendIgnoreMissingClients = do chadUnqualified = qUnqualified chadOwningDomain connectLocalQualifiedUsers aliceUnqualified (list1 bobOwningDomain [chadOwningDomain]) + connectWithRemoteUser aliceUnqualified deeRemote -- FUTUREWORK: Do this test with more than one remote domains - resp <- postConvWithRemoteUser remoteDomain (mkProfile deeRemote (Name "Dee")) aliceUnqualified [bobOwningDomain, chadOwningDomain, deeRemote] + resp <- + postConvWithRemoteUsers + aliceUnqualified + defNewConv {newConvQualifiedUsers = [bobOwningDomain, chadOwningDomain, deeRemote]} let convId = (`Qualified` owningDomain) . decodeConvId $ resp let brigApi = @@ -877,9 +967,13 @@ postMessageQualifiedLocalOwningBackendFailedToSendClients = do chadUnqualified = qUnqualified chadOwningDomain connectLocalQualifiedUsers aliceUnqualified (list1 bobOwningDomain [chadOwningDomain]) + connectWithRemoteUser aliceUnqualified deeRemote -- FUTUREWORK: Do this test with more than one remote domains - resp <- postConvWithRemoteUser remoteDomain (mkProfile deeRemote (Name "Dee")) aliceUnqualified [bobOwningDomain, chadOwningDomain, deeRemote] + resp <- + postConvWithRemoteUsers + aliceUnqualified + defNewConv {newConvQualifiedUsers = [bobOwningDomain, chadOwningDomain, deeRemote]} let convId = (`Qualified` owningDomain) . decodeConvId $ resp WS.bracketR2 cannon bobUnqualified chadUnqualified $ \(wsBob, wsChad) -> do @@ -1146,6 +1240,66 @@ postConvertTeamConv = do -- team members (dave) can still join postJoinCodeConv dave j !!! const 200 === statusCode +testAccessUpdateGuestRemoved :: TestM () +testAccessUpdateGuestRemoved = do + -- alice, bob are in a team + (tid, alice, [bob]) <- createBindingTeamWithQualifiedMembers 2 + + -- charlie is a local guest + charlie <- randomQualifiedUser + connectUsers (qUnqualified alice) (pure (qUnqualified charlie)) + + -- dee is a remote guest + let remoteDomain = Domain "far-away.example.com" + dee <- Qualified <$> randomId <*> pure remoteDomain + + connectWithRemoteUser (qUnqualified alice) dee + + -- they are all in a local conversation + conv <- + responseJsonError + =<< postConvWithRemoteUsers + (qUnqualified alice) + defNewConv + { newConvQualifiedUsers = [bob, charlie, dee], + newConvTeam = Just (ConvTeamInfo tid False) + } + do + -- conversation access role changes to team only + (_, reqs) <- withTempMockFederator (const ()) $ do + putQualifiedAccessUpdate + (qUnqualified alice) + (cnvQualifiedId conv) + (ConversationAccessData mempty TeamAccessRole) + !!! const 200 === statusCode + + -- charlie and dee are kicked out + -- + -- note that removing users happens asynchronously, so this check should + -- happen while the mock federator is still available + WS.assertMatchN_ (5 # Second) [wsA, wsB, wsC] $ + wsAssertMembersLeave (cnvQualifiedId conv) alice [charlie, dee] + + -- dee's remote receives a notification + liftIO . assertBool "remote users are not notified" . isJust . flip find reqs $ \freq -> + let req = F.request freq + in and + [ fmap F.component req == Just F.Galley, + fmap F.path req == Just "/federation/on-conversation-updated", + fmap (fmap FederatedGalley.cuAction . eitherDecode . LBS.fromStrict . F.body) req + == Just (Right (ConversationActionRemoveMembers (charlie :| [dee]))) + ] + + -- only alice and bob remain + conv2 <- + responseJsonError + =<< getConvQualified (qUnqualified alice) (cnvQualifiedId conv) + cmOthers (cnvMembers c) \\ cmOthers (cnvMembers expected)) <$> actual) --- same test as getConvsOk2, but using the listConversations endpoint -listConvsOk2 :: TestM () -listConvsOk2 = do - [alice, bob] <- randomUsers 2 - connectUsers alice (singleton bob) - -- create & get one2one conv - cnv1 <- responseJsonUnsafeWithMsg "conversation" <$> postO2OConv alice bob (Just "gossip1") - let req1 = ListConversations (Just (cnvQualifiedId cnv1 :| [])) Nothing Nothing - listConvs alice req1 !!! do - const 200 === statusCode - const (Just [cnvQualifiedId cnv1]) === fmap (map cnvQualifiedId . convList) . responseJsonUnsafe - -- create & get group conv - carl <- randomUser - connectUsers alice (singleton carl) - cnv2 <- responseJsonUnsafeWithMsg "conversation" <$> postConv alice [bob, carl] (Just "gossip2") [] Nothing Nothing - let req2 = ListConversations (Just (cnvQualifiedId cnv2 :| [])) Nothing Nothing - listConvs alice req2 !!! do - const 200 === statusCode - const (Just [cnvQualifiedId cnv2]) === fmap (map cnvQualifiedId . convList) . responseJsonUnsafe - -- get both - rs <- listAllConvs alice responseJsonUnsafe rs - let c1 = convs >>= find ((== cnvQualifiedId cnv1) . cnvQualifiedId) - let c2 = convs >>= find ((== cnvQualifiedId cnv2) . cnvQualifiedId) - liftIO . forM_ [(cnv1, c1), (cnv2, c2)] $ \(expected, actual) -> do - assertEqual - "name mismatch" - (Just $ cnvName expected) - (cnvName <$> actual) - assertEqual - "self member mismatch" - (Just . cmSelf $ cnvMembers expected) - (cmSelf . cnvMembers <$> actual) - assertEqual - "other members mismatch" - (Just []) - ((\c -> cmOthers (cnvMembers c) \\ cmOthers (cnvMembers expected)) <$> actual) - getConvsFailMaxSize :: TestM () getConvsFailMaxSize = do usr <- randomUser @@ -1322,6 +1430,7 @@ paginateConvListIds = do remoteChad <- randomId let chadDomain = Domain "chad.example.com" qChad = Qualified remoteChad chadDomain + connectWithRemoteUser alice qChad replicateM_ 25 $ do conv <- randomId let cu = @@ -1337,6 +1446,7 @@ paginateConvListIds = do remoteDee <- randomId let deeDomain = Domain "dee.example.com" qDee = Qualified remoteDee deeDomain + connectWithRemoteUser alice qDee replicateM_ 31 $ do conv <- randomId let cu = @@ -1379,6 +1489,8 @@ paginateConvListIdsPageEndingAtLocalsAndDomain = do remoteChad <- randomId let chadDomain = Domain "chad.example.com" qChad = Qualified remoteChad chadDomain + connectWithRemoteUser alice qChad + -- The 3rd page will end with this domain replicateM_ 16 $ do conv <- randomId @@ -1395,6 +1507,8 @@ paginateConvListIdsPageEndingAtLocalsAndDomain = do remoteDee <- randomId let deeDomain = Domain "dee.example.com" qDee = Qualified remoteDee deeDomain + connectWithRemoteUser alice qDee + -- The 4th and last page will end with this domain replicateM_ 16 $ do conv <- randomId @@ -1453,35 +1567,6 @@ getConvsPagingOk = do liftIO $ assertBool "getConvIds /= getConvs" (ids1 == ids3) return $ ids1 >>= listToMaybe . reverse --- same test as getConvsPagingOk, but using the listConversations endpoint --- (only tests pagination behaviour for local conversations) --- FUTUREWORK: pagination for remote conversations -listConvsPagingOk :: TestM () -listConvsPagingOk = do - [ally, bill, carl] <- randomUsers 3 - connectUsers ally (list1 bill [carl]) - replicateM_ 11 $ postConv ally [bill, carl] (Just "gossip") [] Nothing Nothing - walk ally [3, 3, 3, 3, 2] -- 11 (group) + 2 (1:1) + 1 (self) - walk bill [3, 3, 3, 3, 1] -- 11 (group) + 1 (1:1) + 1 (self) - walk carl [3, 3, 3, 3, 1] -- 11 (group) + 1 (1:1) + 1 (self) - where - walk :: Foldable t => UserId -> t Int -> TestM () - walk u = foldM_ (next u 3) Nothing - next :: UserId -> Int32 -> Maybe ConvId -> Int -> TestM (Maybe ConvId) - next u step start n = do - -- FUTUREWORK: support an endpoint to get qualified conversation IDs - -- (without all the conversation metadata) - r1 <- getConvIds u (Right <$> start) (Just step) responseJsonUnsafe r1 - liftIO $ assertEqual "unexpected length (getConvIds)" (Just n) (length <$> ids1) - localDomain <- viewFederationDomain - let requestBody = ListConversations Nothing (flip Qualified localDomain <$> start) (Just (unsafeRange step)) - r2 <- listConvs u requestBody responseJsonUnsafe r2 - liftIO $ assertEqual "unexpected length (getConvs)" (Just n) (length <$> ids3) - liftIO $ assertBool "getConvIds /= getConvs" (ids1 == ids3) - return $ ids1 >>= listToMaybe . reverse - postConvFailNotConnected :: TestM () postConvFailNotConnected = do alice <- randomUser @@ -1496,7 +1581,7 @@ postConvQualifiedFailNotConnected = do alice <- randomUser bob <- randomQualifiedUser jane <- randomQualifiedUser - postConvQualified alice [bob, jane] Nothing [] Nothing Nothing !!! do + postConvQualified alice defNewConv {newConvQualifiedUsers = [bob, jane]} !!! do const 403 === statusCode const (Just "not-connected") === fmap label . responseJsonUnsafe @@ -1525,7 +1610,7 @@ postConvQualifiedFailNumMembers = do alice <- randomUser bob : others <- replicateM n randomQualifiedUser connectLocalQualifiedUsers alice (list1 bob others) - postConvQualified alice (bob : others) Nothing [] Nothing Nothing !!! do + postConvQualified alice defNewConv {newConvQualifiedUsers = (bob : others)} !!! do const 400 === statusCode const (Just "client-error") === fmap label . responseJsonUnsafe @@ -1553,37 +1638,47 @@ postConvQualifiedFailBlocked = do connectLocalQualifiedUsers alice (list1 bob [jane]) putConnectionQualified jane alice Blocked !!! const 200 === statusCode - postConvQualified alice [bob, jane] Nothing [] Nothing Nothing !!! do + postConvQualified alice defNewConv {newConvQualifiedUsers = [bob, jane]} !!! do const 403 === statusCode const (Just "not-connected") === fmap label . responseJsonUnsafe +postConvQualifiedNoConnection :: TestM () +postConvQualifiedNoConnection = do + alice <- randomUser + bob <- flip Qualified (Domain "far-away.example.com") <$> randomId + postConvQualified alice defNewConv {newConvQualifiedUsers = [bob]} + !!! const 403 === statusCode + +postTeamConvQualifiedNoConnection :: TestM () +postTeamConvQualifiedNoConnection = do + (tid, alice, _) <- createBindingTeamWithQualifiedMembers 1 + bob <- randomQualifiedId (Domain "bob.example.com") + charlie <- randomQualifiedUser + postConvQualified + (qUnqualified alice) + defNewConv + { newConvQualifiedUsers = [bob], + newConvTeam = Just (ConvTeamInfo tid False) + } + !!! const 403 === statusCode + postConvQualified + (qUnqualified alice) + defNewConv + { newConvQualifiedUsers = [charlie], + newConvTeam = Just (ConvTeamInfo tid False) + } + !!! const 403 === statusCode + postConvQualifiedNonExistentDomain :: TestM () postConvQualifiedNonExistentDomain = do alice <- randomUser bob <- flip Qualified (Domain "non-existent.example.com") <$> randomId - postConvQualified alice [bob] Nothing [] Nothing Nothing !!! do - const 422 === statusCode - -postConvQualifiedNonExistentUser :: TestM () -postConvQualifiedNonExistentUser = do - alice <- randomUser - bobId <- randomId - charlieId <- randomId - let remoteDomain = Domain "far-away.example.com" - bob = Qualified bobId remoteDomain - charlie = Qualified charlieId remoteDomain - opts <- view tsGConf - _g <- view tsGalley - (resp, _) <- - withTempMockFederator - opts - remoteDomain - (const [mkProfile charlie (Name "charlie")]) - (postConvQualified alice [bob, charlie] (Just "remote gossip") [] Nothing Nothing) - liftIO $ do - statusCode resp @?= 400 - let err = responseJsonUnsafe resp :: Object - (err ^. at "label") @?= Just "unknown-remote-user" + connectWithRemoteUser alice bob + postConvQualified + alice + defNewConv {newConvQualifiedUsers = [bob]} + !!! do + const 422 === statusCode postConvQualifiedFederationNotEnabled :: TestM () postConvQualifiedFederationNotEnabled = do @@ -1591,6 +1686,7 @@ postConvQualifiedFederationNotEnabled = do alice <- randomUser bob <- flip Qualified (Domain "some-remote-backend.example.com") <$> randomId opts <- view tsGConf + connectWithRemoteUser alice bob let federatorNotConfigured :: Opts = opts & optFederator .~ Nothing withSettingsOverrides federatorNotConfigured $ postConvHelper g alice [bob] !!! do @@ -1606,22 +1702,24 @@ postConvHelper g zusr newUsers = do postSelfConvOk :: TestM () postSelfConvOk = do - alice <- randomUser + qalice <- randomQualifiedUser + let alice = qUnqualified qalice m <- postSelfConv alice request alice bob - n <- decodeConvId <$> request alice bob + m <- decodeConvId <$> req alice bob + n <- decodeConvId <$> req alice bob liftIO $ m @=? n where - request alice bob = + req alice bob = postConnectConv alice bob "Alice" "connect with me!" (Just "me@me.com") putConvAcceptOk :: TestM () @@ -1682,18 +1781,20 @@ putConvAcceptRetry = do postMutualConnectConvOk :: TestM () postMutualConnectConvOk = do - alice <- randomUser - bob <- randomUser + qalice <- randomQualifiedUser + let alice = qUnqualified qalice + qbob <- randomQualifiedUser + let bob = qUnqualified qbob ac <- postConnectConv alice bob "A" "a" Nothing postConvQualified alice [bob, chuck] (Just "gossip") [] Nothing Nothing + conv <- + decodeConvId + <$> postConvQualified + alice + defNewConv + { newConvQualifiedUsers = [bob, chuck], + newConvName = Just "gossip" + } getConv alice conv !!! const 200 === statusCode getConv (qUnqualified bob) conv !!! const 200 === statusCode getConv (qUnqualified chuck) conv !!! const 200 === statusCode accessConvMeta :: TestM () accessConvMeta = do - localDomain <- viewFederationDomain g <- view tsGalley alice <- randomUser bob <- randomUser @@ -1814,7 +1921,6 @@ accessConvMeta = do conv <- decodeConvId <$> postConv alice [bob, chuck] (Just "gossip") [] Nothing Nothing let meta = ConversationMetadata - (Qualified conv localDomain) RegularConv alice [InviteAccess] @@ -1835,8 +1941,6 @@ leaveConnectConversation = do let c = maybe (error "invalid connect conversation") (qUnqualified . cnvQualifiedId) (responseJsonUnsafe bdy) deleteMemberUnqualified alice alice c !!! const 403 === statusCode --- FUTUREWORK: Add more tests for scenarios of federation. --- See also the comment in Galley.API.Update.addMembers for some other checks that are necessary. testAddRemoteMember :: TestM () testAddRemoteMember = do qalice <- randomQualifiedUser @@ -1847,22 +1951,23 @@ testAddRemoteMember = do remoteBob = Qualified bobId remoteDomain convId <- decodeConvId <$> postConv alice [] (Just "remote gossip") [] Nothing Nothing let qconvId = Qualified convId localDomain - opts <- view tsGConf - g <- view tsGalley + + postQualifiedMembers alice (remoteBob :| []) convId !!! do + const 403 === statusCode + const (Right (Just "not-connected")) === fmap (view (at "label")) . responseJsonEither @Object + + connectWithRemoteUser alice remoteBob + (resp, reqs) <- - withTempMockFederator - opts - remoteDomain - (respond remoteBob) - (postQualifiedMembers' g alice (remoteBob :| []) convId) + withTempMockFederator (respond remoteBob) $ + postQualifiedMembers alice (remoteBob :| []) convId + (pure resp postTeamConv tid alice [] (Just "remote gossip") [] Nothing Nothing + let _qconvId = Qualified convId localDomain + + connectWithRemoteUser alice remoteBob + + let brigApi = emptyFederatedBrig + galleyApi = + emptyFederatedGalley + { onConversationUpdated = \_domain _update -> pure () + } + + (_, received) <- withTempServantMockFederator brigApi galleyApi localDomain $ do + postQualifiedMembers alice (remoteBob :| []) convId + !!! const 200 === statusCode + + deleteTeamConv tid convId alice + !!! const 200 === statusCode + + liftIO $ do + let convUpdates = mapMaybe parseFedRequest received + convUpdate <- case (filter ((== ConversationActionDelete) . cuAction) convUpdates) of + [] -> assertFailure "No ConversationUpdate requests received" + [convDelete] -> pure convDelete + _ -> assertFailure "Multiple ConversationUpdate requests received" + cuAlreadyPresentUsers convUpdate @?= [bobId] + cuOrigUserId convUpdate @?= qalice + where + parseFedRequest :: FromJSON a => F.FederatedRequest -> Maybe a + parseFedRequest fr = + case F.request fr of + Just r -> + (decode . cs) (F.body r) + Nothing -> Nothing + testGetQualifiedLocalConv :: TestM () testGetQualifiedLocalConv = do alice <- randomUser @@ -1912,6 +2061,7 @@ testGetQualifiedRemoteConv :: TestM () testGetQualifiedRemoteConv = do aliceQ <- randomQualifiedUser let aliceId = qUnqualified aliceQ + loc <- flip toLocalUnsafe () <$> viewFederationDomain bobId <- randomId convId <- randomId let remoteDomain = Domain "far-away.example.com" @@ -1920,22 +2070,21 @@ testGetQualifiedRemoteConv = do bobAsOtherMember = OtherMember bobQ Nothing roleNameWireAdmin aliceAsLocal = LocalMember aliceId defMemberStatus Nothing roleNameWireAdmin aliceAsOtherMember = localMemberToOther (qDomain aliceQ) aliceAsLocal - aliceAsSelfMember = localMemberToSelf aliceAsLocal + aliceAsSelfMember = localMemberToSelf loc aliceAsLocal - registerRemoteConv remoteConvId bobQ Nothing (Set.fromList [aliceAsOtherMember]) + connectWithRemoteUser aliceId bobQ + registerRemoteConv remoteConvId bobId Nothing (Set.fromList [aliceAsOtherMember]) - let mockConversation = mkConv remoteConvId bobId roleNameWireAdmin [bobAsOtherMember] + let mockConversation = mkConv convId bobId roleNameWireAdmin [bobAsOtherMember] remoteConversationResponse = GetConversationsResponse [mockConversation] expected = Conversation + remoteConvId (rcnvMetadata mockConversation) (ConvMembers aliceAsSelfMember (rcmOthers (rcnvMembers mockConversation))) - opts <- view tsGConf (respAll, _) <- withTempMockFederator - opts - remoteDomain (const remoteConversationResponse) (getConvQualified aliceId remoteConvId) @@ -1959,53 +2108,16 @@ testGetQualifiedRemoteConvNotFoundOnRemote = do bobId <- randomId convId <- randomId let remoteDomain = Domain "far-away.example.com" - bobQ = Qualified bobId remoteDomain remoteConvId = Qualified convId remoteDomain aliceAsOtherMember = OtherMember aliceQ Nothing roleNameWireAdmin - registerRemoteConv remoteConvId bobQ Nothing (Set.fromList [aliceAsOtherMember]) + registerRemoteConv remoteConvId bobId Nothing (Set.fromList [aliceAsOtherMember]) - opts <- view tsGConf - void . withTempMockFederator opts remoteDomain (const (GetConversationsResponse [])) $ do + void . withTempMockFederator (const (GetConversationsResponse [])) $ do getConvQualified aliceId remoteConvId !!! do const 404 === statusCode const (Just "no-conversation") === view (at "label") . responseJsonUnsafe @Object -testListRemoteConvs :: TestM () -testListRemoteConvs = do - -- alice on local domain - -- bob and the conversation on the remote domain - aliceQ <- randomQualifiedUser - let alice = qUnqualified aliceQ - bobId <- randomId - convId <- randomId - let remoteDomain = Domain "far-away.example.com" - bobQ = Qualified bobId remoteDomain - remoteConvId = Qualified convId remoteDomain - - let aliceAsOtherMember = OtherMember aliceQ Nothing roleNameWireAdmin - mockConversation = mkConv remoteConvId alice roleNameWireAdmin [aliceAsOtherMember] - remoteConversationResponse = GetConversationsResponse [mockConversation] - opts <- view tsGConf - - registerRemoteConv remoteConvId bobQ Nothing (Set.fromList [aliceAsOtherMember]) - - -- FUTUREWORK: Do this test with more than one remote domains - -- test POST /list-conversations - (respAll, _) <- - withTempMockFederator - opts - remoteDomain - (const remoteConversationResponse) - (listAllConvs alice) - convs <- responseJsonUnsafe <$> (pure respAll postConv alice [] (Just "gossip") [] Nothing Nothing let localConvId = cnvQualifiedId localConv @@ -2054,17 +2173,17 @@ testBulkGetQualifiedConvs = do localConvIdNotParticipating <- decodeQualifiedConvId <$> postConv (qUnqualified eve) [] (Just "gossip about alice!") [] Nothing Nothing let aliceAsOtherMember = OtherMember aliceQ Nothing roleNameWireAdmin - registerRemoteConv remoteConvIdA bobQ Nothing (Set.fromList [aliceAsOtherMember]) - registerRemoteConv remoteConvIdB carlQ Nothing (Set.fromList [aliceAsOtherMember]) - registerRemoteConv remoteConvIdBNotFoundOnRemote carlQ Nothing (Set.fromList [aliceAsOtherMember]) - registerRemoteConv remoteConvIdCFailure carlQ Nothing (Set.fromList [aliceAsOtherMember]) + registerRemoteConv remoteConvIdA bobId Nothing (Set.fromList [aliceAsOtherMember]) + registerRemoteConv remoteConvIdB carlId Nothing (Set.fromList [aliceAsOtherMember]) + registerRemoteConv remoteConvIdBNotFoundOnRemote carlId Nothing (Set.fromList [aliceAsOtherMember]) + registerRemoteConv remoteConvIdCFailure deeId Nothing (Set.fromList [aliceAsOtherMember]) let bobAsOtherMember = OtherMember bobQ Nothing roleNameWireAdmin carlAsOtherMember = OtherMember carlQ Nothing roleNameWireAdmin - mockConversationA = mkConv remoteConvIdA bobId roleNameWireAdmin [bobAsOtherMember] - mockConversationB = mkConv remoteConvIdB carlId roleNameWireAdmin [carlAsOtherMember] + mockConversationA = mkConv (qUnqualified remoteConvIdA) bobId roleNameWireAdmin [bobAsOtherMember] + mockConversationB = mkConv (qUnqualified remoteConvIdB) carlId roleNameWireAdmin [carlAsOtherMember] req = - ListConversationsV2 . unsafeRange $ + ListConversations . unsafeRange $ [ localConvId, remoteConvIdA, remoteConvIdB, @@ -2074,11 +2193,8 @@ testBulkGetQualifiedConvs = do remoteConvIdBNotFoundOnRemote, remoteConvIdCFailure ] - opts <- view tsGConf (respAll, receivedRequests) <- withTempMockFederator' - opts - remoteDomainA ( \fedReq -> do let success = pure . F.OutwardResponseBody . LBS.toStrict . encode case F.domain fedReq of @@ -2087,15 +2203,15 @@ testBulkGetQualifiedConvs = do d | d == domainText remoteDomainC -> pure . F.OutwardResponseError $ F.OutwardError F.DiscoveryFailed "discovery failed" _ -> assertFailure $ "Unrecognized domain: " <> show fedReq ) - (listConvsV2 alice req) + (listConvs alice req) convs <- responseJsonUnsafe <$> (pure respAll maybeToList (remoteConversationView alice defMemberStatus mockConversationB) + $ maybeToList (remoteConversationView lAlice defMemberStatus (toRemoteUnsafe remoteDomainA mockConversationA)) + <> maybeToList (remoteConversationView lAlice defMemberStatus (toRemoteUnsafe remoteDomainB mockConversationB)) <> [localConv] actualFound = sortOn cnvQualifiedId $ crFound convs assertEqual "found conversations" expectedFound actualFound @@ -2113,56 +2229,19 @@ testBulkGetQualifiedConvs = do assertEqual "not founds" expectedNotFound actualNotFound assertEqual "failures" [remoteConvIdCFailure] (crFailed convs) -testAddRemoteMemberFailure :: TestM () -testAddRemoteMemberFailure = do - alice <- randomUser - bobId <- randomId - charlieId <- randomId - let remoteDomain = Domain "far-away.example.com" - remoteBob = Qualified bobId remoteDomain - remoteCharlie = Qualified charlieId remoteDomain - convId <- decodeConvId <$> postConv alice [] (Just "remote gossip") [] Nothing Nothing - opts <- view tsGConf - g <- view tsGalley - (resp, _) <- - withTempMockFederator - opts - remoteDomain - (const [mkProfile remoteCharlie (Name "charlie")]) - (postQualifiedMembers' g alice (remoteBob :| [remoteCharlie]) convId) - liftIO $ statusCode resp @?= 400 - let err = responseJsonUnsafe resp :: Object - liftIO $ (err ^. at "label") @?= Just "unknown-remote-user" - -testAddDeletedRemoteUser :: TestM () -testAddDeletedRemoteUser = do - alice <- randomUser - bobId <- randomId - let remoteDomain = Domain "far-away.example.com" - remoteBob = Qualified bobId remoteDomain - convId <- decodeConvId <$> postConv alice [] (Just "remote gossip") [] Nothing Nothing - opts <- view tsGConf - g <- view tsGalley - (resp, _) <- - withTempMockFederator - opts - remoteDomain - (const [(mkProfile remoteBob (Name "bob")) {profileDeleted = True}]) - (postQualifiedMembers' g alice (remoteBob :| []) convId) - liftIO $ statusCode resp @?= 400 - let err = responseJsonUnsafe resp :: Object - liftIO $ (err ^. at "label") @?= Just "unknown-remote-user" - testAddRemoteMemberInvalidDomain :: TestM () testAddRemoteMemberInvalidDomain = do alice <- randomUser bobId <- randomId let remoteBob = Qualified bobId (Domain "invalid.example.com") convId <- decodeConvId <$> postConv alice [] (Just "remote gossip") [] Nothing Nothing + + connectWithRemoteUser alice remoteBob + postQualifiedMembers alice (remoteBob :| []) convId !!! do const 422 === statusCode - const (Just "/federation/get-users-by-ids") + const (Just "/federation/on-conversation-updated") === preview (ix "data" . ix "path") . responseJsonUnsafe @Value const (Just "invalid.example.com") === preview (ix "data" . ix "domain") . responseJsonUnsafe @Value @@ -2171,27 +2250,46 @@ testAddRemoteMemberInvalidDomain = do -- on environments where federation isn't configured (such as our production as of May 2021) testAddRemoteMemberFederationDisabled :: TestM () testAddRemoteMemberFederationDisabled = do - g <- view tsGalley alice <- randomUser remoteBob <- flip Qualified (Domain "some-remote-backend.example.com") <$> randomId convId <- decodeConvId <$> postConv alice [] (Just "remote gossip") [] Nothing Nothing + connectWithRemoteUser alice remoteBob + opts <- view tsGConf -- federator endpoint not configured is equivalent to federation being disabled -- This is the case on staging/production in May 2021. let federatorNotConfigured :: Opts = opts & optFederator .~ Nothing withSettingsOverrides federatorNotConfigured $ - postQualifiedMembers' g alice (remoteBob :| []) convId !!! do + postQualifiedMembers alice (remoteBob :| []) convId !!! do const 400 === statusCode - const (Just "federation-not-enabled") === fmap label . responseJsonUnsafe + const (Right "federation-not-enabled") === fmap label . responseJsonEither + + -- the member is not actually added to the conversation + conv <- responseJsonError =<< getConv alice convId randomId + convId <- decodeConvId <$> postConv alice [] (Just "remote gossip") [] Nothing Nothing + connectWithRemoteUser alice remoteBob + + opts <- view tsGConf -- federator endpoint being configured in brig and/or galley, but not being -- available (i.e. no service listing on that IP/port) can happen due to a -- misconfiguration of federator. That should give a 500. -- Port 1 should always be wrong hopefully. let federatorUnavailable :: Opts = opts & optFederator ?~ Endpoint "127.0.0.1" 1 withSettingsOverrides federatorUnavailable $ - postQualifiedMembers' g alice (remoteBob :| []) convId !!! do + postQualifiedMembers alice (remoteBob :| []) convId !!! do const 500 === statusCode - const (Just "federation-not-available") === fmap label . responseJsonUnsafe + const (Right "federation-not-available") === fmap label . responseJsonEither + + -- in this case, we discover that federation is unavailable too late, and the + -- member has already been added to the conversation + conv <- responseJsonError =<< getConv alice convId postConv alice [bob, chuck] (Just "gossip") [] Nothing Nothing let qconv = Qualified conv (qDomain qalice) - e <- responseJsonUnsafe <$> (postMembers alice (singleton eve) conv postConv alice [bob, chuck] Nothing [] Nothing Nothing - postMembers bob (singleton chuck) conv !!! do + chuck <- randomQualifiedUser + connectUsers alice (list1 bob [qUnqualified chuck]) + connectUsers bob (singleton . qUnqualified $ chuck) + conv <- decodeConvId <$> postConv alice [bob, qUnqualified chuck] Nothing [] Nothing Nothing + postMembers bob (singleton . qUnqualified $ chuck) conv !!! do const 204 === statusCode const Nothing === responseBody - chuck' <- responseJsonUnsafe <$> (getSelfMember chuck conv (getSelfMember (qUnqualified chuck) conv chuck') @@ -2307,7 +2405,14 @@ deleteMembersConvLocalQualifiedOk = do [alice, bob, eve] <- randomUsers 3 let [qAlice, qBob, qEve] = (`Qualified` localDomain) <$> [alice, bob, eve] connectUsers alice (list1 bob [eve]) - conv <- decodeConvId <$> postConvQualified alice [qBob, qEve] (Just "federated gossip") [] Nothing Nothing + conv <- + decodeConvId + <$> postConvQualified + alice + defNewConv + { newConvQualifiedUsers = [qBob, qEve], + newConvName = Just "federated gossip" + } let qconv = Qualified conv localDomain deleteMemberQualified bob qBob qconv !!! const 200 === statusCode deleteMemberQualified bob qBob qconv !!! const 404 === statusCode @@ -2333,13 +2438,17 @@ deleteLocalMemberConvLocalQualifiedOk = do qEve = Qualified eve remoteDomain connectUsers alice (singleton bob) - convId <- decodeConvId <$> postConvWithRemoteUser remoteDomain (mkProfile qEve (Name "Eve")) alice [qBob, qEve] + connectWithRemoteUser alice qEve + convId <- + decodeConvId + <$> postConvWithRemoteUsers + alice + defNewConv {newConvQualifiedUsers = [qBob, qEve]} let qconvId = Qualified convId localDomain - opts <- view tsGConf let mockReturnEve = onlyMockedFederatedBrigResponse [(qEve, "Eve")] (respDel, fedRequests) <- - withTempMockFederator opts remoteDomain mockReturnEve $ + withTempMockFederator mockReturnEve $ deleteMemberQualified alice qBob qconvId let [galleyFederatedRequest] = fedRequestsForDomain remoteDomain F.Galley fedRequests assertRemoveUpdate galleyFederatedRequest qconvId qAlice [qUnqualified qEve] qBob @@ -2372,8 +2481,8 @@ deleteRemoteMemberConvLocalQualifiedOk = do qDee <- (`Qualified` remoteDomain1) <$> randomId qEve <- (`Qualified` remoteDomain2) <$> randomId connectUsers alice (singleton bob) + mapM_ (connectWithRemoteUser alice) [qChad, qDee, qEve] - opts <- view tsGConf let mockedResponse fedReq = do let success :: ToJSON a => a -> IO F.OutwardResponse success = pure . F.OutwardResponseBody . LBS.toStrict . encode @@ -2388,12 +2497,16 @@ deleteRemoteMemberConvLocalQualifiedOk = do _ -> success () (convId, _) <- - withTempMockFederator' opts remoteDomain1 mockedResponse $ - decodeConvId <$> postConvQualified alice [qBob, qChad, qDee, qEve] Nothing [] Nothing Nothing + withTempMockFederator' mockedResponse $ + fmap decodeConvId $ + postConvQualified + alice + defNewConv {newConvQualifiedUsers = [qBob, qChad, qDee, qEve]} + do (_, requests) <- - withTempMockFederator opts remoteDomain (const ()) $ + withTempMockFederator (const ()) $ putQualifiedConversationName bob qconv "gossip++" !!! const 200 === statusCode req <- assertOne requests @@ -2746,7 +2863,7 @@ putMemberOk update = do -- Expected member state let memberBob = Member - { memId = bob, + { memId = qbob, memService = Nothing, memOtrMutedStatus = mupOtrMuteStatus update, memOtrMutedRef = mupOtrMuteRef update, @@ -2798,6 +2915,8 @@ putRemoteConvMemberOk update = do let remoteDomain = Domain "bobland.example.com" qbob <- Qualified <$> randomId <*> pure remoteDomain qconv <- Qualified <$> randomId <*> pure remoteDomain + connectWithRemoteUser alice qbob + fedGalleyClient <- view tsFedGalleyClient now <- liftIO getCurrentTime let cu = @@ -2814,7 +2933,7 @@ putRemoteConvMemberOk update = do -- Expected member state let memberAlice = Member - { memId = alice, + { memId = qalice, memService = Nothing, memOtrMutedStatus = mupOtrMuteStatus update, memOtrMutedRef = mupOtrMuteRef update, @@ -2847,16 +2966,13 @@ putRemoteConvMemberOk update = do let bobAsLocal = LocalMember (qUnqualified qbob) defMemberStatus Nothing roleNameWireAdmin let mockConversation = mkConv - qconv + (qUnqualified qconv) (qUnqualified qbob) roleNameWireMember [localMemberToOther remoteDomain bobAsLocal] remoteConversationResponse = GetConversationsResponse [mockConversation] - opts <- view tsGConf (rs, _) <- withTempMockFederator - opts - remoteDomain (const remoteConversationResponse) $ getConvQualified alice qconv do (_, requests) <- - withTempMockFederator opts remoteDomain (const ()) $ + withTempMockFederator (const ()) $ putQualifiedReceiptMode bob qconv (ReceiptMode 43) !!! const 200 === statusCode req <- assertOne requests @@ -2984,52 +3104,22 @@ postTypingIndicators = do ) !!! const 400 === statusCode -removeUser :: TestM () -removeUser = do +removeUserNoFederation :: TestM () +removeUserNoFederation = do c <- view tsCannon - let remoteDomain = Domain "far-away.example.com" [alice, bob, carl] <- replicateM 3 randomQualifiedUser - dee <- (`Qualified` remoteDomain) <$> randomId let [alice', bob', carl'] = qUnqualified <$> [alice, bob, carl] + connectUsers alice' (list1 bob' [carl']) + conv1 <- decodeConvId <$> postConv alice' [bob'] (Just "gossip") [] Nothing Nothing conv2 <- decodeConvId <$> postConv alice' [bob', carl'] (Just "gossip2") [] Nothing Nothing conv3 <- decodeConvId <$> postConv alice' [carl'] (Just "gossip3") [] Nothing Nothing - conv4 <- randomId -- a remote conversation at 'remoteDomain' that Alice, Bob and Dee will be in let qconv1 = Qualified conv1 (qDomain bob) qconv2 = Qualified conv2 (qDomain bob) - now <- liftIO getCurrentTime - fedGalleyClient <- view tsFedGalleyClient - let nc = - FederatedGalley.NewRemoteConversation - { FederatedGalley.rcTime = now, - FederatedGalley.rcOrigUserId = dee, - FederatedGalley.rcCnvId = conv4, - FederatedGalley.rcCnvType = RegularConv, - FederatedGalley.rcCnvAccess = [], - FederatedGalley.rcCnvAccessRole = PrivateAccessRole, - FederatedGalley.rcCnvName = Just "gossip4", - FederatedGalley.rcMembers = Set.fromList $ createOtherMember <$> [dee, alice, bob], - FederatedGalley.rcMessageTimer = Nothing, - FederatedGalley.rcReceiptMode = Nothing - } - FederatedGalley.onConversationCreated fedGalleyClient remoteDomain nc - WS.bracketR3 c alice' bob' carl' $ \(wsA, wsB, wsC) -> do - opts <- view tsGConf - (_, fedRequests) <- - withTempMockFederator opts remoteDomain (const (FederatedGalley.LeaveConversationResponse (Right ()))) $ - deleteUser bob' !!! const 200 === statusCode - - req <- assertOne fedRequests - liftIO $ do - F.domain req @?= domainText remoteDomain - fmap F.component (F.request req) @?= Just F.Galley - fmap F.path (F.request req) @?= Just "/federation/leave-conversation" - Just (Right lc) <- pure $ fmap (eitherDecode . LBS.fromStrict . F.body) (F.request req) - FederatedGalley.lcConvId lc @?= conv4 - FederatedGalley.lcLeaver lc @?= qUnqualified bob + deleteUser bob' !!! const 200 === statusCode void . liftIO $ WS.assertMatchN (5 # Second) [wsA, wsB] $ @@ -3048,6 +3138,94 @@ removeUser = do (mems2 >>= other carl) @?= Just (OtherMember carl Nothing roleNameWireAdmin) (mems3 >>= other bob) @?= Nothing (mems3 >>= other carl) @?= Just (OtherMember carl Nothing roleNameWireAdmin) + +removeUser :: TestM () +removeUser = do + c <- view tsCannon + [alice, alexDel, amy] <- replicateM 3 randomQualifiedUser + let [alice', alexDel', amy'] = qUnqualified <$> [alice, alexDel, amy] + let bDomain = Domain "b.example.com" + bart <- randomQualifiedId bDomain + let cDomain = Domain "c.example.com" + carl <- randomQualifiedId cDomain + + connectUsers alice' (list1 alexDel' [amy']) + connectWithRemoteUser alice' bart + connectWithRemoteUser alexDel' bart + connectWithRemoteUser alice' carl + connectWithRemoteUser alexDel' carl + + convA1 <- decodeConvId <$> postConv alice' [alexDel'] (Just "gossip") [] Nothing Nothing + convA2 <- decodeConvId <$> postConv alice' [alexDel', amy'] (Just "gossip2") [] Nothing Nothing + convA3 <- decodeConvId <$> postConv alice' [amy'] (Just "gossip3") [] Nothing Nothing + convA4 <- decodeConvId <$> postConvWithRemoteUsers alice' defNewConv {newConvQualifiedUsers = [alexDel, bart, carl]} + convB1 <- randomId -- a remote conversation at 'bDomain' that Alice, AlexDel and Bart will be in + convB2 <- randomId -- a remote conversation at 'bDomain' that AlexDel and Bart will be in + convC1 <- randomId -- a remote conversation at 'cDomain' that AlexDel and Carl will be in + let qconvA1 = Qualified convA1 (qDomain alexDel) + qconvA2 = Qualified convA2 (qDomain alexDel) + + now <- liftIO getCurrentTime + fedGalleyClient <- view tsFedGalleyClient + let nc cid creator quids = + FederatedGalley.NewRemoteConversation + { FederatedGalley.rcTime = now, + FederatedGalley.rcOrigUserId = qUnqualified creator, + FederatedGalley.rcCnvId = cid, + FederatedGalley.rcCnvType = RegularConv, + FederatedGalley.rcCnvAccess = [], + FederatedGalley.rcCnvAccessRole = PrivateAccessRole, + FederatedGalley.rcCnvName = Just "gossip4", + FederatedGalley.rcNonCreatorMembers = Set.fromList $ createOtherMember <$> quids, + FederatedGalley.rcMessageTimer = Nothing, + FederatedGalley.rcReceiptMode = Nothing + } + FederatedGalley.onConversationCreated fedGalleyClient bDomain $ nc convB1 bart [alice, alexDel] + FederatedGalley.onConversationCreated fedGalleyClient bDomain $ nc convB2 bart [alexDel] + FederatedGalley.onConversationCreated fedGalleyClient cDomain $ nc convC1 carl [alexDel] + + WS.bracketR3 c alice' alexDel' amy' $ \(wsAlice, wsAlexDel, wsAmy) -> do + (_, fedRequests) <- + withTempMockFederator (const (FederatedGalley.LeaveConversationResponse (Right ()))) $ + deleteUser alexDel' !!! const 200 === statusCode + + -- FUTUTREWORK: There should be 4 requests, one to each domain for telling + -- them that alex left the conversation hosted locally. Add assertions for + -- that and implement it. + liftIO $ do + assertEqual ("expect exactly 2 federated requests in : " <> show fedRequests) 2 (length fedRequests) + bReq <- assertOne $ filter (\req -> F.domain req == domainText bDomain) fedRequests + cReq <- assertOne $ filter (\req -> F.domain req == domainText cDomain) fedRequests + liftIO $ do + fmap F.component (F.request bReq) @?= Just F.Galley + fmap F.path (F.request bReq) @?= Just "/federation/on-user-deleted/conversations" + Just (Right udcnB) <- pure $ fmap (eitherDecode . LBS.fromStrict . F.body) (F.request bReq) + sort (fromRange (FederatedGalley.udcnConversations udcnB)) @?= sort [convB1, convB2] + FederatedGalley.udcnUser udcnB @?= qUnqualified alexDel + + fmap F.component (F.request bReq) @?= Just F.Galley + fmap F.path (F.request cReq) @?= Just "/federation/on-user-deleted/conversations" + Just (Right udcnC) <- pure $ fmap (eitherDecode . LBS.fromStrict . F.body) (F.request cReq) + sort (fromRange (FederatedGalley.udcnConversations udcnC)) @?= sort [convC1] + FederatedGalley.udcnUser udcnC @?= qUnqualified alexDel + + WS.assertMatchN_ (5 # Second) [wsAlice, wsAlexDel] $ + wsAssertMembersLeave qconvA1 alexDel [alexDel] + WS.assertMatchN_ (5 # Second) [wsAlice, wsAlexDel, wsAmy] $ + wsAssertMembersLeave qconvA2 alexDel [alexDel] + -- Check memberships + mems1 <- fmap cnvMembers . responseJsonError =<< getConv alice' convA1 + mems2 <- fmap cnvMembers . responseJsonError =<< getConv alice' convA2 + mems3 <- fmap cnvMembers . responseJsonError =<< getConv alice' convA3 + mems4 <- fmap cnvMembers . responseJsonError =<< getConv alice' convA4 + let findOther u = find ((== u) . omQualifiedId) . cmOthers + liftIO $ do + findOther alexDel mems1 @?= Nothing + findOther alexDel mems2 @?= Nothing + findOther amy mems2 @?= Just (OtherMember amy Nothing roleNameWireAdmin) + findOther alexDel mems3 @?= Nothing + findOther amy mems3 @?= Just (OtherMember amy Nothing roleNameWireAdmin) + findOther alexDel mems4 @?= Nothing where createOtherMember :: Qualified UserId -> OtherMember createOtherMember quid = @@ -3056,3 +3234,58 @@ removeUser = do omService = Nothing, omConvRoleName = roleNameWireAdmin } + +testAllOne2OneConversationRequests :: TestM () +testAllOne2OneConversationRequests = do + for_ [LocalActor, RemoteActor] $ \actor -> + for_ [Included, Excluded] $ \desired -> + for_ [True, False] $ \shouldBeLocal -> + testOne2OneConversationRequest shouldBeLocal actor desired + +testOne2OneConversationRequest :: Bool -> Actor -> DesiredMembership -> TestM () +testOne2OneConversationRequest shouldBeLocal actor desired = do + alice <- qTagUnsafe <$> randomQualifiedUser + (bob, expectedConvId) <- generateRemoteAndConvId shouldBeLocal alice + + convId <- do + let req = UpsertOne2OneConversationRequest alice bob actor desired Nothing + res <- + iUpsertOne2OneConversation req + responseJsonError res + + liftIO $ convId @?= expectedConvId + + case shouldBeLocal of + True -> do + members <- case actor of + LocalActor -> runMaybeT $ do + resp <- lift $ getConvQualified (tUnqualified alice) convId + guard $ statusCode resp == 200 + conv <- lift $ responseJsonError resp + pure . map omQualifiedId . cmOthers . cnvMembers $ conv + RemoteActor -> do + fedGalleyClient <- view tsFedGalleyClient + GetConversationsResponse convs <- + FederatedGalley.getConversations + fedGalleyClient + (tDomain bob) + FederatedGalley.GetConversationsRequest + { FederatedGalley.gcrUserId = tUnqualified bob, + FederatedGalley.gcrConvIds = [qUnqualified convId] + } + pure + . fmap (map omQualifiedId . rcmOthers . rcnvMembers) + . listToMaybe + $ convs + liftIO $ case desired of + Included -> members @?= Just [] + Excluded -> members @?= Nothing + False -> do + found <- do + let rconv = mkConv (qUnqualified convId) (tUnqualified bob) roleNameWireAdmin [] + (resp, _) <- + withTempMockFederator (const (FederatedGalley.GetConversationsResponse [rconv])) $ + getConvQualified (tUnqualified alice) convId + pure $ statusCode resp == 200 + liftIO $ found @?= ((actor, desired) == (LocalActor, Included)) diff --git a/services/galley/test/integration/API/Federation.hs b/services/galley/test/integration/API/Federation.hs index 9e5895ab1a..2665106b2d 100644 --- a/services/galley/test/integration/API/Federation.hs +++ b/services/galley/test/integration/API/Federation.hs @@ -22,7 +22,7 @@ import API.Util import Bilge import Bilge.Assert import Control.Lens hiding ((#)) -import Data.Aeson (ToJSON (..)) +import Data.Aeson (FromJSON, ToJSON (..), eitherDecode) import qualified Data.Aeson as A import Data.ByteString.Conversion (toByteString') import qualified Data.ByteString.Lazy as LBS @@ -34,12 +34,15 @@ import Data.List1 import qualified Data.List1 as List1 import qualified Data.Map as Map import qualified Data.ProtoLens as Protolens -import Data.Qualified (Qualified (..)) +import Data.Qualified +import Data.Range import qualified Data.Set as Set +import Data.String.Conversions import Data.Time.Clock import Data.Timeout (TimeoutUnit (..), (#)) import Data.UUID.V4 (nextRandom) import Galley.Types +import Galley.Types.Conversations.Intra import Gundeck.Types.Notification import Imports import Test.QuickCheck (arbitrary, generate) @@ -51,6 +54,7 @@ import TestSetup import Wire.API.Conversation.Action (ConversationAction (..)) import Wire.API.Conversation.Member (Member (..)) import Wire.API.Conversation.Role +import Wire.API.Federation.API.Common import Wire.API.Federation.API.Galley (GetConversationsRequest (..), GetConversationsResponse (..), RemoteConvMembers (..), RemoteConversation (..)) import qualified Wire.API.Federation.API.Galley as FedGalley import qualified Wire.API.Federation.GRPC.Types as F @@ -64,7 +68,9 @@ tests s = "federation" [ test s "POST /federation/get-conversations : All Found" getConversationsAllFound, test s "POST /federation/get-conversations : Conversations user is not a part of are excluded from result" getConversationsNotPartOf, + test s "POST /federation/on-conversation-created : Add local user to remote conversation" onConvCreated, test s "POST /federation/on-conversation-updated : Add local user to remote conversation" addLocalUser, + test s "POST /federation/on-conversation-updated : Add only unconnected local users to remote conversation" addUnconnectedUsersOnly, test s "POST /federation/on-conversation-updated : Notify local user about other members joining" addRemoteUser, test s "POST /federation/on-conversation-updated : Remove a local user from a remote conversation" removeLocalUser, test s "POST /federation/on-conversation-updated : Remove a remote user from a remote conversation" removeRemoteUser, @@ -73,9 +79,11 @@ tests s = test s "POST /federation/on-conversation-updated : Notify local user about member update" notifyMemberUpdate, test s "POST /federation/on-conversation-updated : Notify local user about receipt mode update" notifyReceiptMode, test s "POST /federation/on-conversation-updated : Notify local user about access update" notifyAccess, + test s "POST /federation/on-conversation-updated : Notify local users about a deleted conversation" notifyDeletedConversation, test s "POST /federation/leave-conversation : Success" leaveConversationSuccess, test s "POST /federation/on-message-sent : Receive a message from another backend" onMessageSent, - test s "POST /federation/send-message : Post a message sent from another backend" sendMessage + test s "POST /federation/send-message : Post a message sent from another backend" sendMessage, + test s "POST /federation/on-user-deleted/conversations : Remove deleted remote user from local conversations" onUserDeleted ] getConversationsAllFound :: TestM () @@ -85,11 +93,15 @@ getConversationsAllFound = do -- create & get group conv aliceQ <- Qualified <$> randomId <*> pure (Domain "far-away.example.com") carlQ <- randomQualifiedUser + connectUsers bob (singleton (qUnqualified carlQ)) + connectWithRemoteUser bob aliceQ cnv2 <- responseJsonError - =<< postConvWithRemoteUser (qDomain aliceQ) (mkProfile aliceQ (Name "alice")) bob [aliceQ, carlQ] + =<< postConvWithRemoteUsers + bob + defNewConv {newConvQualifiedUsers = [aliceQ, carlQ]} getConvs bob (Just $ Left [qUnqualified (cnvQualifiedId cnv2)]) Nothing !!! do const 200 === statusCode @@ -101,7 +113,7 @@ getConversationsAllFound = do -- get conversations fedGalleyClient <- view tsFedGalleyClient - GetConversationsResponse cs <- + GetConversationsResponse convs <- FedGalley.getConversations fedGalleyClient (qDomain aliceQ) @@ -110,7 +122,7 @@ getConversationsAllFound = do (map (qUnqualified . cnvQualifiedId) [cnv2]) ) - let c2 = find ((== cnvQualifiedId cnv2) . cnvmQualifiedId . rcnvMetadata) cs + let c2 = find ((== qUnqualified (cnvQualifiedId cnv2)) . rcnvId) convs liftIO $ do assertEqual @@ -140,12 +152,42 @@ getConversationsNotPartOf = do fedGalleyClient <- view tsFedGalleyClient localDomain <- viewFederationDomain rando <- Id <$> liftIO nextRandom - GetConversationsResponse cs <- + GetConversationsResponse convs <- FedGalley.getConversations fedGalleyClient localDomain (GetConversationsRequest rando [qUnqualified . cnvQualifiedId $ cnv1]) - liftIO $ assertEqual "conversation list not empty" [] cs + liftIO $ assertEqual "conversation list not empty" [] convs + +onConvCreated :: TestM () +onConvCreated = do + c <- view tsCannon + (alice, qAlice) <- randomUserTuple + let remoteDomain = Domain "bobland.example.com" + qBob <- Qualified <$> randomId <*> pure remoteDomain + qDee <- Qualified <$> randomId <*> pure remoteDomain + + (charlie, qCharlie) <- randomUserTuple + conv <- randomId + let qconv = Qualified conv remoteDomain + + connectWithRemoteUser alice qBob + -- Remote Bob creates a conversation with local Alice and Charlie; + -- however Bob is not connected to Charlie but only to Alice. + let requestMembers = Set.fromList (map asOtherMember [qAlice, qCharlie, qDee]) + + WS.bracketR2 c alice charlie $ \(wsA, wsC) -> do + registerRemoteConv qconv (qUnqualified qBob) (Just "gossip") requestMembers + liftIO $ do + let expectedSelf = qAlice + expectedOthers = [(qBob, roleNameWireAdmin), (qDee, roleNameWireMember)] + expectedFrom = qBob + -- since Charlie is not connected to Bob; expect a conversation with Alice&Bob only + WS.assertMatch_ (5 # Second) wsA $ + wsAssertConvCreateWithRole qconv expectedFrom expectedSelf expectedOthers + WS.assertNoEvent (1 # Second) [wsC] + convs <- listRemoteConvs remoteDomain alice + liftIO $ convs @?= [Qualified conv remoteDomain] addLocalUser :: TestM () addLocalUser = do @@ -157,8 +199,13 @@ addLocalUser = do bob <- randomId let qbob = Qualified bob remoteDomain charlie <- randomUser + dee <- randomUser + let qdee = Qualified dee localDomain conv <- randomId let qconv = Qualified conv remoteDomain + + connectWithRemoteUser alice qbob + fedGalleyClient <- view tsFedGalleyClient now <- liftIO getCurrentTime let cu = @@ -168,16 +215,65 @@ addLocalUser = do FedGalley.cuConvId = conv, FedGalley.cuAlreadyPresentUsers = [charlie], FedGalley.cuAction = - ConversationActionAddMembers (pure qalice) roleNameWireMember + ConversationActionAddMembers (qalice :| [qdee]) roleNameWireMember } - WS.bracketR2 c alice charlie $ \(wsA, wsC) -> do + WS.bracketRN c [alice, charlie, dee] $ \[wsA, wsC, wsD] -> do FedGalley.onConversationUpdated fedGalleyClient remoteDomain cu liftIO $ do WS.assertMatch_ (5 # Second) wsA $ wsAssertMemberJoinWithRole qconv qbob [qalice] roleNameWireMember + -- Since charlie is not really present in the conv, they don't get any + -- notifications WS.assertNoEvent (1 # Second) [wsC] - convs <- listRemoteConvs remoteDomain alice - liftIO $ convs @?= [Qualified conv remoteDomain] + -- Since dee is not connected to bob, they don't get any notifications + WS.assertNoEvent (1 # Second) [wsD] + aliceConvs <- listRemoteConvs remoteDomain alice + liftIO $ aliceConvs @?= [Qualified conv remoteDomain] + deeConvs <- listRemoteConvs remoteDomain dee + liftIO $ deeConvs @?= [] + +addUnconnectedUsersOnly :: TestM () +addUnconnectedUsersOnly = do + c <- view tsCannon + (alice, qAlice) <- randomUserTuple + (_charlie, qCharlie) <- randomUserTuple + + let remoteDomain = Domain "bobland.example.com" + qBob <- Qualified <$> randomId <*> pure remoteDomain + conv <- randomId + let qconv = Qualified conv remoteDomain + + -- Bob is connected to Alice + -- Bob is not connected to Charlie + connectWithRemoteUser alice qBob + let requestMembers = Set.fromList (map asOtherMember [qAlice]) + + now <- liftIO getCurrentTime + fedGalleyClient <- view tsFedGalleyClient + + WS.bracketR c alice $ \wsA -> do + -- Remote Bob creates a conversation with local Alice + registerRemoteConv qconv (qUnqualified qBob) (Just "gossip") requestMembers + liftIO $ do + let expectedSelf = qAlice + expectedOthers = [(qBob, roleNameWireAdmin)] + expectedFrom = qBob + WS.assertMatch_ (5 # Second) wsA $ + wsAssertConvCreateWithRole qconv expectedFrom expectedSelf expectedOthers + + -- Bob attempts to add unconnected Charlie (possible abuse) + let cu = + FedGalley.ConversationUpdate + { FedGalley.cuTime = now, + FedGalley.cuOrigUserId = qBob, + FedGalley.cuConvId = conv, + FedGalley.cuAlreadyPresentUsers = [alice], + FedGalley.cuAction = + ConversationActionAddMembers (qCharlie :| []) roleNameWireMember + } + -- Alice receives no notifications from this + FedGalley.onConversationUpdated fedGalleyClient remoteDomain cu + WS.assertNoEvent (5 # Second) [wsA] -- | This test invokes the federation endpoint: -- @@ -216,9 +312,10 @@ removeLocalUser = do FedGalley.cuConvId = conv, FedGalley.cuAlreadyPresentUsers = [alice], FedGalley.cuAction = - ConversationActionRemoveMember qAlice + ConversationActionRemoveMembers (pure qAlice) } + connectWithRemoteUser alice qBob WS.bracketR c alice $ \ws -> do FedGalley.onConversationUpdated fedGalleyClient remoteDomain cuAdd afterAddition <- listRemoteConvs remoteDomain alice @@ -269,7 +366,8 @@ removeRemoteUser = do fedGalleyClient <- view tsFedGalleyClient now <- liftIO getCurrentTime - registerRemoteConv qconv qBob (Just "gossip") (Set.fromList [aliceAsOtherMember, deeAsOtherMember, eveAsOtherMember]) + mapM_ (`connectWithRemoteUser` qBob) [alice, dee] + registerRemoteConv qconv (qUnqualified qBob) (Just "gossip") (Set.fromList [aliceAsOtherMember, deeAsOtherMember, eveAsOtherMember]) let cuRemove user = FedGalley.ConversationUpdate @@ -278,7 +376,7 @@ removeRemoteUser = do FedGalley.cuConvId = conv, FedGalley.cuAlreadyPresentUsers = [alice, charlie, dee], FedGalley.cuAction = - ConversationActionRemoveMember user + ConversationActionRemoveMembers (pure user) } WS.bracketRN c [alice, charlie, dee, flo] $ \[wsA, wsC, wsD, wsF] -> do @@ -316,9 +414,10 @@ notifyUpdate extras action etype edata = do mkMember quid = OtherMember quid Nothing roleNameWireMember fedGalleyClient <- view tsFedGalleyClient + mapM_ (`connectWithRemoteUser` qbob) [alice] registerRemoteConv qconv - qbob + bob (Just "gossip") (Set.fromList (map mkMember (qalice : extras))) @@ -395,6 +494,54 @@ notifyMemberUpdate = do MemberStateUpdate (EdMemberUpdate d) +notifyDeletedConversation :: TestM () +notifyDeletedConversation = do + c <- view tsCannon + + qalice <- randomQualifiedUser + let alice = qUnqualified qalice + + bob <- randomId + conv <- randomId + let bobDomain = Domain "bob.example.com" + qbob = Qualified bob bobDomain + qconv = Qualified conv bobDomain + mkMember quid = OtherMember quid Nothing roleNameWireMember + + mapM_ (`connectWithRemoteUser` qbob) [alice] + registerRemoteConv + qconv + bob + (Just "gossip") + (Set.fromList (map mkMember [qalice])) + + fedGalleyClient <- view tsFedGalleyClient + + do + aliceConvs <- listRemoteConvs bobDomain alice + liftIO $ aliceConvs @?= [qconv] + + WS.bracketR c alice $ \wsAlice -> do + now <- liftIO getCurrentTime + let cu = + FedGalley.ConversationUpdate + { FedGalley.cuTime = now, + FedGalley.cuOrigUserId = qbob, + FedGalley.cuConvId = qUnqualified qconv, + FedGalley.cuAlreadyPresentUsers = [alice], + FedGalley.cuAction = ConversationActionDelete + } + FedGalley.onConversationUpdated fedGalleyClient bobDomain cu + + liftIO $ do + WS.assertMatch_ (5 # Second) wsAlice $ \n -> do + let e = List1.head (WS.unpackPayload n) + ConvDelete @=? evtType e + + do + aliceConvs <- listRemoteConvs bobDomain alice + liftIO $ aliceConvs @?= [] + -- TODO: test adding non-existing users -- TODO: test adding resulting in an empty notification @@ -427,8 +574,9 @@ addRemoteUser = do fedGalleyClient <- view tsFedGalleyClient now <- liftIO getCurrentTime - let asOtherMember quid = OtherMember quid Nothing roleNameWireMember - registerRemoteConv qconv qbob (Just "gossip") (Set.fromList (map asOtherMember [qalice, qdee, qeve])) + mapM_ (flip connectWithRemoteUser qbob . qUnqualified) [qalice, qdee] + + registerRemoteConv qconv (qUnqualified qbob) (Just "gossip") (Set.fromList (map asOtherMember [qalice, qdee, qeve])) -- The conversation owning let cu = @@ -436,16 +584,17 @@ addRemoteUser = do { FedGalley.cuTime = now, FedGalley.cuOrigUserId = qbob, FedGalley.cuConvId = qUnqualified qconv, - FedGalley.cuAlreadyPresentUsers = (map qUnqualified [qalice, qcharlie]), + FedGalley.cuAlreadyPresentUsers = map qUnqualified [qalice, qcharlie], FedGalley.cuAction = ConversationActionAddMembers (qdee :| [qeve, qflo]) roleNameWireMember } WS.bracketRN c (map qUnqualified [qalice, qcharlie, qdee, qflo]) $ \[wsA, wsC, wsD, wsF] -> do FedGalley.onConversationUpdated fedGalleyClient bdom cu void . liftIO $ do - WS.assertMatchN_ (5 # Second) [wsA, wsD, wsF] $ - wsAssertMemberJoinWithRole qconv qbob [qeve, qdee, qflo] roleNameWireMember + WS.assertMatchN_ (5 # Second) [wsA, wsD] $ + wsAssertMemberJoinWithRole qconv qbob [qeve, qdee] roleNameWireMember WS.assertNoEvent (1 # Second) [wsC] + WS.assertNoEvent (1 # Second) [wsF] leaveConversationSuccess :: TestM () leaveConversationSuccess = do @@ -459,8 +608,10 @@ leaveConversationSuccess = do qDee <- (`Qualified` remoteDomain1) <$> randomId qEve <- (`Qualified` remoteDomain2) <$> randomId connectUsers alice (singleton bob) + connectWithRemoteUser alice qChad + connectWithRemoteUser alice qDee + connectWithRemoteUser alice qEve - opts <- view tsGConf let mockedResponse fedReq = do let success :: ToJSON a => a -> IO F.OutwardResponse success = pure . F.OutwardResponseBody . LBS.toStrict . A.encode @@ -475,13 +626,18 @@ leaveConversationSuccess = do _ -> success () (convId, _) <- - withTempMockFederator' opts remoteDomain1 mockedResponse $ - decodeConvId <$> postConvQualified alice [qBob, qChad, qDee, qEve] Nothing [] Nothing Nothing + withTempMockFederator' mockedResponse $ + decodeConvId + <$> postConvQualified + alice + defNewConv + { newConvQualifiedUsers = [qBob, qChad, qDee, qEve] + } let qconvId = Qualified convId localDomain (_, federatedRequests) <- WS.bracketR2 c alice bob $ \(wsAlice, wsBob) -> do - withTempMockFederator' opts remoteDomain1 mockedResponse $ do + withTempMockFederator' mockedResponse $ do g <- viewGalley let leaveRequest = FedGalley.LeaveConversationRequest convId (qUnqualified qChad) respBS <- @@ -526,6 +682,7 @@ onMessageSent = do fedGalleyClient <- view tsFedGalleyClient -- only add alice to the remote conversation + connectWithRemoteUser alice qbob let cu = FedGalley.ConversationUpdate { FedGalley.cuTime = now, @@ -589,7 +746,7 @@ onMessageSent = do -- alice local, bob and chad remote in a local conversation -- bob sends a message (using the RPC), we test that alice receives it and that -- a call is made to the onMessageSent RPC to inform chad -sendMessage :: HasCallStack => TestM () +sendMessage :: TestM () sendMessage = do cannon <- view tsCannon let remoteDomain = Domain "far-away.example.com" @@ -607,24 +764,27 @@ sendMessage = do let chad = Qualified chadId remoteDomain chadProfile = mkProfile chad (Name "Chad") + connectWithRemoteUser aliceId bob + connectWithRemoteUser aliceId chad -- conversation - opts <- view tsGConf let responses1 req | fmap F.component (F.request req) == Just F.Brig = toJSON [bobProfile, chadProfile] | otherwise = toJSON () (convId, requests1) <- - withTempMockFederator opts remoteDomain responses1 $ + withTempMockFederator responses1 $ fmap decodeConvId $ - postConvQualified aliceId [bob, chad] Nothing [] Nothing Nothing + postConvQualified + aliceId + defNewConv + { newConvQualifiedUsers = [bob, chad] + } pure xs + [galleyReq] <- case requests1 of + xs@[_] -> pure xs _ -> assertFailure "unexpected number of requests" - fmap F.component (F.request brigReq) @?= Just F.Brig - fmap F.path (F.request brigReq) @?= Just "/federation/get-users-by-ids" fmap F.component (F.request galleyReq) @?= Just F.Galley fmap F.path (F.request galleyReq) @?= Just "/federation/on-conversation-created" let conv = Qualified convId localDomain @@ -654,7 +814,7 @@ sendMessage = do ] ) | otherwise = toJSON () - (_, requests2) <- withTempMockFederator opts remoteDomain responses2 $ do + (_, requests2) <- withTempMockFederator responses2 $ do WS.bracketR cannon aliceId $ \ws -> do g <- viewGalley msresp <- @@ -693,3 +853,133 @@ sendMessage = do FedGalley.rmSender rm @?= bob Map.keysSet (userClientMap (FedGalley.rmRecipients rm)) @?= Set.singleton chadId + +onUserDeleted :: TestM () +onUserDeleted = do + cannon <- view tsCannon + let eveDomain = Domain "eve.example.com" + + alice <- qTagUnsafe <$> randomQualifiedUser + (bob, ooConvId) <- generateRemoteAndConvId True alice + let bobDomain = tDomain bob + charlie <- randomQualifiedUser + dee <- randomQualifiedId bobDomain + eve <- randomQualifiedId eveDomain + + connectWithRemoteUser (tUnqualified alice) (qUntagged bob) + connectUsers (tUnqualified alice) (pure (qUnqualified charlie)) + connectWithRemoteUser (tUnqualified alice) dee + connectWithRemoteUser (tUnqualified alice) eve + + -- create 1-1 conversation between alice and bob + iUpsertOne2OneConversation + UpsertOne2OneConversationRequest + { uooLocalUser = alice, + uooRemoteUser = bob, + uooActor = LocalActor, + uooActorDesiredMembership = Included, + uooConvId = Nothing + } + !!! const 200 === statusCode + iUpsertOne2OneConversation + UpsertOne2OneConversationRequest + { uooLocalUser = alice, + uooRemoteUser = bob, + uooActor = RemoteActor, + uooActorDesiredMembership = Included, + uooConvId = Just ooConvId + } + !!! const 200 === statusCode + + -- create group conversation with everybody + groupConvId <- + decodeQualifiedConvId + <$> ( postConvWithRemoteUsers + (tUnqualified alice) + defNewConv {newConvQualifiedUsers = [qUntagged bob, charlie, dee, eve]} + ( postConvQualified (tUnqualified alice) defNewConv {newConvQualifiedUsers = [charlie]} + do + (resp, rpcCalls) <- withTempMockFederator (const ()) $ do + let udcn = + FedGalley.UserDeletedConversationsNotification + { FedGalley.udcnUser = tUnqualified bob, + FedGalley.udcnConversations = + unsafeRange + [ qUnqualified ooConvId, + qUnqualified groupConvId, + extraConvId, + qUnqualified noBobConvId + ] + } + g <- viewGalley + responseJsonError + =<< post + ( g + . paths ["federation", "on-user-deleted", "conversations"] + . content "application/json" + . header "Wire-Origin-Domain" (toByteString' (tDomain bob)) + . json udcn + ) + F.domain c == domainText bobDomain) rpcCalls + bobDomainRPCReq <- assertRight $ parseFedRequest bobDomainRPC + FedGalley.cuOrigUserId bobDomainRPCReq @?= qUntagged bob + FedGalley.cuConvId bobDomainRPCReq @?= qUnqualified groupConvId + sort (FedGalley.cuAlreadyPresentUsers bobDomainRPCReq) @?= sort [tUnqualified bob, qUnqualified dee] + FedGalley.cuAction bobDomainRPCReq @?= ConversationActionRemoveMembers (pure $ qUntagged bob) + + -- Assertions about RPC to Eve's domain + eveDomainRPC <- assertOne $ filter (\c -> F.domain c == domainText eveDomain) rpcCalls + eveDomainRPCReq <- assertRight $ parseFedRequest eveDomainRPC + FedGalley.cuOrigUserId eveDomainRPCReq @?= qUntagged bob + FedGalley.cuConvId eveDomainRPCReq @?= qUnqualified groupConvId + FedGalley.cuAlreadyPresentUsers eveDomainRPCReq @?= [qUnqualified eve] + FedGalley.cuAction eveDomainRPCReq @?= ConversationActionRemoveMembers (pure $ qUntagged bob) + where + parseFedRequest :: FromJSON a => F.FederatedRequest -> Either String a + parseFedRequest fr = + case F.request fr of + Just r -> + (eitherDecode . cs) (F.body r) + Nothing -> Left "No request" diff --git a/services/galley/test/integration/API/MessageTimer.hs b/services/galley/test/integration/API/MessageTimer.hs index 276c597742..71d47cdf85 100644 --- a/services/galley/test/integration/API/MessageTimer.hs +++ b/services/galley/test/integration/API/MessageTimer.hs @@ -49,7 +49,6 @@ import Wire.API.Conversation.Action import qualified Wire.API.Federation.API.Galley as F import qualified Wire.API.Federation.GRPC.Types as F import qualified Wire.API.Team.Member as Member -import Wire.API.User.Profile (Name (..)) tests :: IO TestSetup -> TestTree tests s = @@ -75,11 +74,12 @@ messageTimerInit :: messageTimerInit mtimer = do -- Create a conversation with a timer [alice, bob, jane] <- randomUsers 3 + qAlice <- Qualified <$> pure alice <*> viewFederationDomain connectUsers alice (list1 bob [jane]) rsp <- postConv alice [bob, jane] Nothing [] Nothing mtimer pure alice <*> viewFederationDomain connectUsers alice (list1 bob [jane]) rsp <- postConv alice [bob, jane] Nothing [] Nothing Nothing pure alice <*> viewFederationDomain connectUsers alice (list1 bob [jane]) rsp <- postConv alice [bob, jane] Nothing [] Nothing Nothing randomId <*> pure remoteDomain qbob <- randomQualifiedUser let bob = qUnqualified qbob + connectWithRemoteUser bob qalice - resp <- postConvWithRemoteUser remoteDomain (mkProfile qalice (Name "Alice")) bob [qalice] + resp <- + postConvWithRemoteUsers + bob + defNewConv {newConvQualifiedUsers = [qalice]} let qconv = decodeQualifiedConvId resp - opts <- view tsGConf WS.bracketR c bob $ \wsB -> do (_, requests) <- - withTempMockFederator opts remoteDomain (const ()) $ + withTempMockFederator (const ()) $ putMessageTimerUpdateQualified bob qconv (ConversationMessageTimerUpdate timer1sec) !!! const 200 === statusCode @@ -207,11 +212,12 @@ messageTimerChangeO2O :: TestM () messageTimerChangeO2O = do -- Create a 1:1 conversation [alice, bob] <- randomUsers 2 + qAlice <- Qualified <$> pure alice <*> viewFederationDomain connectUsers alice (singleton bob) rsp <- postO2OConv alice bob Nothing pure alice <*> viewFederationDomain connectUsers alice (singleton bob) rsp <- postConv alice [bob] Nothing [] Nothing Nothing do let update = ConversationMessageTimerUpdate timer1sec diff --git a/services/galley/test/integration/API/Roles.hs b/services/galley/test/integration/API/Roles.hs index 8fe7b3e7bb..615442b2c7 100644 --- a/services/galley/test/integration/API/Roles.hs +++ b/services/galley/test/integration/API/Roles.hs @@ -44,7 +44,6 @@ import TestSetup import Wire.API.Conversation.Action import qualified Wire.API.Federation.API.Galley as F import qualified Wire.API.Federation.GRPC.Types as F -import Wire.API.User tests :: IO TestSetup -> TestTree tests s = @@ -94,7 +93,7 @@ handleConversationRoleAdmin = do let role = roleNameWireAdmin cid <- WS.bracketR3 c alice bob chuck $ \(wsA, wsB, wsC) -> do rsp <- postConvWithRole alice [bob, chuck] (Just "gossip") [] Nothing Nothing role - void $ assertConvWithRole rsp RegularConv alice alice [bob, chuck] (Just "gossip") Nothing role + void $ assertConvWithRole rsp RegularConv alice qalice [bob, chuck] (Just "gossip") Nothing role let cid = decodeConvId rsp qcid = Qualified cid localDomain -- Make sure everyone gets the correct event @@ -136,7 +135,7 @@ handleConversationRoleMember = do let role = roleNameWireMember cid <- WS.bracketR3 c alice bob chuck $ \(wsA, wsB, wsC) -> do rsp <- postConvWithRole alice [bob, chuck] (Just "gossip") [] Nothing Nothing role - void $ assertConvWithRole rsp RegularConv alice alice [bob, chuck] (Just "gossip") Nothing role + void $ assertConvWithRole rsp RegularConv alice qalice [bob, chuck] (Just "gossip") Nothing role let cid = decodeConvId rsp qcid = Qualified cid localDomain -- Make sure everyone gets the correct event @@ -167,18 +166,16 @@ roleUpdateRemoteMember = do qcharlie <- Qualified <$> randomId <*> pure remoteDomain let bob = qUnqualified qbob + traverse_ (connectWithRemoteUser bob) [qalice, qcharlie] resp <- postConvWithRemoteUsers - remoteDomain - [mkProfile qalice (Name "Alice"), mkProfile qcharlie (Name "Charlie")] bob - [qalice, qcharlie] + defNewConv {newConvQualifiedUsers = [qalice, qcharlie]} let qconv = decodeQualifiedConvId resp - opts <- view tsGConf WS.bracketR c bob $ \wsB -> do (_, requests) <- - withTempMockFederator opts remoteDomain (const ()) $ + withTempMockFederator (const ()) $ putOtherMemberQualified bob qcharlie @@ -238,18 +235,16 @@ roleUpdateWithRemotes = do charlie = qUnqualified qcharlie connectUsers bob (singleton charlie) + connectWithRemoteUser bob qalice resp <- - postConvWithRemoteUser - remoteDomain - (mkProfile qalice (Name "Alice")) + postConvWithRemoteUsers bob - [qalice, qcharlie] + defNewConv {newConvQualifiedUsers = [qalice, qcharlie]} let qconv = decodeQualifiedConvId resp - opts <- view tsGConf WS.bracketR2 c bob charlie $ \(wsB, wsC) -> do (_, requests) <- - withTempMockFederator opts remoteDomain (const ()) $ + withTempMockFederator (const ()) $ putOtherMemberQualified bob qcharlie @@ -298,19 +293,17 @@ accessUpdateWithRemotes = do charlie = qUnqualified qcharlie connectUsers bob (singleton charlie) + connectWithRemoteUser bob qalice resp <- - postConvWithRemoteUser - remoteDomain - (mkProfile qalice (Name "Alice")) + postConvWithRemoteUsers bob - [qalice, qcharlie] + defNewConv {newConvQualifiedUsers = [qalice, qcharlie]} let qconv = decodeQualifiedConvId resp - opts <- view tsGConf let access = ConversationAccessData (Set.singleton CodeAccess) NonActivatedAccessRole WS.bracketR2 c bob charlie $ \(wsB, wsC) -> do (_, requests) <- - withTempMockFederator opts remoteDomain (const ()) $ + withTempMockFederator (const ()) $ putQualifiedAccessUpdate bob qconv access !!! const 200 === statusCode diff --git a/services/galley/test/integration/API/Teams.hs b/services/galley/test/integration/API/Teams.hs index 6b289d6561..8a15a7a255 100644 --- a/services/galley/test/integration/API/Teams.hs +++ b/services/galley/test/integration/API/Teams.hs @@ -42,11 +42,10 @@ import Data.Id import qualified Data.LegalHold as LH import Data.List1 import qualified Data.List1 as List1 -import Data.Misc (HttpsUrl, PlainTextPassword (..)) +import Data.Misc (HttpsUrl, PlainTextPassword (..), mkHttpsUrl) import Data.Qualified import Data.Range import qualified Data.Set as Set -import Data.String.Conversions (cs) import qualified Data.Text as T import qualified Data.UUID as UUID import qualified Data.UUID.Util as UUID @@ -66,6 +65,7 @@ import qualified Network.Wai.Utilities.Error as Error import qualified Network.Wai.Utilities.Error as Wai import qualified Proto.TeamEvents as E import qualified Proto.TeamEvents_Fields as E +import qualified SAML2.WebSSO.Types as SAML import Test.Tasty import Test.Tasty.Cannon (TimeoutUnit (..), (#)) import qualified Test.Tasty.Cannon as WS @@ -277,7 +277,7 @@ testListTeamMembersCsv numMembers = do where userToIdPIssuer :: HasCallStack => U.User -> Maybe HttpsUrl userToIdPIssuer usr = case (U.userIdentity >=> U.ssoIdentity) usr of - Just (U.UserSSOId issuer _) -> maybe (error "shouldn't happen") Just . fromByteString' . cs $ issuer + Just (U.UserSSOId (SAML.UserRef (SAML.Issuer issuer) _)) -> either (const $ error "shouldn't happen") Just $ mkHttpsUrl issuer Just _ -> Nothing Nothing -> Nothing @@ -790,9 +790,10 @@ testAddTeamConvLegacy = do mem2 <- newTeamMember' p <$> Util.randomUser Util.connectUsers owner (list1 (mem1 ^. userId) [extern, mem2 ^. userId]) tid <- Util.createNonBindingTeam "foo" owner [mem2] - let allUserIds = [owner, extern, mem1 ^. userId, mem2 ^. userId] - WS.bracketRN c allUserIds $ \wss -> do - cid <- Util.createTeamConvLegacy owner tid allUserIds (Just "blaa") + allUserIds <- for [owner, extern, mem1 ^. userId, mem2 ^. userId] $ + \u -> Qualified <$> pure u <*> viewFederationDomain + WS.bracketRN c (qUnqualified <$> allUserIds) $ \wss -> do + cid <- Util.createTeamConvLegacy owner tid (qUnqualified <$> allUserIds) (Just "blaa") mapM_ (checkConvCreateEvent cid) wss -- All members become admin by default mapM_ (assertConvMemberWithRole roleNameWireAdmin cid) allUserIds @@ -802,7 +803,9 @@ testAddTeamConvWithRole :: TestM () testAddTeamConvWithRole = do c <- view tsCannon owner <- Util.randomUser + qOwner <- Qualified <$> pure owner <*> viewFederationDomain extern <- Util.randomUser + qExtern <- Qualified <$> pure extern <*> viewFederationDomain let p = Util.symmPermissions [CreateConversation, DoNotUseDeprecatedAddRemoveConvMember] mem1 <- newTeamMember' p <$> Util.randomUser mem2 <- newTeamMember' p <$> Util.randomUser @@ -813,13 +816,13 @@ testAddTeamConvWithRole = do cid2 <- Util.createTeamConvWithRole owner tid [extern] (Just "blaa") Nothing Nothing roleNameWireAdmin checkConvCreateEvent cid2 wsOwner checkConvCreateEvent cid2 wsExtern - mapM_ (assertConvMemberWithRole roleNameWireAdmin cid2) [owner, extern] + mapM_ (assertConvMemberWithRole roleNameWireAdmin cid2) [qOwner, qExtern] -- Regular conversation (using member role for participants): cid3 <- Util.createTeamConvWithRole owner tid [extern] (Just "blaa") Nothing Nothing roleNameWireMember checkConvCreateEvent cid3 wsOwner checkConvCreateEvent cid3 wsExtern - assertConvMemberWithRole roleNameWireAdmin cid3 owner - assertConvMemberWithRole roleNameWireMember cid3 extern + assertConvMemberWithRole roleNameWireAdmin cid3 qOwner + assertConvMemberWithRole roleNameWireMember cid3 qExtern -- mem2 is not a conversation member and no longer receives -- an event that a new team conversation has been created @@ -879,13 +882,18 @@ testAddTeamMemberToConv :: TestM () testAddTeamMemberToConv = do personalUser <- Util.randomUser ownerT1 <- Util.randomUser + qOwnerT1 <- Qualified <$> pure ownerT1 <*> viewFederationDomain let p = Util.symmPermissions [DoNotUseDeprecatedAddRemoveConvMember] mem1T1 <- newTeamMember' p <$> Util.randomUser + qMem1T1 <- Qualified <$> pure (mem1T1 ^. userId) <*> viewFederationDomain mem2T1 <- newTeamMember' p <$> Util.randomUser + qMem2T1 <- Qualified <$> pure (mem2T1 ^. userId) <*> viewFederationDomain mem3T1 <- newTeamMember' (Util.symmPermissions []) <$> Util.randomUser mem4T1 <- newTeamMember' (Util.symmPermissions []) <$> Util.randomUser ownerT2 <- Util.randomUser + qOwnerT2 <- Qualified <$> pure ownerT2 <*> viewFederationDomain mem1T2 <- newTeamMember' p <$> Util.randomUser + qMem1T2 <- Qualified <$> pure (mem1T2 ^. userId) <*> viewFederationDomain Util.connectUsers ownerT1 (list1 (mem1T1 ^. userId) [mem2T1 ^. userId, mem3T1 ^. userId, ownerT2, personalUser]) tidT1 <- Util.createNonBindingTeam "foo" ownerT1 [mem1T1, mem2T1, mem3T1] tidT2 <- Util.createBindingTeamInternal "foo" ownerT2 @@ -902,9 +910,9 @@ testAddTeamMemberToConv = do Util.assertNotConvMember (mem2T1 ^. userId) cidT1 -- OTOH, mem3T1 _can_ add another team member despite lacking the required team permission -- since conversation roles trump any team roles. Note that all users are admins by default - Util.assertConvMember ownerT1 cidT1 + Util.assertConvMember qOwnerT1 cidT1 Util.postMembers ownerT1 (list1 (mem2T1 ^. userId) []) cidT1 !!! const 200 === statusCode - Util.assertConvMember (mem2T1 ^. userId) cidT1 + Util.assertConvMember qMem2T1 cidT1 -- The following tests check the logic: users can add other users to a conversation -- iff: -- - *the adding user is connected to the users being added* @@ -913,24 +921,24 @@ testAddTeamMemberToConv = do -- Now we add someone from T2 that we are connected to Util.postMembers ownerT1 (list1 ownerT2 []) cidT1 !!! const 200 === statusCode - Util.assertConvMember ownerT2 cidT1 + Util.assertConvMember qOwnerT2 cidT1 -- And they can add their own team members Util.postMembers ownerT2 (list1 (mem1T2 ^. userId) []) cidT1 !!! const 200 === statusCode - Util.assertConvMember (mem1T2 ^. userId) cidT1 + Util.assertConvMember qMem1T2 cidT1 -- Still, they cannot add random members without a connection from T1, despite the conversation being "hosted" there Util.postMembers ownerT2 (list1 (mem4T1 ^. userId) []) cidT1 !!! const 403 === statusCode Util.assertNotConvMember (mem4T1 ^. userId) cidT1 -- Now let's look at convs hosted on team2 -- ownerT2 *is* connected to ownerT1 Util.postMembers ownerT2 (list1 ownerT1 []) cidT2 !!! const 200 === statusCode - Util.assertConvMember ownerT1 cidT2 + Util.assertConvMember qOwnerT1 cidT2 -- and mem1T2 is on the same team, but mem1T1 is *not* Util.postMembers ownerT2 (list1 (mem1T2 ^. userId) [mem1T1 ^. userId]) cidT2 !!! const 403 === statusCode Util.assertNotConvMember (mem1T1 ^. userId) cidT2 Util.assertNotConvMember (mem1T2 ^. userId) cidT2 -- mem1T2 is on the same team, so that is fine too Util.postMembers ownerT2 (list1 (mem1T2 ^. userId) []) cidT2 !!! const 200 === statusCode - Util.assertConvMember (mem1T2 ^. userId) cidT2 + Util.assertConvMember qMem1T2 cidT2 -- ownerT2 is *NOT* connected to mem3T1 and not on the same team, so should not be allowed to add Util.postMembers ownerT2 (list1 (mem3T1 ^. userId) []) cidT2 !!! const 403 === statusCode Util.assertNotConvMember (mem3T1 ^. userId) cidT2 @@ -938,19 +946,19 @@ testAddTeamMemberToConv = do -- Can add connected users Util.postMembers personalUser (list1 ownerT1 []) cidPersonal !!! const 200 === statusCode - Util.assertConvMember ownerT1 cidPersonal + Util.assertConvMember qOwnerT1 cidPersonal -- Can *not* add users that are *not* connected Util.postMembers personalUser (list1 ownerT2 []) cidPersonal !!! const 403 === statusCode Util.assertNotConvMember ownerT2 cidPersonal -- Users of the same team can add one another Util.postMembers ownerT1 (list1 (mem1T1 ^. userId) []) cidPersonal !!! const 200 === statusCode - Util.assertConvMember (mem1T1 ^. userId) cidPersonal + Util.assertConvMember qMem1T1 cidPersonal -- Users can not add across teams if *not* connected Util.postMembers (mem1T1 ^. userId) (list1 ownerT2 []) cidPersonal !!! const 403 === statusCode Util.assertNotConvMember ownerT2 cidPersonal -- Users *can* add across teams if *connected* Util.postMembers ownerT1 (list1 ownerT2 []) cidPersonal !!! const 200 === statusCode - Util.assertConvMember ownerT2 cidPersonal + Util.assertConvMember qOwnerT2 cidPersonal testUpdateTeamConv :: -- | Team role of the user who creates the conversation @@ -976,20 +984,24 @@ testDeleteTeam = do g <- view tsGalley c <- view tsCannon owner <- Util.randomUser + qOwner <- Qualified <$> pure owner <*> viewFederationDomain let p = Util.symmPermissions [DoNotUseDeprecatedAddRemoveConvMember] member <- newTeamMember' p <$> Util.randomUser + qMember <- Qualified <$> pure (member ^. userId) <*> viewFederationDomain extern <- Util.randomUser + qExtern <- Qualified <$> pure extern <*> viewFederationDomain + let members = [owner, member ^. userId] Util.connectUsers owner (list1 (member ^. userId) [extern]) tid <- Util.createNonBindingTeam "foo" owner [member] cid1 <- Util.createTeamConv owner tid [] (Just "blaa") Nothing Nothing cid2 <- Util.createTeamConv owner tid members (Just "blup") Nothing Nothing - Util.assertConvMember owner cid2 - Util.assertConvMember (member ^. userId) cid2 + Util.assertConvMember qOwner cid2 + Util.assertConvMember qMember cid2 Util.assertNotConvMember extern cid2 Util.postMembers owner (list1 extern []) cid1 !!! const 200 === statusCode - Util.assertConvMember owner cid1 - Util.assertConvMember extern cid1 + Util.assertConvMember qOwner cid1 + Util.assertConvMember qExtern cid1 Util.assertNotConvMember (member ^. userId) cid1 void . WS.bracketR3 c owner extern (member ^. userId) $ \(wsOwner, wsExtern, wsMember) -> do delete (g . paths ["teams", toByteString' tid] . zUser owner . zConn "conn") @@ -1161,32 +1173,29 @@ testDeleteBindingTeam ownerHasPassword = do testDeleteTeamConv :: TestM () testDeleteTeamConv = do localDomain <- viewFederationDomain - g <- view tsGalley c <- view tsCannon owner <- Util.randomUser + qOwner <- Qualified <$> pure owner <*> viewFederationDomain let p = Util.symmPermissions [DoNotUseDeprecatedDeleteConversation] member <- newTeamMember' p <$> Util.randomUser - let members = [owner, member ^. userId] + qMember <- Qualified <$> pure (member ^. userId) <*> viewFederationDomain + let members = [qOwner, qMember] extern <- Util.randomUser + qExtern <- Qualified <$> pure extern <*> viewFederationDomain Util.connectUsers owner (list1 (member ^. userId) [extern]) tid <- Util.createNonBindingTeam "foo" owner [member] cid1 <- Util.createTeamConv owner tid [] (Just "blaa") Nothing Nothing let access = ConversationAccessData (Set.fromList [InviteAccess, CodeAccess]) ActivatedAccessRole putAccessUpdate owner cid1 access !!! const 200 === statusCode code <- decodeConvCodeEvent <$> (postConvCode owner cid1 members) (Just "blup") Nothing Nothing Util.postMembers owner (list1 extern [member ^. userId]) cid1 !!! const 200 === statusCode - for_ [owner, member ^. userId, extern] $ \u -> Util.assertConvMember u cid1 - for_ [owner, member ^. userId] $ \u -> Util.assertConvMember u cid2 + for_ (qExtern : members) $ \u -> Util.assertConvMember u cid1 + for_ members $ flip Util.assertConvMember cid2 WS.bracketR3 c owner extern (member ^. userId) $ \(wsOwner, wsExtern, wsMember) -> do - delete - ( g - . paths ["teams", toByteString' tid, "conversations", toByteString' cid2] - . zUser (member ^. userId) - . zConn "conn" - ) - !!! const 200 - === statusCode + deleteTeamConv tid cid2 (member ^. userId) + !!! const 200 === statusCode + -- We no longer send duplicate conv deletion events -- i.e., as both a regular "conversation.delete" to all -- conversation members and as "team.conversation-delete" @@ -1195,14 +1204,9 @@ testDeleteTeamConv = do checkConvDeleteEvent qcid2 wsOwner checkConvDeleteEvent qcid2 wsMember WS.assertNoEvent timeout [wsOwner, wsMember] - delete - ( g - . paths ["teams", toByteString' tid, "conversations", toByteString' cid1] - . zUser (member ^. userId) - . zConn "conn" - ) - !!! const 200 - === statusCode + + deleteTeamConv tid cid1 (member ^. userId) + !!! const 200 === statusCode -- We no longer send duplicate conv deletion events -- i.e., as both a regular "conversation.delete" to all -- conversation members and as "team.conversation-delete" diff --git a/services/galley/test/integration/API/Teams/LegalHold.hs b/services/galley/test/integration/API/Teams/LegalHold.hs index d5b1b2cbb6..161b1a2636 100644 --- a/services/galley/test/integration/API/Teams/LegalHold.hs +++ b/services/galley/test/integration/API/Teams/LegalHold.hs @@ -31,7 +31,7 @@ import Bilge hiding (accept, head, timeout, trace) import Bilge.Assert import qualified Bilge.TestSession as BilgeTest import Brig.Types.Client -import Brig.Types.Intra (ConnectionStatus (ConnectionStatus), UserSet (..)) +import Brig.Types.Intra (UserSet (..)) import Brig.Types.Provider import Brig.Types.Team.LegalHold hiding (userId) import Brig.Types.Test.Arbitrary () @@ -91,6 +91,7 @@ import Wire.API.Connection (UserConnection) import qualified Wire.API.Connection as Conn import Wire.API.Conversation.Role (roleNameWireAdmin, roleNameWireMember) import qualified Wire.API.Message as Msg +import Wire.API.Routes.Internal.Brig.Connection import qualified Wire.API.Team.Feature as Public import Wire.API.User (UserProfile (..)) import Wire.API.User.Client (UserClients (..), UserClientsFull (userClientsFull)) @@ -323,7 +324,7 @@ testApproveLegalHoldDevice = do renewToken authToken cassState <- view tsCass liftIO $ do - clients' <- Cql.runClient cassState $ Data.lookupClients [member] + clients' <- Cql.runClient cassState $ Data.lookupClients' [member] assertBool "Expect clientId to be saved on the user" $ Clients.contains member someClientId clients' UserLegalHoldStatusResponse userStatus _ _ <- getUserStatusTyped member tid @@ -940,7 +941,9 @@ data GroupConvAdmin testNoConsentRemoveFromGroupConv :: GroupConvAdmin -> HasCallStack => TestM () testNoConsentRemoveFromGroupConv whoIsAdmin = do (legalholder :: UserId, tid) <- createBindingTeam + qLegalHolder <- Qualified <$> pure legalholder <*> viewFederationDomain (peer :: UserId, teamPeer) <- createBindingTeam + qPeer <- Qualified <$> pure peer <*> viewFederationDomain galley <- view tsGalley let enableLHForLegalholder :: HasCallStack => TestM () @@ -962,41 +965,40 @@ testNoConsentRemoveFromGroupConv whoIsAdmin = do convId <- do let (inviter, tidInviter, invitee, inviteeRole) = case whoIsAdmin of - LegalholderIsAdmin -> (legalholder, tid, peer, roleNameWireMember) - PeerIsAdmin -> (peer, teamPeer, legalholder, roleNameWireMember) - BothAreAdmins -> (legalholder, tid, peer, roleNameWireAdmin) + LegalholderIsAdmin -> (qLegalHolder, tid, qPeer, roleNameWireMember) + PeerIsAdmin -> (qPeer, teamPeer, qLegalHolder, roleNameWireMember) + BothAreAdmins -> (qLegalHolder, tid, qPeer, roleNameWireAdmin) - convId <- createTeamConvWithRole inviter tidInviter [invitee] (Just "group chat with external peer") Nothing Nothing inviteeRole + convId <- createTeamConvWithRole (qUnqualified inviter) tidInviter [qUnqualified invitee] (Just "group chat with external peer") Nothing Nothing inviteeRole mapM_ (assertConvMemberWithRole roleNameWireAdmin convId) ([inviter] <> [invitee | whoIsAdmin == BothAreAdmins]) mapM_ (assertConvMemberWithRole roleNameWireMember convId) [invitee | whoIsAdmin /= BothAreAdmins] pure convId + qconvId <- Qualified <$> pure convId <*> viewFederationDomain checkConvCreateEvent convId legalholderWs checkConvCreateEvent convId peerWs - assertConvMember legalholder convId - assertConvMember peer convId + assertConvMember qLegalHolder convId + assertConvMember qPeer convId void enableLHForLegalholder - localdomain <- viewFederationDomain - case whoIsAdmin of LegalholderIsAdmin -> do - assertConvMember legalholder convId + assertConvMember qLegalHolder convId assertNotConvMember peer convId - checkConvMemberLeaveEvent (Qualified convId localdomain) (Qualified peer localdomain) legalholderWs - checkConvMemberLeaveEvent (Qualified convId localdomain) (Qualified peer localdomain) peerWs + checkConvMemberLeaveEvent qconvId qPeer legalholderWs + checkConvMemberLeaveEvent qconvId qPeer peerWs PeerIsAdmin -> do - assertConvMember peer convId + assertConvMember qPeer convId assertNotConvMember legalholder convId - checkConvMemberLeaveEvent (Qualified convId localdomain) (Qualified legalholder localdomain) legalholderWs - checkConvMemberLeaveEvent (Qualified convId localdomain) (Qualified legalholder localdomain) peerWs + checkConvMemberLeaveEvent qconvId qLegalHolder legalholderWs + checkConvMemberLeaveEvent qconvId qLegalHolder peerWs BothAreAdmins -> do - assertConvMember legalholder convId + assertConvMember qLegalHolder convId assertNotConvMember peer convId - checkConvMemberLeaveEvent (Qualified convId localdomain) (Qualified peer localdomain) legalholderWs - checkConvMemberLeaveEvent (Qualified convId localdomain) (Qualified peer localdomain) peerWs + checkConvMemberLeaveEvent qconvId qPeer legalholderWs + checkConvMemberLeaveEvent qconvId qPeer peerWs data GroupConvInvCase = InviteOnlyConsenters | InviteAlsoNonConsenters deriving (Show, Eq, Ord, Bounded, Enum) @@ -1005,8 +1007,11 @@ testGroupConvInvitationHandlesLHConflicts :: HasCallStack => GroupConvInvCase -> testGroupConvInvitationHandlesLHConflicts inviteCase = do -- team that is legalhold whitelisted (legalholder :: UserId, tid) <- createBindingTeam + qLegalHolder <- Qualified <$> pure legalholder <*> viewFederationDomain userWithConsent <- (^. userId) <$> addUserToTeam legalholder tid - userWithConsent2 <- (^. userId) <$> addUserToTeam legalholder tid + userWithConsent2 <- do + uid <- (^. userId) <$> addUserToTeam legalholder tid + Qualified <$> pure uid <*> viewFederationDomain ensureQueueEmpty putLHWhitelistTeam tid !!! const 200 === statusCode @@ -1036,10 +1041,10 @@ testGroupConvInvitationHandlesLHConflicts inviteCase = do case inviteCase of InviteOnlyConsenters -> do - API.Util.postMembers userWithConsent (List1.list1 legalholder [userWithConsent2]) convId + API.Util.postMembers userWithConsent (List1.list1 legalholder [qUnqualified userWithConsent2]) convId !!! const 200 === statusCode - assertConvMember legalholder convId + assertConvMember qLegalHolder convId assertConvMember userWithConsent2 convId assertNotConvMember peer convId InviteAlsoNonConsenters -> do diff --git a/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs b/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs index b023b3abf5..9d45807646 100644 --- a/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs +++ b/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs @@ -256,7 +256,7 @@ testApproveLegalHoldDevice = do renewToken authToken cassState <- view tsCass liftIO $ do - clients' <- Cql.runClient cassState $ Data.lookupClients [member] + clients' <- Cql.runClient cassState $ Data.lookupClients' [member] assertBool "Expect clientId to be saved on the user" $ Clients.contains member someClientId clients' UserLegalHoldStatusResponse userStatus _ _ <- getUserStatusTyped member tid diff --git a/services/galley/test/integration/API/Util.hs b/services/galley/test/integration/API/Util.hs index 9e12f6e7dd..a0521b675a 100644 --- a/services/galley/test/integration/API/Util.hs +++ b/services/galley/test/integration/API/Util.hs @@ -25,7 +25,7 @@ import Bilge hiding (timeout) import Bilge.Assert import Bilge.TestSession import Brig.Types -import Brig.Types.Intra (ConnectionStatus (ConnectionStatus), UserAccount (..), UserSet (..)) +import Brig.Types.Intra (UserAccount (..), UserSet (..)) import Brig.Types.Team.Invitation import Brig.Types.User.Auth (CookieLabel (..)) import Control.Lens hiding (from, to, (#), (.=)) @@ -34,7 +34,6 @@ import Control.Monad.Except (ExceptT, runExceptT) import Control.Retry (constantDelay, exponentialBackoff, limitRetries, retrying) import Data.Aeson hiding (json) import Data.Aeson.Lens (key, _String) -import Data.Aeson.Types (emptyObject) import qualified Data.ByteString as BS import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Char8 as C @@ -72,8 +71,10 @@ import qualified Galley.Options as Opts import qualified Galley.Run as Run import Galley.Types import qualified Galley.Types as Conv +import Galley.Types.Conversations.Intra (UpsertOne2OneConversationRequest (..)) +import Galley.Types.Conversations.One2One (one2OneConvId) import Galley.Types.Conversations.Roles hiding (DeleteConversation) -import Galley.Types.Teams hiding (Event, EventType (..)) +import Galley.Types.Teams hiding (Event, EventType (..), self) import qualified Galley.Types.Teams as Team import Galley.Types.Teams.Intra import Gundeck.Types.Notification @@ -108,7 +109,7 @@ import Web.Cookie import Wire.API.Conversation import qualified Wire.API.Conversation as Public import Wire.API.Conversation.Action -import Wire.API.Event.Conversation (_EdMembersJoin, _EdMembersLeave) +import Wire.API.Event.Conversation (_EdConversation, _EdMembersJoin, _EdMembersLeave) import qualified Wire.API.Event.Team as TE import qualified Wire.API.Federation.API.Brig as FederatedBrig import qualified Wire.API.Federation.API.Galley as FederatedGalley @@ -118,22 +119,27 @@ import qualified Wire.API.Federation.GRPC.Types as F import qualified Wire.API.Federation.Mock as Mock import Wire.API.Message import qualified Wire.API.Message.Proto as Proto +import Wire.API.Routes.Internal.Brig.Connection import Wire.API.Routes.MultiTablePaging import Wire.API.User.Client (ClientCapability (..), UserClientsFull (UserClientsFull)) import qualified Wire.API.User.Client as Client +import Wire.API.User.Identity (mkSimpleSampleUref) ------------------------------------------------------------------------------- -- API Operations --- | A class for monads with access to a Galley instance +-- | A class for monads with access to a Galley r instance class HasGalley m where viewGalley :: m GalleyR + viewGalleyOpts :: m Opts.Opts instance HasGalley TestM where viewGalley = view tsGalley + viewGalleyOpts = view tsGConf instance (HasGalley m, Monad m) => HasGalley (SessionT m) where viewGalley = lift viewGalley + viewGalleyOpts = lift viewGalleyOpts symmPermissions :: [Perm] -> Permissions symmPermissions p = let s = Set.fromList p in fromJust (newPermissions s s) @@ -162,6 +168,12 @@ createBindingTeamWithMembers numUsers = do return (tid, owner, members) +createBindingTeamWithQualifiedMembers :: HasCallStack => Int -> TestM (TeamId, Qualified UserId, [Qualified UserId]) +createBindingTeamWithQualifiedMembers num = do + localDomain <- viewFederationDomain + (tid, owner, users) <- createBindingTeamWithMembers num + pure (tid, Qualified owner localDomain, map (`Qualified` localDomain) users) + getTeams :: UserId -> TestM TeamList getTeams u = do g <- view tsGalley @@ -396,7 +408,7 @@ addUserToTeamWithRole' role inviter tid = do addUserToTeamWithSSO :: HasCallStack => Bool -> TeamId -> TestM TeamMember addUserToTeamWithSSO hasEmail tid = do - let ssoid = UserSSOId "nil" "nil" + let ssoid = UserSSOId mkSimpleSampleUref user <- responseJsonError =<< postSSOUser "SSO User" hasEmail ssoid tid let uid = Brig.Types.userId user getTeamMember uid tid uid @@ -537,29 +549,38 @@ createOne2OneTeamConv u1 u2 n tid = do postConv :: UserId -> [UserId] -> Maybe Text -> [Access] -> Maybe AccessRole -> Maybe Milliseconds -> TestM ResponseLBS postConv u us name a r mtimer = postConvWithRole u us name a r mtimer roleNameWireAdmin -postConvQualified :: (HasGalley m, MonadIO m, MonadMask m, MonadHttp m) => UserId -> [Qualified UserId] -> Maybe Text -> [Access] -> Maybe AccessRole -> Maybe Milliseconds -> m ResponseLBS -postConvQualified u us name a r mtimer = postConvWithRoleQualified us u [] name a r mtimer roleNameWireAdmin +defNewConv :: NewConv +defNewConv = NewConv [] [] Nothing mempty Nothing Nothing Nothing Nothing roleNameWireAdmin -postConvWithRemoteUser :: Domain -> UserProfile -> UserId -> [Qualified UserId] -> TestM (Response (Maybe LByteString)) -postConvWithRemoteUser remoteDomain user creatorUnqualified members = - postConvWithRemoteUsers remoteDomain [user] creatorUnqualified members +postConvQualified :: + (HasCallStack, HasGalley m, MonadIO m, MonadMask m, MonadHttp m) => + UserId -> + NewConv -> + m ResponseLBS +postConvQualified u n = do + g <- viewGalley + post $ + g + . path "/conversations" + . zUser u + . zConn "conn" + . zType "access" + . json (NewConvUnmanaged n) -postConvWithRemoteUsers :: Domain -> [UserProfile] -> UserId -> [Qualified UserId] -> TestM (Response (Maybe LByteString)) -postConvWithRemoteUsers remoteDomain users creatorUnqualified members = do - opts <- view tsGConf +postConvWithRemoteUsers :: + HasCallStack => + UserId -> + NewConv -> + TestM (Response (Maybe LByteString)) +postConvWithRemoteUsers u n = do fmap fst $ - withTempMockFederator - opts - remoteDomain - respond - $ postConvQualified creatorUnqualified members (Just "federated gossip") [] Nothing Nothing + withTempMockFederator (const ()) $ + postConvQualified u n {newConvName = setName (newConvName n)} Value - respond req - | fmap F.component (F.request req) == Just F.Brig = - toJSON users - | otherwise = toJSON () + setName :: Maybe Text -> Maybe Text + setName Nothing = Just "federated gossip" + setName x = x postTeamConv :: TeamId -> UserId -> [UserId] -> Maybe Text -> [Access] -> Maybe AccessRole -> Maybe Milliseconds -> TestM ResponseLBS postTeamConv tid u us name a r mtimer = do @@ -567,14 +588,28 @@ postTeamConv tid u us name a r mtimer = do let conv = NewConvUnmanaged $ NewConv us [] name (Set.fromList a) r (Just (ConvTeamInfo tid False)) mtimer Nothing roleNameWireAdmin post $ g . path "/conversations" . zUser u . zConn "conn" . zType "access" . json conv -postConvWithRole :: UserId -> [UserId] -> Maybe Text -> [Access] -> Maybe AccessRole -> Maybe Milliseconds -> RoleName -> TestM ResponseLBS -postConvWithRole = postConvWithRoleQualified [] - -postConvWithRoleQualified :: (HasGalley m, MonadIO m, MonadMask m, MonadHttp m) => [Qualified UserId] -> UserId -> [UserId] -> Maybe Text -> [Access] -> Maybe AccessRole -> Maybe Milliseconds -> RoleName -> m ResponseLBS -postConvWithRoleQualified qualifiedUsers u unqualifiedUsers name a r mtimer role = do +deleteTeamConv :: (HasGalley m, MonadIO m, MonadHttp m) => TeamId -> ConvId -> UserId -> m ResponseLBS +deleteTeamConv tid convId zusr = do g <- viewGalley - let conv = NewConvUnmanaged $ NewConv unqualifiedUsers qualifiedUsers name (Set.fromList a) r Nothing mtimer Nothing role - post $ g . path "/conversations" . zUser u . zConn "conn" . zType "access" . json conv + delete + ( g + . paths ["teams", toByteString' tid, "conversations", toByteString' convId] + . zUser zusr + . zConn "conn" + ) + +postConvWithRole :: UserId -> [UserId] -> Maybe Text -> [Access] -> Maybe AccessRole -> Maybe Milliseconds -> RoleName -> TestM ResponseLBS +postConvWithRole u members name access arole timer role = + postConvQualified + u + defNewConv + { newConvUsers = members, + newConvName = name, + newConvAccess = Set.fromList access, + newConvAccessRole = arole, + newConvMessageTimer = timer, + newConvUsersRole = role + } postConvWithReceipt :: UserId -> [UserId] -> Maybe Text -> [Access] -> Maybe AccessRole -> Maybe Milliseconds -> ReceiptMode -> TestM ResponseLBS postConvWithReceipt u us name a r mtimer rcpt = do @@ -595,6 +630,7 @@ postO2OConv u1 u2 n = do postConnectConv :: UserId -> UserId -> Text -> Text -> Maybe Text -> TestM ResponseLBS postConnectConv a b name msg email = do + qb <- Qualified <$> pure b <*> viewFederationDomain g <- view tsGalley post $ g @@ -602,7 +638,7 @@ postConnectConv a b name msg email = do . zUser a . zConn "conn" . zType "access" - . json (Connect b (Just msg) (Just name) email) + . json (Connect qb (Just msg) (Just name) email) putConvAccept :: UserId -> ConvId -> TestM ResponseLBS putConvAccept invited cid = do @@ -654,8 +690,7 @@ postProteusMessageQualifiedWithMockFederator :: TestM (ResponseLBS, Mock.ReceivedRequests) postProteusMessageQualifiedWithMockFederator senderUser senderClient convId recipients dat strat brigApi galleyApi = do localDomain <- viewFederationDomain - opts <- view tsGConf - withTempServantMockFederator opts brigApi galleyApi localDomain (Domain "far-away.example.com") $ + withTempServantMockFederator brigApi galleyApi localDomain $ postProteusMessageQualified senderUser senderClient convId recipients dat strat postProteusMessageQualified :: @@ -766,36 +801,8 @@ getConvs u r s = do . zType "access" . convRange r s --- (should be) equivalent to --- listConvs u (ListConversations [] Nothing Nothing) --- (if the schema of ListConversations is correct) -listAllConvs :: (MonadIO m, MonadHttp m, HasGalley m) => UserId -> m ResponseLBS -listAllConvs u = do - g <- viewGalley - post $ - g - . path "/list-conversations" - . zUser u - . zConn "conn" - . zType "access" - . json emptyObject - listConvs :: (MonadIO m, MonadHttp m, HasGalley m) => UserId -> ListConversations -> m ResponseLBS listConvs u req = do - -- when using servant-client (pending #1605), this would become: - -- galleyClient <- view tsGalleyClient - -- res :: Public.ConversationList Public.Conversation <- listConversations galleyClient req - g <- viewGalley - post $ - g - . path "/list-conversations" - . zUser u - . zConn "conn" - . zType "access" - . json req - -listConvsV2 :: (MonadIO m, MonadHttp m, HasGalley m) => UserId -> ListConversationsV2 -> m ResponseLBS -listConvsV2 u req = do g <- viewGalley post $ g @@ -852,13 +859,14 @@ listRemoteConvs remoteDomain uid = do allConvs <- fmap mtpResults . responseJsonError @_ @ConvIdsPage =<< listConvIds uid paginationOpts qDomain qcnv == remoteDomain) allConvs -postQualifiedMembers :: UserId -> NonEmpty (Qualified UserId) -> ConvId -> TestM ResponseLBS +postQualifiedMembers :: + (HasGalley m, MonadIO m, MonadHttp m) => + UserId -> + NonEmpty (Qualified UserId) -> + ConvId -> + m ResponseLBS postQualifiedMembers zusr invitees conv = do - g <- view tsGalley - postQualifiedMembers' g zusr invitees conv - -postQualifiedMembers' :: (MonadIO m, MonadHttp m) => (Request -> Request) -> UserId -> NonEmpty (Qualified UserId) -> ConvId -> m ResponseLBS -postQualifiedMembers' g zusr invitees conv = do + g <- viewGalley let invite = Public.InviteQualified invitees roleNameWireAdmin post $ g @@ -1232,7 +1240,10 @@ getTeamQueue' zusr msince msize onlyLast = do ] ) -registerRemoteConv :: Qualified ConvId -> Qualified UserId -> Maybe Text -> Set OtherMember -> TestM () +asOtherMember :: Qualified UserId -> OtherMember +asOtherMember quid = OtherMember quid Nothing roleNameWireMember + +registerRemoteConv :: Qualified ConvId -> UserId -> Maybe Text -> Set OtherMember -> TestM () registerRemoteConv convId originUser name othMembers = do fedGalleyClient <- view tsFedGalleyClient now <- liftIO getCurrentTime @@ -1247,7 +1258,7 @@ registerRemoteConv convId originUser name othMembers = do rcCnvAccess = [], rcCnvAccessRole = ActivatedAccessRole, rcCnvName = name, - rcMembers = othMembers, + rcNonCreatorMembers = othMembers, rcMessageTimer = Nothing, rcReceiptMode = Nothing } @@ -1256,16 +1267,16 @@ registerRemoteConv convId originUser name othMembers = do ------------------------------------------------------------------------------- -- Common Assertions -assertConvMemberWithRole :: HasCallStack => RoleName -> ConvId -> UserId -> TestM () +assertConvMemberWithRole :: HasCallStack => RoleName -> ConvId -> Qualified UserId -> TestM () assertConvMemberWithRole r c u = - getSelfMember u c !!! do + getSelfMember (qUnqualified u) c !!! do const 200 === statusCode const (Right u) === (fmap memId <$> responseJsonEither) const (Right r) === (fmap memConvRoleName <$> responseJsonEither) -assertConvMember :: HasCallStack => UserId -> ConvId -> TestM () +assertConvMember :: HasCallStack => Qualified UserId -> ConvId -> TestM () assertConvMember u c = - getSelfMember u c !!! do + getSelfMember (qUnqualified u) c !!! do const 200 === statusCode const (Right u) === (fmap memId <$> responseJsonEither) @@ -1294,7 +1305,7 @@ assertConv :: Response (Maybe Lazy.ByteString) -> ConvType -> UserId -> - UserId -> + Qualified UserId -> [UserId] -> Maybe Text -> Maybe Milliseconds -> @@ -1306,7 +1317,7 @@ assertConvWithRole :: Response (Maybe Lazy.ByteString) -> ConvType -> UserId -> - UserId -> + Qualified UserId -> [UserId] -> Maybe Text -> Maybe Milliseconds -> @@ -1337,6 +1348,54 @@ assertConvWithRole r t c s us n mt role = do _ -> return () return cId +assertConvQualified :: + HasCallStack => + Response (Maybe Lazy.ByteString) -> + ConvType -> + UserId -> + Qualified UserId -> + [Qualified UserId] -> + Maybe Text -> + Maybe Milliseconds -> + TestM ConvId +assertConvQualified r t c s us n mt = assertConvQualifiedWithRole r t c s us n mt roleNameWireAdmin + +assertConvQualifiedWithRole :: + HasCallStack => + Response (Maybe Lazy.ByteString) -> + ConvType -> + UserId -> + Qualified UserId -> + [Qualified UserId] -> + Maybe Text -> + Maybe Milliseconds -> + RoleName -> + TestM ConvId +assertConvQualifiedWithRole r t c s us n mt role = do + cId <- fromBS $ getHeader' "Location" r + let cnv = responseJsonMaybe @Conversation r + let _self = cmSelf . cnvMembers <$> cnv + let others = cmOthers . cnvMembers <$> cnv + liftIO $ do + assertEqual "id" (Just cId) (qUnqualified . cnvQualifiedId <$> cnv) + assertEqual "name" n (cnv >>= cnvName) + assertEqual "type" (Just t) (cnvType <$> cnv) + assertEqual "creator" (Just c) (cnvCreator <$> cnv) + assertEqual "message_timer" (Just mt) (cnvMessageTimer <$> cnv) + assertEqual "self" (Just s) (memId <$> _self) + assertEqual "others" (Just . Set.fromList $ us) (Set.fromList . map omQualifiedId . toList <$> others) + assertEqual "creator is always and admin" (Just roleNameWireAdmin) (memConvRoleName <$> _self) + assertBool "others role" (all (== role) $ maybe (error "Cannot be null") (map omConvRoleName . toList) others) + assertBool "otr muted ref not empty" (isNothing (memOtrMutedRef =<< _self)) + assertBool "otr archived not false" (Just False == (memOtrArchived <$> _self)) + assertBool "otr archived ref not empty" (isNothing (memOtrArchivedRef =<< _self)) + case t of + SelfConv -> assertEqual "access" (Just privateAccess) (cnvAccess <$> cnv) + ConnectConv -> assertEqual "access" (Just privateAccess) (cnvAccess <$> cnv) + One2OneConv -> assertEqual "access" (Just privateAccess) (cnvAccess <$> cnv) + _ -> return () + return cId + wsAssertOtr :: Qualified ConvId -> Qualified UserId -> ClientId -> ClientId -> Text -> Notification -> IO () wsAssertOtr = wsAssertOtr' "data" @@ -1449,7 +1508,7 @@ assertRemoveUpdate req qconvId remover alreadyPresentUsers victim = liftIO $ do FederatedGalley.cuOrigUserId cu @?= remover FederatedGalley.cuConvId cu @?= qUnqualified qconvId sort (FederatedGalley.cuAlreadyPresentUsers cu) @?= sort alreadyPresentUsers - FederatedGalley.cuAction cu @?= ConversationActionRemoveMember victim + FederatedGalley.cuAction cu @?= ConversationActionRemoveMembers (pure victim) ------------------------------------------------------------------------------- -- Helpers @@ -1521,7 +1580,7 @@ connectUsers u us = void $ connectUsersWith expect2xx u us connectLocalQualifiedUsers :: UserId -> List1 (Qualified UserId) -> TestM () connectLocalQualifiedUsers u us = do localDomain <- viewFederationDomain - let partitionMap = partitionQualified . toList . toNonEmpty $ us + let partitionMap = indexQualified . toList . toNonEmpty $ us -- FUTUREWORK: connect all users, not just those on the same domain as 'u' case LMap.lookup localDomain partitionMap of Nothing -> err @@ -1565,6 +1624,25 @@ connectUsersWith fn u = mapM connectTo ) return (r1, r2) +connectWithRemoteUser :: + (MonadReader TestSetup m, MonadIO m, MonadHttp m, MonadCatch m, HasCallStack) => + UserId -> + Qualified UserId -> + m () +connectWithRemoteUser self other = do + let req = CreateConnectionForTest self other + b <- view tsBrig + put + ( b + . zUser self + . contentJson + . zConn "conn" + . paths ["i", "connections", "connection-update"] + . json req + ) + !!! const 200 + === statusCode + -- | A copy of 'postConnection' from Brig integration tests. postConnection :: UserId -> UserId -> TestM ResponseLBS postConnection from to = do @@ -1581,6 +1659,16 @@ postConnection from to = do RequestBodyLBS . encode $ ConnectionRequest to (unsafeRange "some conv name") +postConnectionQualified :: UserId -> Qualified UserId -> TestM ResponseLBS +postConnectionQualified from (Qualified toUser toDomain) = do + brig <- view tsBrig + post $ + brig + . paths ["/connections", toByteString' toDomain, toByteString' toUser] + . contentJson + . zUser from + . zConn "conn" + -- | A copy of 'putConnection' from Brig integration tests. putConnection :: UserId -> UserId -> Relation -> TestM ResponseLBS putConnection from to r = do @@ -1632,6 +1720,11 @@ assertConnections u cstat = do randomUsers :: Int -> TestM [UserId] randomUsers n = replicateM n randomUser +randomUserTuple :: HasCallStack => TestM (UserId, Qualified UserId) +randomUserTuple = do + qUid <- randomQualifiedUser + pure (qUnqualified qUid, qUid) + randomUser :: HasCallStack => TestM UserId randomUser = qUnqualified <$> randomUser' False True True @@ -1877,7 +1970,7 @@ randomEmail = do uid <- liftIO nextRandom return $ Email ("success+" <> UUID.toText uid) "simulator.amazonses.com" -selfConv :: UserId -> Id C +selfConv :: UserId -> ConvId selfConv u = Id (toUUID u) -- TODO: Refactor, as used also in other services @@ -1942,15 +2035,15 @@ someLastPrekeys = ] mkConv :: - Qualified ConvId -> + ConvId -> UserId -> RoleName -> [OtherMember] -> FederatedGalley.RemoteConversation mkConv cnvId creator selfRole otherMembers = FederatedGalley.RemoteConversation + cnvId ( ConversationMetadata - cnvId RegularConv creator [] @@ -2133,43 +2226,39 @@ mkProfile quid name = -- expected request. withTempMockFederator :: (MonadIO m, ToJSON a, HasGalley m, MonadMask m) => - Opts.Opts -> - Domain -> (FederatedRequest -> a) -> SessionT m b -> m (b, Mock.ReceivedRequests) -withTempMockFederator opts targetDomain resp = withTempMockFederator' opts targetDomain (pure . oresp) +withTempMockFederator resp = withTempMockFederator' (pure . oresp) where oresp = OutwardResponseBody . Lazy.toStrict . encode . resp withTempMockFederator' :: (MonadIO m, HasGalley m, MonadMask m) => - Opts.Opts -> - Domain -> (FederatedRequest -> IO F.OutwardResponse) -> SessionT m b -> m (b, Mock.ReceivedRequests) -withTempMockFederator' opts targetDomain resp action = assertRightT - . Mock.withTempMockFederator st0 (lift . resp) - $ \st -> lift $ do - let opts' = - opts & Opts.optFederator - ?~ Endpoint "127.0.0.1" (fromIntegral (Mock.serverPort st)) - withSettingsOverrides opts' action +withTempMockFederator' resp action = do + opts <- viewGalleyOpts + assertRightT + . Mock.withTempMockFederator st0 (lift . resp) + $ \st -> lift $ do + let opts' = + opts & Opts.optFederator + ?~ Endpoint "127.0.0.1" (fromIntegral (Mock.serverPort st)) + withSettingsOverrides opts' action where - st0 = Mock.initState targetDomain (Domain "example.com") + st0 = Mock.initState (Domain "example.com") withTempServantMockFederator :: (MonadMask m, MonadIO m, HasGalley m) => - Opts.Opts -> FederatedBrig.Api (AsServerT Handler) -> FederatedGalley.Api (AsServerT Handler) -> Domain -> - Domain -> SessionT m b -> m (b, Mock.ReceivedRequests) -withTempServantMockFederator opts brigApi galleyApi originDomain targetDomain = - withTempMockFederator' opts targetDomain mock +withTempServantMockFederator brigApi galleyApi originDomain = + withTempMockFederator' mock where server :: ServerT (ToServantApi FederatedBrig.Api :<|> ToServantApi FederatedGalley.Api) Handler server = genericServerT brigApi :<|> genericServerT galleyApi @@ -2291,6 +2380,25 @@ checkConvCreateEvent cid w = WS.assertMatch_ checkTimeout w $ \notif -> do Conv.EdConversation x -> (qUnqualified . cnvQualifiedId) x @?= cid other -> assertFailure $ "Unexpected event data: " <> show other +wsAssertConvCreateWithRole :: + HasCallStack => + Qualified ConvId -> + Qualified UserId -> + Qualified UserId -> + [(Qualified UserId, RoleName)] -> + Notification -> + IO () +wsAssertConvCreateWithRole conv eventFrom selfMember otherMembers n = do + let e = List1.head (WS.unpackPayload n) + ntfTransient n @?= False + evtConv e @?= conv + evtType e @?= Conv.ConvCreate + evtFrom e @?= eventFrom + fmap (memId . cmSelf . cnvMembers) (evtData e ^? _EdConversation) @?= Just selfMember + fmap (sort . cmOthers . cnvMembers) (evtData e ^? _EdConversation) @?= Just (sort (toOtherMember <$> otherMembers)) + where + toOtherMember (quid, role) = OtherMember quid Nothing role + checkTeamDeleteEvent :: HasCallStack => TeamId -> WS.WebSocket -> TestM () checkTeamDeleteEvent tid w = WS.assertMatch_ checkTimeout w $ \notif -> do ntfTransient notif @?= False @@ -2357,3 +2465,17 @@ fedRequestsForDomain domain component = assertOne :: (HasCallStack, MonadIO m, Show a) => [a] -> m a assertOne [a] = pure a assertOne xs = liftIO . assertFailure $ "Expected exactly one element, found " <> show xs + +iUpsertOne2OneConversation :: UpsertOne2OneConversationRequest -> TestM ResponseLBS +iUpsertOne2OneConversation req = do + galley <- view tsGalley + post (galley . path "/i/conversations/one2one/upsert" . Bilge.json req) + +generateRemoteAndConvId :: Bool -> Local UserId -> TestM (Remote UserId, Qualified ConvId) +generateRemoteAndConvId shouldBeLocal lUserId = do + other <- Qualified <$> randomId <*> pure (Domain "far-away.example.com") + let convId = one2OneConvId (qUntagged lUserId) other + isLocal = tDomain lUserId == qDomain convId + if shouldBeLocal == isLocal + then pure (qTagUnsafe other, convId) + else generateRemoteAndConvId shouldBeLocal lUserId diff --git a/services/galley/test/unit/Main.hs b/services/galley/test/unit/Main.hs index c0a1dbcdd3..bfd608d4db 100644 --- a/services/galley/test/unit/Main.hs +++ b/services/galley/test/unit/Main.hs @@ -23,6 +23,7 @@ where import Imports import qualified Test.Galley.API import qualified Test.Galley.API.Message +import qualified Test.Galley.API.One2One import qualified Test.Galley.Intra.User import qualified Test.Galley.Mapping import qualified Test.Galley.Roundtrip @@ -34,6 +35,7 @@ main = =<< sequence [ pure Test.Galley.API.tests, pure Test.Galley.API.Message.tests, + pure Test.Galley.API.One2One.tests, pure Test.Galley.Intra.User.tests, pure Test.Galley.Mapping.tests, Test.Galley.Roundtrip.tests diff --git a/services/galley/test/unit/Test/Galley/API/One2One.hs b/services/galley/test/unit/Test/Galley/API/One2One.hs new file mode 100644 index 0000000000..913a0ed839 --- /dev/null +++ b/services/galley/test/unit/Test/Galley/API/One2One.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE NumericUnderscores #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 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 . + +-- | Tests for one-to-one conversations +module Test.Galley.API.One2One where + +import Data.Id +import Data.List.Extra +import Data.Qualified +import Galley.API.One2One (one2OneConvId) +import Imports +import Test.Tasty +import Test.Tasty.HUnit (Assertion, testCase, (@?=)) +import Test.Tasty.QuickCheck + +tests :: TestTree +tests = + testGroup + "one2OneConvId" + [ testProperty "symmetry" one2OneConvIdSymmetry, + testCase "non-collision" one2OneConvIdNonCollision + ] + +one2OneConvIdSymmetry :: Qualified UserId -> Qualified UserId -> Property +one2OneConvIdSymmetry quid1 quid2 = one2OneConvId quid1 quid2 === one2OneConvId quid2 quid1 + +-- | Make sure that we never get the same conversation ID for a pair of +-- (assumingly) distinct qualified user IDs +one2OneConvIdNonCollision :: Assertion +one2OneConvIdNonCollision = do + let len = 10_000 + -- A generator of lists of length 'len' of qualified user ID pairs + let gen = vectorOf len arbitrary + quids <- nubOrd <$> generate gen + let hashes = nubOrd (fmap (uncurry one2OneConvId) quids) + length hashes @?= length quids diff --git a/services/galley/test/unit/Test/Galley/Mapping.hs b/services/galley/test/unit/Test/Galley/Mapping.hs index f1c8b23780..ffda58da20 100644 --- a/services/galley/test/unit/Test/Galley/Mapping.hs +++ b/services/galley/test/unit/Test/Galley/Mapping.hs @@ -24,7 +24,6 @@ import Data.Containers.ListUtils (nubOrdOn) import Data.Domain import Data.Id import Data.Qualified -import Data.Tagged import Galley.API.Mapping import qualified Galley.Data as Data import Galley.Types.Conversations.Members @@ -43,65 +42,65 @@ tests = testGroup "ConversationMapping" [ testProperty "conversation view for a valid user is non-empty" $ - \(ConvWithLocalUser c uid) dom -> isJust (conversationViewMaybe dom uid c), + \(ConvWithLocalUser c luid) -> isJust (conversationViewMaybe luid c), testProperty "self user in conversation view is correct" $ - \(ConvWithLocalUser c uid) dom -> - fmap (memId . cmSelf . cnvMembers) (conversationViewMaybe dom uid c) - == Just uid, + \(ConvWithLocalUser c luid) -> + fmap (memId . cmSelf . cnvMembers) (conversationViewMaybe luid c) + == Just (qUntagged luid), testProperty "conversation view metadata is correct" $ - \(ConvWithLocalUser c uid) dom -> - fmap cnvMetadata (conversationViewMaybe dom uid c) - == Just (Data.convMetadata dom c), + \(ConvWithLocalUser c luid) -> + fmap cnvMetadata (conversationViewMaybe luid c) + == Just (Data.convMetadata c), testProperty "other members in conversation view do not contain self" $ - \(ConvWithLocalUser c uid) dom -> case conversationViewMaybe dom uid c of + \(ConvWithLocalUser c luid) -> case conversationViewMaybe luid c of Nothing -> False Just cnv -> not - ( Qualified uid dom + ( qUntagged luid `elem` (map omQualifiedId (cmOthers (cnvMembers cnv))) ), testProperty "conversation view contains all users" $ - \(ConvWithLocalUser c uid) dom -> - fmap (sort . cnvUids dom) (conversationViewMaybe dom uid c) - == Just (sort (convUids dom c)), + \(ConvWithLocalUser c luid) -> + fmap (sort . cnvUids) (conversationViewMaybe luid c) + == Just (sort (convUids (tDomain luid) c)), testProperty "conversation view for an invalid user is empty" $ - \(RandomConversation c) dom uid -> - not (elem uid (map lmId (Data.convLocalMembers c))) - ==> isNothing (conversationViewMaybe dom uid c), + \(RandomConversation c) luid -> + not (elem (tUnqualified luid) (map lmId (Data.convLocalMembers c))) + ==> isNothing (conversationViewMaybe luid c), testProperty "remote conversation view for a valid user is non-empty" $ \(ConvWithRemoteUser c ruid) dom -> - qDomain (unTagged ruid) /= dom + qDomain (qUntagged ruid) /= dom ==> isJust (conversationToRemote dom ruid c), testProperty "self user role in remote conversation view is correct" $ \(ConvWithRemoteUser c ruid) dom -> - qDomain (unTagged ruid) /= dom + qDomain (qUntagged ruid) /= dom ==> fmap (rcmSelfRole . rcnvMembers) (conversationToRemote dom ruid c) == Just roleNameWireMember, testProperty "remote conversation view metadata is correct" $ \(ConvWithRemoteUser c ruid) dom -> - qDomain (unTagged ruid) /= dom + qDomain (qUntagged ruid) /= dom ==> fmap (rcnvMetadata) (conversationToRemote dom ruid c) - == Just (Data.convMetadata dom c), + == Just (Data.convMetadata c), testProperty "remote conversation view does not contain self" $ \(ConvWithRemoteUser c ruid) dom -> case conversationToRemote dom ruid c of Nothing -> False Just rcnv -> not - ( unTagged ruid + ( qUntagged ruid `elem` (map omQualifiedId (rcmOthers (rcnvMembers rcnv))) ) ] -cnvUids :: Domain -> Conversation -> [Qualified UserId] -cnvUids dom c = +cnvUids :: Conversation -> [Qualified UserId] +cnvUids c = let mems = cnvMembers c - in Qualified (memId (cmSelf mems)) dom : + in memId (cmSelf mems) : map omQualifiedId (cmOthers mems) convUids :: Domain -> Data.Conversation -> [Qualified UserId] convUids dom c = map ((`Qualified` dom) . lmId) (Data.convLocalMembers c) - <> map (unTagged . rmId) (Data.convRemoteMembers c) + <> map (qUntagged . rmId) (Data.convRemoteMembers c) genLocalMember :: Gen LocalMember genLocalMember = @@ -137,14 +136,16 @@ newtype RandomConversation = RandomConversation instance Arbitrary RandomConversation where arbitrary = RandomConversation <$> genConversation -data ConvWithLocalUser = ConvWithLocalUser Data.Conversation UserId +data ConvWithLocalUser = ConvWithLocalUser Data.Conversation (Local UserId) deriving (Show) instance Arbitrary ConvWithLocalUser where arbitrary = do member <- genLocalMember - ConvWithLocalUser <$> genConv member <*> pure (lmId member) + ConvWithLocalUser <$> genConv member <*> genLocal (lmId member) where + genLocal :: x -> Gen (Local x) + genLocal v = flip toLocalUnsafe v <$> arbitrary genConv m = uniqueMembers m . unRandomConversation <$> arbitrary uniqueMembers :: LocalMember -> Data.Conversation -> Data.Conversation uniqueMembers m c = diff --git a/services/gundeck/test/unit/ThreadBudget.hs b/services/gundeck/test/unit/ThreadBudget.hs index b84154e88f..2d03c38827 100644 --- a/services/gundeck/test/unit/ThreadBudget.hs +++ b/services/gundeck/test/unit/ThreadBudget.hs @@ -143,15 +143,16 @@ mkWatcher tbs logHistory = do tests :: TestTree tests = testGroup "thread budgets" $ - [ testCase "unit test" testThreadBudgets, + [ -- flaky test case as described in https://wearezeta.atlassian.net/browse/BE-527 + -- testCase "unit test" testThreadBudgets, testProperty "qc stm (sequential)" propSequential ] ---------------------------------------------------------------------- -- deterministic unit test -testThreadBudgets :: Assertion -testThreadBudgets = do +_testThreadBudgets :: Assertion +_testThreadBudgets = do let timeUnits n = MilliSeconds $ lengthOfTimeUnit * n lengthOfTimeUnit = 5 -- if you make this larger, the test will run more slowly, and be -- less likely to have timing issues. if you make it too small, some of the calls to diff --git a/services/spar/spar.cabal b/services/spar/spar.cabal index 7086e21075..e23c70faad 100644 --- a/services/spar/spar.cabal +++ b/services/spar/spar.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 573e0f5c3d7b76dbb9fbf48aff2a535df3059af23f8375307021c6c005d98a5b +-- hash: e1e1abfd9d2fd00bd96a693a9466a13e0b7aef15677f0506941f662094a340a1 name: spar version: 0.1 @@ -22,6 +22,7 @@ library exposed-modules: Spar.API Spar.App + Spar.CanonicalInterpreter Spar.Data Spar.Data.Instances Spar.Error @@ -52,8 +53,16 @@ library Spar.Sem.IdP.Mem Spar.Sem.Logger Spar.Sem.Logger.TinyLog + Spar.Sem.Now + Spar.Sem.Now.IO Spar.Sem.Random Spar.Sem.Random.IO + Spar.Sem.Reporter + Spar.Sem.Reporter.Wai + Spar.Sem.SAML2 + Spar.Sem.SAML2.Library + Spar.Sem.SamlProtocolSettings + Spar.Sem.SamlProtocolSettings.Servant Spar.Sem.SAMLUserStore Spar.Sem.SAMLUserStore.Cassandra Spar.Sem.ScimExternalIdStore diff --git a/services/spar/src/Spar/API.hs b/services/spar/src/Spar/API.hs index 4598a56cd7..dddd5b8c65 100644 --- a/services/spar/src/Spar/API.hs +++ b/services/spar/src/Spar/API.hs @@ -1,5 +1,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} -- This file is part of the Wire Server implementation. -- @@ -59,6 +60,7 @@ import qualified SAML2.WebSSO as SAML import Servant import qualified Servant.Multipart as Multipart import Spar.App +import Spar.CanonicalInterpreter import qualified Spar.Data as Data (GetIdPResult (..), Replaced (..), Replacing (..)) import Spar.Error import qualified Spar.Intra.BrigApp as Brig @@ -78,16 +80,21 @@ import qualified Spar.Sem.GalleyAccess as GalleyAccess import qualified Spar.Sem.IdP as IdPEffect import Spar.Sem.Logger (Logger) import qualified Spar.Sem.Logger as Logger +import Spar.Sem.Now (Now) import Spar.Sem.Random (Random) import qualified Spar.Sem.Random as Random +import Spar.Sem.Reporter (Reporter) +import Spar.Sem.SAML2 (SAML2) +import qualified Spar.Sem.SAML2 as SAML2 import Spar.Sem.SAMLUserStore (SAMLUserStore) import qualified Spar.Sem.SAMLUserStore as SAMLUserStore +import Spar.Sem.SamlProtocolSettings (SamlProtocolSettings) +import qualified Spar.Sem.SamlProtocolSettings as SamlProtocolSettings import Spar.Sem.ScimExternalIdStore (ScimExternalIdStore) import Spar.Sem.ScimTokenStore (ScimTokenStore) import qualified Spar.Sem.ScimTokenStore as ScimTokenStore import Spar.Sem.ScimUserTimesStore (ScimUserTimesStore) import System.Logger (Msg) -import qualified System.Logger as TinyLog import qualified URI.ByteString as URI import Wire.API.Cookie import Wire.API.Routes.Public.Spar @@ -97,13 +104,12 @@ import Wire.API.User.Saml app :: Env -> Application app ctx = SAML.setHttpCachePolicy $ - serve (Proxy @API) (hoistServer (Proxy @API) (SAML.nt @SparError @(Spar _) ctx) (api $ sparCtxOpts ctx) :: Server API) + serve (Proxy @API) (hoistServer (Proxy @API) (runSparToHandler ctx) (api $ sparCtxOpts ctx) :: Server API) api :: Members '[ GalleyAccess, BrigAccess, - Input TinyLog.Logger, Input Opts, BindCookieStore, AssIDStore, @@ -115,13 +121,19 @@ api :: IdPEffect.IdP, SAMLUserStore, Random, + Error SparError, + SAML2, + Now, + SamlProtocolSettings, Logger String, - Logger (Msg -> Msg), - Error SparError + Reporter, + -- TODO(sandy): Only necessary for 'fromExceptionSem' in 'apiScim' + Final IO, + Logger (Msg -> Msg) ] r => Opts -> - ServerT API (Spar r) + ServerT API (Sem r) api opts = apiSSO opts :<|> authreqPrecheck @@ -134,7 +146,6 @@ apiSSO :: Members '[ GalleyAccess, Logger String, - Input TinyLog.Logger, Input Opts, BrigAccess, BindCookieStore, @@ -144,14 +155,18 @@ apiSSO :: DefaultSsoCode, IdPEffect.IdP, Random, + Error SparError, + SAML2, + SamlProtocolSettings, + Reporter, SAMLUserStore ] r => Opts -> - ServerT APISSO (Spar r) + ServerT APISSO (Sem r) apiSSO opts = - SAML.meta appName (sparSPIssuer Nothing) (sparResponseURI Nothing) - :<|> (\tid -> SAML.meta appName (sparSPIssuer (Just tid)) (sparResponseURI (Just tid))) + (SAML2.meta appName (SamlProtocolSettings.spIssuer Nothing) (SamlProtocolSettings.responseURI Nothing)) + :<|> (\tid -> SAML2.meta appName (SamlProtocolSettings.spIssuer (Just tid)) (SamlProtocolSettings.responseURI (Just tid))) :<|> authreqPrecheck :<|> authreq (maxttlAuthreqDiffTime opts) DoInitiateLogin :<|> authresp Nothing @@ -170,7 +185,7 @@ apiIDP :: Error SparError ] r => - ServerT APIIDP (Spar r) + ServerT APIIDP (Sem r) apiIDP = idpGet :<|> idpGetRaw @@ -184,10 +199,11 @@ apiINTERNAL :: '[ ScimTokenStore, DefaultSsoCode, IdPEffect.IdP, + Error SparError, SAMLUserStore ] r => - ServerT APIINTERNAL (Spar r) + ServerT APIINTERNAL (Sem r) apiINTERNAL = internalStatus :<|> internalDeleteTeam @@ -199,10 +215,19 @@ appName = "spar" ---------------------------------------------------------------------------- -- SSO API -authreqPrecheck :: Member IdPEffect.IdP r => Maybe URI.URI -> Maybe URI.URI -> SAML.IdPId -> Spar r NoContent +authreqPrecheck :: + Members + '[ IdPEffect.IdP, + Error SparError + ] + r => + Maybe URI.URI -> + Maybe URI.URI -> + SAML.IdPId -> + Sem r NoContent authreqPrecheck msucc merr idpid = validateAuthreqParams msucc merr - *> SAML.getIdPConfig idpid + *> getIdPConfig idpid *> return NoContent authreq :: @@ -213,6 +238,9 @@ authreq :: BindCookieStore, AssIDStore, AReqIDStore, + SAML2, + SamlProtocolSettings, + Error SparError, IdPEffect.IdP ] r => @@ -222,58 +250,65 @@ authreq :: Maybe URI.URI -> Maybe URI.URI -> SAML.IdPId -> - Spar r (WithSetBindCookie (SAML.FormRedirect SAML.AuthnRequest)) -authreq _ DoInitiateLogin (Just _) _ _ _ = throwSpar SparInitLoginWithAuth -authreq _ DoInitiateBind Nothing _ _ _ = throwSpar SparInitBindWithoutAuth + Sem r (WithSetBindCookie (SAML.FormRedirect SAML.AuthnRequest)) +authreq _ DoInitiateLogin (Just _) _ _ _ = throwSparSem SparInitLoginWithAuth +authreq _ DoInitiateBind Nothing _ _ _ = throwSparSem SparInitBindWithoutAuth authreq authreqttl _ zusr msucc merr idpid = do vformat <- validateAuthreqParams msucc merr form@(SAML.FormRedirect _ ((^. SAML.rqID) -> reqid)) <- do - idp :: IdP <- wrapMonadClientSem (IdPEffect.getConfig idpid) >>= maybe (throwSpar (SparIdPNotFound (cs $ show idpid))) pure + idp :: IdP <- IdPEffect.getConfig idpid >>= maybe (throwSparSem (SparIdPNotFound (cs $ show idpid))) pure let mbtid :: Maybe TeamId mbtid = case fromMaybe defWireIdPAPIVersion (idp ^. SAML.idpExtraInfo . wiApiVersion) of WireIdPAPIV1 -> Nothing WireIdPAPIV2 -> Just $ idp ^. SAML.idpExtraInfo . wiTeam - SAML.authreq authreqttl (sparSPIssuer mbtid) idpid - wrapMonadClientSem $ AReqIDStore.storeVerdictFormat authreqttl reqid vformat + SAML2.authReq authreqttl (SamlProtocolSettings.spIssuer mbtid) idpid + AReqIDStore.storeVerdictFormat authreqttl reqid vformat cky <- initializeBindCookie zusr authreqttl - liftSem $ Logger.log SAML.Debug $ "setting bind cookie: " <> show cky + Logger.log SAML.Debug $ "setting bind cookie: " <> show cky pure $ addHeader cky form -- | If the user is already authenticated, create bind cookie with a given life expectancy and our -- domain, and store it in C*. If the user is not authenticated, return a deletion 'SetCookie' -- value that deletes any bind cookies on the client. initializeBindCookie :: - Members '[Random, Input Opts, Logger String, BindCookieStore] r => + Members + '[ Random, + SAML2, + Input Opts, + Logger String, + BindCookieStore + ] + r => Maybe UserId -> NominalDiffTime -> - Spar r SetBindCookie + Sem r SetBindCookie initializeBindCookie zusr authreqttl = do - DerivedOpts {derivedOptsBindCookiePath} <- liftSem $ inputs derivedOpts + DerivedOpts {derivedOptsBindCookiePath} <- inputs derivedOpts msecret <- if isJust zusr - then liftSem $ Just . cs . ES.encode <$> Random.bytes 32 + then Just . cs . ES.encode <$> Random.bytes 32 else pure Nothing - cky <- fmap SetBindCookie . SAML.toggleCookie derivedOptsBindCookiePath $ (,authreqttl) <$> msecret - forM_ zusr $ \userid -> wrapMonadClientSem $ BindCookieStore.insert cky userid authreqttl + cky <- fmap SetBindCookie . SAML2.toggleCookie derivedOptsBindCookiePath $ (,authreqttl) <$> msecret + forM_ zusr $ \userid -> BindCookieStore.insert cky userid authreqttl pure cky redirectURLMaxLength :: Int redirectURLMaxLength = 140 -validateAuthreqParams :: Maybe URI.URI -> Maybe URI.URI -> Spar r VerdictFormat +validateAuthreqParams :: Member (Error SparError) r => Maybe URI.URI -> Maybe URI.URI -> Sem r VerdictFormat validateAuthreqParams msucc merr = case (msucc, merr) of (Nothing, Nothing) -> pure VerdictFormatWeb (Just ok, Just err) -> do validateRedirectURL `mapM_` [ok, err] pure $ VerdictFormatMobile ok err - _ -> throwSpar $ SparBadInitiateLoginQueryParams "need-both-redirect-urls" + _ -> throwSparSem $ SparBadInitiateLoginQueryParams "need-both-redirect-urls" -validateRedirectURL :: URI.URI -> Spar r () +validateRedirectURL :: Member (Error SparError) r => URI.URI -> Sem r () validateRedirectURL uri = do unless ((SBS.take 4 . URI.schemeBS . URI.uriScheme $ uri) == "wire") $ do - throwSpar $ SparBadInitiateLoginQueryParams "invalid-schema" + throwSparSem $ SparBadInitiateLoginQueryParams "invalid-schema" unless ((SBS.length $ URI.serializeURIRef' uri) <= redirectURLMaxLength) $ do - throwSpar $ SparBadInitiateLoginQueryParams "url-too-long" + throwSparSem $ SparBadInitiateLoginQueryParams "url-too-long" authresp :: forall r. @@ -281,7 +316,6 @@ authresp :: '[ Random, Logger String, Input Opts, - Input TinyLog.Logger, GalleyAccess, BrigAccess, BindCookieStore, @@ -289,36 +323,40 @@ authresp :: AReqIDStore, ScimTokenStore, IdPEffect.IdP, + SAML2, + SamlProtocolSettings, + Error SparError, + Reporter, SAMLUserStore ] r => Maybe TeamId -> Maybe ST -> SAML.AuthnResponseBody -> - Spar r Void -authresp mbtid ckyraw arbody = logErrors $ SAML.authresp mbtid (sparSPIssuer mbtid) (sparResponseURI mbtid) go arbody + Sem r Void +authresp mbtid ckyraw arbody = logErrors $ SAML2.authResp mbtid (SamlProtocolSettings.spIssuer mbtid) (SamlProtocolSettings.responseURI mbtid) go arbody where cky :: Maybe BindCookie cky = ckyraw >>= bindCookieFromHeader - go :: SAML.AuthnResponse -> SAML.AccessVerdict -> Spar r Void + go :: SAML.AuthnResponse -> SAML.AccessVerdict -> Sem r Void go resp verdict = do result :: SAML.ResponseVerdict <- verdictHandler cky mbtid resp verdict - throwError $ SAML.CustomServant result + throw @SparError $ SAML.CustomServant result - logErrors :: Spar r Void -> Spar r Void - logErrors = flip catchError $ \case - e@(SAML.CustomServant _) -> throwError e + logErrors :: Sem r Void -> Sem r Void + logErrors action = catch @SparError action $ \case + e@(SAML.CustomServant _) -> throw e e -> do - throwError . SAML.CustomServant $ + throw @SparError . SAML.CustomServant $ errorPage e (Multipart.inputs (SAML.authnResponseBodyRaw arbody)) ckyraw -ssoSettings :: Member DefaultSsoCode r => Spar r SsoSettings +ssoSettings :: Member DefaultSsoCode r => Sem r SsoSettings ssoSettings = do - SsoSettings <$> wrapMonadClientSem DefaultSsoCode.get + SsoSettings <$> DefaultSsoCode.get ---------------------------------------------------------------------------- -- IdP API @@ -335,23 +373,23 @@ idpGet :: r => Maybe UserId -> SAML.IdPId -> - Spar r IdP + Sem r IdP idpGet zusr idpid = withDebugLog "idpGet" (Just . show . (^. SAML.idpId)) $ do - idp <- SAML.getIdPConfig idpid - _ <- liftSem $ authorizeIdP zusr idp + idp <- getIdPConfig idpid + _ <- authorizeIdP zusr idp pure idp idpGetRaw :: Members '[GalleyAccess, BrigAccess, IdPEffect.IdP, Error SparError] r => Maybe UserId -> SAML.IdPId -> - Spar r RawIdPMetadata + Sem r RawIdPMetadata idpGetRaw zusr idpid = do - idp <- SAML.getIdPConfig idpid - _ <- liftSem $ authorizeIdP zusr idp - wrapMonadClientSem (IdPEffect.getRawMetadata idpid) >>= \case + idp <- getIdPConfig idpid + _ <- authorizeIdP zusr idp + IdPEffect.getRawMetadata idpid >>= \case Just txt -> pure $ RawIdPMetadata txt - Nothing -> throwSpar $ SparIdPNotFound (cs $ show idpid) + Nothing -> throwSparSem $ SparIdPNotFound (cs $ show idpid) idpGetAll :: Members @@ -364,10 +402,10 @@ idpGetAll :: ] r => Maybe UserId -> - Spar r IdPList + Sem r IdPList idpGetAll zusr = withDebugLog "idpGetAll" (const Nothing) $ do - teamid <- liftSem $ Brig.getZUsrCheckPerm zusr ReadIdp - _idplProviders <- wrapMonadClientSem $ IdPEffect.getConfigsByTeam teamid + teamid <- Brig.getZUsrCheckPerm zusr ReadIdp + _idplProviders <- IdPEffect.getConfigsByTeam teamid pure IdPList {..} -- | Delete empty IdPs, or if @"purge=true"@ in the HTTP query, delete all users @@ -394,41 +432,40 @@ idpDelete :: Maybe UserId -> SAML.IdPId -> Maybe Bool -> - Spar r NoContent + Sem r NoContent idpDelete zusr idpid (fromMaybe False -> purge) = withDebugLog "idpDelete" (const Nothing) $ do - idp <- SAML.getIdPConfig idpid - _ <- liftSem $ authorizeIdP zusr idp + idp <- getIdPConfig idpid + _ <- authorizeIdP zusr idp let issuer = idp ^. SAML.idpMetadata . SAML.edIssuer team = idp ^. SAML.idpExtraInfo . wiTeam -- if idp is not empty: fail or purge - idpIsEmpty <- wrapMonadClientSem $ isNothing <$> SAMLUserStore.getAnyByIssuer issuer - let doPurge :: Spar r () + idpIsEmpty <- isNothing <$> SAMLUserStore.getAnyByIssuer issuer + let doPurge :: Sem r () doPurge = do - some <- wrapMonadClientSem (SAMLUserStore.getSomeByIssuer issuer) + some <- SAMLUserStore.getSomeByIssuer issuer forM_ some $ \(uref, uid) -> do - liftSem $ BrigAccess.delete uid - wrapMonadClientSem (SAMLUserStore.delete uid uref) + BrigAccess.delete uid + SAMLUserStore.delete uid uref unless (null some) doPurge when (not idpIsEmpty) $ do if purge then doPurge - else throwSpar SparIdPHasBoundUsers + else throwSparSem SparIdPHasBoundUsers updateOldIssuers idp updateReplacingIdP idp - wrapSpar $ do - -- Delete tokens associated with given IdP (we rely on the fact that - -- each IdP has exactly one team so we can look up all tokens - -- associated with the team and then filter them) - tokens <- liftSem $ ScimTokenStore.getByTeam team - for_ tokens $ \ScimTokenInfo {..} -> - when (stiIdP == Just idpid) $ liftSem $ ScimTokenStore.delete team stiId - -- Delete IdP config - liftSem $ do - IdPEffect.deleteConfig idpid issuer team - IdPEffect.deleteRawMetadata idpid + -- Delete tokens associated with given IdP (we rely on the fact that + -- each IdP has exactly one team so we can look up all tokens + -- associated with the team and then filter them) + tokens <- ScimTokenStore.getByTeam team + for_ tokens $ \ScimTokenInfo {..} -> + when (stiIdP == Just idpid) $ ScimTokenStore.delete team stiId + -- Delete IdP config + do + IdPEffect.deleteConfig idpid issuer team + IdPEffect.deleteRawMetadata idpid return NoContent where - updateOldIssuers :: IdP -> Spar r () + updateOldIssuers :: IdP -> Sem r () updateOldIssuers _ = pure () -- we *could* update @idp ^. SAML.idpExtraInfo . wiReplacedBy@ to not keep the idp about -- to be deleted in its old issuers list, but it's tricky to avoid race conditions, and @@ -437,15 +474,14 @@ idpDelete zusr idpid (fromMaybe False -> purge) = withDebugLog "idpDelete" (cons -- won't find any users to migrate. still, doesn't hurt mucht to look either. so we -- leave old issuers dangling for now. - updateReplacingIdP :: IdP -> Spar r () + updateReplacingIdP :: IdP -> Sem r () updateReplacingIdP idp = forM_ (idp ^. SAML.idpExtraInfo . wiOldIssuers) $ \oldIssuer -> do - wrapSpar $ do - getIdPIdByIssuer oldIssuer (idp ^. SAML.idpExtraInfo . wiTeam) >>= \case - Data.GetIdPFound iid -> liftSem $ IdPEffect.clearReplacedBy $ Data.Replaced iid - Data.GetIdPNotFound -> pure () - Data.GetIdPDanglingId _ -> pure () - Data.GetIdPNonUnique _ -> pure () - Data.GetIdPWrongTeam _ -> pure () + getIdPIdByIssuer oldIssuer (idp ^. SAML.idpExtraInfo . wiTeam) >>= \case + Data.GetIdPFound iid -> IdPEffect.clearReplacedBy $ Data.Replaced iid + Data.GetIdPNotFound -> pure () + Data.GetIdPDanglingId _ -> pure () + Data.GetIdPNonUnique _ -> pure () + Data.GetIdPWrongTeam _ -> pure () -- | This handler only does the json parsing, and leaves all authorization checks and -- application logic to 'idpCreateXML'. @@ -464,7 +500,7 @@ idpCreate :: IdPMetadataInfo -> Maybe SAML.IdPId -> Maybe WireIdPAPIVersion -> - Spar r IdP + Sem r IdP idpCreate zusr (IdPMetadataValue raw xml) midpid apiversion = idpCreateXML zusr raw xml midpid apiversion -- | We generate a new UUID for each IdP used as IdPConfig's path, thereby ensuring uniqueness. @@ -484,15 +520,15 @@ idpCreateXML :: SAML.IdPMetadata -> Maybe SAML.IdPId -> Maybe WireIdPAPIVersion -> - Spar r IdP + Sem r IdP idpCreateXML zusr raw idpmeta mReplaces (fromMaybe defWireIdPAPIVersion -> apiversion) = withDebugLog "idpCreate" (Just . show . (^. SAML.idpId)) $ do - teamid <- liftSem $ Brig.getZUsrCheckPerm zusr CreateUpdateDeleteIdp - liftSem $ GalleyAccess.assertSSOEnabled teamid + teamid <- Brig.getZUsrCheckPerm zusr CreateUpdateDeleteIdp + GalleyAccess.assertSSOEnabled teamid assertNoScimOrNoIdP teamid idp <- validateNewIdP apiversion idpmeta teamid mReplaces - wrapMonadClientSem $ IdPEffect.storeRawMetadata (idp ^. SAML.idpId) raw - SAML.storeIdPConfig idp - forM_ mReplaces $ \replaces -> wrapMonadClientSem $ do + IdPEffect.storeRawMetadata (idp ^. SAML.idpId) raw + storeIdPConfig idp + forM_ mReplaces $ \replaces -> do IdPEffect.setReplacedBy (Data.Replaced replaces) (Data.Replacing (idp ^. SAML.idpId)) pure idp @@ -500,12 +536,20 @@ idpCreateXML zusr raw idpmeta mReplaces (fromMaybe defWireIdPAPIVersion -> apive -- data contains no information about the idp issuer, only the user name, so no valid saml -- credentials can be created. To fix this, we need to implement a way to associate scim -- tokens with IdPs. https://wearezeta.atlassian.net/browse/SQSERVICES-165 -assertNoScimOrNoIdP :: Members '[ScimTokenStore, IdPEffect.IdP] r => TeamId -> Spar r () +assertNoScimOrNoIdP :: + Members + '[ ScimTokenStore, + Error SparError, + IdPEffect.IdP + ] + r => + TeamId -> + Sem r () assertNoScimOrNoIdP teamid = do - numTokens <- length <$> wrapMonadClientSem (ScimTokenStore.getByTeam teamid) - numIdps <- length <$> wrapMonadClientSem (IdPEffect.getConfigsByTeam teamid) + numTokens <- length <$> ScimTokenStore.getByTeam teamid + numIdps <- length <$> IdPEffect.getConfigsByTeam teamid when (numTokens > 0 && numIdps > 0) $ do - throwSpar $ + throwSparSem $ SparProvisioningMoreThanOneIdP "Teams with SCIM tokens can only have at most one IdP" @@ -531,37 +575,43 @@ assertNoScimOrNoIdP teamid = do -- update, delete of idps.) validateNewIdP :: forall m r. - (HasCallStack, m ~ Spar r) => - Members '[Random, Logger String, IdPEffect.IdP] r => + (HasCallStack, m ~ Sem r) => + Members + '[ Random, + Logger String, + IdPEffect.IdP, + Error SparError + ] + r => WireIdPAPIVersion -> SAML.IdPMetadata -> TeamId -> Maybe SAML.IdPId -> m IdP validateNewIdP apiversion _idpMetadata teamId mReplaces = withDebugLog "validateNewIdP" (Just . show . (^. SAML.idpId)) $ do - _idpId <- SAML.IdPId <$> SAML.createUUID + _idpId <- SAML.IdPId <$> Random.uuid oldIssuers :: [SAML.Issuer] <- case mReplaces of Nothing -> pure [] Just replaces -> do - idp <- wrapMonadClientSem (IdPEffect.getConfig replaces) >>= maybe (throwSpar (SparIdPNotFound (cs $ show mReplaces))) pure + idp <- IdPEffect.getConfig replaces >>= maybe (throwSparSem (SparIdPNotFound (cs $ show mReplaces))) pure pure $ (idp ^. SAML.idpMetadata . SAML.edIssuer) : (idp ^. SAML.idpExtraInfo . wiOldIssuers) let requri = _idpMetadata ^. SAML.edRequestURI _idpExtraInfo = WireIdP teamId (Just apiversion) oldIssuers Nothing enforceHttps requri - idp <- wrapSpar $ getIdPConfigByIssuer (_idpMetadata ^. SAML.edIssuer) teamId - liftSem $ Logger.log SAML.Debug $ show (apiversion, _idpMetadata, teamId, mReplaces) - liftSem $ Logger.log SAML.Debug $ show (_idpId, oldIssuers, idp) + idp <- getIdPConfigByIssuer (_idpMetadata ^. SAML.edIssuer) teamId + Logger.log SAML.Debug $ show (apiversion, _idpMetadata, teamId, mReplaces) + Logger.log SAML.Debug $ show (_idpId, oldIssuers, idp) let handleIdPClash :: Either id idp -> m () -- (HINT: using type vars above instead of the actual types constitutes a proof that -- we're not using any properties of the arguments in this function.) handleIdPClash = case apiversion of WireIdPAPIV1 -> const $ do - throwSpar $ SparNewIdPAlreadyInUse "you can't create an IdP with api_version v1 if the issuer is already in use on the wire instance." + throwSparSem $ SparNewIdPAlreadyInUse "you can't create an IdP with api_version v1 if the issuer is already in use on the wire instance." WireIdPAPIV2 -> \case (Right _) -> do -- idp' was found by lookup with teamid, so it's in the same team. - throwSpar $ SparNewIdPAlreadyInUse "if the exisitng IdP is registered for a team, the new one can't have it." + throwSparSem $ SparNewIdPAlreadyInUse "if the exisitng IdP is registered for a team, the new one can't have it." (Left _) -> do -- this idp *id* is from a different team, and we're in the 'WireIdPAPIV2' case, so this is fine. pure () @@ -569,7 +619,7 @@ validateNewIdP apiversion _idpMetadata teamId mReplaces = withDebugLog "validate case idp of Data.GetIdPFound idp' {- same team -} -> handleIdPClash (Right idp') Data.GetIdPNotFound -> pure () - res@(Data.GetIdPDanglingId _) -> throwSpar . SparIdPNotFound . ("validateNewIdP: " <>) . cs . show $ res -- database inconsistency + res@(Data.GetIdPDanglingId _) -> throwSparSem . SparIdPNotFound . ("validateNewIdP: " <>) . cs . show $ res -- database inconsistency Data.GetIdPNonUnique ids' {- same team didn't yield anything, but there are at least two other teams with this issuer already -} -> handleIdPClash (Left ids') Data.GetIdPWrongTeam id' {- different team -} -> handleIdPClash (Left id') @@ -591,7 +641,7 @@ idpUpdate :: Maybe UserId -> IdPMetadataInfo -> SAML.IdPId -> - Spar r IdP + Sem r IdP idpUpdate zusr (IdPMetadataValue raw xml) idpid = idpUpdateXML zusr raw xml idpid idpUpdateXML :: @@ -608,15 +658,15 @@ idpUpdateXML :: Text -> SAML.IdPMetadata -> SAML.IdPId -> - Spar r IdP + Sem r IdP idpUpdateXML zusr raw idpmeta idpid = withDebugLog "idpUpdate" (Just . show . (^. SAML.idpId)) $ do (teamid, idp) <- validateIdPUpdate zusr idpmeta idpid - liftSem $ GalleyAccess.assertSSOEnabled teamid - wrapMonadClientSem $ IdPEffect.storeRawMetadata (idp ^. SAML.idpId) raw + GalleyAccess.assertSSOEnabled teamid + IdPEffect.storeRawMetadata (idp ^. SAML.idpId) raw -- (if raw metadata is stored and then spar goes out, raw metadata won't match the -- structured idp config. since this will lead to a 5xx response, the client is epected to -- try again, which would clean up cassandra state.) - SAML.storeIdPConfig idp + storeIdPConfig idp pure idp -- | Check that: idp id is valid; calling user is admin in that idp's home team; team id in @@ -625,7 +675,7 @@ idpUpdateXML zusr raw idpmeta idpid = withDebugLog "idpUpdate" (Just . show . (^ -- info if issuer has changed. validateIdPUpdate :: forall m r. - (HasCallStack, m ~ Spar r) => + (HasCallStack, m ~ Sem r) => Members '[ Random, Logger String, @@ -641,28 +691,28 @@ validateIdPUpdate :: m (TeamId, IdP) validateIdPUpdate zusr _idpMetadata _idpId = withDebugLog "validateNewIdP" (Just . show . (_2 %~ (^. SAML.idpId))) $ do previousIdP <- - wrapMonadClientSem (IdPEffect.getConfig _idpId) >>= \case - Nothing -> throwError errUnknownIdPId + IdPEffect.getConfig _idpId >>= \case + Nothing -> throw errUnknownIdPId Just idp -> pure idp - teamId <- liftSem $ authorizeIdP zusr previousIdP + teamId <- authorizeIdP zusr previousIdP unless (previousIdP ^. SAML.idpExtraInfo . wiTeam == teamId) $ do - throwError errUnknownIdP + throw errUnknownIdP _idpExtraInfo <- do let previousIssuer = previousIdP ^. SAML.idpMetadata . SAML.edIssuer newIssuer = _idpMetadata ^. SAML.edIssuer if previousIssuer == newIssuer then pure $ previousIdP ^. SAML.idpExtraInfo else do - foundConfig <- wrapSpar $ getIdPConfigByIssuerAllowOld newIssuer (Just teamId) + foundConfig <- getIdPConfigByIssuerAllowOld newIssuer (Just teamId) notInUseByOthers <- case foundConfig of Data.GetIdPFound c -> pure $ c ^. SAML.idpId == _idpId Data.GetIdPNotFound -> pure True - res@(Data.GetIdPDanglingId _) -> throwSpar . SparIdPNotFound . ("validateIdPUpdate: " <>) . cs . show $ res -- impossible - res@(Data.GetIdPNonUnique _) -> throwSpar . SparIdPNotFound . ("validateIdPUpdate: " <>) . cs . show $ res -- impossible (because team id was used in lookup) + res@(Data.GetIdPDanglingId _) -> throwSparSem . SparIdPNotFound . ("validateIdPUpdate: " <>) . cs . show $ res -- impossible + res@(Data.GetIdPNonUnique _) -> throwSparSem . SparIdPNotFound . ("validateIdPUpdate: " <>) . cs . show $ res -- impossible (because team id was used in lookup) Data.GetIdPWrongTeam _ -> pure False if notInUseByOthers then pure $ (previousIdP ^. SAML.idpExtraInfo) & wiOldIssuers %~ nub . (previousIssuer :) - else throwSpar SparIdPIssuerInUse + else throwSparSem SparIdPIssuerInUse let requri = _idpMetadata ^. SAML.edRequestURI enforceHttps requri pure (teamId, SAML.IdPConfig {..}) @@ -673,12 +723,12 @@ validateIdPUpdate zusr _idpMetadata _idpId = withDebugLog "validateNewIdP" (Just uri = _idpMetadata ^. SAML.edIssuer . SAML.fromIssuer errUnknownIdPId = SAML.UnknownIdP . cs . SAML.idPIdToST $ _idpId -withDebugLog :: Member (Logger String) r => String -> (a -> Maybe String) -> Spar r a -> Spar r a +withDebugLog :: Member (Logger String) r => String -> (a -> Maybe String) -> Sem r a -> Sem r a withDebugLog msg showval action = do - liftSem $ Logger.log SAML.Debug $ "entering " ++ msg + Logger.log SAML.Debug $ "entering " ++ msg val <- action let mshowedval = showval val - liftSem $ Logger.log SAML.Debug $ "leaving " ++ msg ++ mconcat [": " ++ fromJust mshowedval | isJust mshowedval] + Logger.log SAML.Debug $ "leaving " ++ msg ++ mconcat [": " ++ fromJust mshowedval | isJust mshowedval] pure val authorizeIdP :: @@ -692,35 +742,43 @@ authorizeIdP (Just zusr) idp = do GalleyAccess.assertHasPermission teamid CreateUpdateDeleteIdp zusr pure teamid -enforceHttps :: URI.URI -> Spar r () +enforceHttps :: Member (Error SparError) r => URI.URI -> Sem r () enforceHttps uri = do unless ((uri ^. URI.uriSchemeL . URI.schemeBSL) == "https") $ do - throwSpar . SparNewIdPWantHttps . cs . SAML.renderURI $ uri + throwSparSem . SparNewIdPWantHttps . cs . SAML.renderURI $ uri ---------------------------------------------------------------------------- -- Internal API -internalStatus :: Spar r NoContent +internalStatus :: Sem r NoContent internalStatus = pure NoContent -- | Cleanup handler that is called by Galley whenever a team is about to -- get deleted. -internalDeleteTeam :: Members '[ScimTokenStore, IdPEffect.IdP, SAMLUserStore] r => TeamId -> Spar r NoContent +internalDeleteTeam :: Members '[ScimTokenStore, IdPEffect.IdP, SAMLUserStore] r => TeamId -> Sem r NoContent internalDeleteTeam team = do - wrapSpar $ deleteTeam team + deleteTeam team pure NoContent -internalPutSsoSettings :: Members '[DefaultSsoCode, IdPEffect.IdP] r => SsoSettings -> Spar r NoContent +internalPutSsoSettings :: + Members + '[ DefaultSsoCode, + Error SparError, + IdPEffect.IdP + ] + r => + SsoSettings -> + Sem r NoContent internalPutSsoSettings SsoSettings {defaultSsoCode = Nothing} = do - wrapMonadClientSem $ DefaultSsoCode.delete + DefaultSsoCode.delete pure NoContent internalPutSsoSettings SsoSettings {defaultSsoCode = Just code} = do - wrapMonadClientSem (IdPEffect.getConfig code) >>= \case + IdPEffect.getConfig code >>= \case Nothing -> -- this will return a 404, which is not quite right, -- but it's an internal endpoint and the message clearly says -- "Could not find IdP". - throwSpar $ SparIdPNotFound mempty + throwSparSem $ SparIdPNotFound mempty Just _ -> do - wrapMonadClientSem $ DefaultSsoCode.store code + DefaultSsoCode.store code pure NoContent diff --git a/services/spar/src/Spar/App.hs b/services/spar/src/Spar/App.hs index 733effb5e3..87daf33352 100644 --- a/services/spar/src/Spar/App.hs +++ b/services/spar/src/Spar/App.hs @@ -1,6 +1,5 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} -- This file is part of the Wire Server implementation. @@ -22,9 +21,8 @@ -- | The 'Spar' monad and a set of actions (e.g. 'createUser') that can be performed in it. module Spar.App - ( Spar (..), - Env (..), - wrapMonadClientSem, + ( Env (..), + throwSparSem, verdictHandler, GetUserResult (..), getUserIdByUref, @@ -36,9 +34,11 @@ module Spar.App getIdPConfigByIssuer, getIdPConfigByIssuerAllowOld, deleteTeam, - wrapSpar, - liftSem, - type RealInterpretation, + getIdPConfig, + storeIdPConfig, + getIdPConfigByIssuerOptionalSPId, + sparToServerErrorWithLogging, + renderSparErrorWithLogging, ) where @@ -48,9 +48,7 @@ import Brig.Types.Intra (AccountStatus (..), accountStatus, accountUser) import qualified Cassandra as Cas import Control.Exception (assert) import Control.Lens hiding ((.=)) -import qualified Control.Monad.Catch as Catch import Control.Monad.Except -import Control.Monad.Trans.Except (except) import Data.Aeson as Aeson (encode, object, (.=)) import Data.Aeson.Text as Aeson (encodeToLazyText) import qualified Data.ByteString.Builder as Builder @@ -59,26 +57,15 @@ import Data.Id import Data.String.Conversions import Data.Text.Ascii (encodeBase64, toText) import qualified Data.Text.Lazy as LT -import Imports hiding (log) +import Imports hiding (MonadReader, asks, log) import qualified Network.HTTP.Types.Status as Http import qualified Network.Wai.Utilities.Error as Wai import Polysemy import Polysemy.Error -import Polysemy.Final -import Polysemy.Input (Input, input, inputs, runInputConst) import SAML2.Util (renderURI) import SAML2.WebSSO - ( Assertion (..), - AuthnRequest (..), - HasConfig (..), - HasCreateUUID (..), - HasLogger (..), - HasNow (..), - IdPId (..), + ( IdPId (..), Issuer (..), - SPHandler (..), - SPStoreID (..), - SPStoreIdP (getIdPConfigByIssuerOptionalSPId), UnqualifiedNameID (..), explainDeniedReason, idpExtraInfo, @@ -90,46 +77,31 @@ import qualified SAML2.WebSSO.Types.Email as SAMLEmail import Servant import qualified Servant.Multipart as Multipart import qualified Spar.Data as Data (GetIdPResult (..)) -import Spar.Error +import Spar.Error hiding (sparToServerErrorWithLogging) import qualified Spar.Intra.BrigApp as Intra import Spar.Orphans () import Spar.Sem.AReqIDStore (AReqIDStore) import qualified Spar.Sem.AReqIDStore as AReqIDStore -import Spar.Sem.AReqIDStore.Cassandra (aReqIDStoreToCassandra, ttlErrorToSparError) -import Spar.Sem.AssIDStore (AssIDStore) -import qualified Spar.Sem.AssIDStore as AssIDStore -import Spar.Sem.AssIDStore.Cassandra (assIDStoreToCassandra) import Spar.Sem.BindCookieStore (BindCookieStore) import qualified Spar.Sem.BindCookieStore as BindCookieStore -import Spar.Sem.BindCookieStore.Cassandra (bindCookieStoreToCassandra) import Spar.Sem.BrigAccess (BrigAccess) import qualified Spar.Sem.BrigAccess as BrigAccess -import Spar.Sem.BrigAccess.Http (brigAccessToHttp) -import Spar.Sem.DefaultSsoCode (DefaultSsoCode) -import Spar.Sem.DefaultSsoCode.Cassandra (defaultSsoCodeToCassandra) import Spar.Sem.GalleyAccess (GalleyAccess) import qualified Spar.Sem.GalleyAccess as GalleyAccess -import Spar.Sem.GalleyAccess.Http (galleyAccessToHttp) import Spar.Sem.IdP (GetIdPResult (..)) import qualified Spar.Sem.IdP as IdPEffect -import Spar.Sem.IdP.Cassandra (idPToCassandra) import Spar.Sem.Logger (Logger) import qualified Spar.Sem.Logger as Logger -import Spar.Sem.Logger.TinyLog (loggerToTinyLog, stringLoggerToTinyLog) import Spar.Sem.Random (Random) import qualified Spar.Sem.Random as Random -import Spar.Sem.Random.IO (randomToIO) +import Spar.Sem.Reporter (Reporter) +import qualified Spar.Sem.Reporter as Reporter import Spar.Sem.SAMLUserStore (SAMLUserStore) import qualified Spar.Sem.SAMLUserStore as SAMLUserStore -import Spar.Sem.SAMLUserStore.Cassandra (interpretClientToIO, samlUserStoreToCassandra) import Spar.Sem.ScimExternalIdStore (ScimExternalIdStore) import qualified Spar.Sem.ScimExternalIdStore as ScimExternalIdStore -import Spar.Sem.ScimExternalIdStore.Cassandra (scimExternalIdStoreToCassandra) import Spar.Sem.ScimTokenStore (ScimTokenStore) import qualified Spar.Sem.ScimTokenStore as ScimTokenStore -import Spar.Sem.ScimTokenStore.Cassandra (scimTokenStoreToCassandra) -import Spar.Sem.ScimUserTimesStore (ScimUserTimesStore) -import Spar.Sem.ScimUserTimesStore.Cassandra (scimUserTimesStoreToCassandra) import qualified System.Logger as TinyLog import URI.ByteString as URI import Web.Cookie (SetCookie, renderSetCookie) @@ -139,29 +111,8 @@ import Wire.API.User.IdentityProvider import Wire.API.User.Saml import Wire.API.User.Scim (ValidExternalId (..)) -newtype Spar r a = Spar {fromSpar :: Member (Final IO) r => ExceptT SparError (Sem r) a} - deriving (Functor) - -liftSem :: Sem r a -> Spar r a -liftSem r = Spar $ lift r - -instance Applicative (Spar r) where - pure a = Spar $ pure a - liftA2 f a b = Spar $ liftA2 f (fromSpar a) (fromSpar b) - -instance Monad (Spar r) where - return = pure - f >>= a = Spar $ fromSpar f >>= fromSpar . a - -instance MonadError SparError (Spar r) where - throwError err = Spar $ throwError err - catchError m handler = Spar $ catchError (fromSpar m) $ fromSpar . handler - -instance MonadIO (Spar r) where - liftIO m = Spar $ lift $ embedFinal m - -instance Members '[Input Opts, Logger String] r => HasLogger (Spar r) where - logger lvl = liftSem . Logger.log lvl +throwSparSem :: Member (Error SparError) r => SparCustomError -> Sem r a +throwSparSem = throw . SAML.CustomError data Env = Env { sparCtxOpts :: Opts, @@ -173,68 +124,30 @@ data Env = Env sparCtxRequestId :: RequestId } -instance Member (Input Opts) r => HasConfig (Spar r) where - getConfig = liftSem $ inputs saml - -instance HasNow (Spar r) - -instance Member Random r => HasCreateUUID (Spar r) where - createUUID = liftSem Random.uuid - -instance Member AReqIDStore r => SPStoreID AuthnRequest (Spar r) where - storeID i r = wrapMonadClientSem $ AReqIDStore.store i r - unStoreID r = wrapMonadClientSem $ AReqIDStore.unStore r - isAliveID r = wrapMonadClientSem $ AReqIDStore.isAlive r - -instance Member AssIDStore r => SPStoreID Assertion (Spar r) where - storeID i r = wrapMonadClientSem $ AssIDStore.store i r - unStoreID r = wrapMonadClientSem $ AssIDStore.unStore r - isAliveID r = wrapMonadClientSem $ AssIDStore.isAlive r - -instance Member IdPEffect.IdP r => SPStoreIdP SparError (Spar r) where - type IdPConfigExtra (Spar r) = WireIdP - type IdPConfigSPId (Spar r) = TeamId - - storeIdPConfig :: IdP -> Spar r () - storeIdPConfig idp = wrapMonadClientSem $ IdPEffect.storeConfig idp - - getIdPConfig :: IdPId -> Spar r IdP - getIdPConfig = (>>= maybe (throwSpar (SparIdPNotFound mempty)) pure) . wrapMonadClientSem . IdPEffect.getConfig - - getIdPConfigByIssuerOptionalSPId :: Issuer -> Maybe TeamId -> Spar r IdP - getIdPConfigByIssuerOptionalSPId issuer mbteam = do - wrapSpar (getIdPConfigByIssuerAllowOld issuer mbteam) >>= \case - Data.GetIdPFound idp -> pure idp - Data.GetIdPNotFound -> throwSpar $ SparIdPNotFound mempty - res@(Data.GetIdPDanglingId _) -> throwSpar $ SparIdPNotFound (cs $ show res) - res@(Data.GetIdPNonUnique _) -> throwSpar $ SparIdPNotFound (cs $ show res) - res@(Data.GetIdPWrongTeam _) -> throwSpar $ SparIdPNotFound (cs $ show res) - -instance Member (Final IO) r => Catch.MonadThrow (Sem r) where - throwM = embedFinal . Catch.throwM @IO - -instance Member (Final IO) r => Catch.MonadCatch (Sem r) where - catch m handler = withStrategicToFinal @IO $ do - m' <- runS m - st <- getInitialStateS - handler' <- bindS handler - pure $ m' `Catch.catch` \e -> handler' $ e <$ st - --- | Call a 'Sem' command in the 'Spar' monad. Catch all (IO) exceptions and --- re-throw them as 500 in Handler. -wrapMonadClientSem :: Sem r a -> Spar r a -wrapMonadClientSem action = - Spar $ - lift action - `Catch.catch` (throwSpar . SparCassandraError . cs . show @SomeException) - -wrapSpar :: Spar r a -> Spar r a -wrapSpar action = Spar $ do - fromSpar $ - wrapMonadClientSem (runExceptT $ fromSpar action) >>= Spar . except - -insertUser :: Member SAMLUserStore r => SAML.UserRef -> UserId -> Spar r () -insertUser uref uid = wrapMonadClientSem $ SAMLUserStore.insert uref uid +getIdPConfig :: + Members + '[ IdPEffect.IdP, + Error SparError + ] + r => + IdPId -> + Sem r IdP +getIdPConfig = (>>= maybe (throwSparSem (SparIdPNotFound mempty)) pure) . IdPEffect.getConfig + +storeIdPConfig :: Member IdPEffect.IdP r => IdP -> Sem r () +storeIdPConfig idp = IdPEffect.storeConfig idp + +getIdPConfigByIssuerOptionalSPId :: Members '[IdPEffect.IdP, Error SparError] r => Issuer -> Maybe TeamId -> Sem r IdP +getIdPConfigByIssuerOptionalSPId issuer mbteam = do + getIdPConfigByIssuerAllowOld issuer mbteam >>= \case + Data.GetIdPFound idp -> pure idp + Data.GetIdPNotFound -> throwSparSem $ SparIdPNotFound mempty + res@(Data.GetIdPDanglingId _) -> throwSparSem $ SparIdPNotFound (cs $ show res) + res@(Data.GetIdPNonUnique _) -> throwSparSem $ SparIdPNotFound (cs $ show res) + res@(Data.GetIdPWrongTeam _) -> throwSparSem $ SparIdPNotFound (cs $ show res) + +insertUser :: Member SAMLUserStore r => SAML.UserRef -> UserId -> Sem r () +insertUser uref uid = SAMLUserStore.insert uref uid -- | Look up user locally in table @spar.user@ or @spar.scim_user@ (depending on the -- argument), then in brig, then return the 'UserId'. If either lookup fails, or user is not @@ -253,17 +166,17 @@ insertUser uref uid = wrapMonadClientSem $ SAMLUserStore.insert uref uid -- the team with valid SAML credentials. -- -- FUTUREWORK: Remove and reinstatate getUser, in AuthID refactoring PR. (in https://github.com/wireapp/wire-server/pull/1410, undo https://github.com/wireapp/wire-server/pull/1418) -getUserIdByUref :: Members '[BrigAccess, SAMLUserStore] r => Maybe TeamId -> SAML.UserRef -> Spar r (GetUserResult UserId) +getUserIdByUref :: Members '[BrigAccess, SAMLUserStore] r => Maybe TeamId -> SAML.UserRef -> Sem r (GetUserResult UserId) getUserIdByUref mbteam uref = userId <$$> getUserByUref mbteam uref -getUserByUref :: Members '[BrigAccess, SAMLUserStore] r => Maybe TeamId -> SAML.UserRef -> Spar r (GetUserResult User) +getUserByUref :: Members '[BrigAccess, SAMLUserStore] r => Maybe TeamId -> SAML.UserRef -> Sem r (GetUserResult User) getUserByUref mbteam uref = do - muid <- wrapMonadClientSem $ SAMLUserStore.get uref + muid <- SAMLUserStore.get uref case muid of Nothing -> pure GetUserNotFound Just uid -> do let withpending = Intra.WithPendingInvitations -- see haddocks above - liftSem (Intra.getBrigUser withpending uid) >>= \case + Intra.getBrigUser withpending uid >>= \case Nothing -> pure GetUserNotFound Just user | isNothing (userTeam user) -> pure GetUserNoTeam @@ -284,14 +197,14 @@ instance Functor GetUserResult where fmap _ GetUserWrongTeam = GetUserWrongTeam -- FUTUREWORK: Remove and reinstatate getUser, in AuthID refactoring PR -getUserIdByScimExternalId :: Members '[BrigAccess, ScimExternalIdStore] r => TeamId -> Email -> Spar r (Maybe UserId) +getUserIdByScimExternalId :: Members '[BrigAccess, ScimExternalIdStore] r => TeamId -> Email -> Sem r (Maybe UserId) getUserIdByScimExternalId tid email = do - muid <- wrapMonadClientSem $ (ScimExternalIdStore.lookup tid email) + muid <- (ScimExternalIdStore.lookup tid email) case muid of Nothing -> pure Nothing Just uid -> do let withpending = Intra.WithPendingInvitations -- see haddocks above - itis <- liftSem $ isJust <$> Intra.getBrigUserTeam withpending uid + itis <- isJust <$> Intra.getBrigUserTeam withpending uid pure $ if itis then Just uid else Nothing -- | Create a fresh 'UserId', store it on C* locally together with 'SAML.UserRef', then @@ -310,10 +223,20 @@ getUserIdByScimExternalId tid email = do -- FUTUREWORK: once we support , brig will refuse to delete -- users that have an sso id, unless the request comes from spar. then we can make users -- undeletable in the team admin page, and ask admins to go talk to their IdP system. -createSamlUserWithId :: Members '[BrigAccess, SAMLUserStore] r => TeamId -> UserId -> SAML.UserRef -> Spar r () +createSamlUserWithId :: + Members + '[ Error SparError, + BrigAccess, + SAMLUserStore + ] + r => + TeamId -> + UserId -> + SAML.UserRef -> + Sem r () createSamlUserWithId teamid buid suid = do - uname <- either (throwSpar . SparBadUserName . cs) pure $ Intra.mkUserName Nothing (UrefOnly suid) - buid' <- liftSem $ BrigAccess.createSAML suid buid teamid uname ManagedByWire + uname <- either (throwSparSem . SparBadUserName . cs) pure $ Intra.mkUserName Nothing (UrefOnly suid) + buid' <- BrigAccess.createSAML suid buid teamid uname ManagedByWire assert (buid == buid') $ pure () insertUser suid buid @@ -326,14 +249,15 @@ autoprovisionSamlUser :: BrigAccess, ScimTokenStore, IdPEffect.IdP, + Error SparError, SAMLUserStore ] r => Maybe TeamId -> SAML.UserRef -> - Spar r UserId + Sem r UserId autoprovisionSamlUser mbteam suid = do - buid <- liftSem $ Id <$> Random.uuid + buid <- Id <$> Random.uuid autoprovisionSamlUserWithId mbteam buid suid pure buid @@ -345,13 +269,14 @@ autoprovisionSamlUserWithId :: BrigAccess, ScimTokenStore, IdPEffect.IdP, + Error SparError, SAMLUserStore ] r => Maybe TeamId -> UserId -> SAML.UserRef -> - Spar r () + Sem r () autoprovisionSamlUserWithId mbteam buid suid = do idp <- getIdPConfigByIssuerOptionalSPId (suid ^. uidTenant) mbteam guardReplacedIdP idp @@ -360,33 +285,33 @@ autoprovisionSamlUserWithId mbteam buid suid = do validateEmailIfExists buid suid where -- Replaced IdPs are not allowed to create new wire accounts. - guardReplacedIdP :: IdP -> Spar r () + guardReplacedIdP :: IdP -> Sem r () guardReplacedIdP idp = do unless (isNothing $ idp ^. idpExtraInfo . wiReplacedBy) $ do - throwSpar $ SparCannotCreateUsersOnReplacedIdP (cs . SAML.idPIdToST $ idp ^. idpId) + throwSparSem $ SparCannotCreateUsersOnReplacedIdP (cs . SAML.idPIdToST $ idp ^. idpId) -- IdPs in teams with scim tokens are not allowed to auto-provision. - guardScimTokens :: IdP -> Spar r () + guardScimTokens :: IdP -> Sem r () guardScimTokens idp = do let teamid = idp ^. idpExtraInfo . wiTeam - scimtoks <- wrapMonadClientSem $ ScimTokenStore.getByTeam teamid + scimtoks <- ScimTokenStore.getByTeam teamid unless (null scimtoks) $ do - throwSpar SparSamlCredentialsNotFound + throwSparSem SparSamlCredentialsNotFound -- | If user's 'NameID' is an email address and the team has email validation for SSO enabled, -- make brig initiate the email validate procedure. -validateEmailIfExists :: forall r. Members '[GalleyAccess, BrigAccess] r => UserId -> SAML.UserRef -> Spar r () +validateEmailIfExists :: forall r. Members '[GalleyAccess, BrigAccess] r => UserId -> SAML.UserRef -> Sem r () validateEmailIfExists uid = \case (SAML.UserRef _ (view SAML.nameID -> UNameIDEmail email)) -> doValidate (CI.original email) _ -> pure () where - doValidate :: SAMLEmail.Email -> Spar r () + doValidate :: SAMLEmail.Email -> Sem r () doValidate email = do enabled <- do - tid <- liftSem $ Intra.getBrigUserTeam Intra.NoPendingInvitations uid - maybe (pure False) (liftSem . GalleyAccess.isEmailValidationEnabledTeam) tid + tid <- Intra.getBrigUserTeam Intra.NoPendingInvitations uid + maybe (pure False) (GalleyAccess.isEmailValidationEnabledTeam) tid when enabled $ do - liftSem $ BrigAccess.updateEmail uid (Intra.emailFromSAML email) + BrigAccess.updateEmail uid (Intra.emailFromSAML email) -- | Check if 'UserId' is in the team that hosts the idp that owns the 'UserRef'. If so, -- register a the user under its SAML credentials and write the 'UserRef' into the @@ -394,95 +319,43 @@ validateEmailIfExists uid = \case -- -- Before returning, change account status or fail if account is nto active or pending an -- invitation. -bindUser :: Members '[BrigAccess, IdPEffect.IdP, SAMLUserStore] r => UserId -> SAML.UserRef -> Spar r UserId +bindUser :: + forall r. + Members + '[ BrigAccess, + IdPEffect.IdP, + Error SparError, + SAMLUserStore + ] + r => + UserId -> + SAML.UserRef -> + Sem r UserId bindUser buid userref = do oldStatus <- do - let err :: Spar r a - err = throwSpar . SparBindFromWrongOrNoTeam . cs . show $ buid + let err :: Sem r a + err = throwSparSem . SparBindFromWrongOrNoTeam . cs . show $ buid teamid :: TeamId <- - wrapSpar (getIdPConfigByIssuerAllowOld (userref ^. uidTenant) Nothing) >>= \case + getIdPConfigByIssuerAllowOld (userref ^. uidTenant) Nothing >>= \case Data.GetIdPFound idp -> pure $ idp ^. idpExtraInfo . wiTeam Data.GetIdPNotFound -> err Data.GetIdPDanglingId _ -> err -- database inconsistency - Data.GetIdPNonUnique is -> throwSpar $ SparUserRefInNoOrMultipleTeams (cs $ show (buid, is)) + Data.GetIdPNonUnique is -> throwSparSem $ SparUserRefInNoOrMultipleTeams (cs $ show (buid, is)) Data.GetIdPWrongTeam _ -> err -- impossible - acc <- liftSem (BrigAccess.getAccount Intra.WithPendingInvitations buid) >>= maybe err pure + acc <- BrigAccess.getAccount Intra.WithPendingInvitations buid >>= maybe err pure teamid' :: TeamId <- userTeam (accountUser acc) & maybe err pure unless (teamid' == teamid) err pure (accountStatus acc) insertUser userref buid buid <$ do - liftSem $ BrigAccess.setVeid buid (UrefOnly userref) - let err = throwSpar . SparBindFromBadAccountStatus . cs . show + BrigAccess.setVeid buid (UrefOnly userref) + let err = throwSparSem . SparBindFromBadAccountStatus . cs . show case oldStatus of Active -> pure () Suspended -> err oldStatus Deleted -> err oldStatus Ephemeral -> err oldStatus - PendingInvitation -> liftSem $ BrigAccess.setStatus buid Active - -type RealInterpretation = - '[ BindCookieStore, - AssIDStore, - AReqIDStore, - ScimExternalIdStore, - ScimUserTimesStore, - ScimTokenStore, - DefaultSsoCode, - IdPEffect.IdP, - SAMLUserStore, - Embed (Cas.Client), - BrigAccess, - GalleyAccess, - Error TTLError, - Error SparError, - -- TODO(sandy): Make this a Logger Text instead - Logger String, - Logger (TinyLog.Msg -> TinyLog.Msg), - Input Opts, - Input TinyLog.Logger, - Random, - Embed IO, - Final IO - ] - -instance r ~ RealInterpretation => SPHandler SparError (Spar r) where - type NTCTX (Spar r) = Env - nt :: forall a. Env -> Spar r a -> Handler a - nt ctx (Spar action) = do - err <- actionHandler - throwErrorAsHandlerException err - where - actionHandler :: Handler (Either SparError a) - actionHandler = - fmap join - . liftIO - . runFinal - . embedToFinal @IO - . randomToIO - . runInputConst (sparCtxLogger ctx) - . runInputConst (sparCtxOpts ctx) - . loggerToTinyLog (sparCtxLogger ctx) - . stringLoggerToTinyLog - . runError @SparError - . ttlErrorToSparError - . galleyAccessToHttp (sparCtxHttpManager ctx) (sparCtxHttpGalley ctx) - . brigAccessToHttp (sparCtxHttpManager ctx) (sparCtxHttpBrig ctx) - . interpretClientToIO (sparCtxCas ctx) - . samlUserStoreToCassandra @Cas.Client - . idPToCassandra @Cas.Client - . defaultSsoCodeToCassandra - . scimTokenStoreToCassandra - . scimUserTimesStoreToCassandra - . scimExternalIdStoreToCassandra - . aReqIDStoreToCassandra - . assIDStoreToCassandra - . bindCookieStoreToCassandra - $ runExceptT action - throwErrorAsHandlerException :: Either SparError a -> Handler a - throwErrorAsHandlerException (Left err) = - sparToServerErrorWithLogging (sparCtxLogger ctx) err >>= throwError - throwErrorAsHandlerException (Right a) = pure a + PendingInvitation -> BrigAccess.setStatus buid Active -- | The from of the response on the finalize-login request depends on the verdict (denied or -- granted), plus the choice that the client has made during the initiate-login request. Here we @@ -497,7 +370,6 @@ verdictHandler :: HasCallStack => Members '[ Random, - Input TinyLog.Logger, Logger String, GalleyAccess, BrigAccess, @@ -505,6 +377,8 @@ verdictHandler :: AReqIDStore, ScimTokenStore, IdPEffect.IdP, + Error SparError, + Reporter, SAMLUserStore ] r => @@ -512,14 +386,14 @@ verdictHandler :: Maybe TeamId -> SAML.AuthnResponse -> SAML.AccessVerdict -> - Spar r SAML.ResponseVerdict + Sem r SAML.ResponseVerdict verdictHandler cky mbteam aresp verdict = do -- [3/4.1.4.2] -- [...] If the containing message is in response to an , then -- the InResponseTo attribute MUST match the request's ID. - liftSem $ Logger.log SAML.Debug $ "entering verdictHandler: " <> show (fromBindCookie <$> cky, aresp, verdict) - reqid <- either (throwSpar . SparNoRequestRefInResponse . cs) pure $ SAML.rspInResponseTo aresp - format :: Maybe VerdictFormat <- wrapMonadClientSem $ AReqIDStore.getVerdictFormat reqid + Logger.log SAML.Debug $ "entering verdictHandler: " <> show (fromBindCookie <$> cky, aresp, verdict) + reqid <- either (throwSparSem . SparNoRequestRefInResponse . cs) pure $ SAML.rspInResponseTo aresp + format :: Maybe VerdictFormat <- AReqIDStore.getVerdictFormat reqid resp <- case format of Just (VerdictFormatWeb) -> verdictHandlerResult cky mbteam verdict >>= verdictHandlerWeb @@ -527,8 +401,8 @@ verdictHandler cky mbteam aresp verdict = do verdictHandlerResult cky mbteam verdict >>= verdictHandlerMobile granted denied Nothing -> -- (this shouldn't happen too often, see 'storeVerdictFormat') - throwSpar SparNoSuchRequest - liftSem $ Logger.log SAML.Debug $ "leaving verdictHandler: " <> show resp + throwSparSem SparNoSuchRequest + Logger.log SAML.Debug $ "leaving verdictHandler: " <> show resp pure resp data VerdictHandlerResult @@ -541,34 +415,41 @@ verdictHandlerResult :: HasCallStack => Members '[ Random, - Input TinyLog.Logger, Logger String, GalleyAccess, BrigAccess, BindCookieStore, ScimTokenStore, IdPEffect.IdP, + Error SparError, + Reporter, SAMLUserStore ] r => Maybe BindCookie -> Maybe TeamId -> SAML.AccessVerdict -> - Spar r VerdictHandlerResult + Sem r VerdictHandlerResult verdictHandlerResult bindCky mbteam verdict = do - liftSem $ Logger.log SAML.Debug $ "entering verdictHandlerResult: " <> show (fromBindCookie <$> bindCky) + Logger.log SAML.Debug $ "entering verdictHandlerResult: " <> show (fromBindCookie <$> bindCky) result <- catchVerdictErrors $ verdictHandlerResultCore bindCky mbteam verdict - liftSem $ Logger.log SAML.Debug $ "leaving verdictHandlerResult" <> show result + Logger.log SAML.Debug $ "leaving verdictHandlerResult" <> show result pure result -catchVerdictErrors :: forall r. Member (Input TinyLog.Logger) r => Spar r VerdictHandlerResult -> Spar r VerdictHandlerResult -catchVerdictErrors = (`catchError` hndlr) +catchVerdictErrors :: + forall r. + Members + '[ Reporter, + Error SparError + ] + r => + Sem r VerdictHandlerResult -> + Sem r VerdictHandlerResult +catchVerdictErrors = (`catch` hndlr) where - hndlr :: SparError -> Spar r VerdictHandlerResult + hndlr :: SparError -> Sem r VerdictHandlerResult hndlr err = do - logr <- liftSem input - -- TODO(sandy): When we remove this line, we can get rid of the @Input TinyLog.Logger@ effect - waiErr <- renderSparErrorWithLogging logr err + waiErr <- renderSparErrorWithLogging err pure $ case waiErr of Right (werr :: Wai.Error) -> VerifyHandlerError (cs $ Wai.label werr) (cs $ Wai.message werr) Left (serr :: ServerError) -> VerifyHandlerError "unknown-error" (cs (errReasonPhrase serr) <> " " <> cs (errBody serr)) @@ -576,10 +457,21 @@ catchVerdictErrors = (`catchError` hndlr) -- | If a user attempts to login presenting a new IdP issuer, but there is no entry in -- @"spar.user"@ for her: lookup @"old_issuers"@ from @"spar.idp"@ for the new IdP, and -- traverse the old IdPs in search for the old entry. Return that old entry. -findUserIdWithOldIssuer :: forall r. Members '[BrigAccess, IdPEffect.IdP, SAMLUserStore] r => Maybe TeamId -> SAML.UserRef -> Spar r (GetUserResult (SAML.UserRef, UserId)) +findUserIdWithOldIssuer :: + forall r. + Members + '[ BrigAccess, + IdPEffect.IdP, + SAMLUserStore, + Error SparError + ] + r => + Maybe TeamId -> + SAML.UserRef -> + Sem r (GetUserResult (SAML.UserRef, UserId)) findUserIdWithOldIssuer mbteam (SAML.UserRef issuer subject) = do idp <- getIdPConfigByIssuerOptionalSPId issuer mbteam - let tryFind :: GetUserResult (SAML.UserRef, UserId) -> Issuer -> Spar r (GetUserResult (SAML.UserRef, UserId)) + let tryFind :: GetUserResult (SAML.UserRef, UserId) -> Issuer -> Sem r (GetUserResult (SAML.UserRef, UserId)) tryFind found@(GetUserFound _) _ = pure found tryFind _ oldIssuer = (uref,) <$$> getUserIdByUref mbteam uref where @@ -588,11 +480,11 @@ findUserIdWithOldIssuer mbteam (SAML.UserRef issuer subject) = do -- | After a user has been found using 'findUserWithOldIssuer', update it everywhere so that -- the old IdP is not needed any more next time. -moveUserToNewIssuer :: Members '[BrigAccess, SAMLUserStore] r => SAML.UserRef -> SAML.UserRef -> UserId -> Spar r () +moveUserToNewIssuer :: Members '[BrigAccess, SAMLUserStore] r => SAML.UserRef -> SAML.UserRef -> UserId -> Sem r () moveUserToNewIssuer oldUserRef newUserRef uid = do - wrapMonadClientSem $ SAMLUserStore.insert newUserRef uid - liftSem $ BrigAccess.setVeid uid (UrefOnly newUserRef) - wrapMonadClientSem $ SAMLUserStore.delete uid oldUserRef + SAMLUserStore.insert newUserRef uid + BrigAccess.setVeid uid (UrefOnly newUserRef) + SAMLUserStore.delete uid oldUserRef verdictHandlerResultCore :: HasCallStack => @@ -604,19 +496,20 @@ verdictHandlerResultCore :: BindCookieStore, ScimTokenStore, IdPEffect.IdP, + Error SparError, SAMLUserStore ] r => Maybe BindCookie -> Maybe TeamId -> SAML.AccessVerdict -> - Spar r VerdictHandlerResult + Sem r VerdictHandlerResult verdictHandlerResultCore bindCky mbteam = \case SAML.AccessDenied reasons -> do pure $ VerifyHandlerDenied reasons SAML.AccessGranted userref -> do uid :: UserId <- do - viaBindCookie <- maybe (pure Nothing) (wrapMonadClientSem . BindCookieStore.lookup) bindCky + viaBindCookie <- maybe (pure Nothing) (BindCookieStore.lookup) bindCky viaSparCassandra <- getUserIdByUref mbteam userref -- race conditions: if the user has been created on spar, but not on brig, 'getUser' -- returns 'Nothing'. this is ok assuming 'createUser', 'bindUser' (called below) are @@ -629,10 +522,10 @@ verdictHandlerResultCore bindCky mbteam = \case SparUserRefInNoOrMultipleTeams . cs $ show (userref, viaBindCookie, viaSparCassandra, viaSparCassandraOldIssuer) case (viaBindCookie, viaSparCassandra, viaSparCassandraOldIssuer) of - (_, GetUserNoTeam, _) -> throwSpar err - (_, GetUserWrongTeam, _) -> throwSpar err - (_, _, GetUserNoTeam) -> throwSpar err - (_, _, GetUserWrongTeam) -> throwSpar err + (_, GetUserNoTeam, _) -> throwSparSem err + (_, GetUserWrongTeam, _) -> throwSparSem err + (_, _, GetUserNoTeam) -> throwSparSem err + (_, _, GetUserWrongTeam) -> throwSparSem err -- This is the first SSO authentication, so we auto-create a user. We know the user -- has not been created via SCIM because then we would've ended up in the -- "reauthentication" branch. @@ -647,16 +540,16 @@ verdictHandlerResultCore bindCky mbteam = \case -- Redundant binding (no change to Brig or Spar) | uid == uid' -> pure uid -- Attempt to use ssoid for a second Wire user - | otherwise -> throwSpar SparBindUserRefTaken + | otherwise -> throwSparSem SparBindUserRefTaken -- same two cases as above, but between last login and bind there was an issuer update. (Just uid, GetUserNotFound, GetUserFound (oldUserRef, uid')) | uid == uid' -> moveUserToNewIssuer oldUserRef userref uid >> pure uid - | otherwise -> throwSpar SparBindUserRefTaken + | otherwise -> throwSparSem SparBindUserRefTaken (Just _, GetUserFound _, GetUserFound _) -> -- to see why, consider the condition on the call to 'findUserWithOldIssuer' above. error "impossible." - liftSem $ Logger.log SAML.Debug ("granting sso login for " <> show uid) - cky <- liftSem $ BrigAccess.ssoLogin uid + Logger.log SAML.Debug ("granting sso login for " <> show uid) + cky <- BrigAccess.ssoLogin uid pure $ VerifyHandlerGranted cky uid -- | If the client is web, it will be served with an HTML page that it can process to decide whether @@ -666,7 +559,7 @@ verdictHandlerResultCore bindCky mbteam = \case -- - A title element with contents @wire:sso:@. This is chosen to be easily parseable and -- not be the title of any page sent by the IdP while it negotiates with the user. -- - The page broadcasts a message to '*', to be picked up by the app. -verdictHandlerWeb :: HasCallStack => VerdictHandlerResult -> Spar r SAML.ResponseVerdict +verdictHandlerWeb :: HasCallStack => VerdictHandlerResult -> Sem r SAML.ResponseVerdict verdictHandlerWeb = pure . \case VerifyHandlerGranted cky _uid -> successPage cky @@ -737,22 +630,22 @@ easyHtml doc = -- | If the client is mobile, it has picked error and success redirect urls (see -- 'mkVerdictGrantedFormatMobile', 'mkVerdictDeniedFormatMobile'); variables in these URLs are here -- substituted and the client is redirected accordingly. -verdictHandlerMobile :: HasCallStack => URI.URI -> URI.URI -> VerdictHandlerResult -> Spar r SAML.ResponseVerdict +verdictHandlerMobile :: (HasCallStack, Member (Error SparError) r) => URI.URI -> URI.URI -> VerdictHandlerResult -> Sem r SAML.ResponseVerdict verdictHandlerMobile granted denied = \case VerifyHandlerGranted cky uid -> mkVerdictGrantedFormatMobile granted cky uid & either - (throwSpar . SparCouldNotSubstituteSuccessURI . cs) + (throwSparSem . SparCouldNotSubstituteSuccessURI . cs) (pure . successPage cky) VerifyHandlerDenied reasons -> mkVerdictDeniedFormatMobile denied "forbidden" & either - (throwSpar . SparCouldNotSubstituteFailureURI . cs) + (throwSparSem . SparCouldNotSubstituteFailureURI . cs) (pure . forbiddenPage "forbidden" (explainDeniedReason <$> reasons)) VerifyHandlerError lbl msg -> mkVerdictDeniedFormatMobile denied lbl & either - (throwSpar . SparCouldNotSubstituteFailureURI . cs) + (throwSparSem . SparCouldNotSubstituteFailureURI . cs) (pure . forbiddenPage lbl [msg]) where forbiddenPage :: ST -> [ST] -> URI.URI -> SAML.ResponseVerdict @@ -807,13 +700,13 @@ getIdPIdByIssuerAllowOld :: Member IdPEffect.IdP r => SAML.Issuer -> Maybe TeamId -> - Spar r (GetIdPResult SAML.IdPId) + Sem r (GetIdPResult SAML.IdPId) getIdPIdByIssuerAllowOld issuer mbteam = do - mbv2 <- liftSem $ maybe (pure Nothing) (IdPEffect.getIdByIssuerWithTeam issuer) mbteam - mbv1v2 <- liftSem $ maybe (IdPEffect.getIdByIssuerWithoutTeam issuer) (pure . GetIdPFound) mbv2 + mbv2 <- maybe (pure Nothing) (IdPEffect.getIdByIssuerWithTeam issuer) mbteam + mbv1v2 <- maybe (IdPEffect.getIdByIssuerWithoutTeam issuer) (pure . GetIdPFound) mbv2 case (mbv1v2, mbteam) of (GetIdPFound idpid, Just team) -> do - liftSem (IdPEffect.getConfig idpid) >>= \case + IdPEffect.getConfig idpid >>= \case Nothing -> do pure $ GetIdPDanglingId idpid Just idp -> @@ -828,7 +721,7 @@ getIdPConfigByIssuer :: (HasCallStack, Member IdPEffect.IdP r) => SAML.Issuer -> TeamId -> - Spar r (GetIdPResult IdP) + Sem r (GetIdPResult IdP) getIdPConfigByIssuer issuer = getIdPIdByIssuer issuer >=> mapGetIdPResult @@ -837,7 +730,7 @@ getIdPConfigByIssuerAllowOld :: (HasCallStack, Member IdPEffect.IdP r) => SAML.Issuer -> Maybe TeamId -> - Spar r (GetIdPResult IdP) + Sem r (GetIdPResult IdP) getIdPConfigByIssuerAllowOld issuer = do getIdPIdByIssuerAllowOld issuer >=> mapGetIdPResult @@ -847,13 +740,13 @@ getIdPIdByIssuer :: (HasCallStack, Member IdPEffect.IdP r) => SAML.Issuer -> TeamId -> - Spar r (GetIdPResult SAML.IdPId) + Sem r (GetIdPResult SAML.IdPId) getIdPIdByIssuer issuer = getIdPIdByIssuerAllowOld issuer . Just -- | (There are probably category theoretical models for what we're doing here, but it's more -- straight-forward to just handle the one instance we need.) -mapGetIdPResult :: (HasCallStack, Member IdPEffect.IdP r) => GetIdPResult SAML.IdPId -> Spar r (GetIdPResult IdP) -mapGetIdPResult (GetIdPFound i) = liftSem (IdPEffect.getConfig i) <&> maybe (GetIdPDanglingId i) GetIdPFound +mapGetIdPResult :: (HasCallStack, Member IdPEffect.IdP r) => GetIdPResult SAML.IdPId -> Sem r (GetIdPResult IdP) +mapGetIdPResult (GetIdPFound i) = IdPEffect.getConfig i <&> maybe (GetIdPDanglingId i) GetIdPFound mapGetIdPResult GetIdPNotFound = pure GetIdPNotFound mapGetIdPResult (GetIdPDanglingId i) = pure (GetIdPDanglingId i) mapGetIdPResult (GetIdPNonUnique is) = pure (GetIdPNonUnique is) @@ -863,8 +756,8 @@ mapGetIdPResult (GetIdPWrongTeam i) = pure (GetIdPWrongTeam i) deleteTeam :: (HasCallStack, Members '[ScimTokenStore, SAMLUserStore, IdPEffect.IdP] r) => TeamId -> - Spar r () -deleteTeam team = liftSem $ do + Sem r () +deleteTeam team = do ScimTokenStore.deleteByTeam team -- Since IdPs are not shared between teams, we can look at the set of IdPs -- used by the team, and remove everything related to those IdPs, too. @@ -874,3 +767,15 @@ deleteTeam team = liftSem $ do issuer = idp ^. SAML.idpMetadata . SAML.edIssuer SAMLUserStore.deleteByIssuer issuer IdPEffect.deleteConfig idpid issuer team + +sparToServerErrorWithLogging :: Member Reporter r => SparError -> Sem r ServerError +sparToServerErrorWithLogging err = do + let errServant = sparToServerError err + Reporter.report Nothing (servantToWaiError errServant) + pure errServant + +renderSparErrorWithLogging :: Member Reporter r => SparError -> Sem r (Either ServerError Wai.Error) +renderSparErrorWithLogging err = do + let errPossiblyWai = renderSparError err + Reporter.report Nothing (either servantToWaiError id $ errPossiblyWai) + pure errPossiblyWai diff --git a/services/spar/src/Spar/CanonicalInterpreter.hs b/services/spar/src/Spar/CanonicalInterpreter.hs new file mode 100644 index 0000000000..12e9616376 --- /dev/null +++ b/services/spar/src/Spar/CanonicalInterpreter.hs @@ -0,0 +1,117 @@ +{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} + +module Spar.CanonicalInterpreter where + +import qualified Cassandra as Cas +import Control.Monad.Except +import Imports +import Polysemy +import Polysemy.Error +import Polysemy.Input (Input, runInputConst) +import Servant +import Spar.App hiding (sparToServerErrorWithLogging) +import Spar.Error +import Spar.Orphans () +import Spar.Sem.AReqIDStore (AReqIDStore) +import Spar.Sem.AReqIDStore.Cassandra (aReqIDStoreToCassandra, ttlErrorToSparError) +import Spar.Sem.AssIDStore (AssIDStore) +import Spar.Sem.AssIDStore.Cassandra (assIDStoreToCassandra) +import Spar.Sem.BindCookieStore (BindCookieStore) +import Spar.Sem.BindCookieStore.Cassandra (bindCookieStoreToCassandra) +import Spar.Sem.BrigAccess (BrigAccess) +import Spar.Sem.BrigAccess.Http (brigAccessToHttp) +import Spar.Sem.DefaultSsoCode (DefaultSsoCode) +import Spar.Sem.DefaultSsoCode.Cassandra (defaultSsoCodeToCassandra) +import Spar.Sem.GalleyAccess (GalleyAccess) +import Spar.Sem.GalleyAccess.Http (galleyAccessToHttp) +import qualified Spar.Sem.IdP as IdPEffect +import Spar.Sem.IdP.Cassandra (idPToCassandra) +import Spar.Sem.Logger (Logger) +import Spar.Sem.Logger.TinyLog (loggerToTinyLog, stringLoggerToTinyLog) +import Spar.Sem.Now (Now) +import Spar.Sem.Now.IO (nowToIO) +import Spar.Sem.Random (Random) +import Spar.Sem.Random.IO (randomToIO) +import Spar.Sem.Reporter (Reporter) +import Spar.Sem.Reporter.Wai (reporterToTinyLogWai) +import Spar.Sem.SAML2 (SAML2) +import Spar.Sem.SAML2.Library (saml2ToSaml2WebSso) +import Spar.Sem.SAMLUserStore (SAMLUserStore) +import Spar.Sem.SAMLUserStore.Cassandra (interpretClientToIO, samlUserStoreToCassandra) +import Spar.Sem.SamlProtocolSettings (SamlProtocolSettings) +import Spar.Sem.SamlProtocolSettings.Servant (sparRouteToServant) +import Spar.Sem.ScimExternalIdStore (ScimExternalIdStore) +import Spar.Sem.ScimExternalIdStore.Cassandra (scimExternalIdStoreToCassandra) +import Spar.Sem.ScimTokenStore (ScimTokenStore) +import Spar.Sem.ScimTokenStore.Cassandra (scimTokenStoreToCassandra) +import Spar.Sem.ScimUserTimesStore (ScimUserTimesStore) +import Spar.Sem.ScimUserTimesStore.Cassandra (scimUserTimesStoreToCassandra) +import qualified System.Logger as TinyLog +import Wire.API.User.Saml + +type CanonicalEffs = + '[ SAML2, + SamlProtocolSettings, + BindCookieStore, + AssIDStore, + AReqIDStore, + ScimExternalIdStore, + ScimUserTimesStore, + ScimTokenStore, + DefaultSsoCode, + IdPEffect.IdP, + SAMLUserStore, + Embed (Cas.Client), + BrigAccess, + GalleyAccess, + Error TTLError, + Error SparError, + Reporter, + -- TODO(sandy): Make this a Logger Text instead + Logger String, + Logger (TinyLog.Msg -> TinyLog.Msg), + Input Opts, + Input TinyLog.Logger, + Random, + Now, + Embed IO, + Final IO + ] + +runSparToIO :: Env -> Sem CanonicalEffs a -> IO (Either SparError a) +runSparToIO ctx action = + runFinal + . embedToFinal @IO + . nowToIO + . randomToIO + . runInputConst (sparCtxLogger ctx) + . runInputConst (sparCtxOpts ctx) + . loggerToTinyLog (sparCtxLogger ctx) + . stringLoggerToTinyLog + . reporterToTinyLogWai + . runError @SparError + . ttlErrorToSparError + . galleyAccessToHttp (sparCtxHttpManager ctx) (sparCtxHttpGalley ctx) + . brigAccessToHttp (sparCtxHttpManager ctx) (sparCtxHttpBrig ctx) + . interpretClientToIO (sparCtxCas ctx) + . samlUserStoreToCassandra + . idPToCassandra + . defaultSsoCodeToCassandra + . scimTokenStoreToCassandra + . scimUserTimesStoreToCassandra + . scimExternalIdStoreToCassandra + . aReqIDStoreToCassandra + . assIDStoreToCassandra + . bindCookieStoreToCassandra + . sparRouteToServant (saml $ sparCtxOpts ctx) + $ saml2ToSaml2WebSso action + +runSparToHandler :: Env -> Sem CanonicalEffs a -> Handler a +runSparToHandler ctx spar = do + err <- liftIO $ runSparToIO ctx spar + throwErrorAsHandlerException err + where + throwErrorAsHandlerException :: Either SparError a -> Handler a + throwErrorAsHandlerException (Left err) = + sparToServerErrorWithLogging (sparCtxLogger ctx) err >>= throwError + throwErrorAsHandlerException (Right a) = pure a diff --git a/services/spar/src/Spar/Error.hs b/services/spar/src/Spar/Error.hs index fb96e017b7..6d1e83b03d 100644 --- a/services/spar/src/Spar/Error.hs +++ b/services/spar/src/Spar/Error.hs @@ -29,7 +29,6 @@ module Spar.Error SparCustomError (..), throwSpar, sparToServerErrorWithLogging, - renderSparErrorWithLogging, rethrow, parseResponse, -- FUTUREWORK: we really shouldn't export this, but that requires that we can use our @@ -100,6 +99,12 @@ data SparCustomError | SparIdPIssuerInUse | SparProvisioningMoreThanOneIdP LT | SparProvisioningTokenLimitReached + | -- | FUTUREWORK(fisx): This constructor is used in exactly one place (see + -- "Spar.Sem.SAML2.Library"), for an error that immediately gets caught. + -- Instead, we could just use an IO exception, and catch it with + -- 'catchErrors' (see "Spar.Run"). Maybe we want to remove this case + -- altogether? Not sure. + SparInternalError LT | -- | All errors returned from SCIM handlers are wrapped into 'SparScimError' SparScimError Scim.ScimError deriving (Eq, Show) @@ -126,12 +131,6 @@ waiToServant waierr@(Wai.Error status label _ _) = errHeaders = [] } -renderSparErrorWithLogging :: MonadIO m => Log.Logger -> SparError -> m (Either ServerError Wai.Error) -renderSparErrorWithLogging logger err = do - let errPossiblyWai = renderSparError err - liftIO $ Wai.logError logger (Nothing :: Maybe Wai.Request) (either servantToWaiError id $ errPossiblyWai) - pure errPossiblyWai - renderSparError :: SparError -> Either ServerError Wai.Error renderSparError (SAML.CustomError SparNoSuchRequest) = Right $ Wai.mkError status500 "server-error" "AuthRequest seems to have disappeared (could not find verdict format)." renderSparError (SAML.CustomError (SparNoRequestRefInResponse msg)) = Right $ Wai.mkError status400 "server-error-unsupported-saml" ("The IdP needs to provide an InResponseTo attribute in the assertion: " <> msg) @@ -184,6 +183,7 @@ renderSparError (SAML.CustomError (SparProvisioningMoreThanOneIdP msg)) = Right renderSparError (SAML.CustomError SparProvisioningTokenLimitReached) = Right $ Wai.mkError status403 "token-limit-reached" "The limit of provisioning tokens per team has been reached" -- SCIM errors renderSparError (SAML.CustomError (SparScimError err)) = Left $ Scim.scimToServerError err +renderSparError (SAML.CustomError (SparInternalError err)) = Right $ Wai.mkError status500 "server-error" ("Internal error: " <> err) -- Other renderSparError (SAML.CustomServant err) = Left err diff --git a/services/spar/src/Spar/Intra/Brig.hs b/services/spar/src/Spar/Intra/Brig.hs index fd11882478..cc0be602d7 100644 --- a/services/spar/src/Spar/Intra/Brig.hs +++ b/services/spar/src/Spar/Intra/Brig.hs @@ -51,7 +51,6 @@ import Data.ByteString.Conversion import Data.Handle (Handle (fromHandle)) import Data.Id (Id (Id), TeamId, UserId) import Data.Misc (PlainTextPassword) -import Data.String.Conversions import Imports import Network.HTTP.Types.Method import qualified Network.Wai.Utilities.Error as Wai @@ -65,11 +64,9 @@ import Wire.API.User.Scim (ValidExternalId (..), runValidExternalId) ---------------------------------------------------------------------- +-- | FUTUREWORK: this is redundantly defined in "Spar.Intra.BrigApp". veidToUserSSOId :: ValidExternalId -> UserSSOId -veidToUserSSOId = runValidExternalId urefToUserSSOId (UserScimExternalId . fromEmail) - -urefToUserSSOId :: SAML.UserRef -> UserSSOId -urefToUserSSOId (SAML.UserRef t s) = UserSSOId (cs $ SAML.encodeElem t) (cs $ SAML.encodeElem s) +veidToUserSSOId = runValidExternalId UserSSOId (UserScimExternalId . fromEmail) -- | Similar to 'Network.Wire.Client.API.Auth.tokenResponse', but easier: we just need to set the -- cookie in the response, and the redirect will make the client negotiate a fresh auth token. @@ -102,7 +99,7 @@ createBrigUserSAML uref (Id buid) teamid uname managedBy = do newUser = (emptyNewUser uname) { newUserUUID = Just buid, - newUserIdentity = Just (SSOIdentity (urefToUserSSOId uref) Nothing Nothing), + newUserIdentity = Just (SSOIdentity (UserSSOId uref) Nothing Nothing), newUserOrigin = Just (NewUserOriginTeamUser . NewTeamMemberSSO $ teamid), newUserManagedBy = Just managedBy } diff --git a/services/spar/src/Spar/Intra/BrigApp.hs b/services/spar/src/Spar/Intra/BrigApp.hs index 6c4d2d34f0..68777a7db0 100644 --- a/services/spar/src/Spar/Intra/BrigApp.hs +++ b/services/spar/src/Spar/Intra/BrigApp.hs @@ -27,10 +27,6 @@ module Spar.Intra.BrigApp veidFromUserSSOId, mkUserName, renderValidExternalId, - emailFromSAML, - emailToSAML, - emailToSAMLNameID, - emailFromSAMLNameID, HavePendingInvitations (..), getBrigUser, getBrigUserTeam, @@ -38,6 +34,12 @@ module Spar.Intra.BrigApp authorizeScimTokenManagement, parseResponse, giveDefaultHandle, + + -- * re-exports, mostly for historical reasons and lazyness + emailFromSAML, + emailToSAML, + emailToSAMLNameID, + emailFromSAMLNameID, ) where @@ -55,7 +57,6 @@ import Imports import Polysemy import Polysemy.Error import qualified SAML2.WebSSO as SAML -import qualified SAML2.WebSSO.Types.Email as SAMLEmail import Spar.Error import Spar.Sem.BrigAccess (BrigAccess) import qualified Spar.Sem.BrigAccess as BrigAccess @@ -66,23 +67,16 @@ import Wire.API.User.Scim (ValidExternalId (..), runValidExternalId) ---------------------------------------------------------------------- +-- | FUTUREWORK: this is redundantly defined in "Spar.Intra.Brig" veidToUserSSOId :: ValidExternalId -> UserSSOId -veidToUserSSOId = runValidExternalId urefToUserSSOId (UserScimExternalId . fromEmail) - -urefToUserSSOId :: SAML.UserRef -> UserSSOId -urefToUserSSOId (SAML.UserRef t s) = UserSSOId (cs $ SAML.encodeElem t) (cs $ SAML.encodeElem s) +veidToUserSSOId = runValidExternalId UserSSOId (UserScimExternalId . fromEmail) veidFromUserSSOId :: MonadError String m => UserSSOId -> m ValidExternalId veidFromUserSSOId = \case - UserSSOId tenant subject -> - case (SAML.decodeElem $ cs tenant, SAML.decodeElem $ cs subject) of - (Right t, Right s) -> do - let uref = SAML.UserRef t s - case urefToEmail uref of - Nothing -> pure $ UrefOnly uref - Just email -> pure $ EmailAndUref email uref - (Left msg, _) -> throwError msg - (_, Left msg) -> throwError msg + UserSSOId uref -> + case urefToEmail uref of + Nothing -> pure $ UrefOnly uref + Just email -> pure $ EmailAndUref email uref UserScimExternalId email -> maybe (throwError "externalId not an email and no issuer") @@ -125,22 +119,6 @@ mkUserName Nothing = renderValidExternalId :: ValidExternalId -> Maybe Text renderValidExternalId = runValidExternalId urefToExternalId (Just . fromEmail) -emailFromSAML :: HasCallStack => SAMLEmail.Email -> Email -emailFromSAML = fromJust . parseEmail . SAMLEmail.render - -emailToSAML :: HasCallStack => Email -> SAMLEmail.Email -emailToSAML = CI.original . fromRight (error "emailToSAML") . SAMLEmail.validate . toByteString - --- | FUTUREWORK(fisx): if saml2-web-sso exported the 'NameID' constructor, we could make this --- function total without all that praying and hoping. -emailToSAMLNameID :: HasCallStack => Email -> SAML.NameID -emailToSAMLNameID = fromRight (error "impossible") . SAML.emailNameID . fromEmail - -emailFromSAMLNameID :: HasCallStack => SAML.NameID -> Maybe Email -emailFromSAMLNameID nid = case nid ^. SAML.nameID of - SAML.UNameIDEmail email -> Just . emailFromSAML . CI.original $ email - _ -> Nothing - ---------------------------------------------------------------------- getBrigUser :: (HasCallStack, Member BrigAccess r) => HavePendingInvitations -> UserId -> Sem r (Maybe User) diff --git a/services/spar/src/Spar/Scim.hs b/services/spar/src/Spar/Scim.hs index ac883f39d3..95ae0d4db5 100644 --- a/services/spar/src/Spar/Scim.hs +++ b/services/spar/src/Spar/Scim.hs @@ -64,23 +64,19 @@ module Spar.Scim ) where -import Control.Monad.Catch (try) -import Control.Monad.Except import Data.String.Conversions (cs) import Imports import Polysemy -import Polysemy.Error (Error) -import Polysemy.Input (Input, input) +import Polysemy.Error (Error, fromExceptionSem, runError, throw, try) +import Polysemy.Input (Input) import qualified SAML2.WebSSO as SAML import Servant import Servant.API.Generic import Servant.Server.Generic (AsServerT) -import Spar.App (Spar (..)) +import Spar.App (sparToServerErrorWithLogging, throwSparSem) import Spar.Error ( SparCustomError (SparScimError), SparError, - sparToServerErrorWithLogging, - throwSpar, ) import Spar.Scim.Auth import Spar.Scim.User @@ -88,13 +84,14 @@ import Spar.Sem.BrigAccess (BrigAccess) import Spar.Sem.GalleyAccess (GalleyAccess) import qualified Spar.Sem.IdP as IdPEffect import Spar.Sem.Logger (Logger) +import Spar.Sem.Now (Now) import Spar.Sem.Random (Random) +import Spar.Sem.Reporter (Reporter) import Spar.Sem.SAMLUserStore (SAMLUserStore) import Spar.Sem.ScimExternalIdStore (ScimExternalIdStore) import Spar.Sem.ScimTokenStore (ScimTokenStore) import Spar.Sem.ScimUserTimesStore (ScimUserTimesStore) import System.Logger (Msg) -import qualified System.Logger as TinyLog import qualified Web.Scim.Capabilities.MetaSchema as Scim.Meta import qualified Web.Scim.Class.Auth as Scim.Auth import qualified Web.Scim.Class.User as Scim.User @@ -116,22 +113,25 @@ configuration = Scim.Meta.empty apiScim :: forall r. Members - '[ Input TinyLog.Logger, - Random, + '[ Random, Input Opts, Logger (Msg -> Msg), Logger String, + Now, Error SparError, GalleyAccess, BrigAccess, ScimExternalIdStore, ScimUserTimesStore, ScimTokenStore, + Reporter, IdPEffect.IdP, + -- TODO(sandy): Only necessary for 'fromExceptionSem'. But can these errors even happen? + Final IO, SAMLUserStore ] r => - ServerT APIScim (Spar r) + ServerT APIScim (Sem r) apiScim = hoistScim (toServant (server configuration)) :<|> apiScimToken @@ -139,7 +139,7 @@ apiScim = hoistScim = hoistServer (Proxy @(ScimSiteAPI SparTag)) - (wrapScimErrors . Scim.fromScimHandler (throwSpar . SparScimError)) + (wrapScimErrors . Scim.fromScimHandler (throwSparSem . SparScimError)) -- Wrap /all/ errors into the format required by SCIM, even server exceptions that have -- nothing to do with SCIM. -- @@ -147,34 +147,33 @@ apiScim = -- Let's hope that SCIM clients can handle non-SCIM-formatted errors -- properly. See -- for why it's hard to catch impure exceptions. - wrapScimErrors :: Spar r a -> Spar r a - wrapScimErrors act = Spar $ - ExceptT $ do - result :: Either SomeException (Either SparError a) <- try $ runExceptT $ fromSpar $ act - case result of - Left someException -> do - -- We caught an exception that's not a Spar exception at all. It is wrapped into - -- Scim.serverError. - pure . Left . SAML.CustomError . SparScimError $ - Scim.serverError (cs (displayException someException)) - Right err@(Left (SAML.CustomError (SparScimError _))) -> - -- We caught a 'SparScimError' exception. It is left as-is. - pure err - Right (Left sparError) -> do - -- We caught some other Spar exception. It is rendered and wrapped into a scim error - -- with the same status and message, and no scim error type. - logger <- input @TinyLog.Logger - err :: ServerError <- embedFinal @IO $ sparToServerErrorWithLogging logger sparError - pure . Left . SAML.CustomError . SparScimError $ - Scim.ScimError - { schemas = [Scim.Schema.Error20], - status = Scim.Status $ errHTTPCode err, - scimType = Nothing, - detail = Just . cs $ errBody err - } - Right (Right x) -> do - -- No exceptions! Good. - pure $ Right x + wrapScimErrors :: Sem r a -> Sem r a + wrapScimErrors act = do + result :: Either SomeException (Either SparError a) <- + runError $ fromExceptionSem @SomeException $ raise $ try @SparError act + case result of + Left someException -> do + -- We caught an exception that's not a Spar exception at all. It is wrapped into + -- Scim.serverError. + throw . SAML.CustomError . SparScimError $ + Scim.serverError (cs (displayException someException)) + Right (Left err@(SAML.CustomError (SparScimError _))) -> + -- We caught a 'SparScimError' exception. It is left as-is. + throw err + Right (Left sparError) -> do + -- We caught some other Spar exception. It is rendered and wrapped into a scim error + -- with the same status and message, and no scim error type. + err :: ServerError <- sparToServerErrorWithLogging sparError + throw . SAML.CustomError . SparScimError $ + Scim.ScimError + { schemas = [Scim.Schema.Error20], + status = Scim.Status $ errHTTPCode err, + scimType = Nothing, + detail = Just . cs $ errBody err + } + Right (Right x) -> do + -- No exceptions! Good. + pure x -- | This is similar to 'Scim.siteServer, but does not include the 'Scim.groupServer', -- as we don't support it (we don't implement 'Web.Scim.Class.Group.GroupDB'). diff --git a/services/spar/src/Spar/Scim/Auth.hs b/services/spar/src/Spar/Scim/Auth.hs index 6b8241f8c4..f3ae450783 100644 --- a/services/spar/src/Spar/Scim/Auth.hs +++ b/services/spar/src/Spar/Scim/Auth.hs @@ -39,7 +39,6 @@ import Control.Lens hiding (Strict, (.=)) import qualified Data.ByteString.Base64 as ES import Data.Id (ScimTokenId, UserId) import Data.String.Conversions (cs) -import Data.Time (getCurrentTime) import Imports -- FUTUREWORK: these imports are not very handy. split up Spar.Scim into -- Spar.Scim.{Core,User,Group} to avoid at least some of the hscim name clashes? @@ -49,13 +48,15 @@ import Polysemy.Error import Polysemy.Input import qualified SAML2.WebSSO as SAML import Servant (NoContent (NoContent), ServerT, (:<|>) ((:<|>))) -import Spar.App (Spar, liftSem, wrapMonadClientSem) +import Spar.App (throwSparSem) import qualified Spar.Error as E import qualified Spar.Intra.BrigApp as Intra.Brig import Spar.Sem.BrigAccess (BrigAccess) import qualified Spar.Sem.BrigAccess as BrigAccess import Spar.Sem.GalleyAccess (GalleyAccess) import qualified Spar.Sem.IdP as IdPEffect +import Spar.Sem.Now (Now) +import qualified Spar.Sem.Now as Now import Spar.Sem.Random (Random) import qualified Spar.Sem.Random as Random import Spar.Sem.ScimTokenStore (ScimTokenStore) @@ -68,14 +69,14 @@ import Wire.API.User.Saml (Opts, maxScimTokens) import Wire.API.User.Scim -- | An instance that tells @hscim@ how authentication should be done for SCIM routes. -instance Member ScimTokenStore r => Scim.Class.Auth.AuthDB SparTag (Spar r) where +instance Member ScimTokenStore r => Scim.Class.Auth.AuthDB SparTag (Sem r) where -- Validate and resolve a given token - authCheck :: Maybe ScimToken -> Scim.ScimHandler (Spar r) ScimTokenInfo + authCheck :: Maybe ScimToken -> Scim.ScimHandler (Sem r) ScimTokenInfo authCheck Nothing = Scim.throwScim (Scim.unauthorized "Token not provided") authCheck (Just token) = maybe (Scim.throwScim (Scim.unauthorized "Invalid token")) pure - =<< lift (wrapMonadClientSem (ScimTokenStore.lookup token)) + =<< lift (ScimTokenStore.lookup token) ---------------------------------------------------------------------------- -- Token API @@ -91,11 +92,12 @@ apiScimToken :: GalleyAccess, BrigAccess, ScimTokenStore, + Now, IdPEffect.IdP, Error E.SparError ] r => - ServerT APIScimToken (Spar r) + ServerT APIScimToken (Sem r) apiScimToken = createScimToken :<|> deleteScimToken @@ -113,6 +115,7 @@ createScimToken :: BrigAccess, ScimTokenStore, IdPEffect.IdP, + Now, Error E.SparError ] r => @@ -120,31 +123,35 @@ createScimToken :: Maybe UserId -> -- | Request body CreateScimToken -> - Spar r CreateScimTokenResponse + Sem r CreateScimTokenResponse createScimToken zusr CreateScimToken {..} = do let descr = createScimTokenDescr - teamid <- liftSem $ Intra.Brig.authorizeScimTokenManagement zusr - liftSem $ BrigAccess.ensureReAuthorised zusr createScimTokenPassword - tokenNumber <- fmap length $ wrapMonadClientSem $ ScimTokenStore.getByTeam teamid - maxTokens <- liftSem $ inputs maxScimTokens + teamid <- Intra.Brig.authorizeScimTokenManagement zusr + BrigAccess.ensureReAuthorised zusr createScimTokenPassword + tokenNumber <- fmap length $ ScimTokenStore.getByTeam teamid + maxTokens <- inputs maxScimTokens unless (tokenNumber < maxTokens) $ - E.throwSpar E.SparProvisioningTokenLimitReached - idps <- wrapMonadClientSem $ IdPEffect.getConfigsByTeam teamid + throwSparSem E.SparProvisioningTokenLimitReached + idps <- IdPEffect.getConfigsByTeam teamid - let caseOneOrNoIdP :: Maybe SAML.IdPId -> Spar r CreateScimTokenResponse + let caseOneOrNoIdP :: Maybe SAML.IdPId -> Sem r CreateScimTokenResponse caseOneOrNoIdP midpid = do - token <- liftSem $ ScimToken . cs . ES.encode <$> Random.bytes 32 - tokenid <- liftSem $ Random.scimTokenId - now <- liftIO getCurrentTime + token <- ScimToken . cs . ES.encode <$> Random.bytes 32 + tokenid <- Random.scimTokenId + -- FUTUREWORK(fisx): the fact that we're using @Now.get@ + -- here means that the 'Now' effect should not contain + -- types from saml2-web-sso. We can just use 'UTCTime' + -- there, right? + now <- Now.get let info = ScimTokenInfo { stiId = tokenid, stiTeam = teamid, - stiCreatedAt = now, + stiCreatedAt = SAML.fromTime now, stiIdP = midpid, stiDescr = descr } - wrapMonadClientSem $ ScimTokenStore.insert token info + ScimTokenStore.insert token info pure $ CreateScimTokenResponse token info case idps of @@ -154,7 +161,7 @@ createScimToken zusr CreateScimToken {..} = do -- be changed. currently, it relies on the fact that there is never more than one IdP. -- https://wearezeta.atlassian.net/browse/SQSERVICES-165 _ -> - E.throwSpar $ + throwSparSem $ E.SparProvisioningMoreThanOneIdP "SCIM tokens can only be created for a team with at most one IdP" @@ -166,10 +173,10 @@ deleteScimToken :: -- | Who is trying to delete a token Maybe UserId -> ScimTokenId -> - Spar r NoContent + Sem r NoContent deleteScimToken zusr tokenid = do - teamid <- liftSem $ Intra.Brig.authorizeScimTokenManagement zusr - wrapMonadClientSem $ ScimTokenStore.delete teamid tokenid + teamid <- Intra.Brig.authorizeScimTokenManagement zusr + ScimTokenStore.delete teamid tokenid pure NoContent -- | > docs/reference/provisioning/scim-token.md {#RefScimTokenList} @@ -180,7 +187,7 @@ listScimTokens :: Members '[GalleyAccess, BrigAccess, ScimTokenStore, Error E.SparError] r => -- | Who is trying to list tokens Maybe UserId -> - Spar r ScimTokenList + Sem r ScimTokenList listScimTokens zusr = do - teamid <- liftSem $ Intra.Brig.authorizeScimTokenManagement zusr - ScimTokenList <$> wrapMonadClientSem (ScimTokenStore.getByTeam teamid) + teamid <- Intra.Brig.authorizeScimTokenManagement zusr + ScimTokenList <$> ScimTokenStore.getByTeam teamid diff --git a/services/spar/src/Spar/Scim/User.hs b/services/spar/src/Spar/Scim/User.hs index d74b3a65dc..6b1499dcc5 100644 --- a/services/spar/src/Spar/Scim/User.hs +++ b/services/spar/src/Spar/Scim/User.hs @@ -66,7 +66,7 @@ import Network.URI (URI, parseURI) import Polysemy import Polysemy.Input import qualified SAML2.WebSSO as SAML -import Spar.App (GetUserResult (..), Spar, getUserIdByScimExternalId, getUserIdByUref, liftSem, validateEmailIfExists, wrapMonadClientSem) +import Spar.App (GetUserResult (..), getUserIdByScimExternalId, getUserIdByUref, validateEmailIfExists) import qualified Spar.Intra.BrigApp as Brig import Spar.Scim.Auth () import Spar.Scim.Types (normalizeLikeStored) @@ -76,6 +76,8 @@ import Spar.Sem.GalleyAccess (GalleyAccess) import qualified Spar.Sem.IdP as IdPEffect import Spar.Sem.Logger (Logger) import qualified Spar.Sem.Logger as Logger +import Spar.Sem.Now (Now) +import qualified Spar.Sem.Now as Now import Spar.Sem.Random (Random) import qualified Spar.Sem.Random as Random import Spar.Sem.SAMLUserStore (SAMLUserStore) @@ -115,6 +117,7 @@ instance Logger String, Random, Input Opts, + Now, GalleyAccess, BrigAccess, ScimExternalIdStore, @@ -123,12 +126,12 @@ instance SAMLUserStore ] r => - Scim.UserDB ST.SparTag (Spar r) + Scim.UserDB ST.SparTag (Sem r) where getUsers :: ScimTokenInfo -> Maybe Scim.Filter -> - Scim.ScimHandler (Spar r) (Scim.ListResponse (Scim.StoredUser ST.SparTag)) + Scim.ScimHandler (Sem r) (Scim.ListResponse (Scim.StoredUser ST.SparTag)) getUsers _ Nothing = do throwError $ Scim.badRequest Scim.TooMany (Just "Please specify a filter when getting users.") getUsers tokeninfo@ScimTokenInfo {stiTeam, stiIdP} (Just filter') = @@ -138,7 +141,7 @@ instance . logFilter filter' ) $ do - mIdpConfig <- maybe (pure Nothing) (lift . wrapMonadClientSem . IdPEffect.getConfig) stiIdP + mIdpConfig <- maybe (pure Nothing) (lift . IdPEffect.getConfig) stiIdP case filter' of Scim.FilterAttrCompare (Scim.AttrPath schema attrName _subAttr) Scim.OpEq (Scim.ValString val) | Scim.isUserSchema schema -> do @@ -153,7 +156,7 @@ instance getUser :: ScimTokenInfo -> UserId -> - Scim.ScimHandler (Spar r) (Scim.StoredUser ST.SparTag) + Scim.ScimHandler (Sem r) (Scim.StoredUser ST.SparTag) getUser tokeninfo@ScimTokenInfo {stiTeam, stiIdP} uid = logScim ( logFunction "Spar.Scim.User.getUser" @@ -161,9 +164,9 @@ instance . logTokenInfo tokeninfo ) $ do - mIdpConfig <- maybe (pure Nothing) (lift . wrapMonadClientSem . IdPEffect.getConfig) stiIdP + mIdpConfig <- maybe (pure Nothing) (lift . IdPEffect.getConfig) stiIdP let notfound = Scim.notFound "User" (idToText uid) - brigUser <- lift (liftSem $ BrigAccess.getAccount Brig.WithPendingInvitations uid) >>= maybe (throwError notfound) pure + brigUser <- lift (BrigAccess.getAccount Brig.WithPendingInvitations uid) >>= maybe (throwError notfound) pure unless (userTeam (accountUser brigUser) == Just stiTeam) (throwError notfound) case Brig.veidFromBrigUser (accountUser brigUser) ((^. SAML.idpMetadata . SAML.edIssuer) <$> mIdpConfig) of Right veid -> synthesizeStoredUser brigUser veid @@ -172,18 +175,18 @@ instance postUser :: ScimTokenInfo -> Scim.User ST.SparTag -> - Scim.ScimHandler (Spar r) (Scim.StoredUser ST.SparTag) - postUser tokinfo user = createValidScimUser tokinfo =<< validateScimUser tokinfo user + Scim.ScimHandler (Sem r) (Scim.StoredUser ST.SparTag) + postUser tokinfo user = createValidScimUser tokinfo =<< validateScimUser "post" tokinfo user putUser :: ScimTokenInfo -> UserId -> Scim.User ST.SparTag -> - Scim.ScimHandler (Spar r) (Scim.StoredUser ST.SparTag) + Scim.ScimHandler (Sem r) (Scim.StoredUser ST.SparTag) putUser tokinfo uid newScimUser = - updateValidScimUser tokinfo uid =<< validateScimUser tokinfo newScimUser + updateValidScimUser tokinfo uid =<< validateScimUser "put" tokinfo newScimUser - deleteUser :: ScimTokenInfo -> UserId -> Scim.ScimHandler (Spar r) () + deleteUser :: ScimTokenInfo -> UserId -> Scim.ScimHandler (Sem r) () deleteUser tokeninfo uid = logScim ( logFunction "Spar.Scim.User.deleteUser" @@ -199,20 +202,21 @@ instance -- 'ValidScimUser''. validateScimUser :: forall m r. - (m ~ Scim.ScimHandler (Spar r)) => + (m ~ Scim.ScimHandler (Sem r)) => Members '[Input Opts, IdPEffect.IdP] r => + Text -> -- | Used to decide what IdP to assign the user to ScimTokenInfo -> Scim.User ST.SparTag -> m ST.ValidScimUser -validateScimUser tokinfo user = do +validateScimUser errloc tokinfo user = do mIdpConfig <- tokenInfoToIdP tokinfo - richInfoLimit <- lift $ liftSem $ inputs richInfoLimit - validateScimUser' mIdpConfig richInfoLimit user + richInfoLimit <- lift $ inputs richInfoLimit + validateScimUser' errloc mIdpConfig richInfoLimit user -tokenInfoToIdP :: Member IdPEffect.IdP r => ScimTokenInfo -> Scim.ScimHandler (Spar r) (Maybe IdP) +tokenInfoToIdP :: Member IdPEffect.IdP r => ScimTokenInfo -> Scim.ScimHandler (Sem r) (Maybe IdP) tokenInfoToIdP ScimTokenInfo {stiIdP} = do - maybe (pure Nothing) (lift . wrapMonadClientSem . IdPEffect.getConfig) stiIdP + maybe (pure Nothing) (lift . IdPEffect.getConfig) stiIdP -- | Validate a handle (@userName@). validateHandle :: MonadError Scim.ScimError m => Text -> m Handle @@ -251,24 +255,26 @@ validateHandle txt = case parseHandle txt of validateScimUser' :: forall m. (MonadError Scim.ScimError m) => + -- | Error location (call site, for debugging) + Text -> -- | IdP that the resulting user will be assigned to Maybe IdP -> -- | Rich info limit Int -> Scim.User ST.SparTag -> m ST.ValidScimUser -validateScimUser' midp richInfoLimit user = do +validateScimUser' errloc midp richInfoLimit user = do unless (isNothing $ Scim.password user) $ throwError $ Scim.badRequest Scim.InvalidValue - (Just "Setting user passwords is not supported for security reasons.") + (Just $ "Setting user passwords is not supported for security reasons. (" <> errloc <> ")") veid <- mkValidExternalId midp (Scim.externalId user) handl <- validateHandle . Text.toLower . Scim.userName $ user -- FUTUREWORK: 'Scim.userName' should be case insensitive; then the toLower here would -- be a little less brittle. uname <- do - let err = throwError . Scim.badRequest Scim.InvalidValue . Just . cs + let err msg = throwError . Scim.badRequest Scim.InvalidValue . Just $ cs msg <> " (" <> errloc <> ")" either err pure $ Brig.mkUserName (Scim.displayName user) veid richInfo <- validateRichInfo (Scim.extra user ^. ST.sueRichInfo) let active = Scim.active user @@ -288,6 +294,9 @@ validateScimUser' midp richInfoLimit user = do <> show richInfoLimit <> " characters, but got " <> show sze + <> " (" + <> cs errloc + <> ")" ) ) { Scim.status = Scim.Status 413 @@ -308,7 +317,7 @@ mkValidExternalId _ Nothing = do throwError $ Scim.badRequest Scim.InvalidValue - (Just "externalId is required for SAML users") + (Just "externalId is required") mkValidExternalId Nothing (Just extid) = do let err = Scim.badRequest @@ -338,7 +347,7 @@ mkValidExternalId (Just idp) (Just extid) = do Scim.InvalidValue (Just $ "Can't construct a subject ID from externalId: " <> Text.pack err) -logScim :: forall r a. (Member (Logger (Msg -> Msg)) r) => (Msg -> Msg) -> Scim.ScimHandler (Spar r) a -> Scim.ScimHandler (Spar r) a +logScim :: forall r a. (Member (Logger (Msg -> Msg)) r) => (Msg -> Msg) -> Scim.ScimHandler (Sem r) a -> Scim.ScimHandler (Sem r) a logScim context action = flip mapExceptT action $ \action' -> do eith <- action' @@ -348,10 +357,10 @@ logScim context action = case Scim.detail e of Just d -> d Nothing -> cs (Aeson.encode e) - liftSem $ Logger.warn $ context . Log.msg errorMsg + Logger.warn $ context . Log.msg errorMsg pure (Left e) Right x -> do - liftSem $ Logger.info $ context . Log.msg @Text "call without exception" + Logger.info $ context . Log.msg @Text "call without exception" pure (Right x) logEmail :: Email -> (Msg -> Msg) @@ -391,9 +400,10 @@ veidEmail (ST.EmailOnly email) = Just email -- This is the pain and the price you pay for the horribleness called MTL createValidScimUser :: forall m r. - (m ~ Scim.ScimHandler (Spar r)) => + (m ~ Scim.ScimHandler (Sem r)) => Members '[ Random, + Now, Input Opts, Logger (Msg -> Msg), Logger String, @@ -427,25 +437,24 @@ createValidScimUser tokeninfo@ScimTokenInfo {stiTeam} vsu@(ST.ValidScimUser veid buid <- ST.runValidExternalId ( \uref -> - liftSem $ do + do uid <- Id <$> Random.uuid BrigAccess.createSAML uref uid stiTeam name ManagedByScim ) ( \email -> do - liftSem $ BrigAccess.createNoSAML email stiTeam name + BrigAccess.createNoSAML email stiTeam name ) veid - liftSem $ Logger.debug ("createValidScimUser: brig says " <> show buid) + Logger.debug ("createValidScimUser: brig says " <> show buid) -- {If we crash now, we have an active user that cannot login. And can not -- be bound this will be a zombie user that needs to be manually cleaned -- up. We should consider making setUserHandle part of createUser and -- making it transactional. If the user redoes the POST A new standalone -- user will be created.} - liftSem $ do - BrigAccess.setHandle buid handl - BrigAccess.setRichInfo buid richInfo + BrigAccess.setHandle buid handl + BrigAccess.setRichInfo buid richInfo pure buid -- {If we crash now, a POST retry will fail with 409 user already exists. @@ -458,13 +467,13 @@ createValidScimUser tokeninfo@ScimTokenInfo {stiTeam} vsu@(ST.ValidScimUser veid -- to reload the Account from brig. storedUser <- do acc <- - lift (liftSem $ BrigAccess.getAccount Brig.WithPendingInvitations buid) + lift (BrigAccess.getAccount Brig.WithPendingInvitations buid) >>= maybe (throwError $ Scim.serverError "Server error: user vanished") pure synthesizeStoredUser acc veid - lift $ liftSem $ Logger.debug ("createValidScimUser: spar says " <> show storedUser) + lift $ Logger.debug ("createValidScimUser: spar says " <> show storedUser) -- {(arianvp): these two actions we probably want to make transactional.} - lift . wrapMonadClientSem $ do + lift $ do -- Store scim timestamps, saml credentials, scim externalId locally in spar. ScimUserTimesStore.write storedUser ST.runValidExternalId @@ -477,10 +486,10 @@ createValidScimUser tokeninfo@ScimTokenInfo {stiTeam} vsu@(ST.ValidScimUser veid -- {suspension via scim: if we don't reach the following line, the user will be active.} lift $ do - old <- liftSem $ BrigAccess.getStatus buid + old <- BrigAccess.getStatus buid let new = ST.scimActiveFlagToAccountStatus old (Scim.unScimBool <$> active) active = Scim.active . Scim.value . Scim.thing $ storedUser - when (new /= old) $ liftSem $ BrigAccess.setStatus buid new + when (new /= old) $ BrigAccess.setStatus buid new pure storedUser -- TODO(arianvp): how do we get this safe w.r.t. race conditions / crashes? @@ -491,6 +500,7 @@ updateValidScimUser :: Input Opts, Logger (Msg -> Msg), Logger String, + Now, GalleyAccess, BrigAccess, ScimExternalIdStore, @@ -499,7 +509,7 @@ updateValidScimUser :: SAMLUserStore ] r => - (m ~ Scim.ScimHandler (Spar r)) => + (m ~ Scim.ScimHandler (Sem r)) => ScimTokenInfo -> UserId -> ST.ValidScimUser -> @@ -515,7 +525,7 @@ updateValidScimUser tokinfo@ScimTokenInfo {stiTeam} uid newValidScimUser = oldScimStoredUser :: Scim.StoredUser ST.SparTag <- Scim.getUser tokinfo uid oldValidScimUser :: ST.ValidScimUser <- - validateScimUser tokinfo . Scim.value . Scim.thing $ oldScimStoredUser + validateScimUser "recover-old-value" tokinfo . Scim.value . Scim.thing $ oldScimStoredUser -- assertions about new valid scim user that cannot be checked in 'validateScimUser' because -- they differ from the ones in 'createValidScimUser'. @@ -535,22 +545,21 @@ updateValidScimUser tokinfo@ScimTokenInfo {stiTeam} uid newValidScimUser = _ -> pure () when (newValidScimUser ^. ST.vsuName /= oldValidScimUser ^. ST.vsuName) $ do - liftSem $ BrigAccess.setName uid (newValidScimUser ^. ST.vsuName) + BrigAccess.setName uid (newValidScimUser ^. ST.vsuName) when (oldValidScimUser ^. ST.vsuHandle /= newValidScimUser ^. ST.vsuHandle) $ do - liftSem $ BrigAccess.setHandle uid (newValidScimUser ^. ST.vsuHandle) + BrigAccess.setHandle uid (newValidScimUser ^. ST.vsuHandle) when (oldValidScimUser ^. ST.vsuRichInfo /= newValidScimUser ^. ST.vsuRichInfo) $ do - liftSem $ BrigAccess.setRichInfo uid (newValidScimUser ^. ST.vsuRichInfo) + BrigAccess.setRichInfo uid (newValidScimUser ^. ST.vsuRichInfo) - liftSem $ - BrigAccess.getStatusMaybe uid >>= \case - Nothing -> pure () - Just old -> do - let new = ST.scimActiveFlagToAccountStatus old (Just $ newValidScimUser ^. ST.vsuActive) - when (new /= old) $ BrigAccess.setStatus uid new + BrigAccess.getStatusMaybe uid >>= \case + Nothing -> pure () + Just old -> do + let new = ST.scimActiveFlagToAccountStatus old (Just $ newValidScimUser ^. ST.vsuActive) + when (new /= old) $ BrigAccess.setStatus uid new - wrapMonadClientSem $ ScimUserTimesStore.write newScimStoredUser + ScimUserTimesStore.write newScimStoredUser pure newScimStoredUser updateVsuUref :: @@ -565,18 +574,17 @@ updateVsuUref :: UserId -> ST.ValidExternalId -> ST.ValidExternalId -> - Spar r () + Sem r () updateVsuUref team uid old new = do let geturef = ST.runValidExternalId Just (const Nothing) case (geturef old, geturef new) of (mo, mn@(Just newuref)) | mo /= mn -> validateEmailIfExists uid newuref _ -> pure () - wrapMonadClientSem $ do - old & ST.runValidExternalId (SAMLUserStore.delete uid) (ScimExternalIdStore.delete team) - new & ST.runValidExternalId (`SAMLUserStore.insert` uid) (\email -> ScimExternalIdStore.insert team email uid) + old & ST.runValidExternalId (SAMLUserStore.delete uid) (ScimExternalIdStore.delete team) + new & ST.runValidExternalId (`SAMLUserStore.insert` uid) (\email -> ScimExternalIdStore.insert team email uid) - liftSem $ BrigAccess.setVeid uid new + BrigAccess.setVeid uid new toScimStoredUser' :: HasCallStack => @@ -609,13 +617,13 @@ toScimStoredUser' createdAt lastChangedAt baseuri uid usr = } updScimStoredUser :: - forall m. - (SAML.HasNow m) => + forall r. + Member Now r => Scim.User ST.SparTag -> Scim.StoredUser ST.SparTag -> - m (Scim.StoredUser ST.SparTag) + Sem r (Scim.StoredUser ST.SparTag) updScimStoredUser usr storedusr = do - SAML.Time (toUTCTimeMillis -> now) <- SAML.getNow + SAML.Time (toUTCTimeMillis -> now) <- Now.get pure $ updScimStoredUser' now usr storedusr updScimStoredUser' :: @@ -644,7 +652,7 @@ deleteScimUser :: r => ScimTokenInfo -> UserId -> - Scim.ScimHandler (Spar r) () + Scim.ScimHandler (Sem r) () deleteScimUser tokeninfo@ScimTokenInfo {stiTeam, stiIdP} uid = logScim ( logFunction "Spar.Scim.User.deleteScimUser" @@ -652,7 +660,7 @@ deleteScimUser tokeninfo@ScimTokenInfo {stiTeam, stiIdP} uid = . logUser uid ) $ do - mbBrigUser <- lift (liftSem $ Brig.getBrigUser Brig.WithPendingInvitations uid) + mbBrigUser <- lift (Brig.getBrigUser Brig.WithPendingInvitations uid) case mbBrigUser of Nothing -> do -- double-deletion gets you a 404. @@ -666,19 +674,19 @@ deleteScimUser tokeninfo@ScimTokenInfo {stiTeam, stiIdP} uid = throwError $ Scim.notFound "user" (idToText uid) - mIdpConfig <- maybe (pure Nothing) (lift . wrapMonadClientSem . IdPEffect.getConfig) stiIdP + mIdpConfig <- maybe (pure Nothing) (lift . IdPEffect.getConfig) stiIdP case Brig.veidFromBrigUser brigUser ((^. SAML.idpMetadata . SAML.edIssuer) <$> mIdpConfig) of Left _ -> pure () Right veid -> - lift . wrapMonadClientSem $ + lift $ ST.runValidExternalId (SAMLUserStore.delete uid) (ScimExternalIdStore.delete stiTeam) veid - lift . wrapMonadClientSem $ ScimUserTimesStore.delete uid - lift . liftSem $ BrigAccess.delete uid + lift $ ScimUserTimesStore.delete uid + lift $ BrigAccess.delete uid return () ---------------------------------------------------------------------------- @@ -708,7 +716,7 @@ calculateVersion uid usr = Scim.Weak (Text.pack (show h)) -- -- ASSUMPTION: every scim user has a 'SAML.UserRef', and the `SAML.NameID` in it corresponds -- to a single `externalId`. -assertExternalIdUnused :: Members '[BrigAccess, ScimExternalIdStore, SAMLUserStore] r => TeamId -> ST.ValidExternalId -> Scim.ScimHandler (Spar r) () +assertExternalIdUnused :: Members '[BrigAccess, ScimExternalIdStore, SAMLUserStore] r => TeamId -> ST.ValidExternalId -> Scim.ScimHandler (Sem r) () assertExternalIdUnused tid veid = do assertExternalIdInAllowedValues [Nothing] @@ -722,7 +730,7 @@ assertExternalIdUnused tid veid = do -- -- ASSUMPTION: every scim user has a 'SAML.UserRef', and the `SAML.NameID` in it corresponds -- to a single `externalId`. -assertExternalIdNotUsedElsewhere :: Members '[BrigAccess, ScimExternalIdStore, SAMLUserStore] r => TeamId -> ST.ValidExternalId -> UserId -> Scim.ScimHandler (Spar r) () +assertExternalIdNotUsedElsewhere :: Members '[BrigAccess, ScimExternalIdStore, SAMLUserStore] r => TeamId -> ST.ValidExternalId -> UserId -> Scim.ScimHandler (Sem r) () assertExternalIdNotUsedElsewhere tid veid wireUserId = do assertExternalIdInAllowedValues [Nothing, Just wireUserId] @@ -730,7 +738,7 @@ assertExternalIdNotUsedElsewhere tid veid wireUserId = do tid veid -assertExternalIdInAllowedValues :: Members '[BrigAccess, ScimExternalIdStore, SAMLUserStore] r => [Maybe UserId] -> Text -> TeamId -> ST.ValidExternalId -> Scim.ScimHandler (Spar r) () +assertExternalIdInAllowedValues :: Members '[BrigAccess, ScimExternalIdStore, SAMLUserStore] r => [Maybe UserId] -> Text -> TeamId -> ST.ValidExternalId -> Scim.ScimHandler (Sem r) () assertExternalIdInAllowedValues allowedValues errmsg tid veid = do isGood <- lift $ @@ -747,18 +755,18 @@ assertExternalIdInAllowedValues allowedValues errmsg tid veid = do unless isGood $ throwError Scim.conflict {Scim.detail = Just errmsg} -assertHandleUnused :: Member BrigAccess r => Handle -> Scim.ScimHandler (Spar r) () +assertHandleUnused :: Member BrigAccess r => Handle -> Scim.ScimHandler (Sem r) () assertHandleUnused = assertHandleUnused' "userName is already taken" -assertHandleUnused' :: Member BrigAccess r => Text -> Handle -> Scim.ScimHandler (Spar r) () +assertHandleUnused' :: Member BrigAccess r => Text -> Handle -> Scim.ScimHandler (Sem r) () assertHandleUnused' msg hndl = - lift (liftSem $ BrigAccess.checkHandleAvailable hndl) >>= \case + lift (BrigAccess.checkHandleAvailable hndl) >>= \case True -> pure () False -> throwError Scim.conflict {Scim.detail = Just msg} -assertHandleNotUsedElsewhere :: Member BrigAccess r => UserId -> Handle -> Scim.ScimHandler (Spar r) () +assertHandleNotUsedElsewhere :: Member BrigAccess r => UserId -> Handle -> Scim.ScimHandler (Sem r) () assertHandleNotUsedElsewhere uid hndl = do - musr <- lift $ liftSem $ Brig.getBrigUser Brig.WithPendingInvitations uid + musr <- lift $ Brig.getBrigUser Brig.WithPendingInvitations uid unless ((userHandle =<< musr) == Just hndl) $ assertHandleUnused' "userName already in use by another wire user" hndl @@ -769,6 +777,7 @@ synthesizeStoredUser :: forall r. Members '[ Input Opts, + Now, Logger (Msg -> Msg), BrigAccess, ScimUserTimesStore @@ -776,7 +785,7 @@ synthesizeStoredUser :: r => UserAccount -> ST.ValidExternalId -> - Scim.ScimHandler (Spar r) (Scim.StoredUser ST.SparTag) + Scim.ScimHandler (Sem r) (Scim.StoredUser ST.SparTag) synthesizeStoredUser usr veid = logScim ( logFunction "Spar.Scim.User.synthesizeStoredUser" @@ -789,28 +798,28 @@ synthesizeStoredUser usr veid = let uid = userId (accountUser usr) accStatus = accountStatus usr - let readState :: Spar r (RI.RichInfo, Maybe (UTCTimeMillis, UTCTimeMillis), URIBS.URI) + let readState :: Sem r (RI.RichInfo, Maybe (UTCTimeMillis, UTCTimeMillis), URIBS.URI) readState = do - richInfo <- liftSem $ BrigAccess.getRichInfo uid - accessTimes <- wrapMonadClientSem (ScimUserTimesStore.read uid) - baseuri <- liftSem $ inputs $ derivedOptsScimBaseURI . derivedOpts + richInfo <- BrigAccess.getRichInfo uid + accessTimes <- ScimUserTimesStore.read uid + baseuri <- inputs $ derivedOptsScimBaseURI . derivedOpts pure (richInfo, accessTimes, baseuri) - let writeState :: Maybe (UTCTimeMillis, UTCTimeMillis) -> ManagedBy -> RI.RichInfo -> Scim.StoredUser ST.SparTag -> Spar r () + let writeState :: Maybe (UTCTimeMillis, UTCTimeMillis) -> ManagedBy -> RI.RichInfo -> Scim.StoredUser ST.SparTag -> Sem r () writeState oldAccessTimes oldManagedBy oldRichInfo storedUser = do when (isNothing oldAccessTimes) $ do - wrapMonadClientSem $ ScimUserTimesStore.write storedUser + ScimUserTimesStore.write storedUser when (oldManagedBy /= ManagedByScim) $ do - liftSem $ BrigAccess.setManagedBy uid ManagedByScim + BrigAccess.setManagedBy uid ManagedByScim let newRichInfo = view ST.sueRichInfo . Scim.extra . Scim.value . Scim.thing $ storedUser when (oldRichInfo /= newRichInfo) $ do - liftSem $ BrigAccess.setRichInfo uid newRichInfo + BrigAccess.setRichInfo uid newRichInfo (richInfo, accessTimes, baseuri) <- lift readState - SAML.Time (toUTCTimeMillis -> now) <- lift SAML.getNow + SAML.Time (toUTCTimeMillis -> now) <- lift Now.get let (createdAt, lastUpdatedAt) = fromMaybe (now, now) accessTimes - handle <- lift $ liftSem $ Brig.giveDefaultHandle (accountUser usr) + handle <- lift $ Brig.giveDefaultHandle (accountUser usr) storedUser <- synthesizeStoredUser' @@ -865,6 +874,7 @@ synthesizeScimUser info = scimFindUserByHandle :: Members '[ Input Opts, + Now, Logger (Msg -> Msg), BrigAccess, ScimUserTimesStore @@ -873,10 +883,10 @@ scimFindUserByHandle :: Maybe IdP -> TeamId -> Text -> - MaybeT (Scim.ScimHandler (Spar r)) (Scim.StoredUser ST.SparTag) + MaybeT (Scim.ScimHandler (Sem r)) (Scim.StoredUser ST.SparTag) scimFindUserByHandle mIdpConfig stiTeam hndl = do handle <- MaybeT . pure . parseHandle . Text.toLower $ hndl - brigUser <- MaybeT . lift . liftSem . BrigAccess.getByHandle $ handle + brigUser <- MaybeT . lift . BrigAccess.getByHandle $ handle guard $ userTeam (accountUser brigUser) == Just stiTeam case Brig.veidFromBrigUser (accountUser brigUser) ((^. SAML.idpMetadata . SAML.edIssuer) <$> mIdpConfig) of Right veid -> lift $ synthesizeStoredUser brigUser veid @@ -892,6 +902,7 @@ scimFindUserByEmail :: forall r. Members '[ Input Opts, + Now, Logger (Msg -> Msg), BrigAccess, ScimExternalIdStore, @@ -902,7 +913,7 @@ scimFindUserByEmail :: Maybe IdP -> TeamId -> Text -> - MaybeT (Scim.ScimHandler (Spar r)) (Scim.StoredUser ST.SparTag) + MaybeT (Scim.ScimHandler (Sem r)) (Scim.StoredUser ST.SparTag) scimFindUserByEmail mIdpConfig stiTeam email = do -- Azure has been observed to search for externalIds that are not emails, even if the -- mapping is set up like it should be. This is a problem: if there is no SAML IdP, 'mkValidExternalId' @@ -912,24 +923,24 @@ scimFindUserByEmail mIdpConfig stiTeam email = do -- a UUID, or any other text that is valid according to SCIM. veid <- MaybeT (either (const Nothing) Just <$> runExceptT (mkValidExternalId mIdpConfig (pure email))) uid <- MaybeT . lift $ ST.runValidExternalId withUref withEmailOnly veid - brigUser <- MaybeT . lift . liftSem . BrigAccess.getAccount Brig.WithPendingInvitations $ uid + brigUser <- MaybeT . lift . BrigAccess.getAccount Brig.WithPendingInvitations $ uid guard $ userTeam (accountUser brigUser) == Just stiTeam lift $ synthesizeStoredUser brigUser veid where - withUref :: SAML.UserRef -> Spar r (Maybe UserId) + withUref :: SAML.UserRef -> Sem r (Maybe UserId) withUref uref = do - wrapMonadClientSem (SAMLUserStore.get uref) >>= \case + SAMLUserStore.get uref >>= \case Nothing -> maybe (pure Nothing) withEmailOnly $ Brig.urefToEmail uref Just uid -> pure (Just uid) - withEmailOnly :: BT.Email -> Spar r (Maybe UserId) + withEmailOnly :: BT.Email -> Sem r (Maybe UserId) withEmailOnly eml = maybe inbrig (pure . Just) =<< inspar where -- FUTUREWORK: we could also always lookup brig, that's simpler and possibly faster, -- and it never should be visible in spar, but not in brig. - inspar, inbrig :: Spar r (Maybe UserId) - inspar = wrapMonadClientSem $ ScimExternalIdStore.lookup stiTeam eml - inbrig = liftSem $ userId . accountUser <$$> BrigAccess.getByEmail eml + inspar, inbrig :: Sem r (Maybe UserId) + inspar = ScimExternalIdStore.lookup stiTeam eml + inbrig = userId . accountUser <$$> BrigAccess.getByEmail eml logFilter :: Filter -> (Msg -> Msg) logFilter (FilterAttrCompare attr op val) = diff --git a/services/spar/src/Spar/Sem/Now.hs b/services/spar/src/Spar/Sem/Now.hs new file mode 100644 index 0000000000..4c43be4a46 --- /dev/null +++ b/services/spar/src/Spar/Sem/Now.hs @@ -0,0 +1,9 @@ +module Spar.Sem.Now where + +import Polysemy +import qualified SAML2.WebSSO as SAML + +data Now m a where + Get :: Now m SAML.Time + +makeSem ''Now diff --git a/services/spar/src/Spar/Sem/Now/IO.hs b/services/spar/src/Spar/Sem/Now/IO.hs new file mode 100644 index 0000000000..74f75f738b --- /dev/null +++ b/services/spar/src/Spar/Sem/Now/IO.hs @@ -0,0 +1,10 @@ +module Spar.Sem.Now.IO where + +import Imports +import Polysemy +import SAML2.WebSSO (getNowIO) +import Spar.Sem.Now + +nowToIO :: Member (Embed IO) r => Sem (Now ': r) a -> Sem r a +nowToIO = interpret $ \case + Get -> embed @IO getNowIO diff --git a/services/spar/src/Spar/Sem/Reporter.hs b/services/spar/src/Spar/Sem/Reporter.hs new file mode 100644 index 0000000000..b038152111 --- /dev/null +++ b/services/spar/src/Spar/Sem/Reporter.hs @@ -0,0 +1,12 @@ +module Spar.Sem.Reporter where + +import Imports +import qualified Network.Wai as Wai +import Network.Wai.Utilities.Error (Error) +import Polysemy + +data Reporter m a where + Report :: Maybe Wai.Request -> Error -> Reporter m () + +-- TODO(sandy): Inline this definition --- no TH +makeSem ''Reporter diff --git a/services/spar/src/Spar/Sem/Reporter/Wai.hs b/services/spar/src/Spar/Sem/Reporter/Wai.hs new file mode 100644 index 0000000000..548be65b32 --- /dev/null +++ b/services/spar/src/Spar/Sem/Reporter/Wai.hs @@ -0,0 +1,14 @@ +module Spar.Sem.Reporter.Wai where + +import Imports +import qualified Network.Wai.Utilities.Server as Wai +import Polysemy +import Polysemy.Input +import Spar.Sem.Reporter +import qualified System.Logger as TinyLog + +reporterToTinyLogWai :: Members '[Embed IO, Input TinyLog.Logger] r => Sem (Reporter ': r) a -> Sem r a +reporterToTinyLogWai = interpret $ \case + Report req err -> do + logger <- input + embed @IO $ Wai.logError logger req err diff --git a/services/spar/src/Spar/Sem/SAML2.hs b/services/spar/src/Spar/Sem/SAML2.hs new file mode 100644 index 0000000000..ae5007e970 --- /dev/null +++ b/services/spar/src/Spar/Sem/SAML2.hs @@ -0,0 +1,33 @@ +module Spar.Sem.SAML2 where + +import Data.Id (TeamId) +import Data.String.Conversions (SBS, ST) +import Data.Time (NominalDiffTime) +import GHC.TypeLits (KnownSymbol) +import Imports hiding (log) +import Polysemy +import SAML2.WebSSO +import URI.ByteString (URI) + +data SAML2 m a where + AuthReq :: + NominalDiffTime -> + m Issuer -> + IdPId -> + SAML2 m (FormRedirect AuthnRequest) + AuthResp :: + Maybe TeamId -> + m Issuer -> + m URI -> + (AuthnResponse -> AccessVerdict -> m resp) -> + AuthnResponseBody -> + SAML2 m resp + Meta :: ST -> m Issuer -> m URI -> SAML2 m SPMetadata + ToggleCookie :: + KnownSymbol name => + SBS -> + Maybe (ST, NominalDiffTime) -> + SAML2 m (SimpleSetCookie name) + +-- TODO(sandy): Inline this definition --- no TH +makeSem ''SAML2 diff --git a/services/spar/src/Spar/Sem/SAML2/Library.hs b/services/spar/src/Spar/Sem/SAML2/Library.hs new file mode 100644 index 0000000000..9c8be48238 --- /dev/null +++ b/services/spar/src/Spar/Sem/SAML2/Library.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} + +module Spar.Sem.SAML2.Library (saml2ToSaml2WebSso) where + +import qualified Control.Monad.Catch as Catch +import Control.Monad.Except +import Data.Id (TeamId) +import Data.String.Conversions (cs) +import Imports +import Polysemy +import Polysemy.Error +import Polysemy.Final +import Polysemy.Input +import Polysemy.Internal.Tactics +import SAML2.WebSSO hiding (Error) +import qualified SAML2.WebSSO as SAML hiding (Error) +import qualified Spar.App as App +import Spar.Error (SparCustomError (..), SparError) +import Spar.Sem.AReqIDStore (AReqIDStore) +import qualified Spar.Sem.AReqIDStore as AReqIDStore +import Spar.Sem.AssIDStore (AssIDStore) +import qualified Spar.Sem.AssIDStore as AssIDStore +import qualified Spar.Sem.IdP as IdPEffect +import Spar.Sem.Logger (Logger) +import qualified Spar.Sem.Logger as Logger +import Spar.Sem.SAML2 +import Wire.API.User.IdentityProvider (WireIdP) +import Wire.API.User.Saml + +wrapMonadClientSPImpl :: Members '[Error SparError, Final IO] r => Sem r a -> SPImpl r a +wrapMonadClientSPImpl action = + SPImpl action + `Catch.catch` (SPImpl . throw . SAML.CustomError . SparCassandraError . cs . show @SomeException) + +instance Member (Final IO) r => Catch.MonadThrow (SPImpl r) where + throwM = SPImpl . embedFinal . Catch.throwM @IO + +instance Member (Final IO) r => Catch.MonadCatch (SPImpl r) where + catch (SPImpl m) handler = SPImpl $ + withStrategicToFinal @IO $ do + m' <- runS m + st <- getInitialStateS + handler' <- bindS $ unSPImpl . handler + pure $ m' `Catch.catch` \e -> handler' $ e <$ st + +newtype SPImpl r a = SPImpl {unSPImpl :: Sem r a} + deriving (Functor, Applicative, Monad) + +instance Member (Input Opts) r => HasConfig (SPImpl r) where + getConfig = SPImpl $ inputs saml + +instance Members '[Input Opts, Logger String] r => HasLogger (SPImpl r) where + logger lvl = SPImpl . Logger.log lvl + +instance Member (Embed IO) r => MonadIO (SPImpl r) where + liftIO = SPImpl . embed @IO + +instance Member (Embed IO) r => HasCreateUUID (SPImpl r) + +instance Member (Embed IO) r => HasNow (SPImpl r) + +instance Members '[Error SparError, Final IO, AReqIDStore] r => SPStoreID AuthnRequest (SPImpl r) where + storeID = (wrapMonadClientSPImpl .) . AReqIDStore.store + unStoreID = wrapMonadClientSPImpl . AReqIDStore.unStore + isAliveID = wrapMonadClientSPImpl . AReqIDStore.isAlive + +instance Members '[Error SparError, Final IO, AssIDStore] r => SPStoreID Assertion (SPImpl r) where + storeID = (wrapMonadClientSPImpl .) . AssIDStore.store + unStoreID = wrapMonadClientSPImpl . AssIDStore.unStore + isAliveID = wrapMonadClientSPImpl . AssIDStore.isAlive + +instance Members '[Error SparError, IdPEffect.IdP, Final IO] r => SPStoreIdP SparError (SPImpl r) where + type IdPConfigExtra (SPImpl r) = WireIdP + type IdPConfigSPId (SPImpl r) = TeamId + + storeIdPConfig = SPImpl . App.storeIdPConfig + getIdPConfig = SPImpl . App.getIdPConfig + getIdPConfigByIssuerOptionalSPId a = SPImpl . App.getIdPConfigByIssuerOptionalSPId a + +instance Member (Error SparError) r => MonadError SparError (SPImpl r) where + throwError = SPImpl . throw + catchError m handler = SPImpl $ catch (unSPImpl m) $ unSPImpl . handler + +-- | To learn more about polysemy tactics, read this: +-- * https://reasonablypolymorphic.com/blog/freer-higher-order-effects/ +-- * https://reasonablypolymorphic.com/blog/tactics/ +saml2ToSaml2WebSso :: + forall r a. + Members + '[ AReqIDStore, + AssIDStore, + Error SparError, + IdPEffect.IdP, + Input Opts, + Logger String, + Embed IO, + Final IO + ] + r => + Sem (SAML2 ': r) a -> + Sem r a +saml2ToSaml2WebSso = + interpretH $ \case + AuthReq n ma i -> do + get_a <- runT ma + ins <- getInspectorT + x <- raise $ unSPImpl $ SAML.authreq @_ @SparError n (inspectOrBomb ins get_a) i + s <- getInitialStateT + pure $ x <$ s + AuthResp mitlt ma mb mc ab -> do + get_a <- runT ma + get_b <- runT mb + get_c <- bindT $ uncurry mc + ins <- getInspectorT + s <- getInitialStateT + x <- raise $ unSPImpl $ SAML.authresp mitlt (inspectOrBomb ins get_a) (inspectOrBomb ins get_b) (\x y -> inspectOrBomb ins $ get_c $ (x, y) <$ s) ab + pure $ x <$ s + Meta t ma mb -> do + get_a <- runT ma + get_b <- runT mb + ins <- getInspectorT + x <- raise $ unSPImpl $ SAML.meta t (inspectOrBomb ins get_a) (inspectOrBomb ins get_b) + s <- getInitialStateT + pure $ x <$ s + ToggleCookie sbs mp -> do + liftT $ unSPImpl $ SAML.toggleCookie sbs mp + +inspectOrBomb :: + Members + '[ AReqIDStore, + AssIDStore, + Error SparError, + IdPEffect.IdP, + Logger String, + Input Opts, + Embed IO, + Final IO + ] + r => + Inspector f -> + Sem (SAML2 : r) (f b) -> + SPImpl r b +inspectOrBomb ins get_a = do + fa <- SPImpl $ saml2ToSaml2WebSso get_a + maybe + (SPImpl . throw @SparError $ SAML.CustomError $ SparInternalError "saml2ToSaml2WebSso called with an uninspectable weaving functor") + pure + $ inspect ins fa diff --git a/services/spar/src/Spar/Sem/SAMLUserStore/Cassandra.hs b/services/spar/src/Spar/Sem/SAMLUserStore/Cassandra.hs index 409c5a4b2f..c2711056ae 100644 --- a/services/spar/src/Spar/Sem/SAMLUserStore/Cassandra.hs +++ b/services/spar/src/Spar/Sem/SAMLUserStore/Cassandra.hs @@ -3,9 +3,15 @@ module Spar.Sem.SAMLUserStore.Cassandra where import Cassandra +import qualified Control.Monad.Catch as Catch +import Data.String.Conversions (cs) import Imports import Polysemy +import Polysemy.Error +import Polysemy.Final +import qualified SAML2.WebSSO.Error as SAML import qualified Spar.Data as Data +import Spar.Error import Spar.Sem.SAMLUserStore samlUserStoreToCassandra :: @@ -23,6 +29,14 @@ samlUserStoreToCassandra = DeleteByIssuer is -> Data.deleteSAMLUsersByIssuer is Delete uid ur -> Data.deleteSAMLUser uid ur -interpretClientToIO :: Member (Final IO) r => ClientState -> Sem (Embed Client ': r) a -> Sem r a +interpretClientToIO :: + Members '[Error SparError, Final IO] r => + ClientState -> + Sem (Embed Client ': r) a -> + Sem r a interpretClientToIO ctx = interpret $ \case - Embed action -> embedFinal $ runClient ctx action + Embed action -> withStrategicToFinal @IO $ do + action' <- liftS $ runClient ctx action + st <- getInitialStateS + handler' <- bindS $ throw @SparError . SAML.CustomError . SparCassandraError . cs . show @SomeException + pure $ action' `Catch.catch` \e -> handler' $ e <$ st diff --git a/services/spar/src/Spar/Sem/SamlProtocolSettings.hs b/services/spar/src/Spar/Sem/SamlProtocolSettings.hs new file mode 100644 index 0000000000..ea54570661 --- /dev/null +++ b/services/spar/src/Spar/Sem/SamlProtocolSettings.hs @@ -0,0 +1,13 @@ +module Spar.Sem.SamlProtocolSettings where + +import Data.Id (TeamId) +import Imports +import Polysemy +import qualified SAML2.WebSSO.Types as SAML +import qualified URI.ByteString as URI + +data SamlProtocolSettings m a where + SpIssuer :: Maybe TeamId -> SamlProtocolSettings m SAML.Issuer + ResponseURI :: Maybe TeamId -> SamlProtocolSettings m URI.URI + +makeSem ''SamlProtocolSettings diff --git a/services/spar/src/Spar/Sem/SamlProtocolSettings/Servant.hs b/services/spar/src/Spar/Sem/SamlProtocolSettings/Servant.hs new file mode 100644 index 0000000000..138ba41640 --- /dev/null +++ b/services/spar/src/Spar/Sem/SamlProtocolSettings/Servant.hs @@ -0,0 +1,18 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module Spar.Sem.SamlProtocolSettings.Servant where + +import Imports +import Polysemy +import qualified SAML2.WebSSO as SAML +import Spar.Sem.SamlProtocolSettings +import Wire.API.Routes.Public.Spar + +-- TODO(sandy): Why is this instance not provided by SAML? Very rude! +instance SAML.HasConfig ((->) SAML.Config) where + getConfig = id + +sparRouteToServant :: SAML.Config -> Sem (SamlProtocolSettings ': r) a -> Sem r a +sparRouteToServant cfg = interpret $ \x -> case x of + SpIssuer mitlt -> pure $ sparSPIssuer mitlt cfg + ResponseURI mitlt -> pure $ sparResponseURI mitlt cfg diff --git a/services/spar/test-integration/Test/Spar/APISpec.hs b/services/spar/test-integration/Test/Spar/APISpec.hs index 57afed49fd..7685df8517 100644 --- a/services/spar/test-integration/Test/Spar/APISpec.hs +++ b/services/spar/test-integration/Test/Spar/APISpec.hs @@ -70,7 +70,6 @@ import qualified SAML2.WebSSO as SAML import SAML2.WebSSO.Test.Lenses import SAML2.WebSSO.Test.MockResponse import SAML2.WebSSO.Test.Util -import Spar.App (liftSem) import qualified Spar.Intra.BrigApp as Intra import qualified Spar.Sem.BrigAccess as BrigAccess import qualified Spar.Sem.IdP as IdPEffect @@ -870,7 +869,7 @@ specCRUDIdentityProvider = do pure $ idpmeta1 & edIssuer .~ (idpmeta3 ^. edIssuer) do - midp <- runSpar $ liftSem $ IdPEffect.getConfig idpid1 + midp <- runSpar $ IdPEffect.getConfig idpid1 liftIO $ do (midp ^? _Just . idpMetadata . edIssuer) `shouldBe` Just (idpmeta1 ^. edIssuer) (midp ^? _Just . idpExtraInfo . wiOldIssuers) `shouldBe` Just [] @@ -883,7 +882,7 @@ specCRUDIdentityProvider = do resp <- call $ callIdpUpdate' (env ^. teSpar) (Just owner1) idpid1 (IdPMetadataValue (cs $ SAML.encode new) undefined) liftIO $ statusCode resp `shouldBe` 200 - midp <- runSpar $ liftSem $ IdPEffect.getConfig idpid1 + midp <- runSpar $ IdPEffect.getConfig idpid1 liftIO $ do (midp ^? _Just . idpMetadata . edIssuer) `shouldBe` Just (new ^. edIssuer) sort <$> (midp ^? _Just . idpExtraInfo . wiOldIssuers) `shouldBe` Just (sort $ olds <&> (^. edIssuer)) @@ -1298,7 +1297,7 @@ specDeleteCornerCases = describe "delete corner cases" $ do brig <- view teBrig resp <- call . delete $ brig . paths ["i", "users", toByteString' uid] liftIO $ responseStatus resp `shouldBe` status202 - void $ aFewTimes (runSpar $ liftSem $ BrigAccess.getStatus uid) (== Deleted) + void $ aFewTimes (runSpar $ BrigAccess.getStatus uid) (== Deleted) specScimAndSAML :: SpecWith TestEnv specScimAndSAML = do diff --git a/services/spar/test-integration/Test/Spar/AppSpec.hs b/services/spar/test-integration/Test/Spar/AppSpec.hs index 0ee8760f00..5f38b3830a 100644 --- a/services/spar/test-integration/Test/Spar/AppSpec.hs +++ b/services/spar/test-integration/Test/Spar/AppSpec.hs @@ -33,7 +33,6 @@ import Imports import SAML2.WebSSO as SAML import qualified SAML2.WebSSO.Test.MockResponse as SAML import qualified Servant -import Spar.App (liftSem) import qualified Spar.App as Spar import Spar.Orphans () import qualified Spar.Sem.SAMLUserStore as SAMLUserStore @@ -181,5 +180,5 @@ requestAccessVerdict idp isGranted mkAuthnReq = do $ outcome qry :: [(SBS, SBS)] qry = queryPairs $ uriQuery loc - muid <- runSpar $ liftSem $ SAMLUserStore.get uref + muid <- runSpar $ SAMLUserStore.get uref pure (muid, outcome, loc, qry) diff --git a/services/spar/test-integration/Test/Spar/DataSpec.hs b/services/spar/test-integration/Test/Spar/DataSpec.hs index b37ba065a8..2c66752773 100644 --- a/services/spar/test-integration/Test/Spar/DataSpec.hs +++ b/services/spar/test-integration/Test/Spar/DataSpec.hs @@ -72,7 +72,7 @@ spec = do (_, _, (^. SAML.idpId) -> idpid) <- registerTestIdP (_, req) <- call $ callAuthnReq (env ^. teSpar) idpid let probe :: (MonadIO m, MonadReader TestEnv m) => m Bool - probe = runSpar $ liftSem $ AReqIDStore.isAlive (req ^. SAML.rqID) + probe = runSpar $ AReqIDStore.isAlive (req ^. SAML.rqID) maxttl :: Int -- musec maxttl = (fromIntegral . fromTTL $ env ^. teOpts . to maxttlAuthreq) * 1000 * 1000 liftIO $ maxttl `shouldSatisfy` (< 60 * 1000 * 1000) -- otherwise the test will be really slow. @@ -93,8 +93,8 @@ spec = do context "insert and get are \"inverses\"" $ do let check vf = it (show vf) $ do vid <- nextSAMLID - () <- runSpar $ liftSem $ AReqIDStore.storeVerdictFormat 1 vid vf - mvf <- runSpar $ liftSem $ AReqIDStore.getVerdictFormat vid + () <- runSpar $ AReqIDStore.storeVerdictFormat 1 vid vf + mvf <- runSpar $ AReqIDStore.getVerdictFormat vid liftIO $ mvf `shouldBe` Just vf check `mapM_` [ VerdictFormatWeb, @@ -103,47 +103,47 @@ spec = do context "has timed out" $ do it "AReqIDStore.getVerdictFormat returns Nothing" $ do vid <- nextSAMLID - () <- runSpar $ liftSem $ AReqIDStore.storeVerdictFormat 1 vid VerdictFormatWeb + () <- runSpar $ AReqIDStore.storeVerdictFormat 1 vid VerdictFormatWeb liftIO $ threadDelay 2000000 - mvf <- runSpar $ liftSem $ AReqIDStore.getVerdictFormat vid + mvf <- runSpar $ AReqIDStore.getVerdictFormat vid liftIO $ mvf `shouldBe` Nothing context "does not exist" $ do it "AReqIDStore.getVerdictFormat returns Nothing" $ do vid <- nextSAMLID - mvf <- runSpar $ liftSem $ AReqIDStore.getVerdictFormat vid + mvf <- runSpar $ AReqIDStore.getVerdictFormat vid liftIO $ mvf `shouldBe` Nothing describe "User" $ do context "user is new" $ do it "getUser returns Nothing" $ do uref <- nextUserRef - muid <- runSpar $ liftSem $ SAMLUserStore.get uref + muid <- runSpar $ SAMLUserStore.get uref liftIO $ muid `shouldBe` Nothing it "inserts new user and responds with 201 / returns new user" $ do uref <- nextUserRef uid <- nextWireId - () <- runSpar $ liftSem $ SAMLUserStore.insert uref uid - muid <- runSpar $ liftSem $ SAMLUserStore.get uref + () <- runSpar $ SAMLUserStore.insert uref uid + muid <- runSpar $ SAMLUserStore.get uref liftIO $ muid `shouldBe` Just uid context "user already exists (idempotency)" $ do it "inserts new user and responds with 201 / returns new user" $ do uref <- nextUserRef uid <- nextWireId uid' <- nextWireId - () <- runSpar $ liftSem $ SAMLUserStore.insert uref uid - () <- runSpar $ liftSem $ SAMLUserStore.insert uref uid' - muid <- runSpar $ liftSem $ SAMLUserStore.get uref + () <- runSpar $ SAMLUserStore.insert uref uid + () <- runSpar $ SAMLUserStore.insert uref uid' + muid <- runSpar $ SAMLUserStore.get uref liftIO $ muid `shouldBe` Just uid' describe "DELETE" $ do it "works" $ do uref <- nextUserRef uid <- nextWireId do - () <- runSpar $ liftSem $ SAMLUserStore.insert uref uid - muid <- runSpar $ liftSem (SAMLUserStore.get uref) + () <- runSpar $ SAMLUserStore.insert uref uid + muid <- runSpar $ SAMLUserStore.get uref liftIO $ muid `shouldBe` Just uid do - () <- runSpar $ liftSem $ SAMLUserStore.delete uid uref - muid <- runSpar (liftSem $ SAMLUserStore.get uref) `aFewTimes` isNothing + () <- runSpar $ SAMLUserStore.delete uid uref + muid <- runSpar (SAMLUserStore.get uref) `aFewTimes` isNothing liftIO $ muid `shouldBe` Nothing describe "BindCookie" $ do let mkcky :: TestSpar SetBindCookie @@ -151,58 +151,58 @@ spec = do it "insert and get are \"inverses\"" $ do uid <- nextWireId cky <- mkcky - () <- runSpar $ liftSem $ BindCookieStore.insert cky uid 1 - muid <- runSpar $ liftSem $ BindCookieStore.lookup (setBindCookieValue cky) + () <- runSpar $ BindCookieStore.insert cky uid 1 + muid <- runSpar $ BindCookieStore.lookup (setBindCookieValue cky) liftIO $ muid `shouldBe` Just uid context "has timed out" $ do it "BindCookieStore.lookup returns Nothing" $ do uid <- nextWireId cky <- mkcky - () <- runSpar $ liftSem $ BindCookieStore.insert cky uid 1 + () <- runSpar $ BindCookieStore.insert cky uid 1 liftIO $ threadDelay 2000000 - muid <- runSpar $ liftSem $ BindCookieStore.lookup (setBindCookieValue cky) + muid <- runSpar $ BindCookieStore.lookup (setBindCookieValue cky) liftIO $ muid `shouldBe` Nothing context "does not exist" $ do it "BindCookieStore.lookup returns Nothing" $ do cky <- mkcky - muid <- runSpar $ liftSem $ BindCookieStore.lookup (setBindCookieValue cky) + muid <- runSpar $ BindCookieStore.lookup (setBindCookieValue cky) liftIO $ muid `shouldBe` Nothing describe "Team" $ do testDeleteTeam describe "IdPConfig" $ do it "storeIdPConfig, getIdPConfig are \"inverses\"" $ do idp <- makeTestIdP - () <- runSpar $ liftSem $ IdPEffect.storeConfig idp - midp <- runSpar $ liftSem $ IdPEffect.getConfig (idp ^. idpId) + () <- runSpar $ IdPEffect.storeConfig idp + midp <- runSpar $ IdPEffect.getConfig (idp ^. idpId) liftIO $ midp `shouldBe` Just idp it "getIdPConfigByIssuer works" $ do idp <- makeTestIdP - () <- runSpar $ liftSem $ IdPEffect.storeConfig idp + () <- runSpar $ IdPEffect.storeConfig idp midp <- runSpar $ App.getIdPConfigByIssuer (idp ^. idpMetadata . edIssuer) (idp ^. SAML.idpExtraInfo . wiTeam) liftIO $ midp `shouldBe` GetIdPFound idp it "getIdPIdByIssuer works" $ do idp <- makeTestIdP - () <- runSpar $ liftSem $ IdPEffect.storeConfig idp + () <- runSpar $ IdPEffect.storeConfig idp midp <- runSpar $ App.getIdPIdByIssuer (idp ^. idpMetadata . edIssuer) (idp ^. SAML.idpExtraInfo . wiTeam) liftIO $ midp `shouldBe` GetIdPFound (idp ^. idpId) it "getIdPConfigsByTeam works" $ do skipIdPAPIVersions [WireIdPAPIV1] teamid <- nextWireId idp <- makeTestIdP <&> idpExtraInfo .~ (WireIdP teamid Nothing [] Nothing) - () <- runSpar $ liftSem $ IdPEffect.storeConfig idp - idps <- runSpar $ liftSem $ IdPEffect.getConfigsByTeam teamid + () <- runSpar $ IdPEffect.storeConfig idp + idps <- runSpar $ IdPEffect.getConfigsByTeam teamid liftIO $ idps `shouldBe` [idp] it "deleteIdPConfig works" $ do teamid <- nextWireId idpApiVersion <- asks (^. teWireIdPAPIVersion) idp <- makeTestIdP <&> idpExtraInfo .~ (WireIdP teamid (Just idpApiVersion) [] Nothing) - () <- runSpar $ liftSem $ IdPEffect.storeConfig idp + () <- runSpar $ IdPEffect.storeConfig idp do - midp <- runSpar $ liftSem $ IdPEffect.getConfig (idp ^. idpId) + midp <- runSpar $ IdPEffect.getConfig (idp ^. idpId) liftIO $ midp `shouldBe` Just idp - () <- runSpar $ liftSem $ IdPEffect.deleteConfig (idp ^. idpId) (idp ^. idpMetadata . edIssuer) teamid + () <- runSpar $ IdPEffect.deleteConfig (idp ^. idpId) (idp ^. idpMetadata . edIssuer) teamid do - midp <- runSpar $ liftSem $ IdPEffect.getConfig (idp ^. idpId) + midp <- runSpar $ IdPEffect.getConfig (idp ^. idpId) liftIO $ midp `shouldBe` Nothing do midp <- runSpar $ App.getIdPConfigByIssuer (idp ^. idpMetadata . edIssuer) (idp ^. SAML.idpExtraInfo . wiTeam) @@ -211,18 +211,18 @@ spec = do midp <- runSpar $ App.getIdPIdByIssuer (idp ^. idpMetadata . edIssuer) (idp ^. SAML.idpExtraInfo . wiTeam) liftIO $ midp `shouldBe` GetIdPNotFound do - idps <- runSpar $ liftSem $ IdPEffect.getConfigsByTeam teamid + idps <- runSpar $ IdPEffect.getConfigsByTeam teamid liftIO $ idps `shouldBe` [] describe "{set,clear}ReplacedBy" $ do it "handle non-existent idps gradefully" $ do pendingWith "this requires a cql{,-io} upgrade. https://gitlab.com/twittner/cql-io/-/issues/7" idp1 <- makeTestIdP idp2 <- makeTestIdP - runSpar $ liftSem $ IdPEffect.setReplacedBy (Data.Replaced (idp1 ^. idpId)) (Data.Replacing (idp2 ^. idpId)) - idp1' <- runSpar $ liftSem (IdPEffect.getConfig (idp1 ^. idpId)) + runSpar $ IdPEffect.setReplacedBy (Data.Replaced (idp1 ^. idpId)) (Data.Replacing (idp2 ^. idpId)) + idp1' <- runSpar $ IdPEffect.getConfig (idp1 ^. idpId) liftIO $ idp1' `shouldBe` Nothing - runSpar $ liftSem $ IdPEffect.clearReplacedBy (Data.Replaced (idp1 ^. idpId)) - idp2' <- runSpar $ liftSem (IdPEffect.getConfig (idp1 ^. idpId)) + runSpar $ IdPEffect.clearReplacedBy (Data.Replaced (idp1 ^. idpId)) + idp2' <- runSpar $ IdPEffect.getConfig (idp1 ^. idpId) liftIO $ idp2' `shouldBe` Nothing -- TODO(sandy): This function should be more polymorphic over it's polysemy @@ -230,9 +230,9 @@ spec = do testSPStoreID :: forall (a :: Type). (Typeable a) => - (SAML.ID a -> SAML.Time -> Sem RealInterpretation ()) -> - (SAML.ID a -> Sem RealInterpretation ()) -> - (SAML.ID a -> Sem RealInterpretation Bool) -> + (SAML.ID a -> SAML.Time -> Sem CanonicalEffs ()) -> + (SAML.ID a -> Sem CanonicalEffs ()) -> + (SAML.ID a -> Sem CanonicalEffs Bool) -> SpecWith TestEnv testSPStoreID store unstore isalive = do describe ("SPStoreID @" <> show (typeRep @a)) $ do @@ -240,24 +240,24 @@ testSPStoreID store unstore isalive = do it "isAliveID is True" $ do xid :: SAML.ID a <- nextSAMLID eol :: Time <- addTime 5 <$> runSimpleSP getNow - () <- runSpar $ liftSem $ store xid eol - isit <- runSpar $ liftSem $ isalive xid + () <- runSpar $ store xid eol + isit <- runSpar $ isalive xid liftIO $ isit `shouldBe` True context "after TTL" $ do it "isAliveID returns False" $ do xid :: SAML.ID a <- nextSAMLID eol :: Time <- addTime 2 <$> runSimpleSP getNow - () <- runSpar $ liftSem $ store xid eol + () <- runSpar $ store xid eol liftIO $ threadDelay 3000000 - isit <- runSpar $ liftSem $ isalive xid + isit <- runSpar $ isalive xid liftIO $ isit `shouldBe` False context "after call to unstore" $ do it "isAliveID returns False" $ do xid :: SAML.ID a <- nextSAMLID eol :: Time <- addTime 5 <$> runSimpleSP getNow - () <- runSpar $ liftSem $ store xid eol - () <- runSpar $ liftSem $ unstore xid - isit <- runSpar $ liftSem $ isalive xid + () <- runSpar $ store xid eol + () <- runSpar $ unstore xid + isit <- runSpar $ isalive xid liftIO $ isit `shouldBe` False -- | Test that when a team is deleted, all relevant data is pruned from the @@ -280,38 +280,36 @@ testDeleteTeam = it "cleans up all the right tables after deletion" $ do -- -- The token from 'team_provisioning_by_token': do - tokenInfo <- runSpar $ liftSem $ ScimTokenStore.lookup tok + tokenInfo <- runSpar $ ScimTokenStore.lookup tok liftIO $ tokenInfo `shouldBe` Nothing -- The team from 'team_provisioning_by_team': do - tokens <- runSpar $ liftSem $ ScimTokenStore.getByTeam tid + tokens <- runSpar $ ScimTokenStore.getByTeam tid liftIO $ tokens `shouldBe` [] -- The users from 'user': do mbUser1 <- case veidFromUserSSOId ssoid1 of Right veid -> runSpar $ - liftSem $ - runValidExternalId - SAMLUserStore.get - undefined -- could be @Data.lookupScimExternalId@, but we don't hit that path. - veid + runValidExternalId + SAMLUserStore.get + undefined -- could be @Data.lookupScimExternalId@, but we don't hit that path. + veid Left _email -> undefined -- runSparCass . Data.lookupScimExternalId . fromEmail $ _email liftIO $ mbUser1 `shouldBe` Nothing do mbUser2 <- case veidFromUserSSOId ssoid2 of Right veid -> runSpar $ - liftSem $ - runValidExternalId - SAMLUserStore.get - undefined - veid + runValidExternalId + SAMLUserStore.get + undefined + veid Left _email -> undefined liftIO $ mbUser2 `shouldBe` Nothing -- The config from 'idp': do - mbIdp <- runSpar $ liftSem $ IdPEffect.getConfig (idp ^. SAML.idpId) + mbIdp <- runSpar $ IdPEffect.getConfig (idp ^. SAML.idpId) liftIO $ mbIdp `shouldBe` Nothing -- The config from 'issuer_idp': do @@ -320,5 +318,5 @@ testDeleteTeam = it "cleans up all the right tables after deletion" $ do liftIO $ mbIdp `shouldBe` GetIdPNotFound -- The config from 'team_idp': do - idps <- runSpar $ liftSem $ IdPEffect.getConfigsByTeam tid + idps <- runSpar $ IdPEffect.getConfigsByTeam tid liftIO $ idps `shouldBe` [] diff --git a/services/spar/test-integration/Test/Spar/Intra/BrigSpec.hs b/services/spar/test-integration/Test/Spar/Intra/BrigSpec.hs index 84114d8027..e2e3ef3ce1 100644 --- a/services/spar/test-integration/Test/Spar/Intra/BrigSpec.hs +++ b/services/spar/test-integration/Test/Spar/Intra/BrigSpec.hs @@ -25,7 +25,6 @@ import Control.Lens ((^.)) import Data.Id (Id (Id)) import qualified Data.UUID as UUID import Imports hiding (head) -import Spar.App (liftSem) import qualified Spar.Intra.BrigApp as Intra import Util import qualified Web.Scim.Schema.User as Scim.User @@ -40,7 +39,7 @@ spec = do describe "getBrigUser" $ do it "return Nothing if n/a" $ do - musr <- runSpar $ liftSem $ Intra.getBrigUser Intra.WithPendingInvitations (Id . fromJust $ UUID.fromText "29546d9e-ed5b-11ea-8228-c324b1ea1030") + musr <- runSpar $ Intra.getBrigUser Intra.WithPendingInvitations (Id . fromJust $ UUID.fromText "29546d9e-ed5b-11ea-8228-c324b1ea1030") liftIO $ musr `shouldSatisfy` isNothing it "return Just if /a" $ do @@ -53,5 +52,5 @@ spec = do scimUserId <$> createUser tok scimUser uid <- setup - musr <- runSpar $ liftSem $ Intra.getBrigUser Intra.WithPendingInvitations uid + musr <- runSpar $ Intra.getBrigUser Intra.WithPendingInvitations uid liftIO $ musr `shouldSatisfy` isJust diff --git a/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs b/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs index 831c2951b4..a73b15ed14 100644 --- a/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs +++ b/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs @@ -43,7 +43,6 @@ import qualified Data.Aeson as Aeson import Data.Aeson.Lens (key, _String) import Data.Aeson.QQ (aesonQQ) import Data.Aeson.Types (fromJSON, toJSON) -import qualified Data.Bifunctor as Bifunctor import Data.ByteString.Conversion import qualified Data.CaseInsensitive as CI import qualified Data.Csv as Csv @@ -59,7 +58,6 @@ import Imports import qualified Network.Wai.Utilities.Error as Wai import qualified SAML2.WebSSO as SAML import qualified SAML2.WebSSO.Test.MockResponse as SAML -import Spar.App (liftSem) import qualified Spar.Intra.BrigApp as Intra import Spar.Scim import Spar.Scim.Types (normalizeLikeStored) @@ -69,7 +67,6 @@ import qualified Spar.Sem.SAMLUserStore as SAMLUserStore import qualified Spar.Sem.ScimExternalIdStore as ScimExternalIdStore import qualified Spar.Sem.ScimUserTimesStore as ScimUserTimesStore import qualified Text.XML.DSig as SAML -import qualified URI.ByteString as URI import Util import Util.Invitation (getInvitation, getInvitationCode, headInvitation404, registerInvitation) import qualified Web.Scim.Class.User as Scim.UserC @@ -118,9 +115,9 @@ specSuspend = do -- NOTE: once SCIM is enabled, SSO Auto-provisioning is disabled tok <- registerScimToken teamid (Just (idp ^. SAML.idpId)) handle'@(Handle handle) <- nextHandle - runSpar $ liftSem $ BrigAccess.setHandle member handle' + runSpar $ BrigAccess.setHandle member handle' unless isActive $ do - runSpar $ liftSem $ BrigAccess.setStatus member Suspended + runSpar $ BrigAccess.setStatus member Suspended [user] <- listUsers tok (Just (filterBy "userName" handle)) lift $ (fmap Scim.unScimBool . Scim.User.active . Scim.value . Scim.thing $ user) `shouldBe` Just isActive it "pre-existing suspended users are inactive" $ do @@ -139,19 +136,19 @@ specSuspend = do -- Once we get rid of the `scim` table and make scim serve brig records directly, this is -- not an issue anymore. lift $ (fmap Scim.unScimBool . Scim.User.active . Scim.value . Scim.thing $ scimStoredUserBlah) `shouldBe` Just True - void $ aFewTimes (runSpar $ liftSem $ BrigAccess.getStatus uid) (== Active) + void $ aFewTimes (runSpar $ BrigAccess.getStatus uid) (== Active) do scimStoredUser <- putOrPatch tok uid user True lift $ (fmap Scim.unScimBool . Scim.User.active . Scim.value . Scim.thing $ scimStoredUser) `shouldBe` Just True - void $ aFewTimes (runSpar $ liftSem $ BrigAccess.getStatus uid) (== Active) + void $ aFewTimes (runSpar $ BrigAccess.getStatus uid) (== Active) do scimStoredUser <- putOrPatch tok uid user False lift $ (fmap Scim.unScimBool . Scim.User.active . Scim.value . Scim.thing $ scimStoredUser) `shouldBe` Just False - void $ aFewTimes (runSpar $ liftSem $ BrigAccess.getStatus uid) (== Suspended) + void $ aFewTimes (runSpar $ BrigAccess.getStatus uid) (== Suspended) do scimStoredUser <- putOrPatch tok uid user True lift $ (fmap Scim.unScimBool . Scim.User.active . Scim.value . Scim.thing $ scimStoredUser) `shouldBe` Just True - void $ aFewTimes (runSpar $ liftSem $ BrigAccess.getStatus uid) (== Active) + void $ aFewTimes (runSpar $ BrigAccess.getStatus uid) (== Active) it "PUT will change state from active to inactive and back" $ do void . activeInactiveAndBack $ \tok uid user active -> @@ -190,10 +187,10 @@ specSuspend = do (tok, _) <- registerIdPAndScimToken scimStoredUserBlah <- createUser tok user let uid = Scim.id . Scim.thing $ scimStoredUserBlah - runSpar $ liftSem $ BrigAccess.setStatus uid Suspended - void $ aFewTimes (runSpar $ liftSem $ BrigAccess.getStatus uid) (== Suspended) + runSpar $ BrigAccess.setStatus uid Suspended + void $ aFewTimes (runSpar $ BrigAccess.getStatus uid) (== Suspended) void $ patchUser tok uid $ PatchOp.PatchOp [deleteAttrib "active"] - void $ aFewTimes (runSpar $ liftSem $ BrigAccess.getStatus uid) (== Active) + void $ aFewTimes (runSpar $ BrigAccess.getStatus uid) (== Active) ---------------------------------------------------------------------------- -- User creation @@ -235,8 +232,9 @@ testCsvData :: UserId -> Maybe Text {- externalId -} -> Maybe UserSSOId -> + Bool -> TestSpar () -testCsvData tid owner uid mbeid mbsaml = do +testCsvData tid owner uid mbeid mbsaml hasissuer = do usersInCsv <- do g <- view teGalley resp <- @@ -255,17 +253,15 @@ testCsvData tid owner uid mbeid mbsaml = do let haveIssuer :: Maybe HttpsUrl haveIssuer = case mbsaml of - Just (UserSSOId issuer _) -> - either (const Nothing) Just - . (mkHttpsUrl <=< Bifunctor.first show . (URI.parseURI URI.laxURIParserOptions)) - $ cs issuer + Just (UserSSOId (SAML.UserRef (SAML.Issuer issuer) _)) -> either (const Nothing) Just $ mkHttpsUrl issuer Just (UserScimExternalId _) -> Nothing Nothing -> Nothing + ('h', haveIssuer) `shouldSatisfy` bool isNothing isJust hasissuer . snd ('i', CsvExport.tExportIdpIssuer export) `shouldBe` ('i', haveIssuer) let haveSubject :: Text haveSubject = case mbsaml of - Just (UserSSOId _ subject) -> either (error . show) (CI.original . SAML.unsafeShowNameID) $ SAML.decodeElem (cs subject) + Just (UserSSOId (SAML.UserRef _ subject)) -> CI.original $ SAML.unsafeShowNameID subject Just (UserScimExternalId _) -> "" Nothing -> "" ('n', CsvExport.tExportSAMLNamedId export) `shouldBe` ('n', haveSubject) @@ -304,10 +300,10 @@ testCreateUserNoIdP = do -- get account from brig, status should be PendingInvitation do - aFewTimes (runSpar $ liftSem $ BrigAccess.getAccount Intra.NoPendingInvitations userid) isJust + aFewTimes (runSpar $ BrigAccess.getAccount Intra.NoPendingInvitations userid) isJust >>= maybe (pure ()) (error "pending user in brig is visible, even though it should not be") brigUserAccount <- - aFewTimes (runSpar $ liftSem $ BrigAccess.getAccount Intra.WithPendingInvitations userid) isJust + aFewTimes (runSpar $ BrigAccess.getAccount Intra.WithPendingInvitations userid) isJust >>= maybe (error "could not find user in brig") pure let brigUser = accountUser brigUserAccount brigUser `userShouldMatch` WrappedScimStoredUser scimStoredUser @@ -347,7 +343,7 @@ testCreateUserNoIdP = do -- user should now be active do brigUser <- - aFewTimes (runSpar $ liftSem $ BrigAccess.getAccount Intra.NoPendingInvitations userid) isJust + aFewTimes (runSpar $ BrigAccess.getAccount Intra.NoPendingInvitations userid) isJust >>= maybe (error "could not find user in brig") pure liftIO $ accountStatus brigUser `shouldBe` Active liftIO $ userManagedBy (accountUser brigUser) `shouldBe` ManagedByScim @@ -363,7 +359,7 @@ testCreateUserNoIdP = do -- csv download should work let eid = Scim.User.externalId scimUser sml = Nothing - in testCsvData tid owner userid eid sml + in testCsvData tid owner userid eid sml False -- members table contains an entry -- (this really shouldn't be tested here, but by the type system!) @@ -431,7 +427,7 @@ testCreateUserWithSamlIdP = do . expect2xx ) brigUser `userShouldMatch` WrappedScimStoredUser scimStoredUser - accStatus <- aFewTimes (runSpar $ liftSem $ BrigAccess.getStatus (userId brigUser)) (== Active) + accStatus <- aFewTimes (runSpar $ BrigAccess.getStatus (userId brigUser)) (== Active) liftIO $ accStatus `shouldBe` Active liftIO $ userManagedBy brigUser `shouldBe` ManagedByScim @@ -439,7 +435,7 @@ testCreateUserWithSamlIdP = do eid = Scim.User.externalId user sml :: HasCallStack => UserSSOId sml = fromJust $ userIdentity >=> ssoIdentity $ brigUser - in testCsvData tid owner uid eid (Just sml) + in testCsvData tid owner uid eid (Just sml) True -- members table contains an entry -- (this really shouldn't be tested here, but by the type system!) @@ -823,9 +819,9 @@ testFindSamlAutoProvisionedUserMigratedWithEmailInTeamWithSSO = do -- auto-provision user via saml memberWithSSO <- do uid <- loginSsoUserFirstTime idp privCreds - Just usr <- runSpar $ liftSem $ Intra.getBrigUser Intra.NoPendingInvitations uid + Just usr <- runSpar $ Intra.getBrigUser Intra.NoPendingInvitations uid handle <- nextHandle - runSpar $ liftSem $ BrigAccess.setHandle uid handle + runSpar $ BrigAccess.setHandle uid handle pure usr let memberIdWithSSO = userId memberWithSSO externalId = either error id $ veidToText =<< Intra.veidFromBrigUser memberWithSSO Nothing @@ -836,7 +832,7 @@ testFindSamlAutoProvisionedUserMigratedWithEmailInTeamWithSSO = do liftIO $ userManagedBy memberWithSSO `shouldBe` ManagedByWire users <- listUsers tok (Just (filterBy "externalId" externalId)) liftIO $ (scimUserId <$> users) `shouldContain` [memberIdWithSSO] - Just brigUser' <- runSpar $ liftSem $ Intra.getBrigUser Intra.NoPendingInvitations memberIdWithSSO + Just brigUser' <- runSpar $ Intra.getBrigUser Intra.NoPendingInvitations memberIdWithSSO liftIO $ userManagedBy brigUser' `shouldBe` ManagedByScim where veidToText :: MonadError String m => ValidExternalId -> m Text @@ -857,7 +853,7 @@ testFindTeamSettingsInvitedUserMigratedWithEmailInTeamWithSSO = do users' <- listUsers tok (Just (filterBy "externalId" emailInvited)) liftIO $ (scimUserId <$> users') `shouldContain` [memberIdInvited] - Just brigUserInvited' <- runSpar $ liftSem $ Intra.getBrigUser Intra.NoPendingInvitations memberIdInvited + Just brigUserInvited' <- runSpar $ Intra.getBrigUser Intra.NoPendingInvitations memberIdInvited liftIO $ userManagedBy brigUserInvited' `shouldBe` ManagedByScim testFindTeamSettingsInvitedUserMigratedWithEmailInTeamWithSSOViaUserId :: TestSpar () @@ -869,7 +865,7 @@ testFindTeamSettingsInvitedUserMigratedWithEmailInTeamWithSSOViaUserId = do let memberIdInvited = userId memberInvited _ <- getUser tok memberIdInvited - Just brigUserInvited' <- runSpar $ liftSem $ Intra.getBrigUser Intra.NoPendingInvitations (memberIdInvited) + Just brigUserInvited' <- runSpar $ Intra.getBrigUser Intra.NoPendingInvitations (memberIdInvited) liftIO $ userManagedBy brigUserInvited' `shouldBe` ManagedByScim testFindProvisionedUserNoIdP :: TestSpar () @@ -888,8 +884,8 @@ testFindNonProvisionedUserNoIdP findBy = do uid <- userId <$> call (inviteAndRegisterUser (env ^. teBrig) owner teamid) handle <- nextHandle - runSpar $ liftSem $ BrigAccess.setHandle uid handle - Just brigUser <- runSpar $ liftSem $ Intra.getBrigUser Intra.NoPendingInvitations uid + runSpar $ BrigAccess.setHandle uid handle + Just brigUser <- runSpar $ Intra.getBrigUser Intra.NoPendingInvitations uid let Just email = userEmail brigUser do @@ -904,7 +900,7 @@ testFindNonProvisionedUserNoIdP findBy = do do liftIO $ users `shouldBe` [uid] - Just brigUser' <- runSpar $ liftSem $ Intra.getBrigUser Intra.NoPendingInvitations uid + Just brigUser' <- runSpar $ Intra.getBrigUser Intra.NoPendingInvitations uid liftIO $ userManagedBy brigUser' `shouldBe` ManagedByScim liftIO $ brigUser' `shouldBe` brigUser {userManagedBy = ManagedByScim} @@ -989,7 +985,7 @@ testGetUser = do shouldBeManagedBy :: HasCallStack => UserId -> ManagedBy -> TestSpar () shouldBeManagedBy uid flag = do - managedBy <- maybe (error "user not found") userManagedBy <$> runSpar (liftSem $ Intra.getBrigUser Intra.WithPendingInvitations uid) + managedBy <- maybe (error "user not found") userManagedBy <$> runSpar (Intra.getBrigUser Intra.WithPendingInvitations uid) liftIO $ managedBy `shouldBe` flag -- | This is (roughly) the behavior on develop as well as on the branch where this test was @@ -1042,12 +1038,12 @@ testGetUserWithNoHandle = do uid <- loginSsoUserFirstTime idp privcreds tok <- registerScimToken tid (Just (idp ^. SAML.idpId)) - mhandle :: Maybe Handle <- maybe (error "user not found") userHandle <$> runSpar (liftSem $ Intra.getBrigUser Intra.WithPendingInvitations uid) + mhandle :: Maybe Handle <- maybe (error "user not found") userHandle <$> runSpar (Intra.getBrigUser Intra.WithPendingInvitations uid) liftIO $ mhandle `shouldSatisfy` isNothing storedUser <- getUser tok uid liftIO $ (Scim.User.displayName . Scim.value . Scim.thing) storedUser `shouldSatisfy` isJust - mhandle' :: Maybe Handle <- aFewTimes (maybe (error "user not found") userHandle <$> runSpar (liftSem $ Intra.getBrigUser Intra.WithPendingInvitations uid)) isJust + mhandle' :: Maybe Handle <- aFewTimes (maybe (error "user not found") userHandle <$> runSpar (Intra.getBrigUser Intra.WithPendingInvitations uid)) isJust liftIO $ mhandle' `shouldSatisfy` isJust liftIO $ (fromHandle <$> mhandle') `shouldBe` (Just . Scim.User.userName . Scim.value . Scim.thing $ storedUser) @@ -1321,7 +1317,7 @@ testUpdateExternalId withidp = do lookupByValidExternalId :: ValidExternalId -> TestSpar (Maybe UserId) lookupByValidExternalId = runValidExternalId - (runSpar . liftSem . SAMLUserStore.get) + (runSpar . SAMLUserStore.get) ( \email -> do let action = SU.scimFindUserByEmail midp tid $ fromEmail email result <- runSpar . runExceptT . runMaybeT $ action @@ -1342,10 +1338,8 @@ testBrigSideIsUpdated = do user' <- randomScimUser let userid = scimUserId storedUser _ <- updateUser tok userid user' - validScimUser <- - either (error . show) pure $ - validateScimUser' (Just idp) 999999 user' - brigUser <- maybe (error "no brig user") pure =<< runSpar (liftSem $ Intra.getBrigUser Intra.WithPendingInvitations userid) + validScimUser <- either (error . show) pure $ validateScimUser' "testBrigSideIsUpdated" (Just idp) 999999 user' + brigUser <- maybe (error "no brig user") pure =<< runSpar (Intra.getBrigUser Intra.WithPendingInvitations userid) brigUser `userShouldMatch` validScimUser ---------------------------------------------------------------------------- @@ -1527,7 +1521,7 @@ specDeleteUser = do storedUser <- createUser tok user let uid :: UserId = scimUserId storedUser uref :: SAML.UserRef <- do - usr <- runSpar $ liftSem $ Intra.getBrigUser Intra.WithPendingInvitations uid + usr <- runSpar $ Intra.getBrigUser Intra.WithPendingInvitations uid let err = error . ("brig user without UserRef: " <>) . show case (`Intra.veidFromBrigUser` Nothing) <$> usr of bad@(Just (Right veid)) -> runValidExternalId pure (const $ err bad) veid @@ -1536,11 +1530,11 @@ specDeleteUser = do deleteUser_ (Just tok) (Just uid) spar !!! const 204 === statusCode brigUser :: Maybe User <- - aFewTimes (runSpar $ liftSem $ Intra.getBrigUser Intra.WithPendingInvitations uid) isNothing + aFewTimes (runSpar $ Intra.getBrigUser Intra.WithPendingInvitations uid) isNothing samlUser :: Maybe UserId <- aFewTimes (getUserIdViaRef' uref) isNothing scimUser <- - aFewTimes (runSpar $ liftSem $ ScimUserTimesStore.read uid) isNothing + aFewTimes (runSpar $ ScimUserTimesStore.read uid) isNothing liftIO $ (brigUser, samlUser, scimUser) `shouldBe` (Nothing, Nothing, Nothing) @@ -1744,7 +1738,7 @@ testDeletedUsersFreeExternalIdNoIdp = do void $ aFewTimes - (runSpar $ liftSem $ ScimExternalIdStore.lookup tid email) + (runSpar $ ScimExternalIdStore.lookup tid email) (== Nothing) specSCIMManaged :: SpecWith TestEnv diff --git a/services/spar/test-integration/Util/Core.hs b/services/spar/test-integration/Util/Core.hs index a4f799881c..f51f878974 100644 --- a/services/spar/test-integration/Util/Core.hs +++ b/services/spar/test-integration/Util/Core.hs @@ -117,7 +117,7 @@ module Util.Core ssoToUidSpar, runSimpleSP, runSpar, - type RealInterpretation, + type CanonicalEffs, getSsoidViaSelf, getSsoidViaSelf', getUserIdViaRef, @@ -168,35 +168,20 @@ import Network.HTTP.Client.MultipartFormData import qualified Network.Wai.Handler.Warp as Warp import qualified Network.Wai.Handler.Warp.Internal as Warp import qualified Options.Applicative as OPA -import Polysemy -import Polysemy.Error (runError) -import Polysemy.Input +import Polysemy (Sem) import SAML2.WebSSO as SAML import qualified SAML2.WebSSO.API.Example as SAML import SAML2.WebSSO.Test.Lenses (userRefL) import SAML2.WebSSO.Test.MockResponse import SAML2.WebSSO.Test.Util (SampleIdP (..), makeSampleIdPMetadata) -import Spar.App (liftSem, type RealInterpretation) import qualified Spar.App as Spar -import Spar.Error (SparError) +import Spar.CanonicalInterpreter import qualified Spar.Intra.BrigApp as Intra import qualified Spar.Options import Spar.Run -import Spar.Sem.AReqIDStore.Cassandra (aReqIDStoreToCassandra, ttlErrorToSparError) -import Spar.Sem.AssIDStore.Cassandra (assIDStoreToCassandra) -import Spar.Sem.BindCookieStore.Cassandra (bindCookieStoreToCassandra) -import Spar.Sem.BrigAccess.Http (brigAccessToHttp) -import Spar.Sem.DefaultSsoCode.Cassandra (defaultSsoCodeToCassandra) -import Spar.Sem.GalleyAccess.Http (galleyAccessToHttp) -import Spar.Sem.IdP.Cassandra -import Spar.Sem.Logger.TinyLog (loggerToTinyLog, stringLoggerToTinyLog, toLevel) -import Spar.Sem.Random.IO (randomToIO) +import Spar.Sem.Logger.TinyLog (toLevel) import qualified Spar.Sem.SAMLUserStore as SAMLUserStore -import Spar.Sem.SAMLUserStore.Cassandra import qualified Spar.Sem.ScimExternalIdStore as ScimExternalIdStore -import Spar.Sem.ScimExternalIdStore.Cassandra (scimExternalIdStoreToCassandra) -import Spar.Sem.ScimTokenStore.Cassandra (scimTokenStoreToCassandra) -import Spar.Sem.ScimUserTimesStore.Cassandra (scimUserTimesStoreToCassandra) import qualified System.Logger.Extended as Log import System.Random (randomRIO) import Test.Hspec hiding (it, pending, pendingWith, xit) @@ -205,7 +190,7 @@ import qualified Text.XML as XML import qualified Text.XML.Cursor as XML import Text.XML.DSig (SignPrivCreds) import qualified Text.XML.DSig as SAML -import URI.ByteString +import URI.ByteString as URI import Util.Options import Util.Types import qualified Web.Cookie as Web @@ -216,6 +201,7 @@ import qualified Wire.API.Team.Feature as Public import qualified Wire.API.Team.Invitation as TeamInvitation import Wire.API.User (HandleUpdate (HandleUpdate), UserUpdate) import qualified Wire.API.User as User +import Wire.API.User.Identity (mkSampleUref) import Wire.API.User.IdentityProvider import Wire.API.User.Saml import Wire.API.User.Scim (runValidExternalId) @@ -478,7 +464,8 @@ createTeamMember :: m UserId createTeamMember brigreq galleyreq teamid perms = do let randomtxt = liftIO $ UUID.toText <$> UUID.nextRandom - randomssoid = Brig.UserSSOId <$> randomtxt <*> randomtxt + randomssoid = liftIO $ Brig.UserSSOId <$> (mkSampleUref <$> rnd <*> rnd) + rnd = cs . show <$> randomRIO (0 :: Integer, 10000000) name <- randomtxt ssoid <- randomssoid resp :: ResponseLBS <- @@ -1222,8 +1209,8 @@ ssoToUidSpar tid ssoid = do veid <- either (error . ("could not parse brig sso_id: " <>)) pure $ Intra.veidFromUserSSOId ssoid runSpar $ runValidExternalId - (liftSem . SAMLUserStore.get) - (liftSem . ScimExternalIdStore.lookup tid) + (SAMLUserStore.get) + (ScimExternalIdStore.lookup tid) veid runSimpleSP :: (MonadReader TestEnv m, MonadIO m) => SAML.SimpleSP a -> m a @@ -1236,36 +1223,12 @@ runSimpleSP action = do runSpar :: (MonadReader TestEnv m, MonadIO m) => - Spar.Spar RealInterpretation a -> + Sem CanonicalEffs a -> m a -runSpar (Spar.Spar action) = do +runSpar action = do ctx <- (^. teSparEnv) <$> ask liftIO $ do - result <- - fmap join - . liftIO - . runFinal - . embedToFinal @IO - . randomToIO - . runInputConst (Spar.sparCtxLogger ctx) - . runInputConst (Spar.sparCtxOpts ctx) - . loggerToTinyLog (Spar.sparCtxLogger ctx) - . stringLoggerToTinyLog - . runError @SparError - . ttlErrorToSparError - . galleyAccessToHttp (Spar.sparCtxHttpManager ctx) (Spar.sparCtxHttpGalley ctx) - . brigAccessToHttp (Spar.sparCtxHttpManager ctx) (Spar.sparCtxHttpBrig ctx) - . interpretClientToIO (Spar.sparCtxCas ctx) - . samlUserStoreToCassandra @Cas.Client - . idPToCassandra @Cas.Client - . defaultSsoCodeToCassandra - . scimTokenStoreToCassandra - . scimUserTimesStoreToCassandra - . scimExternalIdStoreToCassandra - . aReqIDStoreToCassandra - . assIDStoreToCassandra - . bindCookieStoreToCassandra - $ runExceptT action + result <- runSparToIO ctx action either (throwIO . ErrorCall . show) pure result getSsoidViaSelf :: HasCallStack => UserId -> TestSpar UserSSOId @@ -1273,7 +1236,7 @@ getSsoidViaSelf uid = maybe (error "not found") pure =<< getSsoidViaSelf' uid getSsoidViaSelf' :: HasCallStack => UserId -> TestSpar (Maybe UserSSOId) getSsoidViaSelf' uid = do - musr <- aFewTimes (runSpar $ liftSem $ Intra.getBrigUser Intra.NoPendingInvitations uid) isJust + musr <- aFewTimes (runSpar $ Intra.getBrigUser Intra.NoPendingInvitations uid) isJust pure $ case userIdentity =<< musr of Just (SSOIdentity ssoid _ _) -> Just ssoid Just (FullIdentity _ _) -> Nothing @@ -1286,7 +1249,7 @@ getUserIdViaRef uref = maybe (error "not found") pure =<< getUserIdViaRef' uref getUserIdViaRef' :: HasCallStack => UserRef -> TestSpar (Maybe UserId) getUserIdViaRef' uref = do - aFewTimes (runSpar $ liftSem $ SAMLUserStore.get uref) isJust + aFewTimes (runSpar $ SAMLUserStore.get uref) isJust checkErr :: HasCallStack => Int -> Maybe TestErrorLabel -> Assertions () checkErr status mlabel = do diff --git a/services/spar/test-integration/Util/Scim.hs b/services/spar/test-integration/Util/Scim.hs index 854ba7dd4f..689fe08076 100644 --- a/services/spar/test-integration/Util/Scim.hs +++ b/services/spar/test-integration/Util/Scim.hs @@ -34,7 +34,6 @@ import Data.UUID.V4 as UUID import Imports import qualified SAML2.WebSSO as SAML import SAML2.WebSSO.Types (IdPId, idpId) -import Spar.App (liftSem) import qualified Spar.Intra.BrigApp as Intra import Spar.Scim.User (synthesizeScimUser, validateScimUser') import qualified Spar.Sem.ScimTokenStore as ScimTokenStore @@ -82,16 +81,15 @@ registerScimToken teamid midpid = do scimTokenId <- randomId now <- liftIO getCurrentTime runSpar $ - liftSem $ - ScimTokenStore.insert - tok - ScimTokenInfo - { stiTeam = teamid, - stiId = scimTokenId, - stiCreatedAt = now, - stiIdP = midpid, - stiDescr = "test token" - } + ScimTokenStore.insert + tok + ScimTokenInfo + { stiTeam = teamid, + stiId = scimTokenId, + stiCreatedAt = now, + stiIdP = midpid, + stiDescr = "test token" + } pure tok -- | Generate a SCIM user with a random name and handle. At the very least, everything considered @@ -624,4 +622,6 @@ userShouldMatch u1 u2 = liftIO $ do -- what we expect a user that comes back from spar to look like in terms of what it looked -- like when we sent it there. whatSparReturnsFor :: HasCallStack => IdP -> Int -> Scim.User.User SparTag -> Either String (Scim.User.User SparTag) -whatSparReturnsFor idp richInfoSizeLimit = either (Left . show) (Right . synthesizeScimUser) . validateScimUser' (Just idp) richInfoSizeLimit +whatSparReturnsFor idp richInfoSizeLimit = + either (Left . show) (Right . synthesizeScimUser) + . validateScimUser' "whatSparReturnsFor" (Just idp) richInfoSizeLimit diff --git a/services/spar/test/Test/Spar/Intra/BrigSpec.hs b/services/spar/test/Test/Spar/Intra/BrigSpec.hs index d37e98582f..d8f6e8edf5 100644 --- a/services/spar/test/Test/Spar/Intra/BrigSpec.hs +++ b/services/spar/test/Test/Spar/Intra/BrigSpec.hs @@ -50,10 +50,9 @@ spec = do ( either (error . show) id $ mkNameID (mkUNameIDTransient "V") (Just "kati") (Just "rolli") (Just "jaan") ) - want = - UserSSOId - "http://wire.com/" - "V" + want = UserSSOId (SAML.UserRef iss nam) + iss :: SAML.Issuer = fromRight undefined $ SAML.decodeElem "http://wire.com/" + nam :: SAML.NameID = fromRight undefined $ SAML.decodeElem "V" veidToUserSSOId have `shouldBe` want veidFromUserSSOId want `shouldBe` Right have it "another example" $ do @@ -64,10 +63,10 @@ spec = do ( either (error . show) id $ mkNameID (mkUNameIDPersistent "PWkS") (Just "hendrik") Nothing (Just "marye") ) - want = - UserSSOId - "http://wire.com/" - "PWkS" + want = UserSSOId (SAML.UserRef iss nam) + iss :: SAML.Issuer = fromRight undefined $ SAML.decodeElem "http://wire.com/" + nam :: SAML.NameID = fromRight undefined $ SAML.decodeElem "PWkS" + veidToUserSSOId have `shouldBe` want veidFromUserSSOId want `shouldBe` Right have diff --git a/stack.yaml b/stack.yaml index 191946cb29..b816f92c3c 100644 --- a/stack.yaml +++ b/stack.yaml @@ -250,8 +250,8 @@ extra-deps: commit: b0e5c08af48911caecffa4fa6a3e74872018b258 # master (Sep 03, 2021) # Error handling fix: https://github.com/vincenthz/hs-certificate/pull/125 -- git: https://github.com/wireapp/hs-certificate - commit: e3ea2e1166f0569982a85aad9bc9de8f5b2994c1 # master (Aug 31, 2021) +- git: https://github.com/vincenthz/hs-certificate + commit: a899bda3d7666d25143be7be8f3105fc076703d9 # master (Sep 29, 2021) subdirs: - x509-store diff --git a/stack.yaml.lock b/stack.yaml.lock index 439ca987af..a8910cfe1d 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -811,15 +811,15 @@ packages: subdir: x509-store name: x509-store version: 1.6.7 - git: https://github.com/wireapp/hs-certificate + git: https://github.com/vincenthz/hs-certificate pantry-tree: size: 398 - sha256: 96deca9a5358118057cd145f198b5be06d88019eae46b263bee86c76b2fc574d - commit: e3ea2e1166f0569982a85aad9bc9de8f5b2994c1 + sha256: bf71c28417dcf76a8aef361fbc74abe78962c80e7e996a2515996fd44b2f6ba6 + commit: a899bda3d7666d25143be7be8f3105fc076703d9 original: subdir: x509-store - git: https://github.com/wireapp/hs-certificate - commit: e3ea2e1166f0569982a85aad9bc9de8f5b2994c1 + git: https://github.com/vincenthz/hs-certificate + commit: a899bda3d7666d25143be7be8f3105fc076703d9 - completed: hackage: ormolu-0.1.4.1@sha256:ed404eac6e4eb64da1ca5fb749e0f99907431a9633e6ba34e44d260e7d7728ba,6499 pantry-tree: diff --git a/tools/api-simulations/lib/src/Network/Wire/Simulations.hs b/tools/api-simulations/lib/src/Network/Wire/Simulations.hs index f0f383a491..7a34d8280b 100644 --- a/tools/api-simulations/lib/src/Network/Wire/Simulations.hs +++ b/tools/api-simulations/lib/src/Network/Wire/Simulations.hs @@ -81,7 +81,8 @@ prepareConv (a : bs) = do mapM_ (connectIfNeeded a) bs let bIds = map botId bs conv <- qUnqualified . cnvQualifiedId <$> runBotSession a (createConv bIds Nothing) - assertConvCreated conv a bs + lconv <- qualifyLocal conv + assertConvCreated lconv a bs return conv -- | Make sure that there is a connection between two bots. diff --git a/tools/api-simulations/smoketest/src/Network/Wire/Simulations/SmokeTest.hs b/tools/api-simulations/smoketest/src/Network/Wire/Simulations/SmokeTest.hs index 529cdf2948..4fcd6d0acf 100644 --- a/tools/api-simulations/smoketest/src/Network/Wire/Simulations/SmokeTest.hs +++ b/tools/api-simulations/smoketest/src/Network/Wire/Simulations/SmokeTest.hs @@ -89,7 +89,8 @@ mainBotNet n = do meetup <- runBotSession ally $ do let others = bill : carl : goons conv <- qUnqualified . cnvQualifiedId <$> createConv (map botId others) (Just "Meetup") - assertConvCreated conv ally others + lconv <- qualifyLocal conv + assertConvCreated lconv ally others return conv info $ msg "Bill updates his member state" localDomain <- viewFederationDomain diff --git a/tools/stern/src/Stern/API.hs b/tools/stern/src/Stern/API.hs index 903c44fa42..27e8e72709 100644 --- a/tools/stern/src/Stern/API.hs +++ b/tools/stern/src/Stern/API.hs @@ -268,7 +268,7 @@ routes = do document "GET" "ejpd-info" $ do Doc.summary "internal wire.com process: https://wearezeta.atlassian.net/wiki/spaces/~463749889/pages/256738296/EJPD+official+requests+process" Doc.parameter Doc.Query "handles" Doc.string' $ - Doc.description "Handles of the user, separated by comments" + Doc.description "Handles of the user, separated by commas (NB: all chars need to be lower case!)" Doc.parameter Doc.Query "include_contacts" Doc.bool' $ do Doc.description "If 'true', this gives you more more exhaustive information about this user (including social network)" Doc.optional diff --git a/tools/stern/src/Stern/Intra.hs b/tools/stern/src/Stern/Intra.hs index 86adc97530..e930aa76e0 100644 --- a/tools/stern/src/Stern/Intra.hs +++ b/tools/stern/src/Stern/Intra.hs @@ -96,6 +96,7 @@ import Stern.Types import System.Logger.Class hiding (Error, name, (.=)) import qualified System.Logger.Class as Log import UnliftIO.Exception hiding (Handler) +import Wire.API.Routes.Internal.Brig.Connection import qualified Wire.API.Routes.Internal.Brig.EJPD as EJPD import qualified Wire.API.Team.Feature as Public @@ -171,20 +172,19 @@ getUsersConnections :: List UserId -> Handler [ConnectionStatus] getUsersConnections uids = do info $ msg "Getting user connections" b <- view brig + let reqBody = ConnectionsStatusRequest (fromList uids) Nothing r <- catchRpcErrors $ rpc' "brig" b - ( method GET + ( method POST . path "/i/users/connections-status" - . queryItem "users" users + . Bilge.json reqBody . expect2xx ) info $ msg ("Response" ++ show r) parseResponse (mkError status502 "bad-upstream") r - where - users = BS.intercalate "," $ map toByteString' (fromList uids) getUserProfiles :: Either [UserId] [Handle] -> Handler [UserAccount] getUserProfiles uidsOrHandles = do