diff --git a/CHANGELOG.md b/CHANGELOG.md index 98782d28fa6..67998fb7958 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,55 @@ +# [2021-12-10] + +## Release notes + +* If you have `selfDeletingMessages` configured in `galley.yaml`, add `lockStatus: unlocked`. (#1963) +* Upgrade SFTD to 2.1.19. (#1983) + +## API changes + +* A new endpoint is added to Brig (`put /users/:uid/email`) that allows a team owner to initiate changing/setting a user email by (re-)sending an activation email. (#1948) +* get team feature config for self deleting messages response includes lock status (#1963) +* A new public Galley endpoint was added to dis-/enable the conversation guest link feature. The feature can only be configured through the public API if the lock status is unlocked in the server config. (#1964) +* new internal endpoints for setting the lock status of self deleting messages (#1963) + +## Features + +* Team and server wide config for conversation guest link feature to configure feature status and lock status (#1964). If the feature is not configured on the server, the defaults will be: + + ```txt + featureFlags: + ... + conversationGuestLinks: + defaults: + status: enabled + lockStatus: unlocked + ``` +* Lock status for the self deleting messages feature can be set internally by ibis and customer support (#1963) + +## Bug fixes and other updates + +* Correctly detect log level when rendering logs as structured JSON (#1959) + +## Documentation + +* Fix typo in swagger. (#1982) +* Proposal for API versioning system. (#1958) +* Update federation error documentation after changes to the federation API (#1956, #1975, #1978) + +## Internal changes + +* Suspend/unsuspend teams in backoffice/stern. (#1977) +* Set request ID correctly in galley logs (#1967) +* Improve cabal make targets: faster installation and better support for building and testing all packages (#1979) +* sftd chart: add config key `additionalArgs` (#1972) + +## Federation changes + +* Add cargohold as a new federated component (#1973) + + # [2021-12-02] ## Release notes diff --git a/Makefile b/Makefile index a2015eba6fc..1401d4d4c49 100644 --- a/Makefile +++ b/Makefile @@ -19,6 +19,9 @@ BUILDAH_PUSH ?= 0 KIND_CLUSTER_NAME := wire-server BUILDAH_KIND_LOAD ?= 1 +package ?= all +EXE_SCHEMA := ./dist/$(package)-schema + # This ensures that focused unit tests written in hspec fail. This is supposed # to help us avoid merging PRs with focused tests. This will not catch focused # integration tests as they are run in kubernetes where this Makefile doesn't @@ -42,7 +45,7 @@ install: init ifeq ($(WIRE_BUILD_WITH_CABAL), 1) cabal build all ./hack/bin/cabal-run-all-tests.sh - ./hack/bin/cabal-install-all-artefacts.sh + ./hack/bin/cabal-install-artefacts.sh all else stack install --pedantic --test --bench --no-run-benchmarks --local-bin-path=dist endif @@ -69,11 +72,19 @@ endif # Usage: make ci package=brig test=1 .PHONY: ci ci: c -ifeq ("$(pattern)", "") - make -C services/$(package) i -else - make -C services/$(package) i-$(pattern) -endif + ./hack/bin/cabal-run-integration.sh $(package) $(pattern) + +# reset db using cabal +.PHONY: db-reset-package +db-reset-package: c + $(EXE_SCHEMA) --keyspace $(package)_test --replication-factor 1 --reset + +# migrate db using cabal +# For using stack see the Makefile of the package, e.g. services/brig/Makefile +# Usage: make db-migrate-package package=galley +.PHONY: db-migrate-package +db-migrate-package: c + $(EXE_SCHEMA) --keyspace $(package)_test --replication-factor 1 # Build everything (Haskell services and nginz) .PHONY: services @@ -230,12 +241,18 @@ run-docker-builder: @echo "if this does not work, consider 'docker pull', 'docker tag', or 'make -C build-alpine builder'." docker run --workdir /wire-server -it $(DOCKER_DEV_NETWORK) $(DOCKER_DEV_VOLUMES) --rm $(DOCKER_DEV_IMAGE) /bin/bash -CASSANDRA_CONTAINER := $(shell docker ps | grep '/cassandra:' | perl -ne '/^(\S+)\s/ && print $$1') .PHONY: git-add-cassandra-schema -git-add-cassandra-schema: db-reset +git-add-cassandra-schema: db-reset git-add-cassandra-schema-impl + +CASSANDRA_CONTAINER := $(shell docker ps | grep '/cassandra:' | perl -ne '/^(\S+)\s/ && print $$1') +.PHONY: git-add-cassandra-schema-impl +git-add-cassandra-schema-impl: ( echo '-- automatically generated with `make git-add-cassandra-schema`' ; docker exec -i $(CASSANDRA_CONTAINER) /usr/bin/cqlsh -e "DESCRIBE schema;" ) > ./docs/reference/cassandra-schema.cql git add ./docs/reference/cassandra-schema.cql +.PHONY: git-add-cassandra-schema-cabal +git-add-cassandra-schema-cabal: db-reset-cabal git-add-cassandra-schema-impl + .PHONY: cqlsh cqlsh: @echo "make sure you have ./deploy/dockerephemeral/run.sh running in another window!" @@ -244,10 +261,17 @@ cqlsh: .PHONY: db-reset db-reset: @echo "make sure you have ./deploy/dockerephemeral/run.sh running in another window!" +ifeq ($(WIRE_BUILD_WITH_CABAL), 1) + make db-reset-package package=brig + make db-reset-package package=galley + make db-reset-package package=gundeck + make db-reset-package package=spar +else make -C services/brig db-reset make -C services/galley db-reset make -C services/gundeck db-reset make -C services/spar db-reset +endif ################################# ## dependencies diff --git a/charts/federator/templates/configmap.yaml b/charts/federator/templates/configmap.yaml index 1c151172e81..58c13106843 100644 --- a/charts/federator/templates/configmap.yaml +++ b/charts/federator/templates/configmap.yaml @@ -31,6 +31,10 @@ data: host: galley port: 8080 + cargohold: + host: cargohold + port: 8080 + {{- with .Values.config }} logNetStrings: True # log using netstrings encoding: diff --git a/charts/federator/templates/tests/configmap.yaml b/charts/federator/templates/tests/configmap.yaml index 31b26123dc9..910411fe5d4 100644 --- a/charts/federator/templates/tests/configmap.yaml +++ b/charts/federator/templates/tests/configmap.yaml @@ -16,6 +16,9 @@ data: galley: host: galley port: 8080 + cargohold: + host: cargohold + port: 8080 nginxIngress: host: federation-test-helper.{{ .Release.Namespace }}.svc.cluster.local port: 443 diff --git a/charts/sftd/Chart.yaml b/charts/sftd/Chart.yaml index c619f35d92a..5d3b865d616 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.1.15 +appVersion: 2.1.19 diff --git a/charts/sftd/templates/statefulset.yaml b/charts/sftd/templates/statefulset.yaml index 391931b1a0b..2c5d52fce40 100644 --- a/charts/sftd/templates/statefulset.yaml +++ b/charts/sftd/templates/statefulset.yaml @@ -87,6 +87,7 @@ spec: -I "${POD_IP}" \ -M "${POD_IP}" \ ${ACCESS_ARGS} \ + {{ .Values.additionalArgs }} \ {{ if .Values.turnDiscoveryEnabled }}-T{{ end }} \ -u "https://{{ required "must specify host" .Values.host }}/sfts/${POD_NAME}" ports: diff --git a/charts/sftd/values.yaml b/charts/sftd/values.yaml index 6c889fc6299..a34ae175892 100644 --- a/charts/sftd/values.yaml +++ b/charts/sftd/values.yaml @@ -85,3 +85,7 @@ joinCall: # trying to establish a connection to clients # DOCS: https://docs.wire.com/understand/sft.html#prerequisites turnDiscoveryEnabled: false + +# Additional arguments to be passed to `sftd` +# Note: this might be removed in the future. +additionalArgs: "" diff --git a/dev-packages.nix b/dev-packages.nix new file mode 100644 index 00000000000..3747cc9ae2a --- /dev/null +++ b/dev-packages.nix @@ -0,0 +1,190 @@ +{ pkgs ? import ./nix }: +let + staticBinaryInTarball = { 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; + }; + + installPhase = '' + mkdir -p $out/bin + 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"; + version = "2.3.1"; + + darwinAmd64Url = "https://github.com/commercialhaskell/stack/releases/download/v2.3.1/stack-2.3.1-osx-x86_64.tar.gz"; + darwinAmd64Sha256 = "089nrb8mxf76a0r0hdccaxfvx1ly24b5zc0cy05gs4adybjygvkk"; + + linuxAmd64Url = "https://github.com/commercialhaskell/stack/releases/download/v2.3.1/stack-2.3.1-linux-x86_64-static.tar.gz"; + linuxAmd64Sha256 = "0iqfqcd88rvlwgm2h8avs0rsi9f3pdxilvcacgrxskb1n8q8ibjb"; + }; + + helm = staticBinaryInTarball { + pname = "helm"; + version = "3.6.3"; + + darwinAmd64Url = "https://get.helm.sh/helm-v3.6.3-darwin-amd64.tar.gz"; + darwinAmd64Sha256 = "0djjvgla8cw27h8s4y6jby19f74j58byb2vfv590cd03vlbzz8c4"; + + 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 { + pname = "kubectl"; + version = "1.19.8"; + + darwinAmd64Url = "https://dl.k8s.io/v1.19.8/kubernetes-client-darwin-amd64.tar.gz"; + darwinAmd64Sha256 = "23b847bb8b545c748e9078e7660c654eef74d15ccab8696d294f3d6c619c788e"; + + linuxAmd64Url = "https://dl.k8s.io/v1.19.8/kubernetes-client-linux-amd64.tar.gz"; + linuxAmd64Sha256 = "8388ff8b5c676bdbb8fe07ef7077de937b0bf60154f302df5f248f38f95122aa"; + + 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"; + }; + }; + + compile-deps = pkgs.buildEnv { + name = "wire-server-compile-deps"; + paths = [ + pkgs.bash + pkgs.coreutils + pkgs.gnused + pkgs.gnugrep + pkgs.pkgconfig + pkgs.gawk + pkgs.git + + pkgs.haskell.compiler.ghc884 + pkgs.protobuf + + pkgs.cryptobox + pkgs.geoip + pkgs.icu.dev + pkgs.icu.out + pkgs.libsodium.dev + pkgs.libsodium.out + pkgs.libxml2.dev + pkgs.libxml2.out + pkgs.ncurses.dev + pkgs.ncurses.out + pkgs.openssl.dev + pkgs.openssl.out + pkgs.pcre.dev + pkgs.pcre.out + pkgs.snappy.dev + pkgs.snappy.out + pkgs.zlib.dev + pkgs.zlib.out + pkgs.lzma.dev + pkgs.lzma.out + ]; + }; + + # This performs roughly the same setup as direnv's load_prefix function, but + # only when invoking cabal. This means that we can set LD_LIBRARY_PATH just + # for cabal, as setting it in direnv can interfere with programs in the host + # system, especially for non-NixOS users. + cabal-wrapper = pkgs.writeShellScriptBin "cabal" '' + export CPATH="${compile-deps}/include" + export LD_LIBRARY_PATH="${compile-deps}/lib" + export LIBRARY_PATH="${compile-deps}/lib" + export PKG_CONFIG_PATH="${compile-deps}/lib/pkgconfig" + export PATH="${compile-deps}/bin" + exec "${pkgs.cabal-install}/bin/cabal" "$@" + ''; +in +[ + pkgs.cfssl + pkgs.docker-compose + pkgs.gnumake + pkgs.haskell-language-server + pkgs.jq + pkgs.ormolu + pkgs.telepresence + pkgs.wget + pkgs.yq + pkgs.rsync + pkgs.netcat + + # To actually run buildah on nixos, I had to follow this: https://gist.github.com/alexhrescale/474d55635154e6b2cd6362c3bb403faf + pkgs.buildah + + pinned.stack + pinned.helm + pinned.helmfile + pinned.kubectl + pinned.kind + + # For cabal-migration + pkgs.haskellPackages.cabal-plan + + # We don't use pkgs.cabal-install here, as we invoke it with a wrapper + # which sets LD_LIBRARY_PATH and others correctly. + cabal-wrapper +] diff --git a/direnv.nix b/direnv.nix index f99ef759825..7c8743db8d3 100644 --- a/direnv.nix +++ b/direnv.nix @@ -1,192 +1,8 @@ { pkgs ? import ./nix }: let - staticBinaryInTarball = { 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; - }; - - installPhase = '' - mkdir -p $out/bin - 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"; - version = "2.3.1"; - - darwinAmd64Url = "https://github.com/commercialhaskell/stack/releases/download/v2.3.1/stack-2.3.1-osx-x86_64.tar.gz"; - darwinAmd64Sha256 = "089nrb8mxf76a0r0hdccaxfvx1ly24b5zc0cy05gs4adybjygvkk"; - - linuxAmd64Url = "https://github.com/commercialhaskell/stack/releases/download/v2.3.1/stack-2.3.1-linux-x86_64-static.tar.gz"; - linuxAmd64Sha256 = "0iqfqcd88rvlwgm2h8avs0rsi9f3pdxilvcacgrxskb1n8q8ibjb"; - }; - - helm = staticBinaryInTarball { - pname = "helm"; - version = "3.6.3"; - - darwinAmd64Url = "https://get.helm.sh/helm-v3.6.3-darwin-amd64.tar.gz"; - darwinAmd64Sha256 = "0djjvgla8cw27h8s4y6jby19f74j58byb2vfv590cd03vlbzz8c4"; - - 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 { - pname = "kubectl"; - version = "1.19.8"; - - darwinAmd64Url = "https://dl.k8s.io/v1.19.8/kubernetes-client-darwin-amd64.tar.gz"; - darwinAmd64Sha256 = "23b847bb8b545c748e9078e7660c654eef74d15ccab8696d294f3d6c619c788e"; - - linuxAmd64Url = "https://dl.k8s.io/v1.19.8/kubernetes-client-linux-amd64.tar.gz"; - linuxAmd64Sha256 = "8388ff8b5c676bdbb8fe07ef7077de937b0bf60154f302df5f248f38f95122aa"; - - 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"; - }; - }; - - compile-deps = pkgs.buildEnv { - name = "wire-server-compile-deps"; - paths = [ - pkgs.bash - pkgs.coreutils - pkgs.gnused - pkgs.gnugrep - pkgs.pkgconfig - pkgs.gawk - pkgs.git - - pkgs.haskell.compiler.ghc884 - pkgs.protobuf - - pkgs.cryptobox - pkgs.geoip - pkgs.icu.dev - pkgs.icu.out - pkgs.libsodium.dev - pkgs.libsodium.out - pkgs.libxml2.dev - pkgs.libxml2.out - pkgs.ncurses.dev - pkgs.ncurses.out - pkgs.openssl.dev - pkgs.openssl.out - pkgs.pcre.dev - pkgs.pcre.out - pkgs.snappy.dev - pkgs.snappy.out - pkgs.zlib.dev - pkgs.zlib.out - pkgs.lzma.dev - pkgs.lzma.out - ]; - }; - - # This performs roughly the same setup as direnv's load_prefix function, but - # only when invoking cabal. This means that we can set LD_LIBRARY_PATH just - # for cabal, as setting it in direnv can interfere with programs in the host - # system, especially for non-NixOS users. - cabal-wrapper = pkgs.writeShellScriptBin "cabal" '' - export CPATH="${compile-deps}/include" - export LD_LIBRARY_PATH="${compile-deps}/lib" - export LIBRARY_PATH="${compile-deps}/lib" - export PKG_CONFIG_PATH="${compile-deps}/lib/pkgconfig" - export PATH="${compile-deps}/bin" - exec "${pkgs.cabal-install}/bin/cabal" "$@" - ''; -in pkgs.buildEnv { + packages = import ./dev-packages.nix { pkgs = pkgs; }; +in +pkgs.buildEnv { name = "wire-server-direnv"; - paths = [ - pkgs.cfssl - pkgs.docker-compose - pkgs.gnumake - pkgs.haskell-language-server - pkgs.jq - pkgs.ormolu - pkgs.telepresence - pkgs.wget - pkgs.yq - pkgs.rsync - pkgs.netcat - - # To actually run buildah on nixos, I had to follow this: https://gist.github.com/alexhrescale/474d55635154e6b2cd6362c3bb403faf - pkgs.buildah - - pinned.stack - pinned.helm - pinned.helmfile - pinned.kubectl - pinned.kind - - # For cabal-migration - pkgs.haskellPackages.cabal-plan - - # We don't use pkgs.cabal-install here, as we invoke it with a wrapper - # which sets LD_LIBRARY_PATH and others correctly. - cabal-wrapper - ]; + paths = packages; } diff --git a/docs/developer/api-versioning.md b/docs/developer/api-versioning.md new file mode 100644 index 00000000000..d5ee1892666 --- /dev/null +++ b/docs/developer/api-versioning.md @@ -0,0 +1,464 @@ +# Status of this document + +This is a proposal for API versioning that we may adopt in the future. +If you don't find any trace of it in the code base, that means you're +not to late to submit a PR yourself! :) + +# Introduction + +Since upgrades cannot happen instantaneously, we need to release wire +backends and wire client apps that work together accross releases. + +In the past, we have made sure that the api is changed in a way that +the backend can be newer than the client, and then releasing the +change on the backend first. This worked well on the cloud where we +had control, but fails a lot in the on-prem setting: if we add a new +end-point to the API, the backend will still be able to handle older +clients that simply don't know about that end-point, but the client +won't handle old backends well, since it will try to call the +end-point, and fail. + +The problem becomes more complicated still if you think about backends +talking to other backends in the context of federation: An HTTP server +will act as a client inside the handler function, and the version it +responds with may differ from the version it talks to another backend +it needs to query. + +The new approach outlined here introduces API versions to address this +problem. Every API version is only compatible with itself, but every +node in the network can support a *set of API versions*. A HTTP +client can query the set of supported versions from an HTTP server, +and then pick one that works for it. + +We believe this is a good approach to solve all our API compatibility +problems both between apps and backends and between backends in the +context of federation, but we also list some open questions (and +probably forget to list more). + +In the following, we will refer to HTTP clients as "clients", no +matter whether it is an app or a backend talking to another backend +(federation); and to HTTP servers as "server", no matter which API is +it serving (federation or app). + + +# Versions and servant routing tables + +All routing tables for which a new version is born will be changed +into taking the version number as a parameter, which is added as a +prefix to every route: + +```haskell +data Api (version :: Symbol) routes = Api + { getUnqualifiedConversation :: + routes + :- version + :> Summary "Get a conversation by ID" + :> ZLocalUser + :> "conversations" + :> Capture "cnv" ConvId + :> Get '[Servant.JSON] Conversation, + getConversation :: + routes + :- version + :> Summary "Get a conversation by ID" + :> ZLocalUser + :> "conversations" + :> QualifiedCapture "cnv" ConvId + :> Get '[Servant.JSON] Conversation, + [...] + } +``` + +APIs of all the supported versions can be composed like this: + +```haskell +type ServantAPI = + ToServantApi (Api "v1") + :<|> ToServantApi (Api "v2") + :<|> ToServantApi (Api "v4") -- v3 is broken +``` + +This will result in a routing table like this one: + +``` +/v1/users/... +/v1/conversations/... +/v2/users/... +/v2/conversations/... +/v4/users/... +/v4/conversations/... +``` + + +## Changes between versions + +The point of having versions is of course not that all of them look +exactly the same except for their prefix. The point is that there are +other things that change between versions. + +There are essentially two categories of changes: + +1. **data**: request or response bodies, variable path segments, + possible headers or status codes (as in `UVerb` or `MultiVerb`), + etc. +2. **structure**: literal path segments, verb, the version itself, ... + + +## Changes in the data + +If a data type in request, response, variable path segments, or anywhere else +changes, introduce a type family parameterized in the version. + +```haskell +[...] + getConversation :: + routes + :- version + :> Summary "Get a conversation by ID" + :> ZLocalUser + :> "conversations" + :> QualifiedCapture "cnv" ConvId + :> Get '[Servant.JSON] (ConversationV version), +[...] + +type family ConversationV (version :: Symbol) :: * where + ConversationV "v1" = Conversation + ConversationV "v2" = Conversation + ConversationV "v4" = ConversationV4 +``` + +Note that before version `"v4"`, nothing changed for this type, so +there was no need to introduce a new concrete data type. + +If the last change of a data type is entirely phased out, the type +family turns constant and can be removed again. If you see this in +your code: + +```haskell +type family ConversationV (version :: Symbol) :: * where + ConversationV "v4" = ConversationV4 + ConversationV "v5" = ConversationV4 + ConversationV "v6" = ConversationV4 + ConversationV "v7" = ConversationV4 +``` + +You can remove 'ConversationV', rename `ConversationV4` to Conversation, +and use it in the routing table instead of `ConversationV` again, as +before `"v4"`. + +### Open questions + +Adding/removing a new version now requires to touch a lot of type +families. The changes are trivial and the compiler will lead us to +all of them, but there are potentially many. + +It would be nice to have a default type that is used for all versions +that don't explicitly mention a given type, then future versions would +only have to be touched if a type actually changes. However, (a) it's +not clear to us how to accomplish that (open type families plus +multi-param type classes plus overlapping instances? type-level +'Maybe' with type-level default type?); and (b) it is less robust and +transparent, and depending on the solution carries the risk of missing +a spot where we want to update a type, but the compiler picks the +wrong default. + + +## Changing structure + +Without loss of generality, we only consider additions and deletions +of routes in this section: if you want to change the path or verb of +an end-point, add a new path instead, and phase the old one out (now +or in some future version). + +When end-points are present in some supported versions, but not in +others, their record fields in the servant routing type needs to be +present for all versions, but in some versions should behave as if it +weren't. + +This is best solved by a new data type: + +```haskell +data NotInThisVersion = NotInThisVersion + -- (The value constructor may be needed to implement the handler) + -- (Or something involving `Verb 'NOTINTHISVERSION`?) +``` + +The entire route will then be a type family over the version that maps +all unsupported versions to `NotInThisVersion`. + +Now we can write a type family that can crawl a `ServantAPI` (not the +record one, the one with `:<|>`) and drop all the routes marked as not +existing. + +This will save us the trouble of writing lots of instances for +`NotInThisVersion` (server, swagger, client, ...), and yield exactly +the desired result: + +```haskell +type ServantAPI = + DropNotInThisVersion + ( ToServantApi (Api "v1") + :<|> ToServantApi (Api "v2") + :<|> ToServantApi (Api "v4") -- v3 is broken + ) +``` + + +## Adoption of versioned APIs + +When API versions are introduced to a code base that has a routing +table without versions, the question arises what to do with old +clients or servers talking to new ones. + +We define a middleware that + + (1) maps requests without version prefix in the path to ones that + have version `"v0"`. + + (2) responds with a specific type of error if an unsupported version + is requested (so the client can re-negotiate a new version to + speak after an upgrade, see below). + + +## Version handshake + +Client and server need to agree on a version to use. The server +provides two (kinds of) end-points for that. + +``` +GET /api-versions +=> { "supported": [1, 2, 45, 119] } + +GET /v*/api-docs +=> +``` + +The client developer can pull the swagger docs of a new version and +diff it against the one they already support, and work their way +through the changes (see below). + +The client will call `GET /api-versions` and pick any number in the +intersection of the versions it supports and the ones the server +supports (usually the largest). + +*Corner case:* if we want to distinguish between backend-to-backend +and client-to-backend, we can do that in path suffixes (`GET +/api-versions/{client,federation}` etc.). + + +### No shared api version + +If the intersection set is empty, the client has no way of talking to +the server. It needs to politely fail with an error message about +upgrading, downgrading, or talking to another server. + +This should only happen if the distance between last upgrade on client +and server exceeds the agreed-upon limits (eg., 6 months). + + +### Update detection and version re-negotation + +If the server is upgraded and some old supported versions are phased +out, the client may be caught by surprise. + +Servers should respond with status `404`, error label +`unsupported-version`. The versioning middleware can do that (see +above). + +Client should install a catch-all that will handle this specific +error, re-fetch `/api-versions`, and try again. + +This will only happen if backend and client grow apart in time beyond +the supported limit, and there is some chance it will result in an +empty set of compatible versions, so it's also ok to just fail here. + + +## Strongly typed versions + +If we make version an ADT `ApiVersion`, we can remove old versions +from it in one place and have the compiler guide us through all the +places where we need to remove it. + +There are at least two ways to implement this: + +1. Add a few extra servant instances for `(v :: ApiVersion) :> route`. +2. Define a type family `Versions` that maps `V*` to `"v*"`, and write +`Versions version :>` in the routing type instead of `"v1"`. + +2 seems a lot less work to write, read, and understand. + + +## Data migration (aka data marshalling) + +If the shape of an end-point changes between versions (if a data type +in the routing table becomes a type family), it is often possible to +write marshalling functions that translate a value from an older +version into one of a newer version or vice versa. + +These functions are called marshalling functions and are useful to +define separately to keep the application logic clean. + +For certain changes to a data type used in an API, marshalling is +straight-forward in both directions. The most common example is +adding an optional attribute to a JSON object: + +- *backward migration*: remove the new attribute. +- *forward migration*: set the new attribute to `null`. + +(This is what wire has traditionally done to accomplish client +backwards compatibility without any API versioning.) + +If a mandatory attribute is added in a newer version, there may be a +plausible default value that can be used in the forward migration +(backward migration would still remove the field). + +In other cases, whether there is an automatic migration depends on the +use case and the semantics. + +It may even be impossible to marshal either in one or in both +directions. In this case, you have 3 options: + +1. abandon compatibility; +2. rethink your new version and craft it in a way that two-way + marshalling is possible; +3. make the application work around the gap, eg. by gracefully + refusing to offer video conferencing in a client if it is not + supported on the server yet. + + +## Writing client code + +If you write all code by hand and don't generate anything from the +swagger docs, just look at the swagger diff for every new version and +take it from there. + +If you generate, say, typescript or kotlin or swift from swagger: + +0. have a generated source module `Gen.ts`, plus a source module with + manually written code `Man.ts`. Re-export everything from `Gen.ts` + in `Man.ts`, and only import `Man.ts` in any modules that contain + application logic. + +1. look at the diff of the swagger of the last supported and the new + versions. + +2. copy all functions for routes that have changed from `Gen.ts` to + `Man.ts`. these are speaking an old api version and won't need to + be re-generated any more. work the last version supported by this + function into the name somehow (eg., suffix `"_v23"`). + +3. for every function that moved to `Man.ts` in this way, write a + function *without* the version suffix. It somehow knows the api + version of the server that it talks to (function parameter, app + config, dosn't matter), and decides based on that whether to call + the deprecated function with the `"_v23"` suffix or the one from + `Gen.ts`. If the old one is called, it may have to do some + marshalling of request and response (see above). + +It will happen that a new client will not be able to accomplish +something with an old API. (Example: if video calling is introduced in +`"v12"`, you can't emulate `POST /video-call` when talking to a `"v9"` +server. In these cases, the function in `Man.ts` must raise a "server +too old" exception, and gracefully shut down the new functionality.) + + +### Open questions + +It will be interesting to develop a good flow for doing this given the +concrete tooling that's in place: Should every API version get its own +library, or just a source module? Where is the diff to be applied +exactly? On the swagger? Or on the generated code? How do we make +sure the old versions replaced with new versions that have not changed +aren't in the way? + +For the user apps, the task here is to write (or construct) query +function that picks a version and either succeeds or fails. In the +context of federation, the task is to write handlers for all version +(or a handler that can handle all versions). Inside this handler, +when calling other backends as a client, it is not guaranteed that +those backends can be called in the version the handler is operating +under. + +In the simple cases, this can (probably?) be solved by writing +version-oblivious query functions that intially are just aliases for +the generated client functions, but are manually adjusted to being +able to call other servers on all the supported versions. But it will +be interesting to see where the hard cases happen, and if we'll see +them when they do. + + +## Concerns and design alternatives + +### Why not version every end-point separately? + +Yes, that would work in principle. On the backend, it would make the +entire routing table smaller (no need to concatenate the same +end-point for many versions), which may result in shorter compile +times. On the clients, with a new API version it would be +straight-forward to see which end-points need to be worked on, and +which remain unchanged. + +On the other hand, the routing table size may not be an issue, and if +it is there are solutions (introduce a CCP switch to compile only the +most recent API version that you're working on); and the client +process is already quite straight-forward with the approach outlined +above via diffing the swagger docs between most recent version and +predecessor. + +Plus, if the entire API has one version, you get a few advantages: + +1. The fact that clients are forced to commit to a concrete API + version for all end-points when talking to the backend reduces + testing complexity. If there is a mapping of end-points to + versions, the behavior of interacting parties is much less + restricted, and versions that have not been tested against each + other may be used together. (This can be avoided, but it's less + obvious how to get it right, and testing complexity will likely be + worse.) + +2. The "one version" approach makes it obvious which end-points are in + the most recent API at any given point in time. The "one version + per end-point" approach would either yeild a noisy union of all + supported versions, or there would have to be a mechanism for + reconstructing something close to what we get for free otherwise. + +3. The backend code is a good combination of concise and type-safe in + the "one version" approach. If every end-point had its own + version, the routing table entry would either have to accept a + variable path segment for the version, and fail at run-time if the + version is not supported, or you would have to add one handler per + supported version (even if in the case where all versions call the + same handler function with slightly different parameters). + + +### Syntactical vs. behavioral changes + +It is quite common that behavior of end-points changes together with +the syntax, or even without a change in the syntax. + +This is not a fundamental problem: since the handler can be called +with the version as a type parameter, there is no reason why it +shouldn't change behavior with or without changing the syntax. In +each such case, it needs to be decided whether the difference is +significant enough to justify a new API version. + +At the very least though it should result in diverging swagger docs +that explains those differences. + + +### Client capabilities + +Wire supports client capabilities to decide whether a client should be +allowed to use certain parts of the API. + +This is another alternative to API versions, and it is in some ways +more straight-forward to decide who to interpret capability sets. But +this approach has its own problems: Most importantly, the number of +supported capability sets grows quadratically (not in practice, +because historically clients will only ever support a small part of +all possible combinations of capabilities, but that makes thigns +worse: it makes the system more complex, and then doesn't use that +complexity for anything). + +Therefore, the capabilities we're using in the wire code base should +be gracefully phased out and replaced by API versions. diff --git a/docs/developer/editor-setup.md b/docs/developer/editor-setup.md index e21d59025b8..249529677d9 100644 --- a/docs/developer/editor-setup.md +++ b/docs/developer/editor-setup.md @@ -99,3 +99,15 @@ If you use sdiehl's module, you you need to collect the language extensions from If you want to be playful, you can look at how `tools/ormolu.sh` collects the language extensions automatically and see if you can get it to work here. + +## VSCode + +The project can be loaded into the [Haskell Language Server](https://github.com/haskell/haskell-language-server). +This gives type checking, code completion, HLint hints, formatting with Ormolu, lookup of definitions and references, etc.. +All needed dependencies (like the `haskell-language-server` and `stack` binaries) are provided by `shell.nix`. + +Setup steps: +- Install the plugins `Haskell` (Haskell Language Server support), `Haskell Syntax` and `Nix Environment Selector` +- Generate the `hie.yaml` file: `make hie.yaml` +- Select the nix environment from `shell.nix` with the command `Nix-Env: Select environment`. +- Reload the window as proposed by the `Nix Environment Selector` plugin \ No newline at end of file diff --git a/docs/reference/cassandra-schema.cql b/docs/reference/cassandra-schema.cql index 7b70e2f4642..08b33cbd7f8 100644 --- a/docs/reference/cassandra-schema.cql +++ b/docs/reference/cassandra-schema.cql @@ -420,8 +420,11 @@ CREATE TABLE galley_test.team_features ( conference_calling int, digital_signatures int, file_sharing int, + guest_links_lock_status int, + guest_links_status int, legalhold_status int, search_visibility_status int, + self_deleting_messages_lock_status int, self_deleting_messages_status int, self_deleting_messages_ttl int, sso_status int, diff --git a/hack/bin/cabal-install-all-artefacts.sh b/hack/bin/cabal-install-all-artefacts.sh deleted file mode 100755 index 2087b655b32..00000000000 --- a/hack/bin/cabal-install-all-artefacts.sh +++ /dev/null @@ -1,11 +0,0 @@ -#!/usr/bin/env bash - -set -euo pipefail - -DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )" -TOP_LEVEL="$(cd "$DIR/../.." && pwd)" - -for d in $(find "$TOP_LEVEL" -name '*.cabal' | grep -v dist-newstyle | xargs -n 1 dirname); do - cd "$d" - "$DIR/cabal-install-artefacts.sh" "$(basename "$d")" -done diff --git a/hack/bin/cabal-install-artefacts.sh b/hack/bin/cabal-install-artefacts.sh index 215f7f868bf..c80ef37de18 100755 --- a/hack/bin/cabal-install-artefacts.sh +++ b/hack/bin/cabal-install-artefacts.sh @@ -6,4 +6,13 @@ TOP_LEVEL="$(cd "$DIR/../.." && pwd)" DIST="$TOP_LEVEL/dist" -cabal-plan list-bins "$1"':exe:*' | awk '{print $2}' | xargs -I '{}' rsync -a {} "$DIST" +if [[ "$1" == "all" ]]; then + pattern='*' +else + pattern="$1" +fi + +cabal-plan list-bins "$pattern:exe:*" | + awk '{print $2}' | + xargs -i sh -c 'test -f {} && echo {} || true' | + xargs -P8 -i rsync -a {} "$DIST" diff --git a/hack/bin/cabal-run-integration.sh b/hack/bin/cabal-run-integration.sh new file mode 100755 index 00000000000..c68bd2a97b5 --- /dev/null +++ b/hack/bin/cabal-run-integration.sh @@ -0,0 +1,26 @@ +#!/usr/bin/env bash +set -euo pipefail + +DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )" +TOP_LEVEL="$(cd "$DIR/../.." && pwd)" + +package=${1:-all} +pattern=${2:-} + +opts="" + +if [[ "$package" != "all" ]]; then + opts="$opts -C services/$package" +fi + +if [[ -n "$pattern" ]]; then + if [[ "$package" == "all" ]]; then + echo -e "\e[31mGlobal pattern not supported\e[0m" >&2 + exit 1 + fi + opts="$opts i-$pattern" +else + opts="$opts i" +fi + +exec make $opts diff --git a/libs/extended/extended.cabal b/libs/extended/extended.cabal index ca3ecbf67b7..aee67e062f1 100644 --- a/libs/extended/extended.cabal +++ b/libs/extended/extended.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 040115252374cb428a08ab286b9a4eb9492a407e9197009e7944f163dc1bfdcc +-- hash: 3aab57e8600541201e0b0f8cd7308f624eb479a4f5601e800399b4787656c449 name: extended version: 0.1.0 @@ -52,3 +52,39 @@ library , tinylog , wai default-language: Haskell2010 + +test-suite extended-tests + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Test.System.Logger.ExtendedSpec + Paths_extended + hs-source-dirs: + test + default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DerivingVia DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -threaded -with-rtsopts=-N + build-tool-depends: + hspec-discover:hspec-discover + build-depends: + aeson + , base + , bytestring + , cassandra-util + , containers + , errors + , exceptions + , extended + , extra + , hspec + , http-types + , imports + , metrics-wai + , optparse-applicative + , servant + , servant-server + , servant-swagger + , string-conversions + , temporary + , tinylog + , wai + default-language: Haskell2010 diff --git a/libs/extended/package.yaml b/libs/extended/package.yaml index 7714754d508..5dbe406f6aa 100644 --- a/libs/extended/package.yaml +++ b/libs/extended/package.yaml @@ -36,4 +36,17 @@ dependencies: - wai library: source-dirs: src +tests: + extended-tests: + main: Spec.hs + source-dirs: test + ghc-options: + - -threaded + - -with-rtsopts=-N + dependencies: + - hspec + - extended + - temporary + build-tools: + - hspec-discover:hspec-discover stability: experimental diff --git a/libs/extended/src/System/Logger/Extended.hs b/libs/extended/src/System/Logger/Extended.hs index 26ba7b4a3ae..ec51ba4870e 100644 --- a/libs/extended/src/System/Logger/Extended.hs +++ b/libs/extended/src/System/Logger/Extended.hs @@ -28,6 +28,7 @@ module System.Logger.Extended LoggerT (..), runWithLogger, netStringsToLogFormat, + structuredJSONRenderer, ) where @@ -78,20 +79,20 @@ collect = foldr go (Element' mempty []) jsonRenderer :: Renderer jsonRenderer _sep _dateFormat _logLevel = fromEncoding . elementToEncoding . collect -data StructuredJSONOutput = StructuredJSONOutput {msgs :: [Text], fields :: Map Text [Text]} +data StructuredJSONOutput = StructuredJSONOutput {lvl :: Maybe Level, msgs :: [Text], fields :: Map Text [Text]} -- | Displays all the 'Bytes' segments in a list under key @msgs@ and 'Field' -- segments as key-value pair in a JSON -- --- >>> logElems = [Bytes "I", Bytes "The message", Field "field1" "val1", Field "field2" "val2", Field "field1" "val1.1"] +-- >>> logElems = [Bytes "W", Bytes "The message", Field "field1" "val1", Field "field2" "val2", Field "field1" "val1.1"] -- >>> B.toLazyByteString $ structuredJSONRenderer "," iso8601UTC Info logElems --- "{\"msgs\":[\"I\",\"The message\"],\"field1\":[\"val1\",\"val1.1\"],\"field2\":\"val2\",\"level\":\"Info\"}" +-- "{\"msgs\":[\"The message\"],\"field1\":[\"val1\",\"val1.1\"],\"field2\":\"val2\",\"level\":\"Warn\"}" structuredJSONRenderer :: Renderer -structuredJSONRenderer _sep _dateFmt lvl logElems = +structuredJSONRenderer _sep _dateFmt _lvlThreshold logElems = let structuredJSON = toStructuredJSONOutput logElems in fromEncoding . toEncoding $ object - ( [ "level" Aeson..= lvl, + ( [ "level" Aeson..= lvl structuredJSON, "msgs" Aeson..= msgs structuredJSON ] <> Map.foldMapWithKey (\k v -> [k Aeson..= renderTextList v]) (fields structuredJSON) @@ -106,14 +107,29 @@ structuredJSONRenderer _sep _dateFmt lvl logElems = builderToText :: Builder -> Text builderToText = cs . eval + -- We need to do this to work around https://gitlab.com/twittner/tinylog/-/issues/5 + parseLevel :: Text -> Maybe Level + parseLevel = \case + "T" -> Just Trace + "D" -> Just Debug + "I" -> Just Info + "W" -> Just Warn + "E" -> Just Log.Error + "F" -> Just Fatal + _ -> Nothing + toStructuredJSONOutput :: [Element] -> StructuredJSONOutput toStructuredJSONOutput = foldr ( \e o -> case e of - Bytes b -> o {msgs = builderToText b : msgs o} + Bytes b -> + let buildMsg = builderToText b + in case parseLevel buildMsg of + Nothing -> o {msgs = builderToText b : msgs o} + Just lvl -> o {lvl = Just lvl} Field k v -> o {fields = Map.insertWith (<>) (builderToText k) (map builderToText [v]) (fields o)} ) - (StructuredJSONOutput mempty mempty) + (StructuredJSONOutput Nothing [] mempty) -- | Here for backwards-compatibility reasons netStringsToLogFormat :: Bool -> LogFormat diff --git a/libs/extended/test/Spec.hs b/libs/extended/test/Spec.hs new file mode 100644 index 00000000000..7b57431c0d0 --- /dev/null +++ b/libs/extended/test/Spec.hs @@ -0,0 +1,18 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} + +-- 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 . diff --git a/libs/extended/test/Test/System/Logger/ExtendedSpec.hs b/libs/extended/test/Test/System/Logger/ExtendedSpec.hs new file mode 100644 index 00000000000..315878eaae2 --- /dev/null +++ b/libs/extended/test/Test/System/Logger/ExtendedSpec.hs @@ -0,0 +1,49 @@ +module Test.System.Logger.ExtendedSpec where + +import Data.Aeson ((.=)) +import qualified Data.Aeson as Aeson +import Data.String.Conversions (cs) +import Imports +import System.IO.Temp +import System.Logger.Extended hiding ((.=)) +import Test.Hspec (Spec, describe, it, shouldBe) + +spec :: Spec +spec = + describe "System.Loggger.Extended" $ do + describe "LogFormat: StructuredJSON" $ do + it "should encode logs as new line separated structured JSON with log level, messages and fields" $ do + withSystemTempFile "structured-json" $ \f h -> do + hClose h -- The handle is not required + l <- + new + . setRenderer structuredJSONRenderer + . setOutput (Path f) + . setFormat Nothing -- date format, not having it makes it easier to test. + $ defSettings + + warn l $ + msg ("first message" :: ByteString) + . field "field1" ("val 1.1" :: ByteString) + . field "field2" ("val 2" :: ByteString) + . field "field1" ("val 1.2" :: ByteString) + . msg ("second message" :: ByteString) + info l $ msg ("just a message" :: ByteString) + + flush l + close l + actualLogs <- map (Aeson.eitherDecode @Aeson.Value . cs) . lines <$> readFile f + + let expectedLogs = + [ Aeson.object + [ "level" .= Warn, + "msgs" .= ["first message" :: Text, "second message"], + "field1" .= ["val 1.1" :: Text, "val 1.2"], + "field2" .= ("val 2" :: Text) + ], + Aeson.object + [ "level" .= Info, + "msgs" .= ["just a message" :: Text] + ] + ] + actualLogs `shouldBe` (Right <$> expectedLogs) diff --git a/libs/galley-types/src/Galley/Types/Teams.hs b/libs/galley-types/src/Galley/Types/Teams.hs index 8e727e90a1d..f1251eff0a5 100644 --- a/libs/galley-types/src/Galley/Types/Teams.hs +++ b/libs/galley-types/src/Galley/Types/Teams.hs @@ -32,6 +32,7 @@ module Galley.Types.Teams flagClassifiedDomains, flagConferenceCalling, flagSelfDeletingMessages, + flagConversationGuestLinks, Defaults (..), unDefaults, FeatureSSO (..), @@ -212,11 +213,12 @@ data FeatureFlags = FeatureFlags { _flagSSO :: !FeatureSSO, _flagLegalHold :: !FeatureLegalHold, _flagTeamSearchVisibility :: !FeatureTeamSearchVisibility, - _flagAppLockDefaults :: !(Defaults (TeamFeatureStatus 'TeamFeatureAppLock)), - _flagClassifiedDomains :: !(TeamFeatureStatus 'TeamFeatureClassifiedDomains), - _flagFileSharing :: !(Defaults (TeamFeatureStatus 'TeamFeatureFileSharing)), - _flagConferenceCalling :: !(Defaults (TeamFeatureStatus 'TeamFeatureConferenceCalling)), - _flagSelfDeletingMessages :: !(Defaults (TeamFeatureStatus 'TeamFeatureSelfDeletingMessages)) + _flagAppLockDefaults :: !(Defaults (TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureAppLock)), + _flagClassifiedDomains :: !(TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureClassifiedDomains), + _flagFileSharing :: !(Defaults (TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureFileSharing)), + _flagConferenceCalling :: !(Defaults (TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureConferenceCalling)), + _flagSelfDeletingMessages :: !(Defaults (TeamFeatureStatus 'WithLockStatus 'TeamFeatureSelfDeletingMessages)), + _flagConversationGuestLinks :: !(Defaults (TeamFeatureStatus 'WithLockStatus 'TeamFeatureGuestLinks)) } deriving (Eq, Show, Generic) @@ -263,9 +265,10 @@ instance FromJSON FeatureFlags where <*> (fromMaybe (Defaults (TeamFeatureStatusNoConfig TeamFeatureEnabled)) <$> (obj .:? "fileSharing")) <*> (fromMaybe (Defaults (TeamFeatureStatusNoConfig TeamFeatureEnabled)) <$> (obj .:? "conferenceCalling")) <*> (fromMaybe (Defaults defaultSelfDeletingMessagesStatus) <$> (obj .:? "selfDeletingMessages")) + <*> (fromMaybe (Defaults defaultGuestLinksStatus) <$> (obj .:? "conversationGuestLinks")) instance ToJSON FeatureFlags where - toJSON (FeatureFlags sso legalhold searchVisibility appLock classifiedDomains fileSharing conferenceCalling selfDeletingMessages) = + toJSON (FeatureFlags sso legalhold searchVisibility appLock classifiedDomains fileSharing conferenceCalling selfDeletingMessages guestLinks) = object $ [ "sso" .= sso, "legalhold" .= legalhold, @@ -274,7 +277,8 @@ instance ToJSON FeatureFlags where "classifiedDomains" .= classifiedDomains, "fileSharing" .= fileSharing, "conferenceCalling" .= conferenceCalling, - "selfDeletingMessages" .= selfDeletingMessages + "selfDeletingMessages" .= selfDeletingMessages, + "conversationGuestLinks" .= guestLinks ] instance FromJSON FeatureSSO where @@ -340,6 +344,7 @@ data HiddenPerm -- efficient this end-point is. better not let all team members -- play with it unless we have to. DownloadTeamMembersCsv + | ChangeTeamMemberProfiles deriving (Eq, Ord, Show) -- | See Note [hidden team roles] @@ -367,6 +372,8 @@ roleHiddenPermissions role = HiddenPermissions p p ChangeTeamFeature TeamFeatureFileSharing, ChangeTeamFeature TeamFeatureClassifiedDomains {- the features not listed here can only be changed in stern -}, ChangeTeamFeature TeamFeatureSelfDeletingMessages, + ChangeTeamFeature TeamFeatureGuestLinks, + ChangeTeamMemberProfiles, ReadIdp, CreateUpdateDeleteIdp, CreateReadDeleteScimToken, @@ -387,6 +394,7 @@ roleHiddenPermissions role = HiddenPermissions p p ViewTeamFeature TeamFeatureClassifiedDomains, ViewTeamFeature TeamFeatureConferenceCalling, ViewTeamFeature TeamFeatureSelfDeletingMessages, + ViewTeamFeature TeamFeatureGuestLinks, ViewLegalHoldUserSettings, ViewTeamSearchVisibility ] diff --git a/libs/galley-types/test/unit/Test/Galley/Types.hs b/libs/galley-types/test/unit/Test/Galley/Types.hs index 3ed957c77d0..e9925f70205 100644 --- a/libs/galley-types/test/unit/Test/Galley/Types.hs +++ b/libs/galley-types/test/unit/Test/Galley/Types.hs @@ -97,3 +97,4 @@ instance Arbitrary FeatureFlags where <*> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API.hs b/libs/wire-api-federation/src/Wire/API/Federation/API.hs index b89d9698eeb..961859a06ff 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/API.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/API.hs @@ -26,6 +26,7 @@ where import Servant.Client.Generic import Wire.API.Federation.API.Brig +import Wire.API.Federation.API.Cargohold import Wire.API.Federation.API.Galley import Wire.API.Federation.Client import Wire.API.Federation.Component @@ -43,3 +44,7 @@ instance HasFederationAPI 'Galley where instance HasFederationAPI 'Brig where type FedApi 'Brig = BrigApi clientRoutes = genericClient + +instance HasFederationAPI 'Cargohold where + type FedApi 'Cargohold = CargoholdApi + clientRoutes = genericClient diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API/Cargohold.hs b/libs/wire-api-federation/src/Wire/API/Federation/API/Cargohold.hs new file mode 100644 index 00000000000..45573476280 --- /dev/null +++ b/libs/wire-api-federation/src/Wire/API/Federation/API/Cargohold.hs @@ -0,0 +1,31 @@ +-- 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 Wire.API.Federation.API.Cargohold where + +import Servant.API +import Servant.API.Generic +import Wire.API.Federation.API.Common + +data CargoholdApi routes = CargoholdApi + { getAsset :: + routes + :- "get-asset" + :> ReqBody '[JSON] () + :> Post '[JSON] EmptyResponse + } + deriving (Generic) diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Component.hs b/libs/wire-api-federation/src/Wire/API/Federation/Component.hs index f2c997ee25b..9f8c0acaf9a 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/Component.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/Component.hs @@ -24,17 +24,20 @@ import Wire.API.Arbitrary (GenericUniform (..)) data Component = Brig | Galley + | Cargohold deriving (Show, Eq, Generic) deriving (Arbitrary) via (GenericUniform Component) parseComponent :: Text -> Maybe Component parseComponent "brig" = Just Brig parseComponent "galley" = Just Galley +parseComponent "cargohold" = Just Cargohold parseComponent _ = Nothing componentName :: Component -> Text componentName Brig = "brig" componentName Galley = "galley" +componentName Cargohold = "cargohold" class KnownComponent (c :: Component) where componentVal :: Component @@ -44,3 +47,6 @@ instance KnownComponent 'Brig where instance KnownComponent 'Galley where componentVal = Galley + +instance KnownComponent 'Cargohold where + componentVal = Cargohold diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Error.hs b/libs/wire-api-federation/src/Wire/API/Federation/Error.hs index ffe9896207c..0229727eeec 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/Error.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/Error.hs @@ -15,6 +15,56 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . +-- | Map federation errors to client-facing errors. +-- +-- This module contains most of the error-mapping logic that turns the various +-- possible errors that can occur while making a federated request into errors +-- that are meaningful for the clients. +-- +-- There are three types of errors, from lowest level to highest: +-- +-- * 'FederatorClientHTTP2Error': this is thrown when something fails while +-- connecting or making a request to the local federator. +-- * 'FederatorClientError': this is the most common type of error, +-- corresponding to a failure at the level of the federator client. It +-- includes, for example, a failure to reach a remote federator, or an +-- error on the remote side. +-- * 'FederatorError': this is created by users of the federator client. It +-- can either wrap a 'FederatorClientError', or be an error that is outside +-- the scope of the client, such as when a federated request succeeds with +-- an unexpected result. +-- +-- A general federated request is normally performed as a chain of HTTP +-- requests (some of which are HTTP2). Errors can occur at each node of the +-- chain, as well as in the communication between two adjacent nodes. A +-- successful request goes through the following stages: +-- +-- 1) a service (say brig) makes a request to (the outward service of) the +-- local federator (HTTP2); +-- 2) the local federator processes this request; +-- 3) the local federator makes a request to (the inward service of) a remote +-- one (HTTP2); +-- 4) the remote federator processes this request; +-- 5) from the remote federator to a service on that backend (HTTP); +-- 6) the remote service processes this request. +-- +-- Failures at step 1 in the chain result in 'FederatorClientHTTP2Error', while +-- any other failure results in a 'FederatorClientError'. +-- +-- Immediate failures in the outward service of a federator (stage 2) result in +-- a 403 status code being returned to the federator client, which is then +-- translated into an error with label federation-local-error. +-- +-- Failures which occurred while making a request to a remote federator (stages +-- 3 to 6) are turned into 5xx errors by federator itself, and then passed on +-- through without any further mapping. This includes issues in stage 4, +-- which are seen by the local federator as 403 status codes returned by the +-- remote, as well as arbitrary error codes returned by a service. +-- +-- Note that the federation API follows the convention that any error should be +-- returned as part of a successful response with status code 200. Therefore any +-- error response from services during a federated call should be considered a bug +-- in the implementation of the federation API, and is therefore wrapped in a 533. module Wire.API.Federation.Error ( FederatorClientHTTP2Error (..), FederatorClientError (..), @@ -122,7 +172,7 @@ federationRemoteHTTP2Error (FederatorClientHTTP2Exception e) = federationRemoteHTTP2Error (FederatorClientTLSException e) = Wai.mkError (HTTP.mkStatus 525 "SSL Handshake Failure") - "tls-failure" + "federation-tls-error" (LT.fromStrict (displayTLSException e)) federationRemoteHTTP2Error (FederatorClientConnectionError e) = Wai.mkError @@ -139,7 +189,7 @@ federationClientHTTP2Error (FederatorClientConnectionError e) = federationClientHTTP2Error e = Wai.mkError HTTP.status500 - "federator-client-error" + "federation-local-error" (LT.pack (displayException e)) federationRemoteResponseError :: HTTP.Status -> Wai.Error @@ -169,11 +219,12 @@ displayTLSError (Error_Packet_Parsing msg) = "packet parsing error: " <> T.pack federationServantErrorToWai :: ClientError -> Wai.Error federationServantErrorToWai (DecodeFailure msg _) = federationInvalidBody msg +-- the following error is never thrown by federator client federationServantErrorToWai (FailureResponse _ _) = federationUnknownError federationServantErrorToWai (InvalidContentTypeHeader res) = Wai.mkError unexpectedFederationResponseStatus - "federation-invalid-content-type-header" + "federation-invalid-content-type" ("Content-type: " <> federationErrorContentType res) federationServantErrorToWai (UnsupportedContentType mediaType res) = Wai.mkError @@ -194,9 +245,6 @@ federationErrorContentType = . find (\(name, _) -> name == "Content-Type") . responseHeaders -noFederationStatus :: Status -noFederationStatus = status403 - unexpectedFederationResponseStatus :: Status unexpectedFederationResponseStatus = HTTP.Status 533 "Unexpected Federation Response" @@ -206,7 +254,7 @@ federatorConnectionRefusedStatus = HTTP.Status 521 "Remote Federator Connection federationNotImplemented :: Wai.Error federationNotImplemented = Wai.mkError - noFederationStatus + HTTP.status500 "federation-not-implemented" "Federation is not yet implemented for this endpoint" diff --git a/libs/wire-api-federation/wire-api-federation.cabal b/libs/wire-api-federation/wire-api-federation.cabal index 3de5fe24a0a..a1592e461ea 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: 8aa2d2b311b92915ab23a4fb07be411b474f2819936b62f46e15b64c31d027fe +-- hash: 621c254076cf520b525269ca4fc550df57f410aea52a288f6cb68bd2d6f1ada3 name: wire-api-federation version: 0.1.0 @@ -22,6 +22,7 @@ library exposed-modules: Wire.API.Federation.API Wire.API.Federation.API.Brig + Wire.API.Federation.API.Cargohold Wire.API.Federation.API.Common Wire.API.Federation.API.Galley Wire.API.Federation.Client diff --git a/libs/wire-api/src/Wire/API/Conversation.hs b/libs/wire-api/src/Wire/API/Conversation.hs index 49412c9d859..f935a206049 100644 --- a/libs/wire-api/src/Wire/API/Conversation.hs +++ b/libs/wire-api/src/Wire/API/Conversation.hs @@ -441,7 +441,7 @@ data AccessRole instance ToSchema AccessRole where schema = (S.schema . description ?~ "Which users can join conversations") $ - enum @Text "Access" $ + enum @Text "AccessRole" $ mconcat [ element "private" PrivateAccessRole, element "team" TeamAccessRole, diff --git a/libs/wire-api/src/Wire/API/Event/FeatureConfig.hs b/libs/wire-api/src/Wire/API/Event/FeatureConfig.hs index d64dac272f6..c9a87c84362 100644 --- a/libs/wire-api/src/Wire/API/Event/FeatureConfig.hs +++ b/libs/wire-api/src/Wire/API/Event/FeatureConfig.hs @@ -30,7 +30,7 @@ import Data.Json.Util (ToJSONObject (..)) import Data.Schema import qualified Data.Swagger as S import Imports -import Wire.API.Team.Feature (TeamFeatureAppLockConfig, TeamFeatureClassifiedDomainsConfig, TeamFeatureName (..), TeamFeatureSelfDeletingMessagesConfig, TeamFeatureStatusNoConfig, TeamFeatureStatusWithConfig) +import Wire.API.Team.Feature (TeamFeatureAppLockConfig, TeamFeatureClassifiedDomainsConfig, TeamFeatureName (..), TeamFeatureSelfDeletingMessagesConfig, TeamFeatureStatusNoConfig, TeamFeatureStatusNoConfigAndLockStatus, TeamFeatureStatusWithConfig) data Event = Event { _eventType :: EventType, @@ -51,6 +51,7 @@ instance ToSchema EventType where data EventData = EdFeatureWithoutConfigChanged TeamFeatureStatusNoConfig + | EdFeatureWithoutConfigAndLockStatusChanged TeamFeatureStatusNoConfigAndLockStatus | EdFeatureApplockChanged (TeamFeatureStatusWithConfig TeamFeatureAppLockConfig) | EdFeatureClassifiedDomainsChanged (TeamFeatureStatusWithConfig TeamFeatureClassifiedDomainsConfig) | EdFeatureSelfDeletingMessagesChanged (TeamFeatureStatusWithConfig TeamFeatureSelfDeletingMessagesConfig) @@ -75,6 +76,7 @@ taggedEventDataSchema = TeamFeatureClassifiedDomains -> tag _EdFeatureClassifiedDomainsChanged (unnamed schema) TeamFeatureConferenceCalling -> tag _EdFeatureWithoutConfigChanged (unnamed schema) TeamFeatureSelfDeletingMessages -> tag _EdFeatureSelfDeletingMessagesChanged (unnamed schema) + TeamFeatureGuestLinks -> tag _EdFeatureWithoutConfigAndLockStatusChanged (unnamed schema) eventObjectSchema :: ObjectSchema SwaggerDoc Event eventObjectSchema = 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 51e34b18d40..c00dd867c33 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs @@ -66,7 +66,7 @@ type GetAccountFeatureConfig = :> Capture "uid" UserId :> "features" :> "conferenceCalling" - :> Get '[Servant.JSON] (ApiFt.TeamFeatureStatus 'ApiFt.TeamFeatureConferenceCalling) + :> Get '[Servant.JSON] (ApiFt.TeamFeatureStatus 'ApiFt.WithoutLockStatus 'ApiFt.TeamFeatureConferenceCalling) type PutAccountFeatureConfig = Summary @@ -75,7 +75,7 @@ type PutAccountFeatureConfig = :> Capture "uid" UserId :> "features" :> "conferenceCalling" - :> Servant.ReqBody '[Servant.JSON] (ApiFt.TeamFeatureStatus 'ApiFt.TeamFeatureConferenceCalling) + :> Servant.ReqBody '[Servant.JSON] (ApiFt.TeamFeatureStatus 'ApiFt.WithoutLockStatus 'ApiFt.TeamFeatureConferenceCalling) :> Put '[Servant.JSON] NoContent type DeleteAccountFeatureConfig = 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 abeb005178a..67d6a218281 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs @@ -135,6 +135,16 @@ data Api routes = Api :> "self" :> ReqBody '[JSON] DeleteUser :> MultiVerb 'DELETE '[JSON] DeleteSelfResponses (Maybe Timeout), + updateUserEmail :: + routes + :- Summary "Resend email address validation email." + :> Description "If the user has a pending email validation, the validation email will be resent." + :> ZUser + :> "users" + :> CaptureUserId "uid" + :> "email" + :> ReqBody '[JSON] EmailUpdate + :> Put '[JSON] (), getHandleInfoUnqualified :: routes :- Summary "(deprecated, use /search/contacts) Get information on a user handle" 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 7aafbfa7bf7..158fddcca3f 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs @@ -623,7 +623,7 @@ data Api routes = Api :- FeatureStatusPut 'TeamFeatureSearchVisibility, teamFeatureStatusSearchVisibilityDeprecatedGet :: routes - :- FeatureStatusDeprecatedGet 'TeamFeatureSearchVisibility, + :- FeatureStatusDeprecatedGet 'WithoutLockStatus 'TeamFeatureSearchVisibility, teamFeatureStatusSearchVisibilityDeprecatedPut :: routes :- FeatureStatusDeprecatedPut 'TeamFeatureSearchVisibility, @@ -632,13 +632,13 @@ data Api routes = Api :- FeatureStatusGet 'TeamFeatureValidateSAMLEmails, teamFeatureStatusValidateSAMLEmailsDeprecatedGet :: routes - :- FeatureStatusDeprecatedGet 'TeamFeatureValidateSAMLEmails, + :- FeatureStatusDeprecatedGet 'WithoutLockStatus 'TeamFeatureValidateSAMLEmails, teamFeatureStatusDigitalSignaturesGet :: routes :- FeatureStatusGet 'TeamFeatureDigitalSignatures, teamFeatureStatusDigitalSignaturesDeprecatedGet :: routes - :- FeatureStatusDeprecatedGet 'TeamFeatureDigitalSignatures, + :- FeatureStatusDeprecatedGet 'WithoutLockStatus 'TeamFeatureDigitalSignatures, teamFeatureStatusAppLockGet :: routes :- FeatureStatusGet 'TeamFeatureAppLock, @@ -663,39 +663,48 @@ data Api routes = Api teamFeatureStatusSelfDeletingMessagesPut :: routes :- FeatureStatusPut 'TeamFeatureSelfDeletingMessages, + featureStatusGuestLinksGet :: + routes + :- FeatureStatusGet 'TeamFeatureGuestLinks, + featureStatusGuestLinksPut :: + routes + :- FeatureStatusPut 'TeamFeatureGuestLinks, featureAllFeatureConfigsGet :: routes :- AllFeatureConfigsGet, featureConfigLegalHoldGet :: routes - :- FeatureConfigGet 'TeamFeatureLegalHold, + :- FeatureConfigGet 'WithoutLockStatus 'TeamFeatureLegalHold, featureConfigSSOGet :: routes - :- FeatureConfigGet 'TeamFeatureSSO, + :- FeatureConfigGet 'WithoutLockStatus 'TeamFeatureSSO, featureConfigSearchVisibilityGet :: routes - :- FeatureConfigGet 'TeamFeatureSearchVisibility, + :- FeatureConfigGet 'WithoutLockStatus 'TeamFeatureSearchVisibility, featureConfigValidateSAMLEmailsGet :: routes - :- FeatureConfigGet 'TeamFeatureValidateSAMLEmails, + :- FeatureConfigGet 'WithoutLockStatus 'TeamFeatureValidateSAMLEmails, featureConfigDigitalSignaturesGet :: routes - :- FeatureConfigGet 'TeamFeatureDigitalSignatures, + :- FeatureConfigGet 'WithoutLockStatus 'TeamFeatureDigitalSignatures, featureConfigAppLockGet :: routes - :- FeatureConfigGet 'TeamFeatureAppLock, + :- FeatureConfigGet 'WithoutLockStatus 'TeamFeatureAppLock, featureConfigFileSharingGet :: routes - :- FeatureConfigGet 'TeamFeatureFileSharing, + :- FeatureConfigGet 'WithoutLockStatus 'TeamFeatureFileSharing, featureConfigClassifiedDomainsGet :: routes - :- FeatureConfigGet 'TeamFeatureClassifiedDomains, + :- FeatureConfigGet 'WithoutLockStatus 'TeamFeatureClassifiedDomains, featureConfigConferenceCallingGet :: routes - :- FeatureConfigGet 'TeamFeatureConferenceCalling, + :- FeatureConfigGet 'WithLockStatus 'TeamFeatureConferenceCalling, featureConfigSelfDeletingMessagesGet :: routes - :- FeatureConfigGet 'TeamFeatureSelfDeletingMessages + :- FeatureConfigGet 'WithLockStatus 'TeamFeatureSelfDeletingMessages, + featureConfigGuestLinksGet :: + routes + :- FeatureConfigGet 'WithLockStatus 'TeamFeatureGuestLinks } deriving (Generic) @@ -708,7 +717,7 @@ type FeatureStatusGet featureName = :> Capture "tid" TeamId :> "features" :> KnownTeamFeatureNameSymbol featureName - :> Get '[Servant.JSON] (TeamFeatureStatus featureName) + :> Get '[Servant.JSON] (TeamFeatureStatus 'WithLockStatus featureName) type FeatureStatusPut featureName = Summary (AppendSymbol "Put config for " (KnownTeamFeatureNameSymbol featureName)) @@ -717,18 +726,18 @@ type FeatureStatusPut featureName = :> Capture "tid" TeamId :> "features" :> KnownTeamFeatureNameSymbol featureName - :> ReqBody '[Servant.JSON] (TeamFeatureStatus featureName) - :> Put '[Servant.JSON] (TeamFeatureStatus featureName) + :> ReqBody '[Servant.JSON] (TeamFeatureStatus 'WithoutLockStatus featureName) + :> Put '[Servant.JSON] (TeamFeatureStatus 'WithoutLockStatus featureName) -- | A type for a GET endpoint for a feature with a deprecated path -type FeatureStatusDeprecatedGet featureName = +type FeatureStatusDeprecatedGet ps featureName = Summary (AppendSymbol "[deprecated] Get config for " (KnownTeamFeatureNameSymbol featureName)) :> ZUser :> "teams" :> Capture "tid" TeamId :> "features" :> DeprecatedFeatureName featureName - :> Get '[Servant.JSON] (TeamFeatureStatus featureName) + :> Get '[Servant.JSON] (TeamFeatureStatus ps featureName) -- | A type for a PUT endpoint for a feature with a deprecated path type FeatureStatusDeprecatedPut featureName = @@ -738,15 +747,15 @@ type FeatureStatusDeprecatedPut featureName = :> Capture "tid" TeamId :> "features" :> DeprecatedFeatureName featureName - :> ReqBody '[Servant.JSON] (TeamFeatureStatus featureName) - :> Put '[Servant.JSON] (TeamFeatureStatus featureName) + :> ReqBody '[Servant.JSON] (TeamFeatureStatus 'WithoutLockStatus featureName) + :> Put '[Servant.JSON] (TeamFeatureStatus 'WithoutLockStatus featureName) -type FeatureConfigGet featureName = +type FeatureConfigGet ps featureName = Summary (AppendSymbol "Get feature config for feature " (KnownTeamFeatureNameSymbol featureName)) :> ZUser :> "feature-configs" :> KnownTeamFeatureNameSymbol featureName - :> Get '[Servant.JSON] (TeamFeatureStatus featureName) + :> Get '[Servant.JSON] (TeamFeatureStatus ps featureName) type AllFeatureConfigsGet = Summary "Get configurations of all features" diff --git a/libs/wire-api/src/Wire/API/Routes/Public/LegalHold.hs b/libs/wire-api/src/Wire/API/Routes/Public/LegalHold.hs index 6bb24b75430..6c3db162ae9 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/LegalHold.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/LegalHold.hs @@ -52,9 +52,9 @@ type PublicAPI = type InternalAPI = "i" :> "teams" :> Capture "tid" TeamId :> "legalhold" - :> Get '[JSON] (TeamFeatureStatus 'TeamFeatureLegalHold) + :> Get '[JSON] (TeamFeatureStatus 'WithLockStatus 'TeamFeatureLegalHold) :<|> "i" :> "teams" :> Capture "tid" TeamId :> "legalhold" - :> ReqBody '[JSON] (TeamFeatureStatus 'TeamFeatureLegalHold) + :> ReqBody '[JSON] (TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureLegalHold) :> Put '[] NoContent swaggerDoc :: Swagger diff --git a/libs/wire-api/src/Wire/API/Swagger.hs b/libs/wire-api/src/Wire/API/Swagger.hs index f746c3465c3..68160851619 100644 --- a/libs/wire-api/src/Wire/API/Swagger.hs +++ b/libs/wire-api/src/Wire/API/Swagger.hs @@ -129,6 +129,7 @@ models = Team.Feature.modelTeamFeatureAppLockConfig, Team.Feature.modelTeamFeatureClassifiedDomainsConfig, Team.Feature.modelTeamFeatureSelfDeletingMessagesConfig, + Team.Feature.modelLockStatus, Team.Invitation.modelTeamInvitation, Team.Invitation.modelTeamInvitationList, Team.Invitation.modelTeamInvitationRequest, diff --git a/libs/wire-api/src/Wire/API/Team/Feature.hs b/libs/wire-api/src/Wire/API/Team/Feature.hs index f466fe3102c..758f29d6b31 100644 --- a/libs/wire-api/src/Wire/API/Team/Feature.hs +++ b/libs/wire-api/src/Wire/API/Team/Feature.hs @@ -29,12 +29,18 @@ module Wire.API.Team.Feature EnforceAppLock (..), KnownTeamFeatureName (..), TeamFeatureStatusNoConfig (..), + TeamFeatureStatusNoConfigAndLockStatus (..), TeamFeatureStatusWithConfig (..), + TeamFeatureStatusWithConfigAndLockStatus (..), HasDeprecatedFeatureName (..), AllFeatureConfigs (..), + LockStatus (..), + LockStatusValue (..), + IncludeLockStatus (..), defaultAppLockStatus, defaultClassifiedDomains, defaultSelfDeletingMessagesStatus, + defaultGuestLinksStatus, -- * Swagger typeTeamFeatureName, @@ -44,7 +50,10 @@ module Wire.API.Team.Feature modelTeamFeatureAppLockConfig, modelTeamFeatureClassifiedDomainsConfig, modelTeamFeatureSelfDeletingMessagesConfig, + modelTeamFeatureStatusWithConfigAndLockStatus, + modelTeamFeatureStatusNoConfigAndLockStatus, modelForTeamFeature, + modelLockStatus, ) where @@ -52,8 +61,9 @@ import qualified Cassandra.CQL as Cass import Control.Lens.Combinators (dimap) import qualified Data.Aeson as Aeson import qualified Data.Attoparsec.ByteString as Parser -import Data.ByteString.Conversion (FromByteString (..), ToByteString (..), toByteString') +import Data.ByteString.Conversion (FromByteString (..), ToByteString (..), fromByteString, toByteString') import Data.Domain (Domain) +import Data.Either.Extra (maybeToEither) import Data.Kind (Constraint) import Data.Schema import Data.String.Conversions (cs) @@ -64,6 +74,7 @@ import qualified Data.Text.Encoding as T import Deriving.Aeson import GHC.TypeLits (Symbol) import Imports +import Servant (FromHttpApiData (..)) import Test.QuickCheck.Arbitrary (arbitrary) import Wire.API.Arbitrary (Arbitrary, GenericUniform (..)) @@ -126,6 +137,7 @@ data TeamFeatureName | TeamFeatureClassifiedDomains | TeamFeatureConferenceCalling | TeamFeatureSelfDeletingMessages + | TeamFeatureGuestLinks deriving stock (Eq, Show, Ord, Generic, Enum, Bounded, Typeable) deriving (Arbitrary) via (GenericUniform TeamFeatureName) @@ -173,6 +185,10 @@ instance KnownTeamFeatureName 'TeamFeatureSelfDeletingMessages where type KnownTeamFeatureNameSymbol 'TeamFeatureSelfDeletingMessages = "selfDeletingMessages" knownTeamFeatureName = TeamFeatureSelfDeletingMessages +instance KnownTeamFeatureName 'TeamFeatureGuestLinks where + type KnownTeamFeatureNameSymbol 'TeamFeatureGuestLinks = "conversationGuestLinks" + knownTeamFeatureName = TeamFeatureGuestLinks + instance FromByteString TeamFeatureName where parser = Parser.takeByteString >>= \b -> @@ -191,6 +207,7 @@ instance FromByteString TeamFeatureName where Right "classifiedDomains" -> pure TeamFeatureClassifiedDomains Right "conferenceCalling" -> pure TeamFeatureConferenceCalling Right "selfDeletingMessages" -> pure TeamFeatureSelfDeletingMessages + Right "conversationGuestLinks" -> pure TeamFeatureGuestLinks Right t -> fail $ "Invalid TeamFeatureName: " <> T.unpack t -- TODO: how do we make this consistent with 'KnownTeamFeatureNameSymbol'? add a test for @@ -206,6 +223,7 @@ instance ToByteString TeamFeatureName where builder TeamFeatureClassifiedDomains = "classifiedDomains" builder TeamFeatureConferenceCalling = "conferenceCalling" builder TeamFeatureSelfDeletingMessages = "selfDeletingMessages" + builder TeamFeatureGuestLinks = "conversationGuestLinks" instance ToSchema TeamFeatureName where schema = @@ -272,8 +290,8 @@ instance Cass.Cql TeamFeatureStatusValue where ctype = Cass.Tagged Cass.IntColumn fromCql (Cass.CqlInt n) = case n of - 0 -> pure $ TeamFeatureDisabled - 1 -> pure $ TeamFeatureEnabled + 0 -> pure TeamFeatureDisabled + 1 -> pure TeamFeatureEnabled _ -> Left "fromCql: Invalid TeamFeatureStatusValue" fromCql _ = Left "fromCql: TeamFeatureStatusValue: CqlInt expected" @@ -283,19 +301,26 @@ instance Cass.Cql TeamFeatureStatusValue where ---------------------------------------------------------------------- -- TeamFeatureStatus -type family TeamFeatureStatus (a :: TeamFeatureName) :: * where - TeamFeatureStatus 'TeamFeatureLegalHold = TeamFeatureStatusNoConfig - TeamFeatureStatus 'TeamFeatureSSO = TeamFeatureStatusNoConfig - TeamFeatureStatus 'TeamFeatureSearchVisibility = TeamFeatureStatusNoConfig - TeamFeatureStatus 'TeamFeatureValidateSAMLEmails = TeamFeatureStatusNoConfig - TeamFeatureStatus 'TeamFeatureDigitalSignatures = TeamFeatureStatusNoConfig - TeamFeatureStatus 'TeamFeatureAppLock = TeamFeatureStatusWithConfig TeamFeatureAppLockConfig - TeamFeatureStatus 'TeamFeatureFileSharing = TeamFeatureStatusNoConfig - TeamFeatureStatus 'TeamFeatureClassifiedDomains = TeamFeatureStatusWithConfig TeamFeatureClassifiedDomainsConfig - TeamFeatureStatus 'TeamFeatureConferenceCalling = TeamFeatureStatusNoConfig - TeamFeatureStatus 'TeamFeatureSelfDeletingMessages = TeamFeatureStatusWithConfig TeamFeatureSelfDeletingMessagesConfig - -type FeatureHasNoConfig (a :: TeamFeatureName) = (TeamFeatureStatus a ~ TeamFeatureStatusNoConfig) :: Constraint +data IncludeLockStatus = WithLockStatus | WithoutLockStatus + +type family TeamFeatureStatus (ps :: IncludeLockStatus) (a :: TeamFeatureName) :: * where + TeamFeatureStatus _ 'TeamFeatureLegalHold = TeamFeatureStatusNoConfig + TeamFeatureStatus _ 'TeamFeatureSSO = TeamFeatureStatusNoConfig + TeamFeatureStatus _ 'TeamFeatureSearchVisibility = TeamFeatureStatusNoConfig + TeamFeatureStatus _ 'TeamFeatureValidateSAMLEmails = TeamFeatureStatusNoConfig + TeamFeatureStatus _ 'TeamFeatureDigitalSignatures = TeamFeatureStatusNoConfig + TeamFeatureStatus _ 'TeamFeatureAppLock = TeamFeatureStatusWithConfig TeamFeatureAppLockConfig + TeamFeatureStatus _ 'TeamFeatureFileSharing = TeamFeatureStatusNoConfig + TeamFeatureStatus _ 'TeamFeatureClassifiedDomains = TeamFeatureStatusWithConfig TeamFeatureClassifiedDomainsConfig + TeamFeatureStatus _ 'TeamFeatureConferenceCalling = TeamFeatureStatusNoConfig + TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureSelfDeletingMessages = TeamFeatureStatusWithConfig TeamFeatureSelfDeletingMessagesConfig + TeamFeatureStatus 'WithLockStatus 'TeamFeatureSelfDeletingMessages = TeamFeatureStatusWithConfigAndLockStatus TeamFeatureSelfDeletingMessagesConfig + TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureGuestLinks = TeamFeatureStatusNoConfig + TeamFeatureStatus 'WithLockStatus 'TeamFeatureGuestLinks = TeamFeatureStatusNoConfigAndLockStatus + +type family FeatureHasNoConfig (ps :: IncludeLockStatus) (a :: TeamFeatureName) :: Constraint where + FeatureHasNoConfig 'WithLockStatus a = (TeamFeatureStatus 'WithLockStatus a ~ TeamFeatureStatusNoConfigAndLockStatus) + FeatureHasNoConfig 'WithoutLockStatus a = (TeamFeatureStatus 'WithoutLockStatus a ~ TeamFeatureStatusNoConfig) -- if you add a new constructor here, don't forget to add it to the swagger (1.2) docs in "Wire.API.Swagger"! modelForTeamFeature :: TeamFeatureName -> Doc.Model @@ -309,6 +334,7 @@ modelForTeamFeature TeamFeatureFileSharing = modelTeamFeatureStatusNoConfig modelForTeamFeature name@TeamFeatureClassifiedDomains = modelTeamFeatureStatusWithConfig name modelTeamFeatureClassifiedDomainsConfig modelForTeamFeature TeamFeatureConferenceCalling = modelTeamFeatureStatusNoConfig modelForTeamFeature name@TeamFeatureSelfDeletingMessages = modelTeamFeatureStatusWithConfig name modelTeamFeatureSelfDeletingMessagesConfig +modelForTeamFeature TeamFeatureGuestLinks = modelTeamFeatureStatusNoConfig ---------------------------------------------------------------------- -- TeamFeatureStatusNoConfig @@ -330,6 +356,29 @@ instance ToSchema TeamFeatureStatusNoConfig where TeamFeatureStatusNoConfig <$> tfwoStatus .= field "status" schema +data TeamFeatureStatusNoConfigAndLockStatus = TeamFeatureStatusNoConfigAndLockStatus + { tfwoapsStatus :: TeamFeatureStatusValue, + tfwoapsLockStatus :: LockStatusValue + } + deriving stock (Eq, Show, Generic, Typeable) + deriving (ToJSON, FromJSON, S.ToSchema) via (Schema TeamFeatureStatusNoConfigAndLockStatus) + +instance Arbitrary TeamFeatureStatusNoConfigAndLockStatus where + arbitrary = TeamFeatureStatusNoConfigAndLockStatus <$> arbitrary <*> arbitrary + +modelTeamFeatureStatusNoConfigAndLockStatus :: Doc.Model +modelTeamFeatureStatusNoConfigAndLockStatus = Doc.defineModel "TeamFeatureStatusNoConfigAndLockStatus" $ do + Doc.description "Team feature that has no configuration beyond the boolean on/off switch and a lock status" + Doc.property "status" typeTeamFeatureStatusValue $ Doc.description "" + Doc.property "lockStatus" typeLockStatusValue $ Doc.description "" + +instance ToSchema TeamFeatureStatusNoConfigAndLockStatus where + schema = + object "TeamFeatureStatusNoConfigAndLockStatus" $ + TeamFeatureStatusNoConfigAndLockStatus + <$> tfwoapsStatus .= field "status" schema + <*> tfwoapsLockStatus .= field "lockStatus" schema + ---------------------------------------------------------------------- -- TeamFeatureStatusWithConfig @@ -360,6 +409,32 @@ instance ToSchema cfg => ToSchema (TeamFeatureStatusWithConfig cfg) where <$> tfwcStatus .= field "status" schema <*> tfwcConfig .= field "config" schema +data TeamFeatureStatusWithConfigAndLockStatus (cfg :: *) = TeamFeatureStatusWithConfigAndLockStatus + { tfwcapsStatus :: TeamFeatureStatusValue, + tfwcapsConfig :: cfg, + tfwcapsLockStatus :: LockStatusValue + } + deriving stock (Eq, Show, Generic, Typeable) + deriving (ToJSON, FromJSON, S.ToSchema) via (Schema (TeamFeatureStatusWithConfigAndLockStatus cfg)) + +instance Arbitrary cfg => Arbitrary (TeamFeatureStatusWithConfigAndLockStatus cfg) where + arbitrary = TeamFeatureStatusWithConfigAndLockStatus <$> arbitrary <*> arbitrary <*> arbitrary + +modelTeamFeatureStatusWithConfigAndLockStatus :: TeamFeatureName -> Doc.Model -> Doc.Model +modelTeamFeatureStatusWithConfigAndLockStatus name cfgModel = Doc.defineModel (cs $ show name) $ do + Doc.description $ "Status and config of " <> cs (show name) + Doc.property "status" typeTeamFeatureStatusValue $ Doc.description "status" + Doc.property "config" (Doc.ref cfgModel) $ Doc.description "config" + Doc.property "lockStatus" typeLockStatusValue $ Doc.description "config" + +instance ToSchema cfg => ToSchema (TeamFeatureStatusWithConfigAndLockStatus cfg) where + schema = + object "TeamFeatureStatusWithConfigAndLockStatus" $ + TeamFeatureStatusWithConfigAndLockStatus + <$> tfwcapsStatus .= field "status" schema + <*> tfwcapsConfig .= field "config" schema + <*> tfwcapsLockStatus .= field "lockStatus" schema + ---------------------------------------------------------------------- -- TeamFeatureClassifiedDomainsConfig @@ -383,7 +458,10 @@ modelTeamFeatureClassifiedDomainsConfig = Doc.property "domains" (Doc.array Doc.string') $ Doc.description "domains" defaultClassifiedDomains :: TeamFeatureStatusWithConfig TeamFeatureClassifiedDomainsConfig -defaultClassifiedDomains = TeamFeatureStatusWithConfig TeamFeatureDisabled (TeamFeatureClassifiedDomainsConfig []) +defaultClassifiedDomains = + TeamFeatureStatusWithConfig + TeamFeatureDisabled + (TeamFeatureClassifiedDomainsConfig []) ---------------------------------------------------------------------- -- TeamFeatureAppLockConfig @@ -445,11 +523,88 @@ modelTeamFeatureSelfDeletingMessagesConfig = Doc.defineModel "TeamFeatureSelfDeletingMessagesConfig" $ do Doc.property "enforcedTimeoutSeconds" Doc.int32' $ Doc.description "optional; default: `0` (no enforcement)" -defaultSelfDeletingMessagesStatus :: TeamFeatureStatusWithConfig TeamFeatureSelfDeletingMessagesConfig +defaultSelfDeletingMessagesStatus :: TeamFeatureStatusWithConfigAndLockStatus TeamFeatureSelfDeletingMessagesConfig defaultSelfDeletingMessagesStatus = - TeamFeatureStatusWithConfig + TeamFeatureStatusWithConfigAndLockStatus TeamFeatureEnabled (TeamFeatureSelfDeletingMessagesConfig 0) + Unlocked + +---------------------------------------------------------------------- +-- LockStatus + +instance FromHttpApiData LockStatusValue where + parseUrlPiece = maybeToEither "Invalid lock status" . fromByteString . cs + +data LockStatusValue = Locked | Unlocked + deriving stock (Eq, Show, Generic) + deriving (Arbitrary) via (GenericUniform LockStatusValue) + deriving (ToJSON, FromJSON, S.ToSchema) via (Schema LockStatusValue) + +newtype LockStatus = LockStatus + { lockStatus :: LockStatusValue + } + deriving stock (Eq, Show, Generic) + deriving (FromJSON, ToJSON, S.ToSchema) via (Schema LockStatus) + deriving (Arbitrary) via (GenericUniform LockStatus) + +instance ToSchema LockStatus where + schema = + object "LockStatus" $ + LockStatus + <$> lockStatus .= field "lockStatus" schema + +modelLockStatus :: Doc.Model +modelLockStatus = + Doc.defineModel "LockStatus" $ do + Doc.property "lockStatus" typeLockStatusValue $ Doc.description "" + +typeLockStatusValue :: Doc.DataType +typeLockStatusValue = + Doc.string $ + Doc.enum + [ "locked", + "unlocked" + ] + +instance ToSchema LockStatusValue where + schema = + enum @Text "LockStatusValue" $ + mconcat + [ element "locked" Locked, + element "unlocked" Unlocked + ] + +instance ToByteString LockStatusValue where + builder Locked = "locked" + builder Unlocked = "unlocked" + +instance FromByteString LockStatusValue where + parser = + Parser.takeByteString >>= \b -> + case T.decodeUtf8' b of + Right "locked" -> pure Locked + Right "unlocked" -> pure Unlocked + Right t -> fail $ "Invalid LockStatusValue: " <> T.unpack t + Left e -> fail $ "Invalid LockStatusValue: " <> show e + +instance Cass.Cql LockStatusValue where + ctype = Cass.Tagged Cass.IntColumn + + fromCql (Cass.CqlInt n) = case n of + 0 -> pure Locked + 1 -> pure Unlocked + _ -> Left "fromCql: Invalid LockStatusValue" + fromCql _ = Left "fromCql: LockStatusValue: CqlInt expected" + + toCql Locked = Cass.CqlInt 0 + toCql Unlocked = Cass.CqlInt 1 + +---------------------------------------------------------------------- +-- guest links + +defaultGuestLinksStatus :: TeamFeatureStatusNoConfigAndLockStatus +defaultGuestLinksStatus = TeamFeatureStatusNoConfigAndLockStatus TeamFeatureEnabled Unlocked ---------------------------------------------------------------------- -- internal diff --git a/libs/wire-api/src/Wire/API/User.hs b/libs/wire-api/src/Wire/API/User.hs index e5cb2e78f07..30bbe2933e8 100644 --- a/libs/wire-api/src/Wire/API/User.hs +++ b/libs/wire-api/src/Wire/API/User.hs @@ -905,6 +905,13 @@ instance FromJSON LocaleUpdate where newtype EmailUpdate = EmailUpdate {euEmail :: Email} deriving stock (Eq, Show, Generic) deriving newtype (Arbitrary) + deriving (S.ToSchema) via (Schema EmailUpdate) + +instance ToSchema EmailUpdate where + schema = + object "EmailUpdate" $ + EmailUpdate + <$> euEmail .= field "email" schema modelEmailUpdate :: Doc.Model modelEmailUpdate = Doc.defineModel "EmailUpdate" $ do diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generator.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generator.hs index 4d022f0eac0..e4daf3da24b 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generator.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generator.hs @@ -328,8 +328,8 @@ generateTestModule = do generateBindingModule @Team.TeamDeleteData "team" ref generateBindingModule @Team.Conversation.TeamConversation "team" ref generateBindingModule @Team.Conversation.TeamConversationList "team" ref - generateBindingModule @(Team.Feature.TeamFeatureStatus 'Team.Feature.TeamFeatureLegalHold) "team" ref - generateBindingModule @(Team.Feature.TeamFeatureStatus 'Team.Feature.TeamFeatureAppLock) "team" ref + generateBindingModule @(Team.Feature.TeamFeatureStatus 'Team.Feature.WithoutLockStatus 'Team.Feature.TeamFeatureLegalHold) "team" ref + generateBindingModule @(Team.Feature.TeamFeatureStatus 'Team.Feature.WithoutLockStatus 'Team.Feature.TeamFeatureAppLock) "team" ref generateBindingModule @Team.Feature.TeamFeatureStatusValue "team" ref generateBindingModule @Team.Invitation.InvitationRequest "team" ref generateBindingModule @Team.Invitation.Invitation "team" ref diff --git a/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/Aeson.hs b/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/Aeson.hs index 6e09181e543..2b10b608d54 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/Aeson.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/Aeson.hs @@ -195,17 +195,22 @@ tests = testRoundTrip @Team.TeamDeleteData, testRoundTrip @Team.Conversation.TeamConversation, testRoundTrip @Team.Conversation.TeamConversationList, - testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.TeamFeatureLegalHold), - testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.TeamFeatureSSO), - testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.TeamFeatureSearchVisibility), - testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.TeamFeatureValidateSAMLEmails), - testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.TeamFeatureDigitalSignatures), - testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.TeamFeatureAppLock), - testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.TeamFeatureFileSharing), - testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.TeamFeatureClassifiedDomains), - testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.TeamFeatureConferenceCalling), - testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.TeamFeatureSelfDeletingMessages), + testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.WithoutLockStatus 'Team.Feature.TeamFeatureLegalHold), + testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.WithoutLockStatus 'Team.Feature.TeamFeatureSSO), + testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.WithoutLockStatus 'Team.Feature.TeamFeatureSearchVisibility), + testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.WithoutLockStatus 'Team.Feature.TeamFeatureValidateSAMLEmails), + testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.WithoutLockStatus 'Team.Feature.TeamFeatureDigitalSignatures), + testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.WithoutLockStatus 'Team.Feature.TeamFeatureAppLock), + testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.WithoutLockStatus 'Team.Feature.TeamFeatureFileSharing), + testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.WithoutLockStatus 'Team.Feature.TeamFeatureClassifiedDomains), + testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.WithoutLockStatus 'Team.Feature.TeamFeatureConferenceCalling), + testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.WithoutLockStatus 'Team.Feature.TeamFeatureSelfDeletingMessages), + testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.WithLockStatus 'Team.Feature.TeamFeatureSelfDeletingMessages), + testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.WithoutLockStatus 'Team.Feature.TeamFeatureSelfDeletingMessages), testRoundTrip @Team.Feature.TeamFeatureStatusValue, + testRoundTrip @Team.Feature.LockStatusValue, + testRoundTrip @Team.Feature.LockStatus, + testRoundTrip @Team.Feature.TeamFeatureStatusNoConfigAndLockStatus, testRoundTrip @Team.Invitation.InvitationRequest, testRoundTrip @Team.Invitation.Invitation, testRoundTrip @Team.Invitation.InvitationList, diff --git a/services/brig/Setup.hs b/services/brig/Setup.hs new file mode 100644 index 00000000000..b7f084b8ca1 --- /dev/null +++ b/services/brig/Setup.hs @@ -0,0 +1,72 @@ +-- 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 . + +import Data.Char +import Data.Foldable +import qualified Data.Map as Map +import Data.Maybe +import Distribution.Simple +import Distribution.Simple.BuildPaths +import Distribution.Simple.LocalBuildInfo +import Distribution.Types.PackageDescription +import System.Directory +import System.FilePath + +main :: IO () +main = + defaultMainWithHooks + simpleUserHooks + { buildHook = \desc info hooks flags -> do + generate desc info + buildHook simpleUserHooks desc info hooks flags, + replHook = \desc info hooks flags args -> do + generate desc info + replHook simpleUserHooks desc info hooks flags args + } + +generate :: PackageDescription -> LocalBuildInfo -> IO () +generate desc info = withLibLBI desc info $ \_ lib -> do + let base = autogenComponentModulesDir info lib "Brig" "Docs" + generateDocs base "swagger.md" + +generateDocs :: FilePath -> FilePath -> IO () +generateDocs base src = do + contents <- readFile ("docs" src) + let name = moduleName src + dest = base (moduleName src <> ".hs") + createDirectoryIfMissing True base + putStrLn ("Generating " <> dest <> " ...") + let out = + unlines + [ "module Brig.Docs." <> name <> " where", + "", + "import Imports", + "", + "contents :: Text", + "contents = " ++ show contents + ] + writeFile dest out + +moduleName :: String -> String +moduleName = go . dropExtension + where + go [] = [] + go (c : cs) = case break (== '-') cs of + (w, rest) -> + (toUpper c : w) <> case rest of + ('-' : name) -> go name + _ -> [] diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal index af88a6605d3..94a4b541681 100644 --- a/services/brig/brig.cabal +++ b/services/brig/brig.cabal @@ -1,13 +1,13 @@ -cabal-version: 1.12 +cabal-version: 2.0 -- This file has been generated from package.yaml by hpack version 0.33.0. -- -- see: https://github.com/sol/hpack -- --- hash: 0613764ce9b6730901fb4a909cae6c25607a3df9e7c5d97b3f51a84c80185e91 +-- hash: 513c0f5104342fb14b0246f7c44733a84ec36fae97633fc55cb209e0e0bcd087 name: brig -version: 1.35.0 +version: 2.0 synopsis: User Service category: Network author: Wire Swiss GmbH @@ -15,7 +15,17 @@ maintainer: Wire Swiss GmbH copyright: (c) 2017 Wire Swiss GmbH license: AGPL-3 license-file: LICENSE -build-type: Simple +build-type: Custom +extra-source-files: + docs/swagger.md + +custom-setup + setup-depends: + Cabal + , base + , containers + , directory + , filepath library exposed-modules: @@ -111,6 +121,9 @@ library Main other-modules: Paths_brig + Brig.Docs.Swagger + autogen-modules: + Brig.Docs.Swagger hs-source-dirs: src default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DerivingVia DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns @@ -167,7 +180,6 @@ library , http-types >=0.8 , imports , insert-ordered-containers - , interpolate , iproute >=1.5 , iso639 >=0.1 , lens >=3.8 diff --git a/services/brig/docs/swagger.md b/services/brig/docs/swagger.md new file mode 100644 index 00000000000..63ec978afb9 --- /dev/null +++ b/services/brig/docs/swagger.md @@ -0,0 +1,75 @@ +## General + +**NOTE**: only a few endpoints are visible here at the moment, more will come as we migrate them to Swagger 2.0. In the meantime please also look at the old swagger docs link for the not-yet-migrated endpoints. See https://docs.wire.com/understand/api-client-perspective/swagger.html for the old endpoints. + +## SSO Endpoints + +### Overview + +`/sso/metadata` will be requested by the IdPs to learn how to talk to wire. + +`/sso/initiate-login`, `/sso/finalize-login` are for the SAML authentication handshake performed by a user in order to log into wire. They are not exactly standard in their details: they may return HTML or XML; redirect to error URLs instead of throwing errors, etc. + +`/identity-providers` end-points are for use in the team settings page when IdPs are registered. They talk json. + + +### Configuring IdPs + +IdPs usually allow you to copy the metadata into your clipboard. That should contain all the details you need to post the idp in your team under `/identity-providers`. (Team id is derived from the authorization credentials of the request.) + +#### okta.com + +Okta will ask you to provide two URLs when you set it up for talking to wireapp: + +1. The `Single sign on URL`. This is the end-point that accepts the user's credentials after successful authentication against the IdP. Choose `/sso/finalize-login` with schema and hostname of the wire server you are configuring. + +2. The `Audience URI`. You can find this in the metadata returned by the `/sso/metadata` end-point. It is the contents of the `md:OrganizationURL` element. + +#### centrify.com + +Centrify allows you to upload the metadata xml document that you get from the `/sso/metadata` end-point. You can also enter the metadata url and have centrify retrieve the xml, but to guarantee integrity of the setup, the metadata should be copied from the team settings page and pasted into the centrify setup page without any URL indirections. + +## Federation errors + +Endpoints involving federated calls to other domains can return some extra failure responses, common to all endpoints. Instead of listing them as possible responses for each endpoint, we document them here. + +For errors that are more likely to be transient, we suggest clients to retry whatever request resulted in the error. Transient errors are indicated explicitly below. + +**Note**: when a failure occurs as a result of making a federated RPC to another backend, the error response contains the following extra fields: + + - `domain`: the target backend of the RPC that failed; + - `path`: the path of the RPC that failed. + +### Domain errors + +Errors in this category result from trying to communicate with a backend that is considered non-existent or invalid. They can result from invalid user input or client issues, but they can also be a symptom of misconfiguration in one or multiple backends. These errors have a 4xx status code. + + - **Remote backend not found** (status: 422, label: `invalid-domain`): This backend attempted to contact a backend which does not exist or is not properly configured. For the most part, clients can consider this error equivalent to a domain not existing, although it should be noted that certain mistakes in the DNS configuration on a remote backend can lead to the backend not being recognized, and hence to this error. It is therefore not advisable to take any destructive action upon encountering this error, such as deleting remote users from conversations. + - **Federation denied locally** (status: 400, label: `federation-denied`): This backend attempted an RPC to a non-whitelisted backend. Similar considerations as for the previous error apply. + - **Federation not enabled** (status: 400, label: `federation-not-enabled`): Federation has not been configured for this backend. This will happen if a federation-aware client tries to talk to a backend for which federation is disabled, or if federation was disabled on the backend after reaching a federation-specific state (e.g. conversations with remote users). There is no way to cleanly recover from these errors at this point. + +### Local federation errors + +An error in this category likely indicates an issue with the configuration of federation on the local backend. Possibly transient errors are indicated explicitly below. All these errors have a 500 status code. + + - **Federation unavailable** (status: 500, label: `federation-not-available`): Federation is configured for this backend, but the local federator cannot be reached. This can be transient, so clients should retry the request. + - **Federation not implemented** (status: 500, label: `federation-not-implemented`): Federated behaviour for a certain endpoint is not yet implemented. + - **Federator discovery failed** (status: 500, label: `discovery-failure`): A DNS error occurred during discovery of a remote backend. This can be transient, so clients should retry the request. + - **Local federation error** (status: 500, label: `federation-local-error`): An error occurred in the communication between this backend and its local federator. These errors are most likely caused by bugs in the backend, and should be reported as such. + +### Remote federation errors + +Errors in this category are returned in case of communication issues between the local backend and a remote one, or if the remote side encountered an error while processing an RPC. Some errors in this category might be caused by incorrect client behaviour, wrong user input, or incorrect certificate configuration. Possibly transient errors are indicated explicitly. We use non-standard 5xx status codes for these errors. + + - **HTTP2 error** (status: 533, label: `federation-http2-error`): The current federator encountered an error when making an HTTP2 request to a remote one. Check the error message for more details. + - **Connection refused** (status: 521, label: `federation-connection-refused`): The local federator could not connect to a remote one. This could be transient, so clients should retry the request. + - **TLS failure**: (status: 525, label: `federation-tls-error`): An error occurred during the TLS handshake between the local federator and a remote one. This is most likely due to an issue with the certificate on the remote end. + - **Remote federation error** (status: 533, label: `federation-remote-error`): The remote backend could not process a request coming from this backend. Check the error message for more details. + +### Backend compatibility errors + +An error in this category will be returned when this backend makes an invalid or unsupported RPC to another backend. This can indicate some incompatibility between backends or a backend bug. These errors are unlikely to be transient, so retrying requests is *not* advised. + + - **Version mismatch** (status: 531, label: `federation-version-mismatch`): A remote backend is running an unsupported version of the federator. + - **Invalid content type** (status: 533, label: `federation-invalid-content-type`): An RPC to another backend returned with an invalid content type. + - **Unsupported content type** (status: 533, label: `federation-unsupported-content-type`): An RPC to another backend returned with an unsupported content type. diff --git a/services/brig/package.yaml b/services/brig/package.yaml index a0520b4412d..05329979f73 100644 --- a/services/brig/package.yaml +++ b/services/brig/package.yaml @@ -1,7 +1,7 @@ defaults: local: ../../package-defaults.yaml name: brig -version: '1.35.0' +version: '2.0' synopsis: User Service category: Network author: Wire Swiss GmbH @@ -10,8 +10,19 @@ copyright: (c) 2017 Wire Swiss GmbH license: AGPL-3 ghc-options: - -funbox-strict-fields +custom-setup: + dependencies: + - Cabal + - base + - containers + - directory + - filepath +extra-source-files: + - docs/* library: source-dirs: src + generated-other-modules: + - Brig.Docs.Swagger dependencies: - aeson >=0.11 - amazonka >=1.3.7 @@ -63,7 +74,6 @@ library: - http-types >=0.8 - imports - insert-ordered-containers - - interpolate - iproute >=1.5 - iso639 >=0.1 - lens >=3.8 diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index 3ed826d0889..081c96f8009 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -40,6 +40,8 @@ import Brig.App import qualified Brig.Calling.API as Calling import qualified Brig.Data.Connection as Data import qualified Brig.Data.User as Data +import qualified Brig.Docs.Swagger +import qualified Brig.IO.Intra as Intra import Brig.Options hiding (internalEvents, sesQueue) import qualified Brig.Provider.API as Provider import qualified Brig.Team.API as Team @@ -72,7 +74,6 @@ import qualified Data.Map.Strict as Map import Data.Misc (IpAddr (..)) import Data.Qualified import Data.Range -import Data.String.Interpolate as QQ import qualified Data.Swagger as S import qualified Data.Swagger.Build.Api as Doc import qualified Data.Text as Text @@ -80,6 +81,7 @@ import qualified Data.Text.Ascii as Ascii import Data.Text.Encoding (decodeLatin1) import Data.Text.Lazy (pack) import qualified Data.ZAuth.Token as ZAuth +import Galley.Types.Teams (HiddenPerm (..), hasPermission) import Imports hiding (head) import Network.HTTP.Types.Status import Network.Wai (Response, lazyRequestBody) @@ -131,7 +133,7 @@ swaggerDocsAPI = swaggerSchemaUIServer $ (BrigAPI.swagger <> GalleyAPI.swaggerDoc <> LegalHoldAPI.swaggerDoc <> SparAPI.swaggerDoc) & S.info . S.title .~ "Wire-Server API" - & S.info . S.description ?~ desc + & S.info . S.description ?~ Brig.Docs.Swagger.contents <> mempty & S.security %~ nub -- sanitise definitions & S.definitions . traverse %~ sanitise @@ -151,97 +153,6 @@ swaggerDocsAPI = (S.properties . traverse . S._Inline %~ sanitise) . (S.required %~ nubOrd) . (S.enum_ . _Just %~ nub) - desc = - Text.pack - [QQ.i| -## General - -**NOTE**: only a few endpoints are visible here at the moment, more will come as we migrate them to Swagger 2.0. In the meantime please also look at the old swagger docs link for the not-yet-migrated endpoints. See https://docs.wire.com/understand/api-client-perspective/swagger.html for the old endpoints. - -## SSO Endpoints - -### Overview - -`/sso/metadata` will be requested by the IdPs to learn how to talk to wire. - -`/sso/initiate-login`, `/sso/finalize-login` are for the SAML authentication handshake performed by a user in order to log into wire. They are not exactly standard in their details: they may return HTML or XML; redirect to error URLs instead of throwing errors, etc. - -`/identity-providers` end-points are for use in the team settings page when IdPs are registered. They talk json. - - -### Configuring IdPs - -IdPs usually allow you to copy the metadata into your clipboard. That should contain all the details you need to post the idp in your team under `/identity-providers`. (Team id is derived from the authorization credentials of the request.) - -#### okta.com - -Okta will ask you to provide two URLs when you set it up for talking to wireapp: - -1. The `Single sign on URL`. This is the end-point that accepts the user's credentials after successful authentication against the IdP. Choose `/sso/finalize-login` with schema and hostname of the wire server you are configuring. - -2. The `Audience URI`. You can find this in the metadata returned by the `/sso/metadata` end-point. It is the contents of the `md:OrganizationURL` element. - -#### centrify.com - -Centrify allows you to upload the metadata xml document that you get from the `/sso/metadata` end-point. You can also enter the metadata url and have centrify retrieve the xml, but to guarantee integrity of the setup, the metadata should be copied from the team settings page and pasted into the centrify setup page without any URL indirections. - -## Federation errors - -Endpoints involving federated calls to other domains can return some extra failure responses, common to all endpoints. Instead of listing them as possible responses for each endpoint, we document them here. - -For errors that are more likely to be transient, we suggest clients to retry whatever request resulted in the error. Transient errors are indicated explicitly below. - -**Note**: when a failure occurs as a result of making a federated RPC to another backend, the error response contains the following extra fields: - - - `domain`: the target backend of the RPC that failed; - - `path`: the path of the RPC that failed. - -### Domain errors - -Errors in this category result from trying to communicate with a backend that is considered non-existent or invalid. They can result from invalid user input or client issues, but they can also be a symptom of misconfiguration in one or multiple backends. - - - **Remote backend not found** (status: 422, label: `srv-record-not-found`): This backend attempted to contact a backend which does not exist or is not properly configured. For the most part, clients can consider this error equivalent to a domain not existing, although it should be noted that certain mistakes in the DNS configuration on a remote backend can lead to the backend not being recognized, and hence to this error. It is therefore not advisable to take any destructive action upon encountering this error, such as deleting remote users from conversations. - - **Federation denied locally** (status: 400, label: `federation-not-allowed`): This backend attempted an RPC to a non-whitelisted backend. Similar considerations as for the previous error apply. - -### Local federation errors - -An error in this category likely indicates an issue with configuration of federation on the local backend. Possibly transient errors are indicated explicitly below. - - - **Federation not enabled** (status: 400, label: `federation-not-enabled`): Federation has not been configured for this backend. This will happen if a federation-aware client tries to talk to a backend for which federation is disabled, or if federation was disabled on the backend after reaching a federation-specific state (e.g. conversations with remote users). There is no way to cleanly recover from these errors at this point. - - **Federation unavailable** (status: 500, label: `federation-not-available`): Federation is configured for this backend, but the local federator cannot be reached. This can be transient, so clients should retry the request. - - **Federation not implemented** (status: 403, label: `federation-not-implemented`): Federated behaviour for a certain endpoint is not yet implemented. - - **Federator discovery failed** (status: 500, label: `srv-lookup-dns-error`): A DNS error occurred during discovery of a remote backend. This can be transient, so clients should retry the request. - - **Too much concurrency** (status: 533, label: `too-much-concurrency`): Too many concurrent requests from this backend. This can be transient, so clients should retry the request. - -### Remote federation errors - -Errors in this category are returned in case of communication issues between the local backend and a remote one, or if the remote side encountered an error while processing an RPC. Some errors in this category might be caused by incorrect client behaviour or wrong user input. All of these errors can be transient, so clients should retry the request that caused them. - - - **gRPC error** (status: 533, label: `grpc-error`): The current federator encountered an error when making an RPC to a remote one. Check the error message for more details. - - **Client RPC error** (status: 500, label: `client-rpc-error`): There was a non-specified error when making a request to another backend. Check the error message for more details. - - **Connection refused** (status: 521, label: `cannot-connect-to-remote-federator`): The local federator could not connect to a remote one. - - **Unknown remote error** (status: 500, label: `unknown-federation-error`): An RPC failed but no specific error was returned by the remote side. Check the error message for more details. - -### Backend compatibility errors - -An error in this category will be returned when this backend makes an invalid or unsupported RPC to another backend. This can indicate some incompatibility between backends or a backend bug. These errors are unlikely to be transient, so retrying requests is *not* advised. - - - **Version mismatch** (status: 531): A remote backend is running an unsupported version of the federator. - - **Invalid method** / **Streaming not supported** (status: 500, label: `federation-invalid-call`): There was an error in the communication between a service on this backend and the local federator. - - **Invalid request** (status: 500, label: `invalid-request-to-federator`): The local federator made an invalid request to a remote one. Check the error message for more details. - - **Invalid content type** (status: 503, label: `federation-invalid-content-type-header`): An RPC to another backend returned an invalid content type. - - **Unsupported content type** (status: 503, label: `federation-unsupported-content-type`): An RPC to another backend returned an unsupported content type. - - **Invalid origin domain** (status: 533, label: `invalid-origin-domain`): The current backend attempted an RPC with an invalid origin domain field. - - **Forbidden endpoint** (status: 533, label: `forbidden-endpoint`): The current backend attempted an RPC to a forbidden or inaccessible remote endpoint. - - **Unknown federation error** (status: 503, label: `unknown-federation-error`): The target of an RPC returned an unexpected reponse. Check the error message for more details. - -### Authentication errors - -The errors in this category relate to authentication or authorization issues between backends. These errors are unlikely to be transient, so retrying requests is *not* advised. - - - **TLS failure**: (status: 525): An error occurred during the TLS handshake between the local federator and a remote one. This is most likely due to an issue with the certificate on the remote end. - - **Federation denied remotely** (status: 532): The current backend made an unauthorized request to a remote one. -|] servantSitemap :: ServerT ServantAPI Handler servantSitemap = @@ -251,6 +162,7 @@ servantSitemap = BrigAPI.getUserQualified = getUser, BrigAPI.getSelf = getSelf, BrigAPI.deleteSelf = deleteUser, + BrigAPI.updateUserEmail = updateUserEmail, BrigAPI.getHandleInfoUnqualified = getHandleInfoUnqualifiedH, BrigAPI.getUserByHandleQualified = Handle.getHandleInfo, BrigAPI.listUsersByUnqualifiedIdsOrHandles = listUsersByUnqualifiedIdsOrHandles, @@ -1193,6 +1105,27 @@ verifyDeleteUserH (r ::: _) = do API.verifyDeleteUser body !>> deleteUserError return (setStatus status200 empty) +updateUserEmail :: UserId -> UserId -> Public.EmailUpdate -> Handler () +updateUserEmail zuserId emailOwnerId (Public.EmailUpdate email) = do + maybeZuserTeamId <- lift $ Data.lookupUserTeam zuserId + whenM (not <$> assertHasPerm maybeZuserTeamId) $ throwStd insufficientTeamPermissions + maybeEmailOwnerTeamId <- lift $ Data.lookupUserTeam emailOwnerId + checkSameTeam maybeZuserTeamId maybeEmailOwnerTeamId + void $ API.changeSelfEmail emailOwnerId email API.AllowSCIMUpdates + where + checkSameTeam :: Maybe TeamId -> Maybe TeamId -> Handler () + checkSameTeam (Just zuserTeamId) maybeEmailOwnerTeamId = + when (Just zuserTeamId /= maybeEmailOwnerTeamId) $ throwStd $ notFound "user not found" + checkSameTeam Nothing _ = throwStd insufficientTeamPermissions + + assertHasPerm :: Maybe TeamId -> Handler Bool + assertHasPerm maybeTeamId = fromMaybe False <$> check + where + check = runMaybeT $ do + teamId <- hoistMaybe maybeTeamId + teamMember <- MaybeT $ lift $ Intra.getTeamMember zuserId teamId + pure $ teamMember `hasPermission` ChangeTeamMemberProfiles + -- activation data ActivationRespWithStatus diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index 94c138721fa..f1bdc2f0b87 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -1232,9 +1232,8 @@ getEmailForProfile profileOwner EmailVisibleIfOnTeam' = then userEmail profileOwner else Nothing getEmailForProfile profileOwner (EmailVisibleIfOnSameTeam' (Just (viewerTeamId, viewerTeamMember))) = - if ( Just viewerTeamId == userTeam profileOwner - && Team.hasPermission viewerTeamMember Team.ViewSameTeamEmails - ) + if Just viewerTeamId == userTeam profileOwner + && Team.hasPermission viewerTeamMember Team.ViewSameTeamEmails then userEmail profileOwner else Nothing getEmailForProfile _ (EmailVisibleIfOnSameTeam' Nothing) = Nothing diff --git a/services/brig/src/Brig/Data/User.hs b/services/brig/src/Brig/Data/User.hs index eed03c3e649..1d501b0f489 100644 --- a/services/brig/src/Brig/Data/User.hs +++ b/services/brig/src/Brig/Data/User.hs @@ -404,7 +404,7 @@ lookupRichInfoMultiUsers users = do -- successful login. lookupUserTeam :: UserId -> AppIO (Maybe TeamId) lookupUserTeam u = - join . fmap runIdentity + (runIdentity =<<) <$> retry x1 (query1 teamSelect (params LocalQuorum (Identity u))) lookupAuth :: (MonadClient m) => UserId -> m (Maybe (Maybe Password, AccountStatus)) @@ -471,7 +471,7 @@ lookupFeatureConferenceCalling uid = do pure $ ApiFt.TeamFeatureStatusNoConfig <$> mStatusValue where select :: PrepQuery R (Identity UserId) (Identity (Maybe ApiFt.TeamFeatureStatusValue)) - select = fromString $ "select feature_conference_calling from user where id = ?" + select = fromString "select feature_conference_calling from user where id = ?" ------------------------------------------------------------------------------- -- Queries diff --git a/services/brig/src/Brig/IO/Intra.hs b/services/brig/src/Brig/IO/Intra.hs index d279ff05283..55fbb8f54bd 100644 --- a/services/brig/src/Brig/IO/Intra.hs +++ b/services/brig/src/Brig/IO/Intra.hs @@ -120,7 +120,7 @@ import System.Logger.Class as Log hiding (name, (.=)) import Wire.API.Federation.API.Brig import Wire.API.Federation.Error import Wire.API.Message (UserClients) -import Wire.API.Team.Feature (TeamFeatureName (..), TeamFeatureStatus) +import Wire.API.Team.Feature (IncludeLockStatus (..), TeamFeatureName (..), TeamFeatureStatus) import Wire.API.Team.LegalHold (LegalholdProtectee) ----------------------------------------------------------------------------- @@ -967,7 +967,7 @@ getTeamName tid = do . expect2xx -- | Calls 'Galley.API.getTeamFeatureStatusH'. -getTeamLegalHoldStatus :: TeamId -> AppIO (TeamFeatureStatus 'TeamFeatureLegalHold) +getTeamLegalHoldStatus :: TeamId -> AppIO (TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureLegalHold) getTeamLegalHoldStatus tid = do debug $ remote "galley" . msg (val "Get legalhold settings") galleyRequest GET req >>= decodeBody "galley" diff --git a/services/brig/src/Brig/Options.hs b/services/brig/src/Brig/Options.hs index 7725bb515ab..ad631e49325 100644 --- a/services/brig/src/Brig/Options.hs +++ b/services/brig/src/Brig/Options.hs @@ -508,8 +508,8 @@ data Settings = Settings -- they are grandfathered), and feature-specific extra data (eg., TLL for self-deleting -- messages). For now, we have something quick & simple. data AccountFeatureConfigs = AccountFeatureConfigs - { afcConferenceCallingDefNew :: !(ApiFT.TeamFeatureStatus 'ApiFT.TeamFeatureConferenceCalling), - afcConferenceCallingDefNull :: !(ApiFT.TeamFeatureStatus 'ApiFT.TeamFeatureConferenceCalling) + { afcConferenceCallingDefNew :: !(ApiFT.TeamFeatureStatus 'ApiFT.WithoutLockStatus 'ApiFT.TeamFeatureConferenceCalling), + afcConferenceCallingDefNull :: !(ApiFT.TeamFeatureStatus 'ApiFT.WithoutLockStatus 'ApiFT.TeamFeatureConferenceCalling) } deriving (Show, Eq, Generic) deriving (Arbitrary) via (GenericUniform AccountFeatureConfigs) diff --git a/services/brig/test/integration/API/Team/Util.hs b/services/brig/test/integration/API/Team/Util.hs index 2e7329bf5c2..aa44fc75895 100644 --- a/services/brig/test/integration/API/Team/Util.hs +++ b/services/brig/test/integration/API/Team/Util.hs @@ -48,6 +48,7 @@ import Util import Web.Cookie (parseSetCookie, setCookieName) import Wire.API.Team.Feature (TeamFeatureStatusValue (..)) import qualified Wire.API.Team.Feature as Public +import qualified Wire.API.User as Public -- | FUTUREWORK: Remove 'createPopulatedBindingTeam', 'createPopulatedBindingTeamWithNames', -- and rename 'createPopulatedBindingTeamWithNamesAndHandles' to 'createPopulatedBindingTeam'. @@ -476,3 +477,14 @@ setTeamSearchVisibility galley tid typ = ) !!! do const 204 === statusCode + +setUserEmail :: Brig -> UserId -> UserId -> Email -> Http ResponseLBS +setUserEmail brig from uid email = do + put + ( brig + . paths ["users", toByteString' uid, "email"] + . zUser from + . zConn "conn" + . contentJson + . body (RequestBodyLBS . encode $ Public.EmailUpdate email) + ) diff --git a/services/brig/test/integration/API/User/Account.hs b/services/brig/test/integration/API/User/Account.hs index a232151fa5a..f723e318aa0 100644 --- a/services/brig/test/integration/API/User/Account.hs +++ b/services/brig/test/integration/API/User/Account.hs @@ -141,9 +141,58 @@ tests _ at opts p b c ch g aws = testGroup "temporary customer extensions" [ test' aws p "domains blocked for registration" $ testDomainsBlockedForRegistration opts b + ], + testGroup + "update user email by team owner" + [ test' aws p "put /users/:uid/email" $ testUpdateUserEmailByTeamOwner b ] ] +testUpdateUserEmailByTeamOwner :: Brig -> Http () +testUpdateUserEmailByTeamOwner brig = do + (_, teamOwner, emailOwner : otherTeamMember : _) <- createPopulatedBindingTeamWithNamesAndHandles brig 2 + (teamOwnerDifferentTeam, _) <- createUserWithTeam' brig + newEmail <- randomEmail + initiateEmailUpdateNoSend brig newEmail (userId emailOwner) !!! (const 202 === statusCode) + checkActivationCode newEmail True + checkLetActivationExpire newEmail + checkActivationCode newEmail False + checkSetUserEmail teamOwner emailOwner newEmail 200 + checkActivationCode newEmail True + checkUnauthorizedRequests emailOwner otherTeamMember teamOwnerDifferentTeam newEmail + activateEmail brig newEmail + -- apparently activating the email does not invalidate the activation code + -- therefore we let the activation code expire again + checkLetActivationExpire newEmail + checkSetUserEmail teamOwner emailOwner newEmail 200 + checkActivationCode newEmail False + checkUnauthorizedRequests emailOwner otherTeamMember teamOwnerDifferentTeam newEmail + checkActivationCode newEmail False + where + checkLetActivationExpire :: Email -> Http () + checkLetActivationExpire email = do + -- assumption: `optSettings.setActivationTimeout = 5` in `brig.yaml` + threadDelay (5100 * 1000) + checkActivationCode email False + + checkActivationCode :: Email -> Bool -> Http () + checkActivationCode email shouldExist = do + maybeActivationCode <- Util.getActivationCode brig (Left email) + void $ + lift $ + if shouldExist + then assertBool "activation code should exists" (isJust maybeActivationCode) + else assertBool "activation code should not exists" (isNothing maybeActivationCode) + + checkSetUserEmail :: User -> User -> Email -> Int -> Http () + checkSetUserEmail teamOwner emailOwner email expectedStatusCode = + setUserEmail brig (userId teamOwner) (userId emailOwner) email !!! (const expectedStatusCode === statusCode) + + checkUnauthorizedRequests :: User -> User -> User -> Email -> Http () + checkUnauthorizedRequests emailOwner otherTeamMember teamOwnerDifferentTeam email = do + setUserEmail brig (userId teamOwnerDifferentTeam) (userId emailOwner) email !!! (const 404 === statusCode) + setUserEmail brig (userId otherTeamMember) (userId emailOwner) email !!! (const 403 === statusCode) + testCreateUserWithPreverified :: Opt.Opts -> Brig -> AWS.Env -> Http () testCreateUserWithPreverified opts brig aws = do -- Register (pre verified) user with phone diff --git a/services/cargohold/cargohold.cabal b/services/cargohold/cargohold.cabal index e3bb71aed7a..dd689436f55 100644 --- a/services/cargohold/cargohold.cabal +++ b/services/cargohold/cargohold.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 7476868d5acce0bd802155cbab24a29a80fd5eec48f540dd3e6dcb492a47d683 +-- hash: 43240dbac626b3b23a6c7631367cc8c708e417b55fa7b007b4a58885878f8911 name: cargohold version: 1.5.0 @@ -27,6 +27,7 @@ library exposed-modules: CargoHold.API CargoHold.API.Error + CargoHold.API.Federation CargoHold.API.Legacy CargoHold.API.Public CargoHold.API.V3 @@ -82,6 +83,8 @@ library , resourcet >=1.1 , retry >=0.5 , safe >=0.3 + , servant + , servant-server , swagger >=0.2 , text >=1.1 , time >=1.4 @@ -97,6 +100,7 @@ library , wai-routing >=0.12 , wai-utilities >=0.16.1 , wire-api + , wire-api-federation , yaml >=0.8 default-language: Haskell2010 diff --git a/services/cargohold/package.yaml b/services/cargohold/package.yaml index 4d9cdc60700..c73d7934df3 100644 --- a/services/cargohold/package.yaml +++ b/services/cargohold/package.yaml @@ -49,6 +49,8 @@ library: - optparse-applicative >=0.10 - retry >=0.5 - resourcet >=1.1 + - servant + - servant-server - swagger >=0.2 - time >=1.4 - tinylog >=0.10 @@ -63,6 +65,7 @@ library: - wai-routing >=0.12 - wai-utilities >=0.16.1 - wire-api + - wire-api-federation executables: cargohold-integration: main: Main.hs diff --git a/services/cargohold/src/CargoHold/API/Federation.hs b/services/cargohold/src/CargoHold/API/Federation.hs new file mode 100644 index 00000000000..e0ff94dc598 --- /dev/null +++ b/services/cargohold/src/CargoHold/API/Federation.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 CargoHold.API.Federation + ( FederationAPI, + federationSitemap, + ) +where + +import CargoHold.App +import Control.Error +import Imports +import Servant.API +import Servant.API.Generic +import Servant.Server hiding (Handler) +import Servant.Server.Generic +import Wire.API.Federation.API +import qualified Wire.API.Federation.API.Cargohold as F +import Wire.API.Federation.API.Common +import Wire.API.Federation.Error + +type FederationAPI = "federation" :> ToServantApi (FedApi 'Cargohold) + +federationSitemap :: ServerT FederationAPI Handler +federationSitemap = + genericServerT $ + F.CargoholdApi {F.getAsset = getAsset} + +getAsset :: () -> Handler EmptyResponse +getAsset _ = throwE federationNotImplemented diff --git a/services/cargohold/src/CargoHold/App.hs b/services/cargohold/src/CargoHold/App.hs index fe8364b24d5..79aa9dddfa5 100644 --- a/services/cargohold/src/CargoHold/App.hs +++ b/services/cargohold/src/CargoHold/App.hs @@ -49,7 +49,8 @@ import Bilge.RPC (HasRequestId (..)) import qualified CargoHold.AWS as AWS import CargoHold.Options as Opt import Control.Error (ExceptT, exceptT) -import Control.Lens (makeLenses, set, view, (^.)) +import Control.Exception (throw) +import Control.Lens (makeLenses, view, (^.)) import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) import Control.Monad.Trans.Resource (ResourceT, runResourceT, transResourceT) import Data.Default (def) @@ -58,10 +59,7 @@ import qualified Data.Metrics.Middleware as Metrics import Imports hiding (log) import Network.HTTP.Client (ManagerSettings (..), requestHeaders, responseTimeoutMicro) import Network.HTTP.Client.OpenSSL -import Network.Wai (Request, ResponseReceived) -import Network.Wai.Routing (Continue) -import Network.Wai.Utilities (Error (..), lookupRequestId) -import qualified Network.Wai.Utilities.Server as Server +import Network.Wai.Utilities (Error (..)) import OpenSSL.Session (SSLContext, SSLOption (..)) import qualified OpenSSL.Session as SSL import qualified OpenSSL.X509.SystemStore as SSL @@ -185,7 +183,5 @@ runAppResourceT e rma = liftIO . runResourceT $ transResourceT (runAppT e) rma type Handler = ExceptT Error App -runHandler :: Env -> Request -> Handler ResponseReceived -> Continue IO -> IO ResponseReceived -runHandler e r h k = - let e' = set requestId (maybe def RequestId (lookupRequestId r)) e - in runAppT e' (exceptT (Server.onError (_appLogger e) [Right $ _metrics e] r k) return h) +runHandler :: Env -> Handler a -> IO a +runHandler e h = runAppT e (exceptT throw pure h) diff --git a/services/cargohold/src/CargoHold/Run.hs b/services/cargohold/src/CargoHold/Run.hs index 150ba36b457..bf305eb2d06 100644 --- a/services/cargohold/src/CargoHold/Run.hs +++ b/services/cargohold/src/CargoHold/Run.hs @@ -21,24 +21,34 @@ module CargoHold.Run where import CargoHold.API (sitemap) +import CargoHold.API.Federation import CargoHold.App import CargoHold.Options -import Control.Lens ((^.)) +import Control.Lens (set, (^.)) import Control.Monad.Catch (finally) +import Data.Default +import Data.Id import Data.Metrics.Middleware.Prometheus (waiPrometheusMiddleware) +import Data.Proxy import Data.Text (unpack) import Imports import qualified Network.Wai as Wai import qualified Network.Wai.Middleware.Gzip as GZip +import Network.Wai.Utilities.Request import Network.Wai.Utilities.Server import qualified Network.Wai.Utilities.Server as Server +import Servant (hoistServer) +import qualified Servant +import Servant.API import Util.Options +type CombinedAPI = FederationAPI :<|> Servant.Raw + run :: Opts -> IO () run o = do e <- newEnv o s <- Server.newSettings (server e) - runSettingsWithShutdown s (middleware e $ serve e) 5 + runSettingsWithShutdown s (middleware e $ servantApp e) 5 `finally` closeEnv e where rtree = compile sitemap @@ -48,4 +58,15 @@ run o = do waiPrometheusMiddleware sitemap . GZip.gzip GZip.def . catchErrors (e ^. appLogger) [Right $ e ^. metrics] - serve e r k = runHandler e r (Server.route rtree r k) k + serve e r k = runHandler e (Server.route rtree r k) + servantApp e0 r = + let e = set requestId (maybe def RequestId (lookupRequestId r)) e0 + in Servant.serve + (Proxy @CombinedAPI) + ( hoistServer (Proxy @FederationAPI) (toServantHandler e) federationSitemap + :<|> Servant.Tagged (serve e) + ) + r + +toServantHandler :: Env -> Handler a -> Servant.Handler a +toServantHandler env = liftIO . runHandler env diff --git a/services/federator/federator.integration.yaml b/services/federator/federator.integration.yaml index 8559f53624f..42e08d35c5c 100644 --- a/services/federator/federator.integration.yaml +++ b/services/federator/federator.integration.yaml @@ -7,6 +7,9 @@ federatorExternal: brig: host: 0.0.0.0 port: 8082 +cargohold: + host: 0.0.0.0 + port: 8084 galley: host: 0.0.0.0 port: 8085 diff --git a/services/federator/src/Federator/Discovery.hs b/services/federator/src/Federator/Discovery.hs index 096213f6760..65844e33d86 100644 --- a/services/federator/src/Federator/Discovery.hs +++ b/services/federator/src/Federator/Discovery.hs @@ -48,7 +48,7 @@ instance AsWai DiscoveryFailure where toWai e = Wai.mkError status label (LText.fromStrict (waiErrorDescription e)) where (status, label) = case e of - DiscoveryFailureSrvNotAvailable _ -> (HTTP.status422, "srv-record-not-found") + DiscoveryFailureSrvNotAvailable _ -> (HTTP.status422, "invalid-domain") DiscoveryFailureDNSError _ -> (HTTP.status500, "discovery-failure") waiErrorDescription :: DiscoveryFailure -> Text waiErrorDescription (DiscoveryFailureSrvNotAvailable msg) = diff --git a/services/federator/src/Federator/Options.hs b/services/federator/src/Federator/Options.hs index 6df11978d84..4904cc4e58f 100644 --- a/services/federator/src/Federator/Options.hs +++ b/services/federator/src/Federator/Options.hs @@ -83,6 +83,8 @@ data Opts = Opts brig :: Endpoint, -- | Host and port of galley galley :: Endpoint, + -- | Host and port of cargohold + cargohold :: Endpoint, -- | Log level (Debug, Info, etc) logLevel :: Level, -- | Use netstrings encoding (see ) diff --git a/services/federator/src/Federator/Run.hs b/services/federator/src/Federator/Run.hs index fafb6296714..3e9312a4604 100644 --- a/services/federator/src/Federator/Run.hs +++ b/services/federator/src/Federator/Run.hs @@ -97,6 +97,7 @@ newEnv o _dnsResolver = do let _runSettings = Opt.optSettings o let _service Brig = mkEndpoint (Opt.brig o) _service Galley = mkEndpoint (Opt.galley o) + _service Cargohold = mkEndpoint (Opt.cargohold o) _httpManager <- initHttpManager _tls <- mkTLSSettingsOrThrow _runSettings >>= newIORef return Env {..} diff --git a/services/federator/src/Federator/Validation.hs b/services/federator/src/Federator/Validation.hs index 57a130a376f..4d7f35867d6 100644 --- a/services/federator/src/Federator/Validation.hs +++ b/services/federator/src/Federator/Validation.hs @@ -59,7 +59,7 @@ instance Exception ValidationError instance AsWai ValidationError where toWai err = - Wai.mkError HTTP.status403 (validationErrorLabel err) + Wai.mkError (validationErrorStatus err) (validationErrorLabel err) . LText.fromStrict $ waiErrorDescription err @@ -82,6 +82,13 @@ validationErrorLabel (DomainParseError _) = "domain-parse-error" validationErrorLabel (AuthenticationFailure _) = "authentication-failure" validationErrorLabel (FederationDenied _) = "federation-denied" +validationErrorStatus :: ValidationError -> HTTP.Status +-- the FederationDenied case is handled differently, because it may be caused +-- by wrong input in the original request, so we let this error propagate to the +-- client +validationErrorStatus (FederationDenied _) = HTTP.status400 +validationErrorStatus _ = HTTP.status403 + -- | Validates an already-parsed domain against the allowList using the federator -- startup configuration. ensureCanFederateWith :: diff --git a/services/federator/test/integration/Test/Federator/InwardSpec.hs b/services/federator/test/integration/Test/Federator/InwardSpec.hs index 6216db63f96..da02ec6f459 100644 --- a/services/federator/test/integration/Test/Federator/InwardSpec.hs +++ b/services/federator/test/integration/Test/Federator/InwardSpec.hs @@ -72,6 +72,11 @@ spec env = Request +type CargoholdReq = Request -> Request + newtype TestFederator m a = TestFederator {unwrapTestFederator :: ReaderT TestEnv m a} deriving newtype ( Functor, @@ -88,6 +90,7 @@ data TestEnv = TestEnv { _teMgr :: Manager, _teTLSSettings :: TLSSettings, _teBrig :: BrigReq, + _teCargohold :: CargoholdReq, -- | federator config _teOpts :: Opts, -- | integration test config @@ -98,6 +101,7 @@ type Select = TestEnv -> (Request -> Request) data IntegrationConfig = IntegrationConfig { cfgBrig :: Endpoint, + cfgCargohold :: Endpoint, cfgFederatorExternal :: Endpoint, cfgNginxIngress :: Endpoint, cfgOriginDomain :: Text @@ -145,6 +149,7 @@ mkEnv _teTstOpts _teOpts = do let managerSettings = mkManagerSettings (Network.Connection.TLSSettingsSimple True False False) Nothing _teMgr :: Manager <- newManager managerSettings let _teBrig = endpointToReq (cfgBrig _teTstOpts) + _teCargohold = endpointToReq (cfgCargohold _teTstOpts) _teTLSSettings <- mkTLSSettingsOrThrow (optSettings _teOpts) pure TestEnv {..} diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index 2d762d9fa26..680261a3317 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: a1c3b8a4df30c11f5be17b3ba16e33ebb8a41438a7cec720761222a90f271f4e +-- hash: 7b6d6110c4a94aa87c7d65d1e004acb6cbc1ce6775be39cde27ff7e5eca83f59 name: galley version: 0.83.0 @@ -436,6 +436,8 @@ executable galley-schema V52_FeatureConferenceCalling V53_AddRemoteConvStatus V54_TeamFeatureSelfDeletingMessages + V55_SelfDeletingMessagesLockStatus + V56_GuestLinksTeamFeatureStatus Paths_galley hs-source-dirs: schema/src diff --git a/services/galley/schema/src/Main.hs b/services/galley/schema/src/Main.hs index 369a4644368..63cda90e089 100644 --- a/services/galley/schema/src/Main.hs +++ b/services/galley/schema/src/Main.hs @@ -57,6 +57,8 @@ import qualified V51_FeatureFileSharing import qualified V52_FeatureConferenceCalling import qualified V53_AddRemoteConvStatus import qualified V54_TeamFeatureSelfDeletingMessages +import qualified V55_SelfDeletingMessagesLockStatus +import qualified V56_GuestLinksTeamFeatureStatus main :: IO () main = do @@ -99,9 +101,11 @@ main = do V51_FeatureFileSharing.migration, V52_FeatureConferenceCalling.migration, V53_AddRemoteConvStatus.migration, - V54_TeamFeatureSelfDeletingMessages.migration + V54_TeamFeatureSelfDeletingMessages.migration, + V55_SelfDeletingMessagesLockStatus.migration, + V56_GuestLinksTeamFeatureStatus.migration -- When adding migrations here, don't forget to update - -- 'schemaVersion' in Galley.Data + -- 'schemaVersion' in Galley.Cassandra -- (see also docs/developer/cassandra-interaction.md) -- -- FUTUREWORK: once #1726 has made its way to master/production, diff --git a/services/galley/schema/src/V55_SelfDeletingMessagesLockStatus.hs b/services/galley/schema/src/V55_SelfDeletingMessagesLockStatus.hs new file mode 100644 index 00000000000..58e61690693 --- /dev/null +++ b/services/galley/schema/src/V55_SelfDeletingMessagesLockStatus.hs @@ -0,0 +1,33 @@ +-- 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 V55_SelfDeletingMessagesLockStatus + ( migration, + ) +where + +import Cassandra.Schema +import Imports +import Text.RawString.QQ + +migration :: Migration +migration = Migration 55 "Add payment status config for self deleting messages team feature" $ do + schema' + [r| ALTER TABLE team_features ADD ( + self_deleting_messages_lock_status int + ) + |] diff --git a/services/galley/schema/src/V56_GuestLinksTeamFeatureStatus.hs b/services/galley/schema/src/V56_GuestLinksTeamFeatureStatus.hs new file mode 100644 index 00000000000..e9ec3264628 --- /dev/null +++ b/services/galley/schema/src/V56_GuestLinksTeamFeatureStatus.hs @@ -0,0 +1,33 @@ +-- 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 V56_GuestLinksTeamFeatureStatus + ( migration, + ) +where + +import Cassandra.Schema +import Imports +import Text.RawString.QQ + +migration :: Migration +migration = Migration 56 "team feature status for guest links" $ do + schema' + [r| ALTER TABLE team_features ADD ( + guest_links_status int + ) + |] diff --git a/services/galley/src/Galley/API/Action.hs b/services/galley/src/Galley/API/Action.hs index 92f0f94831d..7a13e8396e1 100644 --- a/services/galley/src/Galley/API/Action.hs +++ b/services/galley/src/Galley/API/Action.hs @@ -37,10 +37,12 @@ module Galley.API.Action where import qualified Brig.Types.User as User +import Control.Arrow import Control.Lens import Data.Id import Data.Kind import Data.List.NonEmpty (NonEmpty, nonEmpty) +import qualified Data.Map as Map import Data.Misc import Data.Qualified import qualified Data.Set as Set @@ -165,8 +167,6 @@ instance IsConversationAction ConversationJoin where addMembersToLocalConversation lcnv newMembers role where - userIsMember u = (^. userId . to (== u)) - checkLocals :: Members '[ BrigAccess, @@ -181,8 +181,10 @@ instance IsConversationAction ConversationJoin where [UserId] -> Sem r () checkLocals lusr (Just tid) newUsers = do - tms <- E.selectTeamMembers tid newUsers - let userMembershipMap = map (\u -> (u, find (userIsMember u) tms)) newUsers + tms <- + Map.fromList . map (view userId &&& id) + <$> E.selectTeamMembers tid newUsers + let userMembershipMap = map (id &&& flip Map.lookup tms) newUsers ensureAccessRole (convAccessRole conv) userMembershipMap ensureConnectedOrSameTeam lusr newUsers checkLocals lusr Nothing newUsers = do diff --git a/services/galley/src/Galley/API/Error.hs b/services/galley/src/Galley/API/Error.hs index fb3a448d1b0..a4569e788c9 100644 --- a/services/galley/src/Galley/API/Error.hs +++ b/services/galley/src/Galley/API/Error.hs @@ -160,12 +160,14 @@ data TeamFeatureError | LegalHoldFeatureFlagNotEnabled | LegalHoldWhitelistedOnly | DisableSsoNotImplemented + | FeatureLocked instance APIError TeamFeatureError where toWai AppLockinactivityTimeoutTooLow = inactivityTimeoutTooLow toWai LegalHoldFeatureFlagNotEnabled = legalHoldFeatureFlagNotEnabled toWai LegalHoldWhitelistedOnly = legalHoldWhitelistedOnly toWai DisableSsoNotImplemented = disableSsoNotImplemented + toWai FeatureLocked = setTeamFeatureConfigFeatureLocked data TeamNotificationError = InvalidTeamNotificationId @@ -457,6 +459,9 @@ noLegalHoldDeviceAllocated = mkError status404 "legalhold-no-device-allocated" " legalHoldCouldNotBlockConnections :: Error legalHoldCouldNotBlockConnections = mkError status500 "legalhold-internal" "legal hold service: could not block connections when resolving policy conflicts." +setTeamFeatureConfigFeatureLocked :: Error +setTeamFeatureConfigFeatureLocked = mkError status409 "feature-locked" "feature config cannot be updated (eg., because it is configured to be locked, or because you need to upgrade your plan)" + disableSsoNotImplemented :: Error disableSsoNotImplemented = mkError diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index 357bd971b75..ff2b743f92f 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -52,6 +52,7 @@ import Galley.API.Util import Galley.App import Galley.Cassandra.Paging import qualified Galley.Data.Conversation as Data +import Galley.Data.TeamFeatures (MaybeHasLockStatusCol) import Galley.Effects import Galley.Effects.ClientStore import Galley.Effects.ConversationStore @@ -121,79 +122,82 @@ data InternalApi routes = InternalApi -- Viewing the config for features should be allowed for any admin. iTeamFeatureStatusSSOGet :: routes - :- IFeatureStatusGet 'Public.TeamFeatureSSO, + :- IFeatureStatusGet 'Public.WithoutLockStatus 'Public.TeamFeatureSSO, iTeamFeatureStatusSSOPut :: routes :- IFeatureStatusPut 'Public.TeamFeatureSSO, iTeamFeatureStatusLegalHoldGet :: routes - :- IFeatureStatusGet 'Public.TeamFeatureLegalHold, + :- IFeatureStatusGet 'Public.WithoutLockStatus 'Public.TeamFeatureLegalHold, iTeamFeatureStatusLegalHoldPut :: routes :- IFeatureStatusPut 'Public.TeamFeatureLegalHold, iTeamFeatureStatusSearchVisibilityGet :: routes - :- IFeatureStatusGet 'Public.TeamFeatureSearchVisibility, + :- IFeatureStatusGet 'Public.WithoutLockStatus 'Public.TeamFeatureSearchVisibility, iTeamFeatureStatusSearchVisibilityPut :: routes :- IFeatureStatusPut 'Public.TeamFeatureSearchVisibility, iTeamFeatureStatusSearchVisibilityDeprecatedGet :: routes - :- IFeatureStatusDeprecatedGet 'Public.TeamFeatureSearchVisibility, + :- IFeatureStatusDeprecatedGet 'Public.WithoutLockStatus 'Public.TeamFeatureSearchVisibility, iTeamFeatureStatusSearchVisibilityDeprecatedPut :: routes :- IFeatureStatusDeprecatedPut 'Public.TeamFeatureSearchVisibility, iTeamFeatureStatusValidateSAMLEmailsGet :: routes - :- IFeatureStatusGet 'Public.TeamFeatureValidateSAMLEmails, + :- IFeatureStatusGet 'Public.WithoutLockStatus 'Public.TeamFeatureValidateSAMLEmails, iTeamFeatureStatusValidateSAMLEmailsPut :: routes :- IFeatureStatusPut 'Public.TeamFeatureValidateSAMLEmails, iTeamFeatureStatusValidateSAMLEmailsDeprecatedGet :: routes - :- IFeatureStatusDeprecatedGet 'Public.TeamFeatureValidateSAMLEmails, + :- IFeatureStatusDeprecatedGet 'Public.WithoutLockStatus 'Public.TeamFeatureValidateSAMLEmails, iTeamFeatureStatusValidateSAMLEmailsDeprecatedPut :: routes :- IFeatureStatusDeprecatedPut 'Public.TeamFeatureValidateSAMLEmails, iTeamFeatureStatusDigitalSignaturesGet :: routes - :- IFeatureStatusGet 'Public.TeamFeatureDigitalSignatures, + :- IFeatureStatusGet 'Public.WithoutLockStatus 'Public.TeamFeatureDigitalSignatures, iTeamFeatureStatusDigitalSignaturesPut :: routes :- IFeatureStatusPut 'Public.TeamFeatureDigitalSignatures, iTeamFeatureStatusDigitalSignaturesDeprecatedGet :: routes - :- IFeatureStatusDeprecatedGet 'Public.TeamFeatureDigitalSignatures, + :- IFeatureStatusDeprecatedGet 'Public.WithoutLockStatus 'Public.TeamFeatureDigitalSignatures, iTeamFeatureStatusDigitalSignaturesDeprecatedPut :: routes :- IFeatureStatusDeprecatedPut 'Public.TeamFeatureDigitalSignatures, iTeamFeatureStatusAppLockGet :: routes - :- IFeatureStatusGet 'Public.TeamFeatureAppLock, + :- IFeatureStatusGet 'Public.WithoutLockStatus 'Public.TeamFeatureAppLock, iTeamFeatureStatusAppLockPut :: routes :- IFeatureStatusPut 'Public.TeamFeatureAppLock, iTeamFeatureStatusFileSharingGet :: routes - :- IFeatureStatusGet 'Public.TeamFeatureFileSharing, + :- IFeatureStatusGet 'Public.WithoutLockStatus 'Public.TeamFeatureFileSharing, iTeamFeatureStatusFileSharingPut :: routes :- IFeatureStatusPut 'Public.TeamFeatureFileSharing, iTeamFeatureStatusClassifiedDomainsGet :: routes - :- IFeatureStatusGet 'Public.TeamFeatureClassifiedDomains, + :- IFeatureStatusGet 'Public.WithoutLockStatus 'Public.TeamFeatureClassifiedDomains, iTeamFeatureStatusConferenceCallingPut :: routes :- IFeatureStatusPut 'Public.TeamFeatureConferenceCalling, iTeamFeatureStatusConferenceCallingGet :: routes - :- IFeatureStatusGet 'Public.TeamFeatureConferenceCalling, + :- IFeatureStatusGet 'Public.WithoutLockStatus 'Public.TeamFeatureConferenceCalling, iTeamFeatureStatusSelfDeletingMessagesPut :: routes :- IFeatureStatusPut 'Public.TeamFeatureSelfDeletingMessages, iTeamFeatureStatusSelfDeletingMessagesGet :: routes - :- IFeatureStatusGet 'Public.TeamFeatureSelfDeletingMessages, + :- IFeatureStatusGet 'Public.WithLockStatus 'Public.TeamFeatureSelfDeletingMessages, + iTeamFeatureLockStatusSelfDeletingMessagesPut :: + routes + :- IFeatureStatusLockStatusPut 'Public.TeamFeatureSelfDeletingMessages, -- This endpoint can lead to the following events being sent: -- - MemberLeave event to members for all conversations the user was in iDeleteUser :: @@ -232,14 +236,14 @@ data InternalApi routes = InternalApi type ServantAPI = ToServantApi InternalApi -type IFeatureStatusGet featureName = +type IFeatureStatusGet lockStatus featureName = Summary (AppendSymbol "Get config for " (Public.KnownTeamFeatureNameSymbol featureName)) :> "i" :> "teams" :> Capture "tid" TeamId :> "features" :> Public.KnownTeamFeatureNameSymbol featureName - :> Get '[Servant.JSON] (Public.TeamFeatureStatus featureName) + :> Get '[Servant.JSON] (Public.TeamFeatureStatus lockStatus featureName) type IFeatureStatusPut featureName = Summary (AppendSymbol "Put config for " (Public.KnownTeamFeatureNameSymbol featureName)) @@ -248,18 +252,28 @@ type IFeatureStatusPut featureName = :> Capture "tid" TeamId :> "features" :> Public.KnownTeamFeatureNameSymbol featureName - :> ReqBody '[Servant.JSON] (Public.TeamFeatureStatus featureName) - :> Put '[Servant.JSON] (Public.TeamFeatureStatus featureName) + :> ReqBody '[Servant.JSON] (Public.TeamFeatureStatus 'Public.WithoutLockStatus featureName) + :> Put '[Servant.JSON] (Public.TeamFeatureStatus 'Public.WithoutLockStatus featureName) + +type IFeatureStatusLockStatusPut featureName = + Summary (AppendSymbol "(Un-)lock " (Public.KnownTeamFeatureNameSymbol featureName)) + :> "i" + :> "teams" + :> Capture "tid" TeamId + :> "features" + :> Public.KnownTeamFeatureNameSymbol featureName + :> Capture "lockStatus" Public.LockStatusValue + :> Put '[Servant.JSON] Public.LockStatus -- | A type for a GET endpoint for a feature with a deprecated path -type IFeatureStatusDeprecatedGet featureName = +type IFeatureStatusDeprecatedGet lockStatus featureName = Summary (AppendSymbol "[deprecated] Get config for " (Public.KnownTeamFeatureNameSymbol featureName)) :> "i" :> "teams" :> Capture "tid" TeamId :> "features" :> Public.DeprecatedFeatureName featureName - :> Get '[Servant.JSON] (Public.TeamFeatureStatus featureName) + :> Get '[Servant.JSON] (Public.TeamFeatureStatus lockStatus featureName) -- | A type for a PUT endpoint for a feature with a deprecated path type IFeatureStatusDeprecatedPut featureName = @@ -269,8 +283,8 @@ type IFeatureStatusDeprecatedPut featureName = :> Capture "tid" TeamId :> "features" :> Public.DeprecatedFeatureName featureName - :> ReqBody '[Servant.JSON] (Public.TeamFeatureStatus featureName) - :> Put '[Servant.JSON] (Public.TeamFeatureStatus featureName) + :> ReqBody '[Servant.JSON] (Public.TeamFeatureStatus 'Public.WithoutLockStatus featureName) + :> Put '[Servant.JSON] (Public.TeamFeatureStatus 'Public.WithoutLockStatus featureName) servantSitemap :: ServerT ServantAPI (Sem GalleyEffects) servantSitemap = @@ -278,38 +292,39 @@ servantSitemap = InternalApi { iStatusGet = pure NoContent, iStatusHead = pure NoContent, - iTeamFeatureStatusSSOGet = iGetTeamFeature @'Public.TeamFeatureSSO Features.getSSOStatusInternal, + iTeamFeatureStatusSSOGet = iGetTeamFeature @'Public.WithoutLockStatus @'Public.TeamFeatureSSO Features.getSSOStatusInternal, iTeamFeatureStatusSSOPut = iPutTeamFeature @'Public.TeamFeatureSSO Features.setSSOStatusInternal, - iTeamFeatureStatusLegalHoldGet = iGetTeamFeature @'Public.TeamFeatureLegalHold Features.getLegalholdStatusInternal, + iTeamFeatureStatusLegalHoldGet = iGetTeamFeature @'Public.WithoutLockStatus @'Public.TeamFeatureLegalHold Features.getLegalholdStatusInternal, iTeamFeatureStatusLegalHoldPut = iPutTeamFeature @'Public.TeamFeatureLegalHold (Features.setLegalholdStatusInternal @InternalPaging), - iTeamFeatureStatusSearchVisibilityGet = iGetTeamFeature @'Public.TeamFeatureSearchVisibility Features.getTeamSearchVisibilityAvailableInternal, + iTeamFeatureStatusSearchVisibilityGet = iGetTeamFeature @'Public.WithoutLockStatus @'Public.TeamFeatureSearchVisibility Features.getTeamSearchVisibilityAvailableInternal, iTeamFeatureStatusSearchVisibilityPut = iPutTeamFeature @'Public.TeamFeatureLegalHold Features.setTeamSearchVisibilityAvailableInternal, - iTeamFeatureStatusSearchVisibilityDeprecatedGet = iGetTeamFeature @'Public.TeamFeatureSearchVisibility Features.getTeamSearchVisibilityAvailableInternal, + iTeamFeatureStatusSearchVisibilityDeprecatedGet = iGetTeamFeature @'Public.WithoutLockStatus @'Public.TeamFeatureSearchVisibility Features.getTeamSearchVisibilityAvailableInternal, iTeamFeatureStatusSearchVisibilityDeprecatedPut = iPutTeamFeature @'Public.TeamFeatureLegalHold Features.setTeamSearchVisibilityAvailableInternal, - iTeamFeatureStatusValidateSAMLEmailsGet = iGetTeamFeature @'Public.TeamFeatureValidateSAMLEmails Features.getValidateSAMLEmailsInternal, + iTeamFeatureStatusValidateSAMLEmailsGet = iGetTeamFeature @'Public.WithoutLockStatus @'Public.TeamFeatureValidateSAMLEmails Features.getValidateSAMLEmailsInternal, iTeamFeatureStatusValidateSAMLEmailsPut = iPutTeamFeature @'Public.TeamFeatureValidateSAMLEmails Features.setValidateSAMLEmailsInternal, - iTeamFeatureStatusValidateSAMLEmailsDeprecatedGet = iGetTeamFeature @'Public.TeamFeatureValidateSAMLEmails Features.getValidateSAMLEmailsInternal, + iTeamFeatureStatusValidateSAMLEmailsDeprecatedGet = iGetTeamFeature @'Public.WithoutLockStatus @'Public.TeamFeatureValidateSAMLEmails Features.getValidateSAMLEmailsInternal, iTeamFeatureStatusValidateSAMLEmailsDeprecatedPut = iPutTeamFeature @'Public.TeamFeatureValidateSAMLEmails Features.setValidateSAMLEmailsInternal, - iTeamFeatureStatusDigitalSignaturesGet = iGetTeamFeature @'Public.TeamFeatureDigitalSignatures Features.getDigitalSignaturesInternal, + iTeamFeatureStatusDigitalSignaturesGet = iGetTeamFeature @'Public.WithoutLockStatus @'Public.TeamFeatureDigitalSignatures Features.getDigitalSignaturesInternal, iTeamFeatureStatusDigitalSignaturesPut = iPutTeamFeature @'Public.TeamFeatureDigitalSignatures Features.setDigitalSignaturesInternal, - iTeamFeatureStatusDigitalSignaturesDeprecatedGet = iGetTeamFeature @'Public.TeamFeatureDigitalSignatures Features.getDigitalSignaturesInternal, + iTeamFeatureStatusDigitalSignaturesDeprecatedGet = iGetTeamFeature @'Public.WithoutLockStatus @'Public.TeamFeatureDigitalSignatures Features.getDigitalSignaturesInternal, iTeamFeatureStatusDigitalSignaturesDeprecatedPut = iPutTeamFeature @'Public.TeamFeatureDigitalSignatures Features.setDigitalSignaturesInternal, - iTeamFeatureStatusAppLockGet = iGetTeamFeature @'Public.TeamFeatureAppLock Features.getAppLockInternal, + iTeamFeatureStatusAppLockGet = iGetTeamFeature @'Public.WithoutLockStatus @'Public.TeamFeatureAppLock Features.getAppLockInternal, iTeamFeatureStatusAppLockPut = iPutTeamFeature @'Public.TeamFeatureAppLock Features.setAppLockInternal, - iTeamFeatureStatusFileSharingGet = iGetTeamFeature @'Public.TeamFeatureFileSharing Features.getFileSharingInternal, + iTeamFeatureStatusFileSharingGet = iGetTeamFeature @'Public.WithoutLockStatus @'Public.TeamFeatureFileSharing Features.getFileSharingInternal, iTeamFeatureStatusFileSharingPut = iPutTeamFeature @'Public.TeamFeatureFileSharing Features.setFileSharingInternal, - iTeamFeatureStatusClassifiedDomainsGet = iGetTeamFeature @'Public.TeamFeatureClassifiedDomains Features.getClassifiedDomainsInternal, + iTeamFeatureStatusClassifiedDomainsGet = iGetTeamFeature @'Public.WithoutLockStatus @'Public.TeamFeatureClassifiedDomains Features.getClassifiedDomainsInternal, iTeamFeatureStatusConferenceCallingPut = iPutTeamFeature @'Public.TeamFeatureConferenceCalling Features.setConferenceCallingInternal, - iTeamFeatureStatusConferenceCallingGet = iGetTeamFeature @'Public.TeamFeatureConferenceCalling Features.getConferenceCallingInternal, + iTeamFeatureStatusConferenceCallingGet = iGetTeamFeature @'Public.WithoutLockStatus @'Public.TeamFeatureConferenceCalling Features.getConferenceCallingInternal, iTeamFeatureStatusSelfDeletingMessagesPut = iPutTeamFeature @'Public.TeamFeatureSelfDeletingMessages Features.setSelfDeletingMessagesInternal, - iTeamFeatureStatusSelfDeletingMessagesGet = iGetTeamFeature @'Public.TeamFeatureSelfDeletingMessages Features.getSelfDeletingMessagesInternal, + iTeamFeatureStatusSelfDeletingMessagesGet = iGetTeamFeature @'Public.WithLockStatus @'Public.TeamFeatureSelfDeletingMessages Features.getSelfDeletingMessagesInternal, + iTeamFeatureLockStatusSelfDeletingMessagesPut = Features.setLockStatus @'Public.TeamFeatureSelfDeletingMessages, iDeleteUser = rmUser, iConnect = Create.createConnectConversation, iUpsertOne2OneConversation = One2One.iUpsertOne2OneConversation } iGetTeamFeature :: - forall a r. + forall ps a r. ( Public.KnownTeamFeatureName a, Members '[ Error ActionError, @@ -319,26 +334,29 @@ iGetTeamFeature :: ] r ) => - (Features.GetFeatureInternalParam -> Sem r (Public.TeamFeatureStatus a)) -> + (Features.GetFeatureInternalParam -> Sem r (Public.TeamFeatureStatus ps a)) -> TeamId -> - Sem r (Public.TeamFeatureStatus a) -iGetTeamFeature getter = Features.getFeatureStatus @a getter DontDoAuth + Sem r (Public.TeamFeatureStatus ps a) +iGetTeamFeature getter = Features.getFeatureStatus @ps @a getter DontDoAuth iPutTeamFeature :: forall a r. ( Public.KnownTeamFeatureName a, + MaybeHasLockStatusCol a, Members '[ Error ActionError, Error NotATeamMember, Error TeamError, - TeamStore + Error TeamFeatureError, + TeamStore, + TeamFeatureStore ] r ) => - (TeamId -> Public.TeamFeatureStatus a -> Sem r (Public.TeamFeatureStatus a)) -> + (TeamId -> Public.TeamFeatureStatus 'Public.WithoutLockStatus a -> Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus a)) -> TeamId -> - Public.TeamFeatureStatus a -> - Sem r (Public.TeamFeatureStatus a) + Public.TeamFeatureStatus 'Public.WithoutLockStatus a -> + Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus a) iPutTeamFeature setter = Features.setFeatureStatus @a setter DontDoAuth sitemap :: Routes a (Sem GalleyEffects) () @@ -581,7 +599,7 @@ rmUser lusr conn = do for_ (maybeList1 (catMaybes pp)) - (push) + push -- FUTUREWORK: This could be optimized to reduce the number of RPCs -- made. When a team is deleted the burst of RPCs created here could diff --git a/services/galley/src/Galley/API/Public.hs b/services/galley/src/Galley/API/Public.hs index 3027ba070ab..31d41ae0531 100644 --- a/services/galley/src/Galley/API/Public.hs +++ b/services/galley/src/Galley/API/Public.hs @@ -117,70 +117,77 @@ servantSitemap = GalleyAPI.postOtrMessageUnqualified = Update.postOtrMessageUnqualified, GalleyAPI.postProteusMessage = Update.postProteusMessage, GalleyAPI.teamFeatureStatusSSOGet = - getFeatureStatus @'Public.TeamFeatureSSO Features.getSSOStatusInternal + getFeatureStatus @'Public.WithoutLockStatus @'Public.TeamFeatureSSO Features.getSSOStatusInternal . DoAuth, GalleyAPI.teamFeatureStatusLegalHoldGet = - getFeatureStatus @'Public.TeamFeatureLegalHold Features.getLegalholdStatusInternal + getFeatureStatus @'Public.WithoutLockStatus @'Public.TeamFeatureLegalHold Features.getLegalholdStatusInternal . DoAuth, GalleyAPI.teamFeatureStatusLegalHoldPut = setFeatureStatus @'Public.TeamFeatureLegalHold (Features.setLegalholdStatusInternal @InternalPaging) . DoAuth, GalleyAPI.teamFeatureStatusSearchVisibilityGet = - getFeatureStatus @'Public.TeamFeatureSearchVisibility Features.getTeamSearchVisibilityAvailableInternal + getFeatureStatus @'Public.WithoutLockStatus @'Public.TeamFeatureSearchVisibility Features.getTeamSearchVisibilityAvailableInternal . DoAuth, GalleyAPI.teamFeatureStatusSearchVisibilityPut = setFeatureStatus @'Public.TeamFeatureSearchVisibility Features.setTeamSearchVisibilityAvailableInternal . DoAuth, GalleyAPI.teamFeatureStatusSearchVisibilityDeprecatedGet = - getFeatureStatus @'Public.TeamFeatureSearchVisibility Features.getTeamSearchVisibilityAvailableInternal + getFeatureStatus @'Public.WithoutLockStatus @'Public.TeamFeatureSearchVisibility Features.getTeamSearchVisibilityAvailableInternal . DoAuth, GalleyAPI.teamFeatureStatusSearchVisibilityDeprecatedPut = setFeatureStatus @'Public.TeamFeatureSearchVisibility Features.setTeamSearchVisibilityAvailableInternal . DoAuth, GalleyAPI.teamFeatureStatusValidateSAMLEmailsGet = - getFeatureStatus @'Public.TeamFeatureValidateSAMLEmails Features.getValidateSAMLEmailsInternal + getFeatureStatus @'Public.WithoutLockStatus @'Public.TeamFeatureValidateSAMLEmails Features.getValidateSAMLEmailsInternal . DoAuth, GalleyAPI.teamFeatureStatusValidateSAMLEmailsDeprecatedGet = - getFeatureStatus @'Public.TeamFeatureValidateSAMLEmails Features.getValidateSAMLEmailsInternal + getFeatureStatus @'Public.WithoutLockStatus @'Public.TeamFeatureValidateSAMLEmails Features.getValidateSAMLEmailsInternal . DoAuth, GalleyAPI.teamFeatureStatusDigitalSignaturesGet = - getFeatureStatus @'Public.TeamFeatureDigitalSignatures Features.getDigitalSignaturesInternal + getFeatureStatus @'Public.WithoutLockStatus @'Public.TeamFeatureDigitalSignatures Features.getDigitalSignaturesInternal . DoAuth, GalleyAPI.teamFeatureStatusDigitalSignaturesDeprecatedGet = - getFeatureStatus @'Public.TeamFeatureDigitalSignatures Features.getDigitalSignaturesInternal + getFeatureStatus @'Public.WithoutLockStatus @'Public.TeamFeatureDigitalSignatures Features.getDigitalSignaturesInternal . DoAuth, GalleyAPI.teamFeatureStatusAppLockGet = - getFeatureStatus @'Public.TeamFeatureAppLock Features.getAppLockInternal + getFeatureStatus @'Public.WithoutLockStatus @'Public.TeamFeatureAppLock Features.getAppLockInternal . DoAuth, GalleyAPI.teamFeatureStatusAppLockPut = setFeatureStatus @'Public.TeamFeatureAppLock Features.setAppLockInternal . DoAuth, GalleyAPI.teamFeatureStatusFileSharingGet = - getFeatureStatus @'Public.TeamFeatureFileSharing Features.getFileSharingInternal . DoAuth, + getFeatureStatus @'Public.WithoutLockStatus @'Public.TeamFeatureFileSharing Features.getFileSharingInternal . DoAuth, GalleyAPI.teamFeatureStatusFileSharingPut = setFeatureStatus @'Public.TeamFeatureFileSharing Features.setFileSharingInternal . DoAuth, GalleyAPI.teamFeatureStatusClassifiedDomainsGet = - getFeatureStatus @'Public.TeamFeatureClassifiedDomains Features.getClassifiedDomainsInternal + getFeatureStatus @'Public.WithoutLockStatus @'Public.TeamFeatureClassifiedDomains Features.getClassifiedDomainsInternal . DoAuth, GalleyAPI.teamFeatureStatusConferenceCallingGet = - getFeatureStatus @'Public.TeamFeatureConferenceCalling Features.getConferenceCallingInternal + getFeatureStatus @'Public.WithoutLockStatus @'Public.TeamFeatureConferenceCalling Features.getConferenceCallingInternal . DoAuth, GalleyAPI.teamFeatureStatusSelfDeletingMessagesGet = - getFeatureStatus @'Public.TeamFeatureSelfDeletingMessages Features.getSelfDeletingMessagesInternal + getFeatureStatus @'Public.WithLockStatus @'Public.TeamFeatureSelfDeletingMessages Features.getSelfDeletingMessagesInternal . DoAuth, GalleyAPI.teamFeatureStatusSelfDeletingMessagesPut = setFeatureStatus @'Public.TeamFeatureSelfDeletingMessages Features.setSelfDeletingMessagesInternal . DoAuth, + GalleyAPI.featureStatusGuestLinksGet = + Features.getFeatureStatus @'Public.WithLockStatus @'Public.TeamFeatureGuestLinks Features.getGuestLinkInternal + . DoAuth, + GalleyAPI.featureStatusGuestLinksPut = + Features.setFeatureStatus @'Public.TeamFeatureGuestLinks Features.setGuestLinkInternal + . DoAuth, GalleyAPI.featureAllFeatureConfigsGet = Features.getAllFeatureConfigs, - GalleyAPI.featureConfigLegalHoldGet = Features.getFeatureConfig @'Public.TeamFeatureLegalHold Features.getLegalholdStatusInternal, - GalleyAPI.featureConfigSSOGet = Features.getFeatureConfig @'Public.TeamFeatureSSO Features.getSSOStatusInternal, - GalleyAPI.featureConfigSearchVisibilityGet = Features.getFeatureConfig @'Public.TeamFeatureSearchVisibility Features.getTeamSearchVisibilityAvailableInternal, - GalleyAPI.featureConfigValidateSAMLEmailsGet = Features.getFeatureConfig @'Public.TeamFeatureValidateSAMLEmails Features.getValidateSAMLEmailsInternal, - GalleyAPI.featureConfigDigitalSignaturesGet = Features.getFeatureConfig @'Public.TeamFeatureDigitalSignatures Features.getDigitalSignaturesInternal, - GalleyAPI.featureConfigAppLockGet = Features.getFeatureConfig @'Public.TeamFeatureAppLock Features.getAppLockInternal, - GalleyAPI.featureConfigFileSharingGet = Features.getFeatureConfig @'Public.TeamFeatureFileSharing Features.getFileSharingInternal, - GalleyAPI.featureConfigClassifiedDomainsGet = Features.getFeatureConfig @'Public.TeamFeatureClassifiedDomains Features.getClassifiedDomainsInternal, - GalleyAPI.featureConfigConferenceCallingGet = Features.getFeatureConfig @'Public.TeamFeatureConferenceCalling Features.getConferenceCallingInternal, - GalleyAPI.featureConfigSelfDeletingMessagesGet = Features.getFeatureConfig @'Public.TeamFeatureSelfDeletingMessages Features.getSelfDeletingMessagesInternal + GalleyAPI.featureConfigLegalHoldGet = Features.getFeatureConfig @'Public.WithoutLockStatus @'Public.TeamFeatureLegalHold Features.getLegalholdStatusInternal, + GalleyAPI.featureConfigSSOGet = Features.getFeatureConfig @'Public.WithoutLockStatus @'Public.TeamFeatureSSO Features.getSSOStatusInternal, + GalleyAPI.featureConfigSearchVisibilityGet = Features.getFeatureConfig @'Public.WithoutLockStatus @'Public.TeamFeatureSearchVisibility Features.getTeamSearchVisibilityAvailableInternal, + GalleyAPI.featureConfigValidateSAMLEmailsGet = Features.getFeatureConfig @'Public.WithoutLockStatus @'Public.TeamFeatureValidateSAMLEmails Features.getValidateSAMLEmailsInternal, + GalleyAPI.featureConfigDigitalSignaturesGet = Features.getFeatureConfig @'Public.WithoutLockStatus @'Public.TeamFeatureDigitalSignatures Features.getDigitalSignaturesInternal, + GalleyAPI.featureConfigAppLockGet = Features.getFeatureConfig @'Public.WithoutLockStatus @'Public.TeamFeatureAppLock Features.getAppLockInternal, + GalleyAPI.featureConfigFileSharingGet = Features.getFeatureConfig @'Public.WithoutLockStatus @'Public.TeamFeatureFileSharing Features.getFileSharingInternal, + GalleyAPI.featureConfigClassifiedDomainsGet = Features.getFeatureConfig @'Public.WithoutLockStatus @'Public.TeamFeatureClassifiedDomains Features.getClassifiedDomainsInternal, + GalleyAPI.featureConfigConferenceCallingGet = Features.getFeatureConfig @'Public.WithoutLockStatus @'Public.TeamFeatureConferenceCalling Features.getConferenceCallingInternal, + GalleyAPI.featureConfigSelfDeletingMessagesGet = Features.getFeatureConfig @'Public.WithLockStatus @'Public.TeamFeatureSelfDeletingMessages Features.getSelfDeletingMessagesInternal, + GalleyAPI.featureConfigGuestLinksGet = Features.getFeatureConfig @'Public.WithLockStatus @'Public.TeamFeatureGuestLinks Features.getGuestLinkInternal } sitemap :: Routes ApiBuilder (Sem GalleyEffects) () diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index 6c4d104240a..9d46c2fcd7a 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -1522,7 +1522,7 @@ canUserJoinTeam tid = do getTeamSearchVisibilityAvailableInternal :: Members '[Input Opts, TeamFeatureStore] r => TeamId -> - Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility) + Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureSearchVisibility) getTeamSearchVisibilityAvailableInternal tid = do -- TODO: This is just redundant given there is a decent default defConfig <- do diff --git a/services/galley/src/Galley/API/Teams/Features.hs b/services/galley/src/Galley/API/Teams/Features.hs index 3ac5bf52db0..63ef91cd19a 100644 --- a/services/galley/src/Galley/API/Teams/Features.hs +++ b/services/galley/src/Galley/API/Teams/Features.hs @@ -40,6 +40,9 @@ module Galley.API.Teams.Features setConferenceCallingInternal, getSelfDeletingMessagesInternal, setSelfDeletingMessagesInternal, + getGuestLinkInternal, + setGuestLinkInternal, + setLockStatus, DoAuth (..), GetFeatureInternalParam, ) @@ -90,7 +93,7 @@ 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) r. + forall (ps :: Public.IncludeLockStatus) (a :: Public.TeamFeatureName) r. ( Public.KnownTeamFeatureName a, Members '[ Error ActionError, @@ -100,10 +103,10 @@ getFeatureStatus :: ] r ) => - (GetFeatureInternalParam -> Sem r (Public.TeamFeatureStatus a)) -> + (GetFeatureInternalParam -> Sem r (Public.TeamFeatureStatus ps a)) -> DoAuth -> TeamId -> - Sem r (Public.TeamFeatureStatus a) + Sem r (Public.TeamFeatureStatus ps a) getFeatureStatus getter doauth tid = do case doauth of DoAuth uid -> do @@ -117,19 +120,21 @@ getFeatureStatus getter doauth tid = do setFeatureStatus :: forall (a :: Public.TeamFeatureName) r. ( Public.KnownTeamFeatureName a, + MaybeHasLockStatusCol a, Members '[ Error ActionError, Error TeamError, Error NotATeamMember, - TeamStore + TeamStore, + TeamFeatureStore ] r ) => - (TeamId -> Public.TeamFeatureStatus a -> Sem r (Public.TeamFeatureStatus a)) -> + (TeamId -> Public.TeamFeatureStatus 'Public.WithoutLockStatus a -> Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus a)) -> DoAuth -> TeamId -> - Public.TeamFeatureStatus a -> - Sem r (Public.TeamFeatureStatus a) + Public.TeamFeatureStatus 'Public.WithoutLockStatus a -> + Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus a) setFeatureStatus setter doauth tid status = do case doauth of DoAuth uid -> do @@ -139,9 +144,30 @@ setFeatureStatus setter doauth tid status = do assertTeamExists tid setter tid status +-- | Setting lock status can only be done through the internal API and therefore doesn't require auth. +setLockStatus :: + forall (a :: Public.TeamFeatureName) r. + ( Public.KnownTeamFeatureName a, + HasLockStatusCol a, + Members + [ Error ActionError, + Error TeamError, + Error NotATeamMember, + TeamStore, + TeamFeatureStore + ] + r + ) => + TeamId -> + Public.LockStatusValue -> + Sem r Public.LockStatus +setLockStatus tid lockStatusUpdate = do + assertTeamExists tid + TeamFeatures.setLockStatus @a tid (Public.LockStatus lockStatusUpdate) + -- | For individual users to get feature config for their account (personal or team). getFeatureConfig :: - forall (a :: Public.TeamFeatureName) r. + forall (ps :: Public.IncludeLockStatus) (a :: Public.TeamFeatureName) r. ( Public.KnownTeamFeatureName a, Members '[ Error ActionError, @@ -151,9 +177,9 @@ getFeatureConfig :: ] r ) => - (GetFeatureInternalParam -> Sem r (Public.TeamFeatureStatus a)) -> + (GetFeatureInternalParam -> Sem r (Public.TeamFeatureStatus ps a)) -> UserId -> - Sem r (Public.TeamFeatureStatus a) + Sem r (Public.TeamFeatureStatus ps a) getFeatureConfig getter zusr = do mbTeam <- getOneUserTeam zusr case mbTeam of @@ -180,34 +206,35 @@ getAllFeatureConfigs :: Sem r AllFeatureConfigs getAllFeatureConfigs zusr = do mbTeam <- getOneUserTeam zusr - zusrMembership <- maybe (pure Nothing) ((flip getTeamMember zusr)) mbTeam + zusrMembership <- maybe (pure Nothing) (flip getTeamMember zusr) mbTeam let getStatus :: - forall (a :: Public.TeamFeatureName) r. + forall (ps :: Public.IncludeLockStatus) (a :: Public.TeamFeatureName) r. ( Public.KnownTeamFeatureName a, - Aeson.ToJSON (Public.TeamFeatureStatus a), + Aeson.ToJSON (Public.TeamFeatureStatus ps a), Members '[Error ActionError, Error TeamError, Error NotATeamMember, TeamStore] r ) => - (GetFeatureInternalParam -> Sem r (Public.TeamFeatureStatus a)) -> + (GetFeatureInternalParam -> Sem r (Public.TeamFeatureStatus ps a)) -> Sem r (Text, Aeson.Value) getStatus getter = do when (isJust mbTeam) $ do void $ permissionCheck (ViewTeamFeature (Public.knownTeamFeatureName @a)) zusrMembership status <- getter (maybe (Left (Just zusr)) Right mbTeam) let feature = Public.knownTeamFeatureName @a - pure $ (cs (toByteString' feature) Aeson..= status) + pure $ cs (toByteString' feature) Aeson..= status AllFeatureConfigs . HashMap.fromList <$> sequence - [ getStatus @'Public.TeamFeatureLegalHold getLegalholdStatusInternal, - getStatus @'Public.TeamFeatureSSO getSSOStatusInternal, - getStatus @'Public.TeamFeatureSearchVisibility getTeamSearchVisibilityAvailableInternal, - getStatus @'Public.TeamFeatureValidateSAMLEmails getValidateSAMLEmailsInternal, - getStatus @'Public.TeamFeatureDigitalSignatures getDigitalSignaturesInternal, - getStatus @'Public.TeamFeatureAppLock getAppLockInternal, - getStatus @'Public.TeamFeatureFileSharing getFileSharingInternal, - getStatus @'Public.TeamFeatureClassifiedDomains getClassifiedDomainsInternal, - getStatus @'Public.TeamFeatureConferenceCalling getConferenceCallingInternal, - getStatus @'Public.TeamFeatureSelfDeletingMessages getSelfDeletingMessagesInternal + [ getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureLegalHold getLegalholdStatusInternal, + getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureSSO getSSOStatusInternal, + getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureSearchVisibility getTeamSearchVisibilityAvailableInternal, + getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureValidateSAMLEmails getValidateSAMLEmailsInternal, + getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureDigitalSignatures getDigitalSignaturesInternal, + getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureAppLock getAppLockInternal, + getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureFileSharing getFileSharingInternal, + getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureClassifiedDomains getClassifiedDomainsInternal, + getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureConferenceCalling getConferenceCallingInternal, + getStatus @'Public.WithLockStatus @'Public.TeamFeatureSelfDeletingMessages getSelfDeletingMessagesInternal, + getStatus @'Public.WithLockStatus @'Public.TeamFeatureGuestLinks getGuestLinkInternal ] getAllFeaturesH :: @@ -246,39 +273,40 @@ getAllFeatures :: getAllFeatures uid tid = do Aeson.object <$> sequence - [ getStatus @'Public.TeamFeatureSSO getSSOStatusInternal, - getStatus @'Public.TeamFeatureLegalHold getLegalholdStatusInternal, - getStatus @'Public.TeamFeatureSearchVisibility getTeamSearchVisibilityAvailableInternal, - getStatus @'Public.TeamFeatureValidateSAMLEmails getValidateSAMLEmailsInternal, - getStatus @'Public.TeamFeatureDigitalSignatures getDigitalSignaturesInternal, - getStatus @'Public.TeamFeatureAppLock getAppLockInternal, - getStatus @'Public.TeamFeatureFileSharing getFileSharingInternal, - getStatus @'Public.TeamFeatureClassifiedDomains getClassifiedDomainsInternal, - getStatus @'Public.TeamFeatureConferenceCalling getConferenceCallingInternal, - getStatus @'Public.TeamFeatureSelfDeletingMessages getSelfDeletingMessagesInternal + [ getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureSSO getSSOStatusInternal, + getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureLegalHold getLegalholdStatusInternal, + getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureSearchVisibility getTeamSearchVisibilityAvailableInternal, + getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureValidateSAMLEmails getValidateSAMLEmailsInternal, + getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureDigitalSignatures getDigitalSignaturesInternal, + getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureAppLock getAppLockInternal, + getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureFileSharing getFileSharingInternal, + getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureClassifiedDomains getClassifiedDomainsInternal, + getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureConferenceCalling getConferenceCallingInternal, + getStatus @'Public.WithLockStatus @'Public.TeamFeatureSelfDeletingMessages getSelfDeletingMessagesInternal, + getStatus @'Public.WithLockStatus @'Public.TeamFeatureGuestLinks getGuestLinkInternal ] where getStatus :: - forall (a :: Public.TeamFeatureName). + forall (ps :: Public.IncludeLockStatus) (a :: Public.TeamFeatureName). ( Public.KnownTeamFeatureName a, - Aeson.ToJSON (Public.TeamFeatureStatus a) + Aeson.ToJSON (Public.TeamFeatureStatus ps a) ) => - (GetFeatureInternalParam -> Sem r (Public.TeamFeatureStatus a)) -> + (GetFeatureInternalParam -> Sem r (Public.TeamFeatureStatus ps a)) -> Sem r (Text, Aeson.Value) getStatus getter = do - status <- getFeatureStatus @a getter (DoAuth uid) tid + status <- getFeatureStatus @ps @a getter (DoAuth uid) tid let feature = Public.knownTeamFeatureName @a - pure $ (cs (toByteString' feature) Aeson..= status) + pure $ cs (toByteString' feature) Aeson..= status getFeatureStatusNoConfig :: forall (a :: Public.TeamFeatureName) r. - ( Public.FeatureHasNoConfig a, + ( Public.FeatureHasNoConfig 'Public.WithoutLockStatus a, HasStatusCol a, Member TeamFeatureStore r ) => Sem r Public.TeamFeatureStatusValue -> TeamId -> - Sem r (Public.TeamFeatureStatus a) + Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus a) getFeatureStatusNoConfig getDefault tid = do defaultStatus <- Public.TeamFeatureStatusNoConfig <$> getDefault fromMaybe defaultStatus <$> TeamFeatures.getFeatureStatusNoConfig @a tid @@ -286,14 +314,14 @@ getFeatureStatusNoConfig getDefault tid = do setFeatureStatusNoConfig :: forall (a :: Public.TeamFeatureName) r. ( Public.KnownTeamFeatureName a, - Public.FeatureHasNoConfig a, + Public.FeatureHasNoConfig 'Public.WithoutLockStatus a, HasStatusCol a, Members '[GundeckAccess, TeamFeatureStore, TeamStore, P.TinyLog] r ) => (Public.TeamFeatureStatusValue -> TeamId -> Sem r ()) -> TeamId -> - Public.TeamFeatureStatus a -> - Sem r (Public.TeamFeatureStatus a) + Public.TeamFeatureStatus 'Public.WithoutLockStatus a -> + Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus a) setFeatureStatusNoConfig applyState tid status = do applyState (Public.tfwoStatus status) tid newStatus <- TeamFeatures.setFeatureStatusNoConfig @a tid status @@ -308,7 +336,7 @@ type GetFeatureInternalParam = Either (Maybe UserId) TeamId getSSOStatusInternal :: Members '[Input Opts, TeamFeatureStore] r => GetFeatureInternalParam -> - Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureSSO) + Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureSSO) getSSOStatusInternal = either (const $ Public.TeamFeatureStatusNoConfig <$> getDef) @@ -323,8 +351,8 @@ getSSOStatusInternal = setSSOStatusInternal :: Members '[Error TeamFeatureError, GundeckAccess, TeamFeatureStore, TeamStore, P.TinyLog] r => TeamId -> - (Public.TeamFeatureStatus 'Public.TeamFeatureSSO) -> - Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureSSO) + Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureSSO -> + Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureSSO) setSSOStatusInternal = setFeatureStatusNoConfig @'Public.TeamFeatureSSO $ \case Public.TeamFeatureDisabled -> const (throw DisableSsoNotImplemented) Public.TeamFeatureEnabled -> const (pure ()) @@ -332,7 +360,7 @@ setSSOStatusInternal = setFeatureStatusNoConfig @'Public.TeamFeatureSSO $ \case getTeamSearchVisibilityAvailableInternal :: Members '[Input Opts, TeamFeatureStore] r => GetFeatureInternalParam -> - Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility) + Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureSearchVisibility) getTeamSearchVisibilityAvailableInternal = either (const $ Public.TeamFeatureStatusNoConfig <$> getDef) @@ -346,8 +374,8 @@ getTeamSearchVisibilityAvailableInternal = setTeamSearchVisibilityAvailableInternal :: Members '[GundeckAccess, SearchVisibilityStore, TeamFeatureStore, TeamStore, P.TinyLog] r => TeamId -> - (Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility) -> - Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility) + Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureSearchVisibility -> + Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureSearchVisibility) setTeamSearchVisibilityAvailableInternal = setFeatureStatusNoConfig @'Public.TeamFeatureSearchVisibility $ \case Public.TeamFeatureDisabled -> SearchVisibilityData.resetSearchVisibility Public.TeamFeatureEnabled -> const (pure ()) @@ -355,7 +383,7 @@ setTeamSearchVisibilityAvailableInternal = setFeatureStatusNoConfig @'Public.Tea getValidateSAMLEmailsInternal :: Member TeamFeatureStore r => GetFeatureInternalParam -> - Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureValidateSAMLEmails) + Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureValidateSAMLEmails) getValidateSAMLEmailsInternal = either (const $ Public.TeamFeatureStatusNoConfig <$> getDef) @@ -369,14 +397,14 @@ getValidateSAMLEmailsInternal = setValidateSAMLEmailsInternal :: Members '[GundeckAccess, TeamFeatureStore, TeamStore, P.TinyLog] r => TeamId -> - (Public.TeamFeatureStatus 'Public.TeamFeatureValidateSAMLEmails) -> - Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureValidateSAMLEmails) + Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureValidateSAMLEmails -> + Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureValidateSAMLEmails) setValidateSAMLEmailsInternal = setFeatureStatusNoConfig @'Public.TeamFeatureValidateSAMLEmails $ \_ _ -> pure () getDigitalSignaturesInternal :: Member TeamFeatureStore r => GetFeatureInternalParam -> - Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureDigitalSignatures) + Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureDigitalSignatures) getDigitalSignaturesInternal = either (const $ Public.TeamFeatureStatusNoConfig <$> getDef) @@ -390,14 +418,14 @@ getDigitalSignaturesInternal = setDigitalSignaturesInternal :: Members '[GundeckAccess, TeamFeatureStore, TeamStore, P.TinyLog] r => TeamId -> - Public.TeamFeatureStatus 'Public.TeamFeatureDigitalSignatures -> - Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureDigitalSignatures) + Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureDigitalSignatures -> + Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureDigitalSignatures) setDigitalSignaturesInternal = setFeatureStatusNoConfig @'Public.TeamFeatureDigitalSignatures $ \_ _ -> pure () getLegalholdStatusInternal :: Members '[LegalHoldStore, TeamFeatureStore, TeamStore] r => GetFeatureInternalParam -> - Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureLegalHold) + Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureLegalHold) getLegalholdStatusInternal (Left _) = pure $ Public.TeamFeatureStatusNoConfig Public.TeamFeatureDisabled getLegalholdStatusInternal (Right tid) = do @@ -440,8 +468,8 @@ setLegalholdStatusInternal :: r ) => TeamId -> - Public.TeamFeatureStatus 'Public.TeamFeatureLegalHold -> - Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureLegalHold) + Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureLegalHold -> + Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureLegalHold) setLegalholdStatusInternal tid status@(Public.tfwoStatus -> statusValue) = do do -- this extra do is to encapsulate the assertions running before the actual operation. @@ -466,7 +494,7 @@ setLegalholdStatusInternal tid status@(Public.tfwoStatus -> statusValue) = do getFileSharingInternal :: Members '[Input Opts, TeamFeatureStore] r => GetFeatureInternalParam -> - Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureFileSharing) + Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureFileSharing) getFileSharingInternal = getFeatureStatusWithDefaultConfig @'Public.TeamFeatureFileSharing flagFileSharing . either (const Nothing) Just @@ -474,12 +502,12 @@ getFeatureStatusWithDefaultConfig :: forall (a :: TeamFeatureName) r. ( KnownTeamFeatureName a, HasStatusCol a, - FeatureHasNoConfig a, + FeatureHasNoConfig 'Public.WithoutLockStatus a, Members '[Input Opts, TeamFeatureStore] r ) => - Lens' FeatureFlags (Defaults (Public.TeamFeatureStatus a)) -> + Lens' FeatureFlags (Defaults (Public.TeamFeatureStatus 'Public.WithoutLockStatus a)) -> Maybe TeamId -> - Sem r (Public.TeamFeatureStatus a) + Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus a) getFeatureStatusWithDefaultConfig lens' = maybe (Public.TeamFeatureStatusNoConfig <$> getDef) @@ -493,14 +521,14 @@ getFeatureStatusWithDefaultConfig lens' = setFileSharingInternal :: Members '[GundeckAccess, TeamFeatureStore, TeamStore, P.TinyLog] r => TeamId -> - Public.TeamFeatureStatus 'Public.TeamFeatureFileSharing -> - Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureFileSharing) + Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureFileSharing -> + Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureFileSharing) setFileSharingInternal = setFeatureStatusNoConfig @'Public.TeamFeatureFileSharing $ \_status _tid -> pure () getAppLockInternal :: Members '[Input Opts, TeamFeatureStore] r => GetFeatureInternalParam -> - Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureAppLock) + Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureAppLock) getAppLockInternal mbtid = do Defaults defaultStatus <- inputs (view (optSettings . setFeatureFlags . flagAppLockDefaults)) status <- @@ -510,32 +538,31 @@ getAppLockInternal mbtid = do setAppLockInternal :: Members '[GundeckAccess, TeamFeatureStore, TeamStore, Error TeamFeatureError, P.TinyLog] r => TeamId -> - Public.TeamFeatureStatus 'Public.TeamFeatureAppLock -> - Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureAppLock) + Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureAppLock -> + Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureAppLock) setAppLockInternal tid status = do when (Public.applockInactivityTimeoutSecs (Public.tfwcConfig status) < 30) $ throw AppLockinactivityTimeoutTooLow let pushEvent = pushFeatureConfigEvent tid $ Event.Event Event.Update Public.TeamFeatureAppLock (EdFeatureApplockChanged status) - (TeamFeatures.setApplockFeatureStatus tid status) <* pushEvent + TeamFeatures.setApplockFeatureStatus tid status <* pushEvent getClassifiedDomainsInternal :: Member (Input Opts) r => GetFeatureInternalParam -> - Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureClassifiedDomains) + Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureClassifiedDomains) getClassifiedDomainsInternal _mbtid = do globalConfig <- inputs (view (optSettings . setFeatureFlags . flagClassifiedDomains)) let config = globalConfig pure $ case Public.tfwcStatus config of - Public.TeamFeatureDisabled -> - Public.TeamFeatureStatusWithConfig Public.TeamFeatureDisabled (Public.TeamFeatureClassifiedDomainsConfig []) + Public.TeamFeatureDisabled -> Public.defaultClassifiedDomains Public.TeamFeatureEnabled -> config getConferenceCallingInternal :: Members '[BrigAccess, Input Opts, TeamFeatureStore] r => GetFeatureInternalParam -> - Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureConferenceCalling) + Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureConferenceCalling) getConferenceCallingInternal (Left (Just uid)) = do getFeatureConfigViaAccount @'Public.TeamFeatureConferenceCalling uid getConferenceCallingInternal (Left Nothing) = do @@ -546,31 +573,123 @@ getConferenceCallingInternal (Right tid) = do setConferenceCallingInternal :: Members '[GundeckAccess, TeamFeatureStore, TeamStore, P.TinyLog] r => TeamId -> - Public.TeamFeatureStatus 'Public.TeamFeatureConferenceCalling -> - Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureConferenceCalling) + Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureConferenceCalling -> + Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureConferenceCalling) setConferenceCallingInternal = setFeatureStatusNoConfig @'Public.TeamFeatureConferenceCalling $ \_status _tid -> pure () getSelfDeletingMessagesInternal :: - Member TeamFeatureStore r => + forall r. + ( Member (Input Opts) r, + Member TeamFeatureStore r + ) => GetFeatureInternalParam -> - Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureSelfDeletingMessages) + Sem r (Public.TeamFeatureStatus 'Public.WithLockStatus 'Public.TeamFeatureSelfDeletingMessages) getSelfDeletingMessagesInternal = \case - Left _ -> pure Public.defaultSelfDeletingMessagesStatus - Right tid -> - TeamFeatures.getSelfDeletingMessagesStatus tid - <&> maybe Public.defaultSelfDeletingMessagesStatus id + Left _ -> getCfgDefault + Right tid -> do + cfgDefault <- getCfgDefault + let defLockStatus = Public.tfwcapsLockStatus cfgDefault + (maybeFeatureStatus, fromMaybe defLockStatus -> lockStatus) <- TeamFeatures.getSelfDeletingMessagesStatus tid + pure $ case (lockStatus, maybeFeatureStatus) of + (Public.Unlocked, Just featureStatus) -> + Public.TeamFeatureStatusWithConfigAndLockStatus + (Public.tfwcStatus featureStatus) + (Public.tfwcConfig featureStatus) + Public.Unlocked + (Public.Unlocked, Nothing) -> cfgDefault {Public.tfwcapsLockStatus = Public.Unlocked} + (Public.Locked, _) -> cfgDefault {Public.tfwcapsLockStatus = Public.Locked} + where + getCfgDefault :: Sem r (Public.TeamFeatureStatusWithConfigAndLockStatus Public.TeamFeatureSelfDeletingMessagesConfig) + getCfgDefault = input <&> view (optSettings . setFeatureFlags . flagSelfDeletingMessages . unDefaults) setSelfDeletingMessagesInternal :: - Members '[GundeckAccess, TeamFeatureStore, TeamStore, P.TinyLog] r => + forall r. + ( Member GundeckAccess r, + Member TeamStore r, + Member TeamFeatureStore r, + Member P.TinyLog r, + Member (Error TeamFeatureError) r, + Member (Input Opts) r + ) => TeamId -> - Public.TeamFeatureStatus 'Public.TeamFeatureSelfDeletingMessages -> - Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureSelfDeletingMessages) + Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureSelfDeletingMessages -> + Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureSelfDeletingMessages) setSelfDeletingMessagesInternal tid st = do + dftLockStatus <- Public.tfwcapsLockStatus <$> getCfgDefault + guardLockStatus @'Public.TeamFeatureSelfDeletingMessages tid dftLockStatus let pushEvent = pushFeatureConfigEvent tid $ Event.Event Event.Update Public.TeamFeatureSelfDeletingMessages (EdFeatureSelfDeletingMessagesChanged st) - (TeamFeatures.setSelfDeletingMessagesStatus tid st) <* pushEvent + TeamFeatures.setSelfDeletingMessagesStatus tid st <* pushEvent + where + getCfgDefault :: Sem r (Public.TeamFeatureStatusWithConfigAndLockStatus Public.TeamFeatureSelfDeletingMessagesConfig) + getCfgDefault = input <&> view (optSettings . setFeatureFlags . flagSelfDeletingMessages . unDefaults) + +getGuestLinkInternal :: + forall r. + (Member (Input Opts) r, Member TeamFeatureStore r) => + GetFeatureInternalParam -> + Sem r (Public.TeamFeatureStatus 'Public.WithLockStatus 'Public.TeamFeatureGuestLinks) +getGuestLinkInternal = \case + Left _ -> getCfgDefault + Right tid -> do + cfgDefault <- getCfgDefault + let defLockStatus = Public.tfwoapsLockStatus cfgDefault + maybeFeatureStatus <- TeamFeatures.getFeatureStatusNoConfig @'Public.TeamFeatureGuestLinks tid + pure $ case (defLockStatus, maybeFeatureStatus) of + (Public.Unlocked, Just featureStatus) -> + Public.TeamFeatureStatusNoConfigAndLockStatus + (Public.tfwoStatus featureStatus) + Public.Unlocked + (Public.Unlocked, Nothing) -> cfgDefault {Public.tfwoapsLockStatus = Public.Unlocked} + (Public.Locked, _) -> cfgDefault {Public.tfwoapsLockStatus = Public.Locked} + where + getCfgDefault :: Sem r (Public.TeamFeatureStatus 'Public.WithLockStatus 'Public.TeamFeatureGuestLinks) + getCfgDefault = input <&> view (optSettings . setFeatureFlags . flagConversationGuestLinks . unDefaults) + +setGuestLinkInternal :: + forall r. + ( Member GundeckAccess r, + Member TeamStore r, + Member TeamFeatureStore r, + Member P.TinyLog r, + Member (Error TeamFeatureError) r, + Member (Input Opts) r + ) => + TeamId -> + Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureGuestLinks -> + Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureGuestLinks) +setGuestLinkInternal tid status = do + cfgDefault <- Public.tfwoapsLockStatus <$> getCfgDefault + guardLockStatus @'Public.TeamFeatureGuestLinks tid cfgDefault + let pushEvent = + pushFeatureConfigEvent tid $ + Event.Event + Event.Update + Public.TeamFeatureGuestLinks + ( EdFeatureWithoutConfigAndLockStatusChanged + (Public.TeamFeatureStatusNoConfigAndLockStatus (Public.tfwoStatus status) Public.Unlocked) + ) + TeamFeatures.setFeatureStatusNoConfig @'Public.TeamFeatureGuestLinks tid status <* pushEvent + where + getCfgDefault :: Sem r (Public.TeamFeatureStatus 'Public.WithLockStatus 'Public.TeamFeatureGuestLinks) + getCfgDefault = input <&> view (optSettings . setFeatureFlags . flagConversationGuestLinks . unDefaults) + +-- TODO(fisx): move this function to a more suitable place / module. +guardLockStatus :: + forall (a :: Public.TeamFeatureName) r. + ( MaybeHasLockStatusCol a, + Member TeamFeatureStore r, + Member (Error TeamFeatureError) r + ) => + TeamId -> + Public.LockStatusValue -> -- FUTUREWORK(fisx): move this into its own type class and infer from `a`? + Sem r () +guardLockStatus tid defLockStatus = do + (TeamFeatures.getLockStatus @a tid <&> fromMaybe defLockStatus) >>= \case + Public.Unlocked -> pure () + Public.Locked -> throw FeatureLocked pushFeatureConfigEvent :: Members '[GundeckAccess, TeamStore, P.TinyLog] r => @@ -588,7 +707,7 @@ pushFeatureConfigEvent tid event = do let recipients = membersToRecipients Nothing (memList ^. teamMembers) for_ (newPush (memList ^. teamMemberListType) Nothing (FeatureConfigEvent event) recipients) - (push1) + push1 -- | (Currently, we only have 'Public.TeamFeatureConferenceCalling' here, but we may have to -- extend this in the future.) @@ -597,5 +716,5 @@ getFeatureConfigViaAccount :: Member BrigAccess r ) => UserId -> - Sem r (Public.TeamFeatureStatus flag) + Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus flag) getFeatureConfigViaAccount = getAccountFeatureConfigClient diff --git a/services/galley/src/Galley/App.hs b/services/galley/src/Galley/App.hs index 7b63c880cbe..e3a80a6bef7 100644 --- a/services/galley/src/Galley/App.hs +++ b/services/galley/src/Galley/App.hs @@ -37,7 +37,6 @@ module Galley.App -- * Running Galley effects GalleyEffects, - runGalley, evalGalley, ask, DeleteItem (..), @@ -95,7 +94,6 @@ 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 qualified Network.Wai.Utilities as Wai import qualified Network.Wai.Utilities.Server as Server import OpenSSL.Session as Ssl @@ -188,11 +186,6 @@ initHttpManager o = do managerIdleConnectionCount = 3 * (o ^. optSettings . setHttpPoolSize) } -runGalley :: Env -> Request -> Sem GalleyEffects a -> IO a -runGalley e r m = - let e' = reqId .~ lookupReqId r $ e - in evalGalley e' m - interpretTinyLog :: Members '[Embed IO] r => Env -> @@ -201,9 +194,6 @@ interpretTinyLog :: interpretTinyLog e = interpret $ \case P.Polylog l m -> Logger.log (e ^. applog) l (reqIdMsg (e ^. reqId) . m) -lookupReqId :: Request -> RequestId -lookupReqId = maybe def RequestId . lookup requestIdName . requestHeaders - toServantHandler :: Env -> Sem GalleyEffects a -> Servant.Handler a toServantHandler env galley = do eith <- liftIO $ Control.Exception.try (evalGalley env galley) diff --git a/services/galley/src/Galley/Cassandra.hs b/services/galley/src/Galley/Cassandra.hs index a32e4fdce1a..a5477dd16d9 100644 --- a/services/galley/src/Galley/Cassandra.hs +++ b/services/galley/src/Galley/Cassandra.hs @@ -20,4 +20,4 @@ module Galley.Cassandra (schemaVersion) where import Imports schemaVersion :: Int32 -schemaVersion = 54 +schemaVersion = 56 diff --git a/services/galley/src/Galley/Cassandra/TeamFeatures.hs b/services/galley/src/Galley/Cassandra/TeamFeatures.hs index e723fe47689..53a4065f874 100644 --- a/services/galley/src/Galley/Cassandra/TeamFeatures.hs +++ b/services/galley/src/Galley/Cassandra/TeamFeatures.hs @@ -29,15 +29,38 @@ import Polysemy import Polysemy.Input import Wire.API.Team.Feature +-- TODO(leif): according to the specs it should only be supported to read the lock status via the api +-- changes can only be made in the server configuration file +-- we can probably remove the lock status from the db? +getFeatureStatusNoConfigAndLockStatus :: + forall (a :: TeamFeatureName) m. + (MonadClient m, FeatureHasNoConfig 'WithoutLockStatus a, HasStatusCol a, HasLockStatusCol a) => + Proxy a -> + TeamId -> + m (Maybe (TeamFeatureStatus 'WithoutLockStatus a), Maybe LockStatusValue) +getFeatureStatusNoConfigAndLockStatus _ tid = do + let q = query1 select (params LocalQuorum (Identity tid)) + mTuple <- retry x1 q + pure (mTuple >>= (fmap TeamFeatureStatusNoConfig . fst), mTuple >>= snd) + where + select :: PrepQuery R (Identity TeamId) (Maybe TeamFeatureStatusValue, Maybe LockStatusValue) + select = + fromString $ + "select " + <> statusCol @a + <> ", " + <> lockStatusCol @a + <> " from team_features where team_id = ?" + getFeatureStatusNoConfig :: forall (a :: TeamFeatureName) m. ( MonadClient m, - FeatureHasNoConfig a, + FeatureHasNoConfig 'WithoutLockStatus a, HasStatusCol a ) => Proxy a -> TeamId -> - m (Maybe (TeamFeatureStatus a)) + m (Maybe (TeamFeatureStatus 'WithoutLockStatus a)) getFeatureStatusNoConfig _ tid = do let q = query1 select (params LocalQuorum (Identity tid)) mStatusValue <- (>>= runIdentity) <$> retry x1 q @@ -49,13 +72,13 @@ getFeatureStatusNoConfig _ tid = do setFeatureStatusNoConfig :: forall (a :: TeamFeatureName) m. ( MonadClient m, - FeatureHasNoConfig a, + FeatureHasNoConfig 'WithoutLockStatus a, HasStatusCol a ) => Proxy a -> TeamId -> - TeamFeatureStatus a -> - m (TeamFeatureStatus a) + TeamFeatureStatus 'WithoutLockStatus a -> + m (TeamFeatureStatus 'WithoutLockStatus a) setFeatureStatusNoConfig _ tid status = do let flag = tfwoStatus status retry x5 $ write insert (params LocalQuorum (tid, flag)) @@ -68,7 +91,7 @@ getApplockFeatureStatus :: forall m. (MonadClient m) => TeamId -> - m (Maybe (TeamFeatureStatus 'TeamFeatureAppLock)) + m (Maybe (TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureAppLock)) getApplockFeatureStatus tid = do let q = query1 select (params LocalQuorum (Identity tid)) mTuple <- retry x1 q @@ -85,8 +108,8 @@ getApplockFeatureStatus tid = do setApplockFeatureStatus :: (MonadClient m) => TeamId -> - TeamFeatureStatus 'TeamFeatureAppLock -> - m (TeamFeatureStatus 'TeamFeatureAppLock) + TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureAppLock -> + m (TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureAppLock) setApplockFeatureStatus tid status = do let statusValue = tfwcStatus status enforce = applockEnforceAppLock . tfwcConfig $ status @@ -105,27 +128,30 @@ getSelfDeletingMessagesStatus :: forall m. (MonadClient m) => TeamId -> - m (Maybe (TeamFeatureStatus 'TeamFeatureSelfDeletingMessages)) + m (Maybe (TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureSelfDeletingMessages), Maybe LockStatusValue) getSelfDeletingMessagesStatus tid = do let q = query1 select (params LocalQuorum (Identity tid)) mTuple <- retry x1 q - pure $ - mTuple >>= \(mbStatusValue, mbTimeout) -> - TeamFeatureStatusWithConfig <$> mbStatusValue <*> (TeamFeatureSelfDeletingMessagesConfig <$> mbTimeout) + pure + ( mTuple >>= \(mbStatusValue, mbTimeout, _) -> + TeamFeatureStatusWithConfig <$> mbStatusValue <*> (TeamFeatureSelfDeletingMessagesConfig <$> mbTimeout), + mTuple >>= \(_, _, mbLockStatus) -> mbLockStatus + ) where - select :: PrepQuery R (Identity TeamId) (Maybe TeamFeatureStatusValue, Maybe Int32) + select :: PrepQuery R (Identity TeamId) (Maybe TeamFeatureStatusValue, Maybe Int32, Maybe LockStatusValue) select = fromString $ "select " <> statusCol @'TeamFeatureSelfDeletingMessages - <> ", self_deleting_messages_ttl " - <> "from team_features where team_id = ?" + <> ", self_deleting_messages_ttl, " + <> lockStatusCol @'TeamFeatureSelfDeletingMessages + <> " from team_features where team_id = ?" setSelfDeletingMessagesStatus :: (MonadClient m) => TeamId -> - TeamFeatureStatus 'TeamFeatureSelfDeletingMessages -> - m (TeamFeatureStatus 'TeamFeatureSelfDeletingMessages) + TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureSelfDeletingMessages -> + m (TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureSelfDeletingMessages) setSelfDeletingMessagesStatus tid status = do let statusValue = tfwcStatus status timeout = sdmEnforcedTimeoutSeconds . tfwcConfig $ status @@ -140,13 +166,56 @@ setSelfDeletingMessagesStatus tid status = do <> ", self_deleting_messages_ttl) " <> "values (?, ?, ?)" +setLockStatus :: + forall (a :: TeamFeatureName) m. + ( MonadClient m, + HasLockStatusCol a + ) => + Proxy a -> + TeamId -> + LockStatus -> + m LockStatus +setLockStatus _ tid (LockStatus lockStatus) = do + retry x5 $ write insert (params LocalQuorum (tid, lockStatus)) + pure (LockStatus lockStatus) + where + insert :: PrepQuery W (TeamId, LockStatusValue) () + insert = + fromString $ + "insert into team_features (team_id, " <> lockStatusCol @a <> ") values (?, ?)" + +getLockStatus :: + forall (a :: TeamFeatureName) m. + ( MonadClient m, + MaybeHasLockStatusCol a + ) => + Proxy a -> + TeamId -> + m (Maybe LockStatusValue) +getLockStatus _ tid = + case maybeLockStatusCol @a of + Nothing -> pure Nothing + Just lockStatusColName -> do + let q = query1 select (params LocalQuorum (Identity tid)) + (>>= runIdentity) <$> retry x1 q + where + select :: PrepQuery R (Identity TeamId) (Identity (Maybe LockStatusValue)) + select = + fromString $ + "select " + <> lockStatusColName + <> " from team_features where team_id = ?" + interpretTeamFeatureStoreToCassandra :: Members '[Embed IO, Input ClientState] r => Sem (TeamFeatureStore ': r) a -> Sem r a interpretTeamFeatureStoreToCassandra = interpret $ \case - GetFeatureStatusNoConfig' p tid -> embedClient $ getFeatureStatusNoConfig p tid - SetFeatureStatusNoConfig' p tid value -> embedClient $ setFeatureStatusNoConfig p tid value + GetFeatureStatusNoConfig' tfn tid -> embedClient $ getFeatureStatusNoConfig tfn tid + GetFeatureStatusNoConfigAndLockStatus' tfn tid -> embedClient $ getFeatureStatusNoConfigAndLockStatus tfn tid + SetFeatureStatusNoConfig' tfn tid value -> embedClient $ setFeatureStatusNoConfig tfn tid value + SetLockStatus' p tid value -> embedClient $ setLockStatus p tid value + GetLockStatus' p tid -> embedClient $ getLockStatus p tid GetApplockFeatureStatus tid -> embedClient $ getApplockFeatureStatus tid SetApplockFeatureStatus tid value -> embedClient $ setApplockFeatureStatus tid value GetSelfDeletingMessagesStatus tid -> embedClient $ getSelfDeletingMessagesStatus tid diff --git a/services/galley/src/Galley/Data/TeamFeatures.hs b/services/galley/src/Galley/Data/TeamFeatures.hs index e7ab337d0f5..12cd3dc28b6 100644 --- a/services/galley/src/Galley/Data/TeamFeatures.hs +++ b/services/galley/src/Galley/Data/TeamFeatures.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.Data.TeamFeatures (HasStatusCol (..)) where +module Galley.Data.TeamFeatures (HasStatusCol (..), HasLockStatusCol (..), MaybeHasLockStatusCol (..)) where import Imports import Wire.API.Team.Feature @@ -48,3 +48,37 @@ instance HasStatusCol 'TeamFeatureFileSharing where statusCol = "file_sharing" instance HasStatusCol 'TeamFeatureConferenceCalling where statusCol = "conference_calling" instance HasStatusCol 'TeamFeatureSelfDeletingMessages where statusCol = "self_deleting_messages_status" + +instance HasStatusCol 'TeamFeatureGuestLinks where statusCol = "guest_links_status" + +---------------------------------------------------------------------- +class HasLockStatusCol (a :: TeamFeatureName) where + lockStatusCol :: String + +class MaybeHasLockStatusCol (a :: TeamFeatureName) where + maybeLockStatusCol :: Maybe String + +instance {-# OVERLAPPABLE #-} HasLockStatusCol a => MaybeHasLockStatusCol a where + maybeLockStatusCol = Just (lockStatusCol @a) + +---------------------------------------------------------------------- +instance HasLockStatusCol 'TeamFeatureSelfDeletingMessages where + lockStatusCol = "self_deleting_messages_lock_status" + +instance MaybeHasLockStatusCol 'TeamFeatureGuestLinks where maybeLockStatusCol = Nothing + +instance MaybeHasLockStatusCol 'TeamFeatureLegalHold where maybeLockStatusCol = Nothing + +instance MaybeHasLockStatusCol 'TeamFeatureSSO where maybeLockStatusCol = Nothing + +instance MaybeHasLockStatusCol 'TeamFeatureSearchVisibility where maybeLockStatusCol = Nothing + +instance MaybeHasLockStatusCol 'TeamFeatureValidateSAMLEmails where maybeLockStatusCol = Nothing + +instance MaybeHasLockStatusCol 'TeamFeatureDigitalSignatures where maybeLockStatusCol = Nothing + +instance MaybeHasLockStatusCol 'TeamFeatureAppLock where maybeLockStatusCol = Nothing + +instance MaybeHasLockStatusCol 'TeamFeatureFileSharing where maybeLockStatusCol = Nothing + +instance MaybeHasLockStatusCol 'TeamFeatureConferenceCalling where maybeLockStatusCol = Nothing diff --git a/services/galley/src/Galley/Effects/TeamFeatureStore.hs b/services/galley/src/Galley/Effects/TeamFeatureStore.hs index d2910980f20..a71bac93714 100644 --- a/services/galley/src/Galley/Effects/TeamFeatureStore.hs +++ b/services/galley/src/Galley/Effects/TeamFeatureStore.hs @@ -18,11 +18,14 @@ module Galley.Effects.TeamFeatureStore ( TeamFeatureStore (..), getFeatureStatusNoConfig, + getFeatureStatusNoConfigAndLockStatus, setFeatureStatusNoConfig, getApplockFeatureStatus, setApplockFeatureStatus, getSelfDeletingMessagesStatus, setSelfDeletingMessagesStatus, + setLockStatus, + getLockStatus, ) where @@ -37,50 +40,94 @@ data TeamFeatureStore m a where -- the proxy argument makes sure that makeSem below generates type-inference-friendly code GetFeatureStatusNoConfig' :: forall (a :: TeamFeatureName) m. - ( FeatureHasNoConfig a, + ( FeatureHasNoConfig 'WithoutLockStatus a, HasStatusCol a ) => Proxy a -> TeamId -> - TeamFeatureStore m (Maybe (TeamFeatureStatus a)) + TeamFeatureStore m (Maybe (TeamFeatureStatus 'WithoutLockStatus a)) + -- the proxy argument makes sure that makeSem below generates type-inference-friendly code + GetFeatureStatusNoConfigAndLockStatus' :: + forall (a :: TeamFeatureName) m. + (FeatureHasNoConfig 'WithoutLockStatus a, HasStatusCol a, HasLockStatusCol a) => + Proxy a -> + TeamId -> + TeamFeatureStore m (Maybe (TeamFeatureStatus 'WithoutLockStatus a), Maybe LockStatusValue) -- the proxy argument makes sure that makeSem below generates type-inference-friendly code SetFeatureStatusNoConfig' :: forall (a :: TeamFeatureName) m. - ( FeatureHasNoConfig a, + ( FeatureHasNoConfig 'WithoutLockStatus a, HasStatusCol a ) => Proxy a -> TeamId -> - TeamFeatureStatus a -> - TeamFeatureStore m (TeamFeatureStatus a) + TeamFeatureStatus 'WithoutLockStatus a -> + TeamFeatureStore m (TeamFeatureStatus 'WithoutLockStatus a) GetApplockFeatureStatus :: TeamId -> - TeamFeatureStore m (Maybe (TeamFeatureStatus 'TeamFeatureAppLock)) + TeamFeatureStore m (Maybe (TeamFeatureStatus ps 'TeamFeatureAppLock)) SetApplockFeatureStatus :: TeamId -> - TeamFeatureStatus 'TeamFeatureAppLock -> - TeamFeatureStore m (TeamFeatureStatus 'TeamFeatureAppLock) + TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureAppLock -> + TeamFeatureStore m (TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureAppLock) GetSelfDeletingMessagesStatus :: TeamId -> - TeamFeatureStore m (Maybe (TeamFeatureStatus 'TeamFeatureSelfDeletingMessages)) + TeamFeatureStore m (Maybe (TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureSelfDeletingMessages), Maybe LockStatusValue) SetSelfDeletingMessagesStatus :: TeamId -> - TeamFeatureStatus 'TeamFeatureSelfDeletingMessages -> - TeamFeatureStore m (TeamFeatureStatus 'TeamFeatureSelfDeletingMessages) + TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureSelfDeletingMessages -> + TeamFeatureStore m (TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureSelfDeletingMessages) + SetLockStatus' :: + forall (a :: TeamFeatureName) m. + ( HasLockStatusCol a + ) => + Proxy a -> + TeamId -> + LockStatus -> + TeamFeatureStore m LockStatus + GetLockStatus' :: + forall (a :: TeamFeatureName) m. + ( MaybeHasLockStatusCol a + ) => + Proxy a -> + TeamId -> + TeamFeatureStore m (Maybe LockStatusValue) makeSem ''TeamFeatureStore getFeatureStatusNoConfig :: forall (a :: TeamFeatureName) r. - (Member TeamFeatureStore r, FeatureHasNoConfig a, HasStatusCol a) => + (Member TeamFeatureStore r, FeatureHasNoConfig 'WithoutLockStatus a, HasStatusCol a) => TeamId -> - Sem r (Maybe (TeamFeatureStatus a)) + Sem r (Maybe (TeamFeatureStatus 'WithoutLockStatus a)) getFeatureStatusNoConfig = getFeatureStatusNoConfig' (Proxy @a) +getFeatureStatusNoConfigAndLockStatus :: + forall (a :: TeamFeatureName) r. + (Member TeamFeatureStore r, FeatureHasNoConfig 'WithoutLockStatus a, HasStatusCol a, HasLockStatusCol a) => + TeamId -> + Sem r (Maybe (TeamFeatureStatus 'WithoutLockStatus a), Maybe LockStatusValue) +getFeatureStatusNoConfigAndLockStatus = getFeatureStatusNoConfigAndLockStatus' (Proxy @a) + setFeatureStatusNoConfig :: forall (a :: TeamFeatureName) r. - (Member TeamFeatureStore r, FeatureHasNoConfig a, HasStatusCol a) => + (Member TeamFeatureStore r, FeatureHasNoConfig 'WithoutLockStatus a, HasStatusCol a) => TeamId -> - TeamFeatureStatus a -> - Sem r (TeamFeatureStatus a) + TeamFeatureStatus 'WithoutLockStatus a -> + Sem r (TeamFeatureStatus 'WithoutLockStatus a) setFeatureStatusNoConfig = setFeatureStatusNoConfig' (Proxy @a) + +setLockStatus :: + forall (a :: TeamFeatureName) r. + (Member TeamFeatureStore r, HasLockStatusCol a) => + TeamId -> + LockStatus -> + Sem r LockStatus +setLockStatus = setLockStatus' (Proxy @a) + +getLockStatus :: + forall (a :: TeamFeatureName) r. + (Member TeamFeatureStore r, MaybeHasLockStatusCol a) => + TeamId -> + Sem r (Maybe LockStatusValue) +getLockStatus = getLockStatus' (Proxy @a) diff --git a/services/galley/src/Galley/Run.hs b/services/galley/src/Galley/Run.hs index b34d7df7243..18f5a8d0e70 100644 --- a/services/galley/src/Galley/Run.hs +++ b/services/galley/src/Galley/Run.hs @@ -21,13 +21,16 @@ module Galley.Run ) where +import Bilge.Request (requestIdName) import Cassandra (runClient, shutdown) import Cassandra.Schema (versionCheck) import qualified Control.Concurrent.Async as Async import Control.Exception (finally) -import Control.Lens (view, (^.)) +import Control.Lens (view, (.~), (^.)) import qualified Data.Aeson as Aeson +import Data.Default import Data.Domain +import Data.Id import qualified Data.Metrics.Middleware as M import Data.Metrics.Servant (servantPlusWAIPrometheusMiddleware) import Data.Misc (portNumber) @@ -45,6 +48,7 @@ import qualified Galley.Queue as Q import Imports import qualified Network.HTTP.Media.RenderHeader as HTTPMedia import qualified Network.HTTP.Types as HTTP +import Network.Wai import qualified Network.Wai.Middleware.Gunzip as GZip import qualified Network.Wai.Middleware.Gzip as GZip import Network.Wai.Utilities.Server @@ -91,21 +95,25 @@ mkApp o = do return (middlewares $ servantApp e, e, finalizer) where rtree = compile API.sitemap - app e r k = runGalley e r (route rtree r k) + app e r k = evalGalley e (route rtree r k) -- the servant API wraps the one defined using wai-routing - servantApp e r = - Servant.serveWithContext - (Proxy @CombinedAPI) - ( view (options . optSettings . setFederationDomain) e - :. customFormatters - :. Servant.EmptyContext - ) - ( hoistServer' @GalleyAPI.ServantAPI (toServantHandler e) API.servantSitemap - :<|> hoistServer' @Internal.ServantAPI (toServantHandler e) Internal.servantSitemap - :<|> hoistServer' @FederationAPI (toServantHandler e) federationSitemap - :<|> Servant.Tagged (app e) - ) - r + servantApp e0 r = + let e = reqId .~ lookupReqId r $ e0 + in Servant.serveWithContext + (Proxy @CombinedAPI) + ( view (options . optSettings . setFederationDomain) e + :. customFormatters + :. Servant.EmptyContext + ) + ( hoistServer' @GalleyAPI.ServantAPI (toServantHandler e) API.servantSitemap + :<|> hoistServer' @Internal.ServantAPI (toServantHandler e) Internal.servantSitemap + :<|> hoistServer' @FederationAPI (toServantHandler e) federationSitemap + :<|> Servant.Tagged (app e) + ) + r + + lookupReqId :: Request -> RequestId + lookupReqId = maybe def RequestId . lookup requestIdName . requestHeaders -- Servant needs a context type argument here that contains *at least* the -- context types required by all the HasServer instances. In reality, this should diff --git a/services/galley/test/integration/API/Teams.hs b/services/galley/test/integration/API/Teams.hs index 43985abb00b..837f499864b 100644 --- a/services/galley/test/integration/API/Teams.hs +++ b/services/galley/test/integration/API/Teams.hs @@ -355,7 +355,7 @@ testEnableSSOPerTeam = do assertQueue "create team" tActivate let check :: HasCallStack => String -> Public.TeamFeatureStatusValue -> TestM () check msg enabledness = do - status :: Public.TeamFeatureStatus 'Public.TeamFeatureSSO <- responseJsonUnsafe <$> (getSSOEnabledInternal tid (getSSOEnabledInternal tid TestM () @@ -382,10 +382,10 @@ testEnableSSOPerTeam = do testEnableTeamSearchVisibilityPerTeam :: TestM () testEnableTeamSearchVisibilityPerTeam = do g <- view tsGalley - (tid, owner, (member : _)) <- Util.createBindingTeamWithMembers 2 + (tid, owner, member : _) <- Util.createBindingTeamWithMembers 2 let check :: (HasCallStack, MonadCatch m, MonadIO m, Monad m, MonadHttp m) => String -> Public.TeamFeatureStatusValue -> m () check msg enabledness = do - status :: Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility <- responseJsonUnsafe <$> (Util.getTeamSearchVisibilityAvailableInternal g tid (Util.getTeamSearchVisibilityAvailableInternal g tid return (x, xs) (201, 200, _, _) -> createAndConnectUserWhileLimitNotReached alice (remaining -1) ((uid, cid) : acc) pk (403, 403, _, []) -> error "Need to connect with at least 1 user" - (403, 403, _, (x : xs)) -> return (x, xs) + (403, 403, _, x : xs) -> return (x, xs) (xxx, yyy, _, _) -> error ("Unexpected while connecting users: " ++ show xxx ++ " and " ++ show yyy) newTeamMember' :: Permissions -> UserId -> TeamMember @@ -1892,7 +1892,7 @@ getSSOEnabledInternal :: HasCallStack => TeamId -> TestM ResponseLBS getSSOEnabledInternal = Util.getTeamFeatureFlagInternal Public.TeamFeatureSSO putSSOEnabledInternal :: HasCallStack => TeamId -> Public.TeamFeatureStatusValue -> TestM () -putSSOEnabledInternal tid statusValue = Util.putTeamFeatureFlagInternal @'Public.TeamFeatureSSO expect2xx tid (Public.TeamFeatureStatusNoConfig statusValue) +putSSOEnabledInternal tid statusValue = void $ Util.putTeamFeatureFlagInternal @'Public.TeamFeatureSSO expect2xx tid (Public.TeamFeatureStatusNoConfig statusValue) getSearchVisibility :: HasCallStack => (Request -> Request) -> UserId -> TeamId -> (MonadIO m, MonadHttp m) => m ResponseLBS getSearchVisibility g uid tid = do diff --git a/services/galley/test/integration/API/Teams/Feature.hs b/services/galley/test/integration/API/Teams/Feature.hs index 76c5f7b408d..f3b1989bd91 100644 --- a/services/galley/test/integration/API/Teams/Feature.hs +++ b/services/galley/test/integration/API/Teams/Feature.hs @@ -22,7 +22,7 @@ import qualified API.Util as Util import qualified API.Util.TeamFeature as Util import Bilge import Bilge.Assert -import Control.Lens (over, view) +import Control.Lens (over, to, view) import Control.Monad.Catch (MonadCatch) import Data.Aeson (FromJSON, ToJSON, object, (.=)) import qualified Data.Aeson as Aeson @@ -56,7 +56,8 @@ import qualified Wire.API.Team.Feature as Public tests :: IO TestSetup -> TestTree tests s = - testGroup "Feature Config API and Team Features API" $ + testGroup + "Feature Config API and Team Features API" [ test s "SSO" testSSO, test s "LegalHold" testLegalHold, test s "SearchVisibility" testSearchVisibility, @@ -68,7 +69,8 @@ tests s = test s "All features" testAllFeatures, test s "Feature Configs / Team Features Consistency" testFeatureConfigConsistency, test s "ConferenceCalling" $ testSimpleFlag @'Public.TeamFeatureConferenceCalling Public.TeamFeatureEnabled, - test s "SelfDeletingMessages" $ testSelfDeletingMessages + test s "SelfDeletingMessages" testSelfDeletingMessages, + test s "ConversationGuestLinks" testGuestLinks ] testSSO :: TestM () @@ -87,7 +89,7 @@ testSSO = do getSSOInternal :: HasCallStack => Public.TeamFeatureStatusValue -> TestM () getSSOInternal = assertFlagNoConfig @'Public.TeamFeatureSSO $ Util.getTeamFeatureFlagInternal Public.TeamFeatureSSO tid setSSOInternal :: HasCallStack => Public.TeamFeatureStatusValue -> TestM () - setSSOInternal = Util.putTeamFeatureFlagInternal @'Public.TeamFeatureSSO expect2xx tid . Public.TeamFeatureStatusNoConfig + setSSOInternal = void . Util.putTeamFeatureFlagInternal @'Public.TeamFeatureSSO expect2xx tid . Public.TeamFeatureStatusNoConfig assertFlagForbidden $ Util.getTeamFeatureFlag Public.TeamFeatureSSO nonMember tid @@ -127,7 +129,7 @@ testLegalHold = do getLegalHoldFeatureConfig = assertFlagNoConfig @'Public.TeamFeatureLegalHold $ Util.getFeatureConfig Public.TeamFeatureLegalHold member setLegalHoldInternal :: HasCallStack => Public.TeamFeatureStatusValue -> TestM () - setLegalHoldInternal = Util.putTeamFeatureFlagInternal @'Public.TeamFeatureLegalHold expect2xx tid . Public.TeamFeatureStatusNoConfig + setLegalHoldInternal = void . Util.putTeamFeatureFlagInternal @'Public.TeamFeatureLegalHold expect2xx tid . Public.TeamFeatureStatusNoConfig getLegalHold Public.TeamFeatureDisabled getLegalHoldInternal Public.TeamFeatureDisabled @@ -249,7 +251,7 @@ getClassifiedDomains :: (HasCallStack, HasGalley m, MonadIO m, MonadHttp m, MonadCatch m) => UserId -> TeamId -> - Public.TeamFeatureStatus 'Public.TeamFeatureClassifiedDomains -> + Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureClassifiedDomains -> m () getClassifiedDomains member tid = assertFlagWithConfig @Public.TeamFeatureClassifiedDomainsConfig $ @@ -258,7 +260,7 @@ getClassifiedDomains member tid = getClassifiedDomainsInternal :: (HasCallStack, HasGalley m, MonadIO m, MonadHttp m, MonadCatch m) => TeamId -> - Public.TeamFeatureStatus 'Public.TeamFeatureClassifiedDomains -> + Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureClassifiedDomains -> m () getClassifiedDomainsInternal tid = assertFlagWithConfig @Public.TeamFeatureClassifiedDomainsConfig $ @@ -276,7 +278,7 @@ testClassifiedDomainsEnabled = do let getClassifiedDomainsFeatureConfig :: (HasCallStack, HasGalley m, MonadIO m, MonadHttp m, MonadCatch m) => UserId -> - Public.TeamFeatureStatus 'Public.TeamFeatureClassifiedDomains -> + Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureClassifiedDomains -> m () getClassifiedDomainsFeatureConfig uid = do assertFlagWithConfig @Public.TeamFeatureClassifiedDomainsConfig $ @@ -298,7 +300,7 @@ testClassifiedDomainsDisabled = do let getClassifiedDomainsFeatureConfig :: (HasCallStack, HasGalley m, MonadIO m, MonadHttp m, MonadCatch m) => UserId -> - Public.TeamFeatureStatus 'Public.TeamFeatureClassifiedDomains -> + Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureClassifiedDomains -> m () getClassifiedDomainsFeatureConfig uid = do assertFlagWithConfig @Public.TeamFeatureClassifiedDomainsConfig $ @@ -319,10 +321,10 @@ testSimpleFlag :: forall (a :: Public.TeamFeatureName). ( HasCallStack, Typeable a, - Public.FeatureHasNoConfig a, + Public.FeatureHasNoConfig 'Public.WithoutLockStatus a, Public.KnownTeamFeatureName a, - FromJSON (Public.TeamFeatureStatus a), - ToJSON (Public.TeamFeatureStatus a) + FromJSON (Public.TeamFeatureStatus 'Public.WithoutLockStatus a), + ToJSON (Public.TeamFeatureStatus 'Public.WithoutLockStatus a) ) => Public.TeamFeatureStatusValue -> TestM () @@ -349,7 +351,7 @@ testSimpleFlag defaultValue = do setFlagInternal :: Public.TeamFeatureStatusValue -> TestM () setFlagInternal statusValue = - Util.putTeamFeatureFlagInternal @a expect2xx tid (Public.TeamFeatureStatusNoConfig statusValue) + void $ Util.putTeamFeatureFlagInternal @a expect2xx tid (Public.TeamFeatureStatusNoConfig statusValue) assertFlagForbidden $ Util.getTeamFeatureFlag feature nonMember tid @@ -380,32 +382,50 @@ testSimpleFlag defaultValue = do testSelfDeletingMessages :: TestM () testSelfDeletingMessages = do + defLockStatus :: Public.LockStatusValue <- + view + ( tsGConf + . optSettings + . setFeatureFlags + . flagSelfDeletingMessages + . unDefaults + . to Public.tfwcapsLockStatus + ) + -- personal users - let setting :: TeamFeatureStatusValue -> Int32 -> Public.TeamFeatureStatus 'Public.TeamFeatureSelfDeletingMessages - setting stat tout = + let settingWithoutLockStatus :: TeamFeatureStatusValue -> Int32 -> Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureSelfDeletingMessages + settingWithoutLockStatus stat tout = Public.TeamFeatureStatusWithConfig @Public.TeamFeatureSelfDeletingMessagesConfig stat (Public.TeamFeatureSelfDeletingMessagesConfig tout) + settingWithLockStatus :: TeamFeatureStatusValue -> Int32 -> Public.LockStatusValue -> Public.TeamFeatureStatus 'Public.WithLockStatus 'Public.TeamFeatureSelfDeletingMessages + settingWithLockStatus stat tout lockStatus = + Public.TeamFeatureStatusWithConfigAndLockStatus @Public.TeamFeatureSelfDeletingMessagesConfig + stat + (Public.TeamFeatureSelfDeletingMessagesConfig tout) + lockStatus personalUser <- Util.randomUser Util.getFeatureConfig Public.TeamFeatureSelfDeletingMessages personalUser - !!! responseJsonEither === const (Right $ setting TeamFeatureEnabled 0) + !!! responseJsonEither === const (Right $ settingWithLockStatus TeamFeatureEnabled 0 defLockStatus) -- team users galley <- view tsGalley (owner, tid, []) <- Util.createBindingTeamWithNMembers 0 - let checkSet :: TeamFeatureStatusValue -> Int32 -> TestM () - checkSet stat tout = do - Util.putTeamFeatureFlagInternal @'Public.TeamFeatureSelfDeletingMessages - galley - tid - (setting stat tout) + let checkSet :: TeamFeatureStatusValue -> Int32 -> Int -> TestM () + checkSet stat tout expectedStatusCode = + do + Util.putTeamFeatureFlagInternal @'Public.TeamFeatureSelfDeletingMessages + galley + tid + (settingWithoutLockStatus stat tout) + !!! statusCode === const expectedStatusCode -- internal, public (/team/:tid/features), and team-agnostic (/feature-configs). - checkGet :: HasCallStack => TeamFeatureStatusValue -> Int32 -> TestM () - checkGet stat tout = do - let expected = setting stat tout + checkGet :: HasCallStack => TeamFeatureStatusValue -> Int32 -> Public.LockStatusValue -> TestM () + checkGet stat tout lockStatus = do + let expected = settingWithLockStatus stat tout lockStatus forM_ [ Util.getTeamFeatureFlagInternal Public.TeamFeatureSelfDeletingMessages tid, Util.getTeamFeatureFlagWithGalley Public.TeamFeatureSelfDeletingMessages galley owner tid, @@ -413,30 +433,96 @@ testSelfDeletingMessages = do ] (!!! responseJsonEither === const (Right expected)) - checkGet TeamFeatureEnabled 0 - checkSet TeamFeatureDisabled 0 - checkGet TeamFeatureDisabled 0 - checkSet TeamFeatureEnabled 30 - checkGet TeamFeatureEnabled 30 + checkSetLockStatus :: HasCallStack => Public.LockStatusValue -> TestM () + checkSetLockStatus status = + do + Util.setLockStatusInternal @'Public.TeamFeatureSelfDeletingMessages galley tid status + !!! statusCode === const 200 + + -- test that the default lock status comes from `galley.yaml`. + -- use this to change `galley.integration.yaml` locally and manually test that conf file + -- parsing works as expected. + checkGet TeamFeatureEnabled 0 defLockStatus + + case defLockStatus of + Public.Locked -> do + checkSet TeamFeatureDisabled 0 409 + Public.Unlocked -> do + checkSet TeamFeatureDisabled 0 200 + checkGet TeamFeatureDisabled 0 Public.Unlocked + checkSet TeamFeatureEnabled 0 200 + checkGet TeamFeatureEnabled 0 Public.Unlocked + + -- now don't worry about what's in the config, write something to cassandra, and test with that. + checkSetLockStatus Public.Locked + checkGet TeamFeatureEnabled 0 Public.Locked + checkSet TeamFeatureDisabled 0 409 + checkGet TeamFeatureEnabled 0 Public.Locked + checkSet TeamFeatureEnabled 30 409 + checkGet TeamFeatureEnabled 0 Public.Locked + checkSetLockStatus Public.Unlocked + checkGet TeamFeatureEnabled 0 Public.Unlocked + checkSet TeamFeatureDisabled 0 200 + checkGet TeamFeatureDisabled 0 Public.Unlocked + checkSet TeamFeatureEnabled 30 200 + checkGet TeamFeatureEnabled 30 Public.Unlocked + checkSet TeamFeatureDisabled 30 200 + checkGet TeamFeatureDisabled 30 Public.Unlocked + checkSetLockStatus Public.Locked + checkGet TeamFeatureEnabled 0 Public.Locked + checkSet TeamFeatureEnabled 50 409 + checkSetLockStatus Public.Unlocked + checkGet TeamFeatureDisabled 30 Public.Unlocked + +testGuestLinks :: TestM () +testGuestLinks = do + galley <- view tsGalley + (owner, tid, []) <- Util.createBindingTeamWithNMembers 0 + let checkGet :: HasCallStack => Public.TeamFeatureStatusValue -> Public.LockStatusValue -> TestM () + checkGet status lock = + do + Util.getTeamFeatureFlagWithGalley Public.TeamFeatureGuestLinks galley owner tid + !!! responseJsonEither === const (Right (Public.TeamFeatureStatusNoConfigAndLockStatus status lock)) + checkSet :: HasCallStack => Public.TeamFeatureStatusValue -> TestM () + checkSet status = + do + Util.putTeamFeatureFlagWithGalley @'Public.TeamFeatureGuestLinks galley owner tid (Public.TeamFeatureStatusNoConfig status) + !!! statusCode === const 200 + + checkGet Public.TeamFeatureEnabled Public.Unlocked + checkSet Public.TeamFeatureDisabled + checkGet Public.TeamFeatureDisabled Public.Unlocked + checkSet Public.TeamFeatureEnabled + checkGet Public.TeamFeatureEnabled Public.Unlocked -- | Call 'GET /teams/:tid/features' and 'GET /feature-configs', and check if all -- features are there. testAllFeatures :: TestM () testAllFeatures = do + defLockStatus :: Public.LockStatusValue <- + view + ( tsGConf + . optSettings + . setFeatureFlags + . flagSelfDeletingMessages + . unDefaults + . to Public.tfwcapsLockStatus + ) + (_owner, tid, member : _) <- Util.createBindingTeamWithNMembers 1 Util.getAllTeamFeatures member tid !!! do statusCode === const 200 - responseJsonMaybe === const (Just (expected TeamFeatureEnabled {- determined by default in galley -})) + responseJsonMaybe === const (Just (expected TeamFeatureEnabled defLockStatus {- determined by default in galley -})) Util.getAllTeamFeaturesPersonal member !!! do statusCode === const 200 - responseJsonMaybe === const (Just (expected TeamFeatureEnabled {- determined by default in galley -})) + responseJsonMaybe === const (Just (expected TeamFeatureEnabled defLockStatus {- determined by default in galley -})) randomPersonalUser <- Util.randomUser Util.getAllTeamFeaturesPersonal randomPersonalUser !!! do statusCode === const 200 - responseJsonMaybe === const (Just (expected TeamFeatureEnabled {- determined by 'getAfcConferenceCallingDefNew' in brig -})) + responseJsonMaybe === const (Just (expected TeamFeatureEnabled defLockStatus {- determined by 'getAfcConferenceCallingDefNew' in brig -})) where - expected confCalling = + expected confCalling lockState = object [ toS TeamFeatureLegalHold .= Public.TeamFeatureStatusNoConfig TeamFeatureDisabled, toS TeamFeatureSSO .= Public.TeamFeatureStatusNoConfig TeamFeatureDisabled, @@ -455,10 +541,14 @@ testAllFeatures = do toS TeamFeatureConferenceCalling .= Public.TeamFeatureStatusNoConfig confCalling, toS TeamFeatureSelfDeletingMessages - .= ( Public.TeamFeatureStatusWithConfig @Public.TeamFeatureSelfDeletingMessagesConfig - TeamFeatureEnabled - (Public.TeamFeatureSelfDeletingMessagesConfig 0) - ) + .= Public.TeamFeatureStatusWithConfigAndLockStatus @Public.TeamFeatureSelfDeletingMessagesConfig + TeamFeatureEnabled + (Public.TeamFeatureSelfDeletingMessagesConfig 0) + lockState, + toS TeamFeatureGuestLinks + .= Public.TeamFeatureStatusNoConfigAndLockStatus + TeamFeatureEnabled + Public.Unlocked ] toS :: TeamFeatureName -> Text toS = TE.decodeUtf8 . toByteString' @@ -478,8 +568,6 @@ testFeatureConfigConsistency = do unless (allTeamFeaturesRes `Set.isSubsetOf` allFeaturesRes) $ liftIO $ expectationFailure (show allTeamFeaturesRes <> " is not a subset of " <> show allFeaturesRes) - - pure () where parseObjectKeys :: ResponseLBS -> TestM (Set.Set Text) parseObjectKeys res = do @@ -503,8 +591,8 @@ assertFlagNoConfig :: forall (a :: Public.TeamFeatureName). ( HasCallStack, Typeable a, - Public.FeatureHasNoConfig a, - FromJSON (Public.TeamFeatureStatus a), + Public.FeatureHasNoConfig 'Public.WithoutLockStatus a, + FromJSON (Public.TeamFeatureStatus 'Public.WithoutLockStatus a), Public.KnownTeamFeatureName a ) => TestM ResponseLBS -> @@ -514,7 +602,7 @@ assertFlagNoConfig res expected = do res !!! do statusCode === const 200 ( fmap Public.tfwoStatus - . responseJsonEither @(Public.TeamFeatureStatus a) + . responseJsonEither @(Public.TeamFeatureStatus 'Public.WithoutLockStatus a) ) === const (Right expected) diff --git a/services/galley/test/integration/API/Teams/LegalHold.hs b/services/galley/test/integration/API/Teams/LegalHold.hs index 7ccefd4ea6a..d44974b5f73 100644 --- a/services/galley/test/integration/API/Teams/LegalHold.hs +++ b/services/galley/test/integration/API/Teams/LegalHold.hs @@ -566,14 +566,14 @@ testEnablePerTeam = withTeam $ \owner tid -> do addTeamMemberInternal tid member (rolePermissions RoleMember) Nothing ensureQueueEmpty do - status :: Public.TeamFeatureStatus 'Public.TeamFeatureLegalHold <- responseJsonUnsafe <$> (getEnabled tid (getEnabled tid (getEnabled tid (getEnabled tid do @@ -585,7 +585,7 @@ testEnablePerTeam = withTeam $ \owner tid -> do liftIO $ assertEqual "User legal hold status should be enabled" UserLegalHoldEnabled status do putEnabled' id tid Public.TeamFeatureDisabled !!! testResponse 403 (Just "legalhold-whitelisted-only") - status :: Public.TeamFeatureStatus 'Public.TeamFeatureLegalHold <- responseJsonUnsafe <$> (getEnabled tid (getEnabled tid (getEnabled tid (getEnabled tid (getEnabled tid (getEnabled tid do @@ -554,7 +554,7 @@ testEnablePerTeam = do liftIO $ assertEqual "User legal hold status should be enabled" UserLegalHoldEnabled status do putEnabled tid Public.TeamFeatureDisabled -- disable again - status :: Public.TeamFeatureStatus 'Public.TeamFeatureLegalHold <- responseJsonUnsafe <$> (getEnabled tid (getEnabled tid (getEnabled tid (getEnabled tid (getEnabled tid (getEnabled tid (MonadIO m, MonadHttp m) => m () putTeamSearchVisibilityAvailableInternal g tid statusValue = - putTeamFeatureFlagInternalWithGalleyAndMod - @'Public.TeamFeatureSearchVisibility - g - expect2xx - tid - (Public.TeamFeatureStatusNoConfig statusValue) + void $ + putTeamFeatureFlagInternalWithGalleyAndMod + @'Public.TeamFeatureSearchVisibility + g + expect2xx + tid + (Public.TeamFeatureStatusNoConfig statusValue) putLegalHoldEnabledInternal' :: HasCallStack => @@ -65,7 +66,7 @@ putLegalHoldEnabledInternal' :: Public.TeamFeatureStatusValue -> TestM () putLegalHoldEnabledInternal' g tid statusValue = - putTeamFeatureFlagInternal @'Public.TeamFeatureLegalHold g tid (Public.TeamFeatureStatusNoConfig statusValue) + void $ putTeamFeatureFlagInternal @'Public.TeamFeatureLegalHold g tid (Public.TeamFeatureStatusNoConfig statusValue) -------------------------------------------------------------------------------- @@ -148,16 +149,34 @@ getAllFeatureConfigsWithGalley galley uid = do . paths ["feature-configs"] . zUser uid +putTeamFeatureFlagWithGalley :: + forall (a :: Public.TeamFeatureName). + ( HasCallStack, + Public.KnownTeamFeatureName a, + ToJSON (Public.TeamFeatureStatus 'Public.WithoutLockStatus a) + ) => + (Request -> Request) -> + UserId -> + TeamId -> + Public.TeamFeatureStatus 'Public.WithoutLockStatus a -> + TestM ResponseLBS +putTeamFeatureFlagWithGalley galley uid tid status = + put $ + galley + . paths ["teams", toByteString' tid, "features", toByteString' (Public.knownTeamFeatureName @a)] + . json status + . zUser uid + putTeamFeatureFlagInternal :: forall (a :: Public.TeamFeatureName). ( HasCallStack, Public.KnownTeamFeatureName a, - ToJSON (Public.TeamFeatureStatus a) + ToJSON (Public.TeamFeatureStatus 'Public.WithoutLockStatus a) ) => (Request -> Request) -> TeamId -> - (Public.TeamFeatureStatus a) -> - TestM () + Public.TeamFeatureStatus 'Public.WithoutLockStatus a -> + TestM ResponseLBS putTeamFeatureFlagInternal reqmod tid status = do g <- view tsGalley putTeamFeatureFlagInternalWithGalleyAndMod @a g reqmod tid status @@ -168,16 +187,33 @@ putTeamFeatureFlagInternalWithGalleyAndMod :: MonadHttp m, HasCallStack, Public.KnownTeamFeatureName a, - ToJSON (Public.TeamFeatureStatus a) + ToJSON (Public.TeamFeatureStatus 'Public.WithoutLockStatus a) ) => (Request -> Request) -> (Request -> Request) -> TeamId -> - (Public.TeamFeatureStatus a) -> - m () + Public.TeamFeatureStatus 'Public.WithoutLockStatus a -> + m ResponseLBS putTeamFeatureFlagInternalWithGalleyAndMod galley reqmod tid status = - void . put $ + put $ galley . paths ["i", "teams", toByteString' tid, "features", toByteString' (Public.knownTeamFeatureName @a)] . json status . reqmod + +setLockStatusInternal :: + forall (a :: Public.TeamFeatureName). + ( HasCallStack, + Public.KnownTeamFeatureName a, + ToJSON Public.LockStatusValue + ) => + (Request -> Request) -> + TeamId -> + Public.LockStatusValue -> + TestM ResponseLBS +setLockStatusInternal reqmod tid lockStatus = do + galley <- view tsGalley + put $ + galley + . paths ["i", "teams", toByteString' tid, "features", toByteString' (Public.knownTeamFeatureName @a), toByteString' lockStatus] + . reqmod diff --git a/services/spar/src/Spar/Intra/Galley.hs b/services/spar/src/Spar/Intra/Galley.hs index d8a0bc6291c..f4984b2b059 100644 --- a/services/spar/src/Spar/Intra/Galley.hs +++ b/services/spar/src/Spar/Intra/Galley.hs @@ -31,7 +31,13 @@ import Imports import Network.HTTP.Types.Method import Spar.Error import qualified System.Logger.Class as Log -import Wire.API.Team.Feature (TeamFeatureName (..), TeamFeatureStatus, TeamFeatureStatusNoConfig (..), TeamFeatureStatusValue (..)) +import Wire.API.Team.Feature + ( IncludeLockStatus (..), + TeamFeatureName (..), + TeamFeatureStatus, + TeamFeatureStatusNoConfig (..), + TeamFeatureStatusValue (..), + ) ---------------------------------------------------------------------- @@ -88,7 +94,7 @@ isEmailValidationEnabledTeam tid = do resp <- call $ method GET . paths ["i", "teams", toByteString' tid, "features", "validateSAMLemails"] pure ( (statusCode resp == 200) - && ( responseJsonMaybe @(TeamFeatureStatus 'TeamFeatureValidateSAMLEmails) resp + && ( responseJsonMaybe @(TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureValidateSAMLEmails) resp == Just (TeamFeatureStatusNoConfig TeamFeatureEnabled) ) ) diff --git a/shell.nix b/shell.nix new file mode 100644 index 00000000000..e647c264021 --- /dev/null +++ b/shell.nix @@ -0,0 +1,8 @@ +let + pkgs = import ./nix; + packages = import ./dev-packages.nix { pkgs = pkgs; }; +in +pkgs.mkShell { + name = "wire-server-direnv"; + buildInputs = packages; +} diff --git a/tools/stern/src/Stern/API.hs b/tools/stern/src/Stern/API.hs index 27e8e727098..8aac06f7f20 100644 --- a/tools/stern/src/Stern/API.hs +++ b/tools/stern/src/Stern/API.hs @@ -45,6 +45,7 @@ import qualified Data.Swagger.Build.Api as Doc import Data.Text (unpack) import qualified Data.Text as T import Data.Text.Encoding (decodeLatin1) +import qualified Galley.Types.Teams.Intra as Team import qualified Galley.Types.Teams.SearchVisibility as Team import Imports hiding (head) import Network.HTTP.Types @@ -246,6 +247,22 @@ routes = do Doc.response 200 "Account deleted" Doc.end Doc.response 400 "Bad request" (Doc.model Doc.errorModel) + put "/teams/:tid/suspend" (continue (setTeamStatusH Team.Suspended)) $ + capture "tid" + document "PUT" "setTeamStatusH:suspended" $ do + summary "Suspend a team." + Doc.parameter Doc.Path "tid" Doc.bytes' $ + description "Team ID" + Doc.response 200 mempty Doc.end + + put "/teams/:tid/unsuspend" (continue (setTeamStatusH Team.Active)) $ + capture "tid" + document "PUT" "setTeamStatusH:active" $ do + summary "Set a team status to 'Active', independently on previous status. (Cannot be used to un-delete teams, though.)" + Doc.parameter Doc.Path "tid" Doc.bytes' $ + description "Team ID" + Doc.response 200 mempty Doc.end + delete "/teams/:tid" (continue deleteTeam) $ capture "tid" .&. query "email" @@ -545,6 +562,9 @@ deleteUser (uid ::: emailOrPhone) = do where checkUUID u = userId u == uid +setTeamStatusH :: Team.TeamStatus -> TeamId -> Handler Response +setTeamStatusH status tid = empty <$ Intra.setStatusBindingTeam tid status + deleteTeam :: TeamId ::: Email -> Handler Response deleteTeam (givenTid ::: email) = do acc <- (listToMaybe <$> Intra.getUserProfilesByIdentity (Left email)) >>= handleNoUser @@ -594,25 +614,25 @@ getTeamAdminInfo = liftM (json . toAdminInfo) . Intra.getTeamInfo getTeamFeatureFlagH :: forall (a :: Public.TeamFeatureName). ( Public.KnownTeamFeatureName a, - FromJSON (Public.TeamFeatureStatus a), - ToJSON (Public.TeamFeatureStatus a), - Typeable (Public.TeamFeatureStatus a) + FromJSON (Public.TeamFeatureStatus 'Public.WithoutLockStatus a), + ToJSON (Public.TeamFeatureStatus 'Public.WithoutLockStatus a), + Typeable (Public.TeamFeatureStatus 'Public.WithoutLockStatus a) ) => TeamId -> Handler Response getTeamFeatureFlagH tid = - json <$> Intra.getTeamFeatureFlag @a tid + json <$> Intra.getTeamFeatureFlag @'Public.WithoutLockStatus @a tid setTeamFeatureFlagH :: forall (a :: Public.TeamFeatureName). ( Public.KnownTeamFeatureName a, - FromJSON (Public.TeamFeatureStatus a), - ToJSON (Public.TeamFeatureStatus a) + FromJSON (Public.TeamFeatureStatus 'Public.WithoutLockStatus a), + ToJSON (Public.TeamFeatureStatus 'Public.WithoutLockStatus a) ) => - TeamId ::: JsonRequest (Public.TeamFeatureStatus a) ::: JSON -> + TeamId ::: JsonRequest (Public.TeamFeatureStatus 'Public.WithoutLockStatus a) ::: JSON -> Handler Response setTeamFeatureFlagH (tid ::: req ::: _) = do - status :: Public.TeamFeatureStatus a <- parseBody req !>> mkError status400 "client-error" + status :: Public.TeamFeatureStatus 'Public.WithoutLockStatus a <- parseBody req !>> mkError status400 "client-error" empty <$ Intra.setTeamFeatureFlag @a tid status getTeamFeatureFlagNoConfigH :: @@ -755,9 +775,9 @@ noSuchUser = ifNothing (mkError status404 "no-user" "No such user") mkFeaturePutGetRoute :: forall (a :: Public.TeamFeatureName). ( Public.KnownTeamFeatureName a, - FromJSON (Public.TeamFeatureStatus a), - ToJSON (Public.TeamFeatureStatus a), - Typeable (Public.TeamFeatureStatus a) + FromJSON (Public.TeamFeatureStatus 'Public.WithoutLockStatus a), + ToJSON (Public.TeamFeatureStatus 'Public.WithoutLockStatus a), + Typeable (Public.TeamFeatureStatus 'Public.WithoutLockStatus a) ) => Routes Doc.ApiBuilder Handler () mkFeaturePutGetRoute = do @@ -774,7 +794,7 @@ mkFeaturePutGetRoute = do put ("/teams/:tid/features/" <> toByteString' featureName) (continue (setTeamFeatureFlagH @a)) $ capture "tid" - .&. jsonRequest @(Public.TeamFeatureStatus a) + .&. jsonRequest @(Public.TeamFeatureStatus 'Public.WithoutLockStatus a) .&. accept "application" "json" document "PUT" "setTeamFeatureFlag" $ do summary "Disable / enable feature flag for a given team" diff --git a/tools/stern/src/Stern/Intra.hs b/tools/stern/src/Stern/Intra.hs index e930aa76e03..bdad751f68d 100644 --- a/tools/stern/src/Stern/Intra.hs +++ b/tools/stern/src/Stern/Intra.hs @@ -36,6 +36,7 @@ module Stern.Intra changeEmail, changePhone, deleteAccount, + setStatusBindingTeam, deleteBindingTeam, getTeamInfo, getUserBindingTeam, @@ -85,6 +86,7 @@ import Data.Text.Lazy (pack) import Galley.Types import Galley.Types.Teams import Galley.Types.Teams.Intra +import qualified Galley.Types.Teams.Intra as Team import Galley.Types.Teams.SearchVisibility import Gundeck.Types import Imports @@ -293,6 +295,20 @@ deleteAccount uid = do . expect2xx ) +setStatusBindingTeam :: TeamId -> Team.TeamStatus -> Handler () +setStatusBindingTeam tid status = do + info $ msg ("Setting team status to " <> (cs $ encode status)) + g <- view galley + void . catchRpcErrors $ + rpc' + "galley" + g + ( method PUT + . paths ["/i/teams", toByteString' tid, "status"] + . Bilge.json (Team.TeamStatusUpdate status Nothing) + . expect2xx + ) + deleteBindingTeam :: TeamId -> Handler () deleteBindingTeam tid = do info $ msg "Deleting team" @@ -452,13 +468,13 @@ setBlacklistStatus status emailOrPhone = do statusToMethod True = POST getTeamFeatureFlag :: - forall (a :: Public.TeamFeatureName). + forall (ps :: Public.IncludeLockStatus) (a :: Public.TeamFeatureName). ( Public.KnownTeamFeatureName a, - Typeable (Public.TeamFeatureStatus a), - FromJSON (Public.TeamFeatureStatus a) + Typeable (Public.TeamFeatureStatus ps a), + FromJSON (Public.TeamFeatureStatus ps a) ) => TeamId -> - Handler (Public.TeamFeatureStatus a) + Handler (Public.TeamFeatureStatus ps a) getTeamFeatureFlag tid = do info $ msg "Getting team feature status" gly <- view galley @@ -467,17 +483,17 @@ getTeamFeatureFlag tid = do . paths ["/i/teams", toByteString' tid, "features", toByteString' (Public.knownTeamFeatureName @a)] resp <- catchRpcErrors $ rpc' "galley" gly req case Bilge.statusCode resp of - 200 -> pure $ responseJsonUnsafe @(Public.TeamFeatureStatus a) resp + 200 -> pure $ responseJsonUnsafe @(Public.TeamFeatureStatus ps a) resp 404 -> throwE (mkError status404 "bad-upstream" "team doesnt exist") _ -> throwE (mkError status502 "bad-upstream" "bad response") setTeamFeatureFlag :: forall (a :: Public.TeamFeatureName). ( Public.KnownTeamFeatureName a, - ToJSON (Public.TeamFeatureStatus a) + ToJSON (Public.TeamFeatureStatus 'Public.WithoutLockStatus a) ) => TeamId -> - Public.TeamFeatureStatus a -> + Public.TeamFeatureStatus 'Public.WithoutLockStatus a -> Handler () setTeamFeatureFlag tid status = do info $ msg "Setting team feature status"