diff --git a/.dockerignore b/.dockerignore index e3606f86bea..f23c963a415 100644 --- a/.dockerignore +++ b/.dockerignore @@ -1,5 +1,6 @@ **/.* **/dist +**/dist-buildah **/target **/*.aci **/*.tgz diff --git a/.gitignore b/.gitignore index d1c8a56e869..a906ed007c6 100644 --- a/.gitignore +++ b/.gitignore @@ -85,6 +85,9 @@ hie.yaml hie.orig.yaml stack-dev.yaml +# HIE db files (e.g. generated for stan) +*.hie + # generated files under .local .local @@ -102,4 +105,4 @@ telepresence.log # local config .envrc.local -cabal.project.local \ No newline at end of file +cabal.project.local diff --git a/CHANGELOG.md b/CHANGELOG.md index 67998fb7958..e6b66eb36bf 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,80 @@ +# [2022-01-18] + +## Release notes + +* This release introduces a mandatory `federationDomain` configuration setting to cargohold. Please update your `values/wire-server/values.yaml` to set `cargohold.settings.federationDomain` to the same value as the corresponding option in galley (and brig). (#1990) +* The brig server config option `setDefaultLocale` has been replaced by `setDefaultUserLocale` and `setDefaultTemplateLocale` (see docs/reference/config-options.md for details) (#2028) +* From this release onwards, the images for haskell components (brig, galley, + cargohold, etc.) will be using Ubuntu 20.04 as the base. The images are about + 30-35 MB larger than the previous alpine based images. (#1852) +* Wire cloud operators: Make sure [#35](https://github.com/wireapp/ansible-sft/pull/35) is applied to all SFT servers before deploying. (#2030) + +## API changes + +* The deprecated endpoint `GET /teams` now ignores query parameters `ids`, `start` (#2027) +* Add qualified v4 endpoints for downloading and deleting assets. The upload API is still on the same path, but the asset object it returns now contains a `domain` field. (#2002) +* Remove resumable upload API (#1998) + +## Features + +* Allow configuring setDefaultLocale in brig using helm chart (#2025) +* If the guest links team feature is disabled guest links will be revoked. (#1976) +* Revoke guest links if feature is disabled. If the guest links team feature is disabled `get /conversations/join`, `post /conversations/:cnv/code`, and `get /conversations/:cnv/code` will return an error. (#1980) +* Specialize `setDefaultLocale` to distinguish between default user locale and default template locale if the user's locale is n/a. (#2028) + +## Bug fixes and other updates + +* Fix an issue with remote asset streaming (#2037, #2038) + +## Documentation + +* Annotate a first batch of integration and unit tests to map them to externally-facing documentation (#1869) +* Add the description to several test cases (#1991) +* Improve documentation for stern tool and helm chart (#2032) + +## Internal changes + +* Replace servant-generic in Galley with a custom `Named` combinator (#2022) +* The Swagger documentation module is not regenerated anymore if its content is unchanged (#2018) +* cabal-run-integration.sh - remove Makefile indirection (#2044) +* Fix test runner for global cabal make target (#1987) +* The `cabal-install-artefacts.sh` script now creates the `dist` directory if it does not exist (#2007) +* Set `purge: false` in fake-s3 chart (#1981) +* Add missing backendTwo.carghold in integration.yaml (#2039) +* Use GHC 8.10.7 and stack 2.7.3 for builds (#1852) +* Fix non-controversial HLint issues in federator to improve code quality (#2011) +* Added laws for DefaultSsoCode, Now, IdP and ScimExternalIdStore (#1940) +* Moved specifications for Spar effects out of the test suite and into the library (#2005) +* Tag integration tests for security audit. (#2000) +* Upgrade nixpkgs pin used to provision developement dependencies (#1852) +* Servantify Galley Teams API. (#2008, #2010, #2027) +* When sending an activation code, the blocked domains are checked before the whitelist. This only affects the wire SaaS staging environment (there is no whitelist configuration in prod, and blocked domains are not applicable to on-prem installations). (#2023) +* Add a helm chart that deploys [restund](https://docs.wire.com/understand/restund.html) (#2003) +* Publish restund helm chart (#2036) +* Improve optional field API in schema-profunctor (#1988) +* Migrate the public API of Cannon to Servant. (There is an internal API that is not yet migrated.) (#2024) +* sftd chart: Add multiSFT option, remove additionalArgs option (#1992) +* sftd chart: Fix quoted args for multiSFT option (#1999) +* `rangedSchema` does not need to be passed singletons explicitly anymore (#2017) +* Split cannon benchmarks and tests (#1986) +* Tag integration tests for certification. (#1985) +* Tag integration tests for certification. (#2001) +* New internal endpoint to configure the guest links team feature. (#1993) + +## Federation changes + +* Make federator capable of streaming responses (#1966) +* Use `Named` routes for the federation API (#2033) +* Fix Brig's configmap for SFT lookups (#2015) +* SFTD chart: provide a /sft_servers_all.json url that can be used by brig to populate /calls/config/v2 (#2019) +* Allow making HTTP-only requests to SFTs via an IPv4 address (#2026) +* Replace IPv4-HTTP-only Approach to SFT Server Lookup with /sft_servers_all.json (#2030) +* Extend GET /calls/config/v2 to include all SFT servers in federation (#2012) +* Improve Brig's configuration for SFTs and fix a call to SFT servers (#2014) +* Enable downloading assets from a remote (federated) cargohold instance via the v4 API. The content of remote assets is returned as stream with content type `application/octet-stream`. Please refer to the Swagger API documentation for more details. (#2004) + # [2021-12-10] ## Release notes diff --git a/Makefile b/Makefile index 1401d4d4c49..7cdd010749a 100644 --- a/Makefile +++ b/Makefile @@ -7,14 +7,14 @@ NAMESPACE ?= test-$(USER) DOCKER_TAG ?= $(USER) # default helm chart version must be 0.0.42 for local development (because 42 is the answer to the universe and everything) HELM_SEMVER ?= 0.0.42 -# The list of helm charts needed for integration tests on kubernetes -CHARTS_INTEGRATION := wire-server databases-ephemeral fake-aws nginx-ingress-controller nginx-ingress-services wire-server-metrics fluent-bit kibana +# The list of helm charts needed on internal kubernetes testing environments +CHARTS_INTEGRATION := wire-server databases-ephemeral fake-aws nginx-ingress-controller nginx-ingress-services wire-server-metrics fluent-bit kibana sftd restund # The list of helm charts to publish on S3 # FUTUREWORK: after we "inline local subcharts", # (e.g. move charts/brig to charts/wire-server/brig) # this list could be generated from the folder names under ./charts/ like so: # CHARTS_RELEASE := $(shell find charts/ -maxdepth 1 -type d | xargs -n 1 basename | grep -v charts) -CHARTS_RELEASE := wire-server redis-ephemeral databases-ephemeral fake-aws fake-aws-s3 fake-aws-sqs aws-ingress fluent-bit kibana backoffice calling-test demo-smtp elasticsearch-curator elasticsearch-external elasticsearch-ephemeral minio-external cassandra-external nginx-ingress-controller nginx-ingress-services reaper wire-server-metrics sftd +CHARTS_RELEASE := wire-server redis-ephemeral databases-ephemeral fake-aws fake-aws-s3 fake-aws-sqs aws-ingress fluent-bit kibana backoffice calling-test demo-smtp elasticsearch-curator elasticsearch-external elasticsearch-ephemeral minio-external cassandra-external nginx-ingress-controller nginx-ingress-services reaper wire-server-metrics sftd restund BUILDAH_PUSH ?= 0 KIND_CLUSTER_NAME := wire-server BUILDAH_KIND_LOAD ?= 1 @@ -70,9 +70,10 @@ endif # ci here doesn't refer to continuous integration, but to cabal-integration # Usage: make ci package=brig test=1 +# If you want to pass arguments to the test-suite call the script directly. .PHONY: ci ci: c - ./hack/bin/cabal-run-integration.sh $(package) $(pattern) + ./hack/bin/cabal-run-integration.sh $(package) # reset db using cabal .PHONY: db-reset-package @@ -189,30 +190,30 @@ i-%: .PHONY: docker-prebuilder docker-prebuilder: # `docker-prebuilder` needs to be built or pulled only once (unless native dependencies change) - $(MAKE) -C build/alpine prebuilder + $(MAKE) -C build/ubuntu prebuilder .PHONY: docker-deps docker-deps: # `docker-deps` needs to be built or pulled only once (unless native dependencies change) - $(MAKE) -C build/alpine deps + $(MAKE) -C build/ubuntu deps .PHONY: docker-builder docker-builder: # `docker-builder` needs to be built or pulled only once (unless native dependencies change) - $(MAKE) -C build/alpine builder + $(MAKE) -C build/ubuntu builder .PHONY: docker-intermediate docker-intermediate: # `docker-intermediate` needs to be built whenever code changes - this essentially runs `stack clean && stack install` on the whole repo - docker build -t $(DOCKER_USER)/alpine-intermediate:$(DOCKER_TAG) -f build/alpine/Dockerfile.intermediate --build-arg builder=$(DOCKER_USER)/alpine-builder:develop --build-arg deps=$(DOCKER_USER)/alpine-deps:develop .; - docker tag $(DOCKER_USER)/alpine-intermediate:$(DOCKER_TAG) $(DOCKER_USER)/alpine-intermediate:latest; - if test -n "$$DOCKER_PUSH"; then docker login -u $(DOCKER_USERNAME) -p $(DOCKER_PASSWORD); docker push $(DOCKER_USER)/alpine-intermediate:$(DOCKER_TAG); docker push $(DOCKER_USER)/alpine-intermediate:latest; fi; + docker build -t $(DOCKER_USER)/ubuntu20-intermediate:$(DOCKER_TAG) -f build/ubuntu/Dockerfile.intermediate --build-arg builder=$(DOCKER_USER)/ubuntu20-builder:develop --build-arg deps=$(DOCKER_USER)/ubuntu20-deps:develop .; + docker tag $(DOCKER_USER)/ubuntu20-intermediate:$(DOCKER_TAG) $(DOCKER_USER)/ubuntu20-intermediate:latest; + if test -n "$$DOCKER_PUSH"; then docker login -u $(DOCKER_USERNAME) -p $(DOCKER_PASSWORD); docker push $(DOCKER_USER)/ubuntu20-intermediate:$(DOCKER_TAG); docker push $(DOCKER_USER)/ubuntu20-intermediate:latest; fi; .PHONY: docker-exe-% docker-exe-%: - docker image ls | grep $(DOCKER_USER)/alpine-deps > /dev/null || (echo "'make docker-deps' required.", exit 1) - docker image ls | grep $(DOCKER_USER)/alpine-intermediate > /dev/null || (echo "'make docker-intermediate' required."; exit 1) - docker build -t $(DOCKER_USER)/"$*":$(DOCKER_TAG) -f build/alpine/Dockerfile.executable --build-arg executable="$*" --build-arg intermediate=$(DOCKER_USER)/alpine-intermediate --build-arg deps=$(DOCKER_USER)/alpine-deps . + docker image ls | grep $(DOCKER_USER)/ubuntu20-deps > /dev/null || (echo "'make docker-deps' required.", exit 1) + docker image ls | grep $(DOCKER_USER)/ubuntu20-intermediate > /dev/null || (echo "'make docker-intermediate' required."; exit 1) + docker build -t $(DOCKER_USER)/"$*":$(DOCKER_TAG) -f build/ubuntu/Dockerfile.executable --build-arg executable="$*" --build-arg intermediate=$(DOCKER_USER)/ubuntu20-intermediate --build-arg deps=$(DOCKER_USER)/ubuntu20-deps . docker tag $(DOCKER_USER)/"$*":$(DOCKER_TAG) $(DOCKER_USER)/"$*":latest if test -n "$$DOCKER_PUSH"; then docker login -u $(DOCKER_USERNAME) -p $(DOCKER_PASSWORD); docker push $(DOCKER_USER)/"$*":$(DOCKER_TAG); docker push $(DOCKER_USER)/"$*":latest; fi; @@ -220,8 +221,8 @@ docker-exe-%: docker-services: # make docker-services doesn't compile, only makes small images out of the `docker-intermediate` image # to recompile, run `docker-intermediate` first. - docker image ls | grep $(DOCKER_USER)/alpine-deps > /dev/null || (echo "'make docker-deps' required.", exit 1) - docker image ls | grep $(DOCKER_USER)/alpine-intermediate > /dev/null || (echo "'make docker-intermediate' required."; exit 1) + docker image ls | grep $(DOCKER_USER)/ubuntu20-deps > /dev/null || (echo "'make docker-deps' required.", exit 1) + docker image ls | grep $(DOCKER_USER)/ubuntu20-intermediate > /dev/null || (echo "'make docker-intermediate' required."; exit 1) # `make -C services/brig docker` == `make docker-exe-brig docker-exe-brig-integration docker-exe-brig-schema docker-exe-brig-index` $(MAKE) -C services/brig docker $(MAKE) -C services/gundeck docker @@ -235,10 +236,10 @@ docker-services: DOCKER_DEV_NETWORK := --net=host DOCKER_DEV_VOLUMES := -v `pwd`:/wire-server -DOCKER_DEV_IMAGE := quay.io/wire/alpine-builder:$(DOCKER_TAG) +DOCKER_DEV_IMAGE := quay.io/wire/ubuntu20-builder:$(DOCKER_TAG) .PHONY: run-docker-builder run-docker-builder: - @echo "if this does not work, consider 'docker pull', 'docker tag', or 'make -C build-alpine builder'." + @echo "if this does not work, consider 'docker pull', 'docker tag', or 'make -C build/ubuntu builder'." docker run --workdir /wire-server -it $(DOCKER_DEV_NETWORK) $(DOCKER_DEV_VOLUMES) --rm $(DOCKER_DEV_IMAGE) /bin/bash .PHONY: git-add-cassandra-schema diff --git a/README.md b/README.md index f5d86ab3e72..240f9850ea6 100644 --- a/README.md +++ b/README.md @@ -108,22 +108,22 @@ For building nginz, see [services/nginz/README.md](services/nginz/README.md) #### 2. Use docker -*If you don't wish to build all docker images from scratch (e.g. the `alpine-builder` takes a very long time), ready-built images can be downloaded from [here](https://quay.io/organization/wire).* +*If you don't wish to build all docker images from scratch (e.g. the `ubuntu20-builder` takes a very long time), ready-built images can be downloaded from [here](https://quay.io/organization/wire).* If you wish to build your own docker images, you need [docker version >= 17.05](https://www.docker.com/) and [`make`](https://www.gnu.org/software/make/). Then, ```bash # optionally: -# make docker-builder # if you don't run this, it pulls the alpine-builder image from quay.io +# make docker-builder # if you don't run this, it pulls the ubuntu20-builder image from quay.io make docker-deps docker-intermediate docker-services # subsequent times, after changing code, if you wish to re-create docker images, it's sufficient to make docker-intermediate docker-services ``` -will, eventually, have built a range of docker images. Make sure to [give Docker enough RAM](https://github.com/wireapp/wire-server/issues/562); if you see `make: *** [builder] Error 137`, it might be a sign that the build ran out of memory. You can also mix and match – e.g. pull the [`alpine-builder`](https://quay.io/repository/wire/alpine-builder?tab=tags) image and build the rest locally. +will, eventually, have built a range of docker images. Make sure to [give Docker enough RAM](https://github.com/wireapp/wire-server/issues/562); if you see `make: *** [builder] Error 137`, it might be a sign that the build ran out of memory. You can also mix and match – e.g. pull the [`ubuntu20-builder`](https://quay.io/repository/wire/ubuntu20-builder?tab=tags) image and build the rest locally. -See the `Makefile`s and `Dockerfile`s, as well as [build/alpine/README.md](build/alpine/README.md) for details. +See the `Makefile`s and `Dockerfile`s, as well as [build/ubuntu/README.md](build/ubuntu/README.md) for details. ### How to run integration tests diff --git a/build/alpine/Dockerfile.deps b/build/alpine/Dockerfile.deps deleted file mode 100644 index 9ef4958bb15..00000000000 --- a/build/alpine/Dockerfile.deps +++ /dev/null @@ -1,31 +0,0 @@ -# Requires docker >= 17.05 (requires support for multi-stage builds) - -FROM alpine:3.12 as cryptobox-builder - -# compile cryptobox-c -RUN apk add --no-cache cargo file libsodium-dev git && \ - cd /tmp && \ - git clone https://github.com/wireapp/cryptobox-c.git && \ - cd cryptobox-c && \ - export SODIUM_USE_PKG_CONFIG=1 && \ - cargo build --release - -# Minimal dependencies for alpine-compiled, dynamically linked wire-server Haskell services -FROM alpine:3.12 - -COPY --from=cryptobox-builder /tmp/cryptobox-c/target/release/libcryptobox.so /usr/lib - -RUN apk add --no-cache \ - libsodium \ - openssl \ - gmp \ - libgcc \ - libffi \ - libstdc++ \ - icu \ - geoip \ - llvm-libunwind \ - ca-certificates \ - dumb-init \ - libxml2 \ - ncurses diff --git a/build/alpine/Dockerfile.fast-intermediate b/build/alpine/Dockerfile.fast-intermediate deleted file mode 100644 index 91fcf399d68..00000000000 --- a/build/alpine/Dockerfile.fast-intermediate +++ /dev/null @@ -1,26 +0,0 @@ -# Produces intermediate docker image with all executables under /dist using fast option - -# Requires docker version >= 17.05 (requires support for multi-stage builds) -# Requires to have created the wire-server-builder and wire-server-deps docker images (run `make` in this directory) -# Usage example: -# (from wire-server root directory) -# docker build -f build/alpine/Dockerfile.fastintermediate . - -ARG builder=quay.io/wire/alpine-builder -ARG deps=quay.io/wire/alpine-deps - -#--- Builder stage --- -FROM ${builder} as builder - -WORKDIR /wire-server/ - -COPY . /wire-server/ - -RUN make clean fast - -#--- Minified stage --- -FROM ${deps} - -COPY --from=builder /wire-server/dist/ /dist/ -# brig also needs some templates. -COPY --from=builder /wire-server/services/brig/deb/opt/brig/templates/ /dist/templates/ diff --git a/build/alpine/Dockerfile.prebuilder b/build/alpine/Dockerfile.prebuilder deleted file mode 100644 index 3f84e00a7a4..00000000000 --- a/build/alpine/Dockerfile.prebuilder +++ /dev/null @@ -1,54 +0,0 @@ -# Requires docker >= 17.05 (requires support for multi-stage builds) - -FROM alpine:3.12 as cryptobox-builder - -# compile cryptobox-c -RUN apk add --no-cache cargo file libsodium-dev git && \ - cd /tmp && \ - git clone https://github.com/wireapp/cryptobox-c.git && \ - cd cryptobox-c && \ - export SODIUM_USE_PKG_CONFIG=1 && \ - cargo build --release - -FROM alpine:3.12 - -# install cryptobox-c in the new container -COPY --from=cryptobox-builder /tmp/cryptobox-c/target/release/libcryptobox.so /usr/lib/libcryptobox.so -COPY --from=cryptobox-builder /tmp/cryptobox-c/src/cbox.h /usr/include/cbox.h - -# development packages required for wire-server Haskell services -RUN apk add --no-cache \ - alpine-sdk \ - ca-certificates \ - linux-headers \ - zlib-dev \ - perl \ - gmp-dev \ - libffi-dev \ - make \ - libsodium-dev \ - openssl-dev \ - protobuf \ - icu-dev \ - geoip-dev \ - snappy-dev \ - llvm-libunwind-dev \ - bash \ - xz \ - libxml2-dev \ - git \ - ncurses \ - ncurses-dev \ - sed - -# get static version of Haskell Stack and use system ghc by default -ARG STACK_ALPINE_VERSION=2.3.1 -RUN curl -sSfL https://github.com/commercialhaskell/stack/releases/download/v${STACK_ALPINE_VERSION}/stack-${STACK_ALPINE_VERSION}-linux-x86_64-static.tar.gz \ - | tar --wildcards -C /usr/local/bin --strip-components=1 -xzvf - '*/stack' && chmod 755 /usr/local/bin/stack && \ - stack config set system-ghc --global true - -ARG GHC_VERSION=8.8.4 -RUN curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org \ - | BOOTSTRAP_HASKELL_NONINTERACTIVE=1 BOOTSTRAP_HASKELL_GHC_VERSION=${GHC_VERSION} sh - -ENV PATH=/root/.ghcup/bin:${PATH} diff --git a/build/alpine/Makefile b/build/alpine/Makefile deleted file mode 100644 index 90b1aa5e646..00000000000 --- a/build/alpine/Makefile +++ /dev/null @@ -1,23 +0,0 @@ -LANG := en_US.UTF-8 -DOCKER_USER ?= quay.io/wire -DOCKER_TAG ?= local - -default: deps prebuilder builder - -.PHONY: deps -deps: - docker build -t $(DOCKER_USER)/alpine-deps:$(DOCKER_TAG) -f Dockerfile.deps . - docker tag $(DOCKER_USER)/alpine-deps:$(DOCKER_TAG) $(DOCKER_USER)/alpine-deps:latest - if test -n "$$DOCKER_PUSH"; then docker push $(DOCKER_USER)/alpine-deps:$(DOCKER_TAG); docker push $(DOCKER_USER)/alpine-deps:latest; fi; - -.PHONY: prebuilder -prebuilder: - docker build -t $(DOCKER_USER)/alpine-prebuilder:$(DOCKER_TAG) -f Dockerfile.prebuilder . - docker tag $(DOCKER_USER)/alpine-prebuilder:$(DOCKER_TAG) $(DOCKER_USER)/alpine-prebuilder:latest - if test -n "$$DOCKER_PUSH"; then docker push $(DOCKER_USER)/alpine-prebuilder:$(DOCKER_TAG); docker push $(DOCKER_USER)/alpine-prebuilder:latest; fi; - -.PHONY: builder -builder: - docker build --build-arg prebuilder=$(DOCKER_USER)/alpine-prebuilder -t $(DOCKER_USER)/alpine-builder:$(DOCKER_TAG) -f Dockerfile.builder . - docker tag $(DOCKER_USER)/alpine-builder:$(DOCKER_TAG) $(DOCKER_USER)/alpine-builder:latest - if test -n "$$DOCKER_PUSH"; then docker push $(DOCKER_USER)/alpine-builder:$(DOCKER_TAG); docker push $(DOCKER_USER)/alpine-builder:latest; fi; diff --git a/build/alpine/ghc/build.mk b/build/alpine/ghc/build.mk deleted file mode 100644 index c9c5dfebf88..00000000000 --- a/build/alpine/ghc/build.mk +++ /dev/null @@ -1,10 +0,0 @@ -SRC_HC_OPTS = -O -H256m -GhcStage1HcOpts = -O -GhcStage2HcOpts = -O2 -GhcLibHcOpts = -O2 -BUILD_PROF_LIBS = YES -SplitSections = YES -BUILD_SPHINX_HTML = YES -BUILD_SPHINX_PDF = NO -HADDOCK_DOCS = YES -EXTRA_HADDOCK_OPTS += --hyperlinked-source diff --git a/build/alpine/ghc/config.yaml b/build/alpine/ghc/config.yaml deleted file mode 100644 index 063311f04f5..00000000000 --- a/build/alpine/ghc/config.yaml +++ /dev/null @@ -1,10 +0,0 @@ -build: - prefetch: true -ghc-build: standard -system-ghc: true -ghc-options: - "$everything": -split-sections -package-indices: - - name: HackageOrig - download-prefix: https://hackage.haskell.org/package/ - http: https://hackage.haskell.org/01-index.tar.gz diff --git a/build/alpine/Dockerfile.builder b/build/ubuntu/Dockerfile.builder similarity index 66% rename from build/alpine/Dockerfile.builder rename to build/ubuntu/Dockerfile.builder index 52203d7a58b..f34e4fc91d5 100644 --- a/build/alpine/Dockerfile.builder +++ b/build/ubuntu/Dockerfile.builder @@ -1,5 +1,4 @@ -# Requires docker >= 17.05 (requires support for multi-stage builds) -ARG prebuilder=quay.io/wire/alpine-prebuilder +ARG prebuilder=quay.io/wire/ubuntu20-prebuilder FROM ${prebuilder} WORKDIR / @@ -18,9 +17,9 @@ RUN set -x && \ cd /wire-server && \ stack update && \ echo "allow-different-user: true" >> /root/.stack/config.yaml && \ - stack build --haddock --dependencies-only haskell-src-exts && \ - stack build --haddock --no-haddock-hyperlink-source haskell-src-exts && \ - stack build --pedantic --haddock --test --no-run-tests --bench --no-run-benchmarks --dependencies-only -j${THREADS} && \ + stack build --dependencies-only haskell-src-exts && \ + stack build haskell-src-exts && \ + stack build --pedantic --test --no-run-tests --bench --no-run-benchmarks --dependencies-only -j${THREADS} && \ stack install ormolu && \ cd / && \ # we run the build only to cache the built source in /root/.stack, we can remove the source code itself diff --git a/build/ubuntu/Dockerfile.deps b/build/ubuntu/Dockerfile.deps new file mode 100644 index 00000000000..85531bd85fe --- /dev/null +++ b/build/ubuntu/Dockerfile.deps @@ -0,0 +1,33 @@ +FROM ubuntu:20.04 as cryptobox-builder + +# compile cryptobox-c +RUN export DEBIAN_FRONTEND=noninteractive && \ + apt-get update && \ + apt-get install -y cargo file libsodium-dev git pkg-config && \ + cd /tmp && \ + git clone https://github.com/wireapp/cryptobox-c.git && \ + cd cryptobox-c && \ + export SODIUM_USE_PKG_CONFIG=1 && \ + cargo build --release + +# Minimal dependencies for ubuntu-compiled, dynamically linked wire-server Haskell services +FROM ubuntu:20.04 + +COPY --from=cryptobox-builder /tmp/cryptobox-c/target/release/libcryptobox.so /usr/lib + +RUN export DEBIAN_FRONTEND=noninteractive && \ + apt-get update && \ + apt-get install -y \ + libsodium23 \ + libssl1.1 \ + libgmp10 \ + libffi7 \ + libicu66 \ + geoip-database \ + ca-certificates \ + dumb-init \ + libxml2 \ + libncurses6 \ + zlib1g \ + netbase && \ + rm -rf /var/lib/apt/lists/* diff --git a/build/alpine/Dockerfile.executable b/build/ubuntu/Dockerfile.executable similarity index 88% rename from build/alpine/Dockerfile.executable rename to build/ubuntu/Dockerfile.executable index d00e2dc3140..1afa4103b4d 100644 --- a/build/alpine/Dockerfile.executable +++ b/build/ubuntu/Dockerfile.executable @@ -4,10 +4,9 @@ # Requires to have created the wire-server-builder and wire-server-deps docker images (run `make` in this directory) # Usage example: # (from wire-server root directory) -# export EXECUTABLE=galley-schema; docker build -t $EXECUTABLE -f build/alpine/Dockerfile.executable --build-arg executable=$EXECUTABLE . - -ARG intermediate=quay.io/wire/alpine-intermediate -ARG deps=quay.io/wire/alpine-deps +# export EXECUTABLE=galley-schema; docker build -t $EXECUTABLE -f build/ubuntu/Dockerfile.executable --build-arg executable=$EXECUTABLE . +ARG intermediate=quay.io/wire/ubuntu20-intermediate +ARG deps=quay.io/wire/ubuntu20-deps #--- Intermediate stage --- FROM ${intermediate} as intermediate diff --git a/build/ubuntu/Dockerfile.fast-intermediate b/build/ubuntu/Dockerfile.fast-intermediate new file mode 100644 index 00000000000..a4563d0ffca --- /dev/null +++ b/build/ubuntu/Dockerfile.fast-intermediate @@ -0,0 +1,18 @@ +ARG builder=quay.io/wire/ubuntu20-builder +ARG deps=quay.io/wire/ubuntu-deps + +#--- Builder stage --- +FROM ${builder} as builder + +WORKDIR /wire-server/ + +COPY . /wire-server/ + +RUN make clean fast + +#--- Minified stage --- +FROM ${deps} + +COPY --from=builder /wire-server/dist/ /dist/ +# brig also needs some templates. +COPY --from=builder /wire-server/services/brig/deb/opt/brig/templates/ /dist/templates/ diff --git a/build/alpine/Dockerfile.intermediate b/build/ubuntu/Dockerfile.intermediate similarity index 73% rename from build/alpine/Dockerfile.intermediate rename to build/ubuntu/Dockerfile.intermediate index de58eb16181..61562ab4f07 100644 --- a/build/alpine/Dockerfile.intermediate +++ b/build/ubuntu/Dockerfile.intermediate @@ -1,13 +1,12 @@ # Produces intermediate docker image with all executables under /dist -# Requires docker version >= 17.05 (requires support for multi-stage builds) # Requires to have created the wire-server-builder and wire-server-deps docker images (run `make` in this directory) # Usage example: # (from wire-server root directory) -# docker build -f build/alpine/Dockerfile.intermediate . +# docker build -f build/alpine/Dockerfile.intermediate -ARG builder=quay.io/wire/alpine-builder -ARG deps=quay.io/wire/alpine-deps +ARG builder=quay.io/wire/ubuntu20-builder +ARG deps=quay.io/wire/ubuntu20-deps #--- Builder stage --- FROM ${builder} as builder diff --git a/build/ubuntu/Dockerfile.prebuilder b/build/ubuntu/Dockerfile.prebuilder new file mode 100644 index 00000000000..22f8dc04c67 --- /dev/null +++ b/build/ubuntu/Dockerfile.prebuilder @@ -0,0 +1,71 @@ +FROM ubuntu:20.04 as cryptobox-builder + +# compile cryptobox-c +RUN export DEBIAN_FRONTEND=noninteractive && \ + apt-get update && \ + apt-get install -y cargo file libsodium-dev git pkg-config && \ + cd /tmp && \ + git clone https://github.com/wireapp/cryptobox-c.git && \ + cd cryptobox-c && \ + export SODIUM_USE_PKG_CONFIG=1 && \ + cargo build --release + +FROM ubuntu:20.04 + +# install cryptobox-c in the new container +COPY --from=cryptobox-builder /tmp/cryptobox-c/target/release/libcryptobox.so /usr/lib/libcryptobox.so +COPY --from=cryptobox-builder /tmp/cryptobox-c/src/cbox.h /usr/include/cbox.h + +# development packages required for wire-server Haskell services +RUN export DEBIAN_FRONTEND=noninteractive && \ + apt-get update \ + && apt-get install -y \ + ca-certificates \ + build-essential \ + clang \ + debhelper \ + dh-autoreconf \ + libgeoip-dev \ + libglib2.0-dev \ + libicu-dev \ + libleveldb1d \ + libleveldb-dev \ + libossp-uuid-dev \ + libpcre3-dev \ + libsnappy-dev \ + libssl-dev \ + libstatgrab-dev \ + pkg-config \ + tcl \ + upx-ucl \ + zlib1g-dev \ + libbz2-dev \ + liblzma-dev \ + liblzma5 \ + libsodium-dev \ + libsodium23 \ + libpq-dev \ + libxml2-dev \ + libxml2 \ + curl \ + wget \ + git \ + libffi-dev \ + libffi7 \ + libgmp-dev \ + libgmp10 \ + libncurses-dev \ + libncurses5 \ + libtinfo5 \ + protobuf-compiler + +ARG GHC_VERSION=8.10.7 +RUN curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org \ + | BOOTSTRAP_HASKELL_NONINTERACTIVE=1 BOOTSTRAP_HASKELL_GHC_VERSION=${GHC_VERSION} sh + +ENV PATH=/root/.ghcup/bin:${PATH} \ + LANG=C.UTF-8 \ + LC_ALL=C.UTF-8 + +ARG STACK_VERSION=2.7.3 +RUN ghcup install stack ${STACK_VERSION} diff --git a/build/ubuntu/Makefile b/build/ubuntu/Makefile new file mode 100644 index 00000000000..5db0b8c91f0 --- /dev/null +++ b/build/ubuntu/Makefile @@ -0,0 +1,23 @@ +LANG := en_US.UTF-8 +DOCKER_USER ?= quay.io/wire +DOCKER_TAG ?= local + +default: deps prebuilder builder + +.PHONY: deps +deps: + docker build -t $(DOCKER_USER)/ubuntu20-deps:$(DOCKER_TAG) -f Dockerfile.deps . + docker tag $(DOCKER_USER)/ubuntu20-deps:$(DOCKER_TAG) $(DOCKER_USER)/ubuntu20-deps:latest + if test -n "$$DOCKER_PUSH"; then docker push $(DOCKER_USER)/ubuntu20-deps:$(DOCKER_TAG); docker push $(DOCKER_USER)/ubuntu20-deps:latest; fi; + +.PHONY: prebuilder +prebuilder: + docker build -t $(DOCKER_USER)/ubuntu20-prebuilder:$(DOCKER_TAG) -f Dockerfile.prebuilder . + docker tag $(DOCKER_USER)/ubuntu20-prebuilder:$(DOCKER_TAG) $(DOCKER_USER)/ubuntu20-prebuilder:latest + if test -n "$$DOCKER_PUSH"; then docker push $(DOCKER_USER)/ubuntu20-prebuilder:$(DOCKER_TAG); docker push $(DOCKER_USER)/ubuntu20-prebuilder:latest; fi; + +.PHONY: builder +builder: + docker build --build-arg prebuilder=$(DOCKER_USER)/ubuntu20-prebuilder -t $(DOCKER_USER)/ubuntu20-builder:$(DOCKER_TAG) -f Dockerfile.builder . + docker tag $(DOCKER_USER)/ubuntu20-builder:$(DOCKER_TAG) $(DOCKER_USER)/ubuntu20-builder:latest + if test -n "$$DOCKER_PUSH"; then docker push $(DOCKER_USER)/ubuntu20-builder:$(DOCKER_TAG); docker push $(DOCKER_USER)/ubuntu20-builder:latest; fi; diff --git a/build/alpine/README.md b/build/ubuntu/README.md similarity index 76% rename from build/alpine/README.md rename to build/ubuntu/README.md index f42a12ebf98..397afdb5a04 100644 --- a/build/alpine/README.md +++ b/build/ubuntu/README.md @@ -2,15 +2,14 @@ To create docker images, you need to install [docker version >= 17.05](https://www.docker.com/) and [`make`](https://www.gnu.org/software/make/). -* `Dockerfile.builder` contains all the compile-time dependencies necessary to compile any of the Haskell services (it also downloads, builds and caches some Haskell libraries). This image is fairly large, ~4GB uncompressed. -* `Dockerfile.deps` contains all the run-time dependencies e.g. shared libraries, at a total size of ~18MB compressed. +* `Dockerfile.builder` contains all the compile-time dependencies necessary to compile any of the Haskell services (it also downloads, builds and caches some Haskell libraries). This image is fairly large, ~1.7GB compressed. +* `Dockerfile.deps` contains all the run-time dependencies e.g. shared libraries, at a total size of ~52MB compressed. Both of the above need to be built first (only once) to be able to actually build a service docker image. * `Dockerfile.intermediate` - based on `Dockerfile.deps`/`Dockerfile.builder`, this is an intermediate image compiling all dynamically linked binaries (obtained when running `make install` in the top-level directory). * `Dockerfile.executable` - based on `Dockerfile.deps`/`Dockerfile.intermediate`, this extracts a single executable from the intermediate image, yielding a small image (~30MB compressed) with a single dynamically linked binary. - ### Build the `builder` and `deps` docker images locally (from within the `wire-server` directory) @@ -28,7 +27,4 @@ make docker-exe-brig # this only extracts one binary from the intermediate image ## Other dockerfiles -* `Dockerfile.migrations` - same as `Dockerfile.executable`, with a fixed set of database migration binaries. -* `Dockerfile.prebuilder` - dependencies of `Dockerfile.builder` that are expected to change very rarely (GHC, system libraries). Currently we're able to use system GHC, but if we require a newer version of GHC than the one provided by Alpine, we could build GHC in `Dockerfile.prebuilder` (as it has been [done before][2018-11-28]). - -[2018-11-28]: https://github.com/wireapp/wire-server/releases/tag/v2018-11-28 +* `Dockerfile.prebuilder` - dependencies of `Dockerfile.builder` that are expected to change very rarely (GHC, system libraries). diff --git a/cabal.project b/cabal.project index 35f93fb1000..be2bc1ee317 100644 --- a/cabal.project +++ b/cabal.project @@ -1,6 +1,6 @@ -- Generated by stackage-to-hackage -with-compiler: ghc-8.8.4 +with-compiler: ghc-8.10.7 packages: libs/api-bot/ @@ -135,12 +135,12 @@ source-repository-package source-repository-package type: git location: https://github.com/wireapp/http2 - tag: 1ee1ce432d923839dab6782410e91dc17df2a880 + tag: aa3501ad58e1abbd196781fac25a84f41ec2a787 source-repository-package type: git location: https://github.com/wireapp/saml2-web-sso - tag: 60398f375987b74d6b855b5d225e45dc3a96ac06 + tag: 4227e38be5c0810012dc472fc6931f6087fbce68 source-repository-package type: git diff --git a/cabal.project.freeze b/cabal.project.freeze index 22013305b8f..eac24bfbdc7 100644 --- a/cabal.project.freeze +++ b/cabal.project.freeze @@ -1,101 +1,107 @@ constraints: any.AC-Angle ==1.0, any.ALUT ==2.4.0.3, any.ANum ==0.2.0.2, - any.Allure ==0.9.5.0, + any.Agda ==2.6.2, + any.Allure ==0.10.3.0, + any.BNFC ==2.9.3, + any.BNFC-meta ==0.6.1, any.Boolean ==0.2.4, any.BoundedChan ==1.0.3.0, any.ChannelT ==0.0.0.7, any.Chart ==1.9.3, - any.Chart-diagrams ==1.9.3, - any.ChasingBottoms ==1.3.1.9, + any.ChasingBottoms ==1.3.1.11, any.Clipboard ==2.3.2.0, any.ClustalParser ==1.3.0, - any.Color ==0.1.4, - any.ConfigFile ==1.1.4, + any.Color ==0.3.3, any.DAV ==1.3.4, - any.DBFunctor ==0.1.1.1, - any.Decimal ==0.5.1, + any.DBFunctor ==0.1.2.1, + any.Decimal ==0.5.2, any.Diff ==0.4.0, any.ENIG ==0.0.1.0, any.Earley ==0.13.0.1, any.Ebnf2ps ==1.0.15, any.FenwickTree ==0.1.2.1, any.FindBin ==0.0.5, - any.FloatingHex ==0.4, + any.FloatingHex ==0.5, any.FontyFruity ==0.5.3.5, any.ForestStructures ==0.0.1.0, any.GLFW-b ==3.3.0.0, - any.GLURaw ==2.0.0.4, - any.GLUT ==2.7.0.15, + any.GLURaw ==2.0.0.5, + any.GLUT ==2.7.0.16, any.GenericPretty ==1.2.2, - any.Glob ==0.10.1, + any.Glob ==0.10.2, + any.H ==0.9.0.1, any.HCodecs ==0.5.2, any.HDBC ==2.4.0.3, any.HDBC-session ==0.1.2.0, any.HSlippyMap ==3.0.1, - any.HStringTemplate ==0.8.7, - any.HSvm ==0.1.1.3.22, - any.HTF ==0.14.0.3, - any.HTTP ==4000.3.15, - any.HUnit ==1.6.0.0, + any.HStringTemplate ==0.8.8, + any.HSvm ==0.1.1.3.25, + any.HTF ==0.14.0.6, + any.HTTP ==4000.3.16, + any.HUnit ==1.6.2.0, any.HUnit-approx ==1.1.1.1, - any.HaTeX ==3.22.2.0, - any.HaXml ==1.25.5, + any.HaTeX ==3.22.3.0, + any.HaXml ==1.25.7, any.HandsomeSoup ==0.4.2, any.HasBigDecimal ==0.1.1, - any.HaskellNet ==0.5.2, + any.HaskellNet ==0.6, HsOpenSSL -fast-bignum, - any.HsOpenSSL ==0.11.4.19, - any.HsOpenSSL-x509-system ==0.1.0.3, + any.HsOpenSSL ==0.11.7.2, + any.HsOpenSSL-x509-system ==0.1.0.4, any.HsYAML ==0.2.1.0, - any.HsYAML-aeson ==0.2.0.0, - any.IPv6Addr ==1.1.5, + any.HsYAML-aeson ==0.2.0.1, + any.IPv6Addr ==2.0.3, any.Imlib ==0.1.2, any.IntervalMap ==0.6.1.2, - any.JuicyPixels ==3.3.5, + any.JuicyPixels ==3.3.6, any.JuicyPixels-blurhash ==0.1.0.3, - any.JuicyPixels-extra ==0.4.1, + any.JuicyPixels-extra ==0.5.2, any.JuicyPixels-scale-dct ==0.1.2, - any.LambdaHack ==0.9.5.0, + any.LambdaHack ==0.10.3.0, any.LibZip ==1.0.1, any.List ==0.6.2, - any.ListLike ==4.7.2, + any.ListLike ==4.7.6, any.ListTree ==0.2.3, + any.MapWith ==0.2.0.0, any.MemoTrie ==0.6.10, - any.MissingH ==1.4.3.0, any.MonadPrompt ==1.0.0.5, - any.MonadRandom ==0.5.2, + any.MonadRandom ==0.5.3, any.MusicBrainz ==0.4.1, NineP -bytestring-in-base, any.NineP ==0.0.2.1, any.NumInstances ==1.4, - any.ObjectName ==1.1.0.1, + any.ObjectName ==1.1.0.2, any.OneTuple ==0.2.2.1, any.Only ==0.1, any.OpenAL ==1.7.0.5, any.OpenGL ==3.0.3.0, - any.OpenGLRaw ==3.3.4.0, + any.OpenGLRaw ==3.3.4.1, any.ParsecTools ==0.0.2.0, - any.PyF ==0.9.0.2, + any.PyF ==0.9.0.3, any.QuasiText ==0.1.2.6, - any.QuickCheck ==2.14, + QuickCheck -old-random, + any.QuickCheck ==2.14.2, any.RSA ==2.4.1, any.Ranged-sets ==0.4.0, - any.Rasterific ==0.7.5.2, + any.Rasterific ==0.7.5.4, + any.Rattus ==0.5.0.1, any.RefSerialize ==0.4.0, any.SHA ==1.6.4.4, - any.SVGFonts ==1.7.0.1, + any.STMonadTrans ==0.4.6, any.SafeSemaphore ==0.10.1, - any.ShellCheck ==0.7.1, - any.Spintax ==0.3.5, - any.StateVar ==1.2, + any.ShellCheck ==0.7.2, + any.Sit ==0.2021.1.18, + any.Spintax ==0.3.6, + any.StateVar ==1.2.2, + any.Stream ==0.4.7.2, any.TCache ==0.12.1, - any.Taxonomy ==2.1.0, + any.Taxonomy ==2.2.0, any.TypeCompose ==0.9.14, any.ViennaRNAParser ==1.3.3, - any.Win32 ==2.6.1.0, + any.Win32 ==2.6.2.1, any.Win32-notify ==0.3.0.3, - any.X11 ==1.9.2, + any.X11 ==1.10.2, any.X11-xft ==0.3.1, any.Xauth ==0.1, any.abstract-deque ==0.3, @@ -103,40 +109,44 @@ constraints: any.AC-Angle ==1.0, any.accuerr ==0.2.0.2, any.ace ==0.6, any.action-permutations ==0.0.0.1, - any.active ==0.2.0.14, - any.ad ==4.4, + any.ad ==4.4.1, any.adjunctions ==4.4, any.adler32 ==0.1.2.0, - any.advent-of-code-api ==0.2.7.0, + any.aern2-mp ==0.2.8.0, + any.aern2-real ==0.2.8.0, any.aeson ==1.4.7.1, any.aeson-attoparsec ==0.0.0, any.aeson-better-errors ==0.9.1.0, any.aeson-casing ==0.2.0.0, - any.aeson-combinators ==0.0.2.1, - any.aeson-compat ==0.3.9, + any.aeson-combinators ==0.0.5.0, + any.aeson-commit ==1.3, + any.aeson-compat ==0.3.10, any.aeson-default ==0.9.1.0, any.aeson-diff ==1.1.0.9, any.aeson-generic-compat ==0.0.1.3, any.aeson-lens ==0.5.0.0, - any.aeson-optics ==1.1.0.1, + any.aeson-optics ==1.1.1, any.aeson-picker ==0.1.0.5, - any.aeson-pretty ==0.8.8, - any.aeson-qq ==0.8.3, - any.aeson-schemas ==1.2.0, - any.aeson-utils ==0.3.0.2, + any.aeson-pretty ==0.8.9, + any.aeson-qq ==0.8.4, + any.aeson-schemas ==1.3.5, + any.aeson-typescript ==0.3.0.1, + any.aeson-with ==0.1.2.0, any.aeson-yak ==0.1.1.3, - any.aeson-yaml ==1.0.6.0, + any.aeson-yaml ==1.1.0.1, + any.agda2lagda ==0.2021.6.1, any.al ==0.1.4.2, any.alarmclock ==0.7.0.5, any.alerts ==0.1.2.0, - any.alex ==3.2.5, + any.alex ==3.2.6, + any.alex-meta ==0.3.0.13, any.alg ==0.2.13.1, any.algebraic-graphs ==0.5, any.almost-fix ==0.0.2, any.alsa-core ==0.5.0.1, any.alsa-mixer ==0.3.0, any.alsa-pcm ==0.6.1.1, - any.alsa-seq ==0.6.0.7, + any.alsa-seq ==0.6.0.8, any.alternative-vector ==0.0.0, any.amazonka-apigateway ==1.6.1, any.amazonka-application-autoscaling ==1.6.1, @@ -220,154 +230,158 @@ constraints: any.AC-Angle ==1.0, any.amazonka-waf ==1.6.1, any.amazonka-workspaces ==1.6.1, any.amazonka-xray ==1.6.1, - any.amqp ==0.20.0, - any.amqp-utils ==0.4.4.1, + any.amqp ==0.22.0, + any.amqp-utils ==0.6.3.2, any.annotated-wl-pprint ==0.7.0, - any.ansi-terminal ==0.10.3, + any.ansi-terminal ==0.11, any.ansi-wl-pprint ==0.6.9, - any.antiope-core ==7.5.1, - any.antiope-dynamodb ==7.5.1, - any.antiope-messages ==7.5.1, - any.antiope-s3 ==7.5.1, - any.antiope-sns ==7.5.1, - any.antiope-sqs ==7.5.1, - any.apecs ==0.9.2, + any.ap-normalize ==0.1.0.1, + any.apecs ==0.9.3, any.apecs-gloss ==0.2.4, - any.apecs-physics ==0.4.4, + any.apecs-physics ==0.4.5, any.api-field-json-th ==0.1.0.2, + any.api-maker ==0.1.0.0, any.app-settings ==0.2.0.12, any.appar ==0.1.8, any.appendmap ==0.1.5, + any.apply-refact ==0.9.3.0, any.apportionment ==0.0.0.3, - any.approximate ==0.3.2, + any.approximate ==0.3.5, + any.approximate-equality ==1.1.0.2, any.arbor-lru-cache ==0.1.1.1, - any.arithmoi ==0.10.0.0, + any.arithmoi ==0.12.0.1, any.array-memoize ==0.6.0, any.arrow-extras ==0.1.0.1, - any.ascii ==1.0.0.2, - any.ascii-case ==1.0.0.2, - any.ascii-char ==1.0.0.2, - any.ascii-group ==1.0.0.2, - any.ascii-predicates ==1.0.0.2, + any.arrows ==0.4.4.2, + any.ascii ==1.0.1.6, + any.ascii-case ==1.0.0.8, + any.ascii-char ==1.0.0.12, + any.ascii-group ==1.0.0.8, + any.ascii-predicates ==1.0.0.6, any.ascii-progress ==0.3.3.0, - any.ascii-superset ==1.0.0.2, - any.ascii-th ==1.0.0.2, + any.ascii-superset ==1.0.1.8, + any.ascii-th ==1.0.0.6, any.asciidiagram ==1.3.3.3, any.asn1-encoding ==0.9.6, any.asn1-parse ==0.9.5, any.asn1-types ==0.3.4, any.assert-failure ==0.1.2.5, any.assoc ==1.0.2, - any.astro ==0.4.2.1, - any.async ==2.2.2, + any.astro ==0.4.3.0, + any.async ==2.2.4, any.async-extra ==0.2.0.0, + any.async-pool ==0.9.1, any.async-refresh ==0.3.0.0, any.async-refresh-tokens ==0.4.0.0, - any.async-timer ==0.2.0.0, any.atom-basic ==0.2.5, - any.atomic-primops ==0.8.3, + any.atomic-primops ==0.8.4, any.atomic-write ==0.2.0.7, - any.attoparsec ==0.13.2.4, + any.attoparsec ==0.13.2.5, any.attoparsec-base64 ==0.0.0, any.attoparsec-binary ==0.2, any.attoparsec-expr ==0.1.1.2, - any.attoparsec-iso8601 ==1.0.1.0, + any.attoparsec-iso8601 ==1.0.2.0, any.attoparsec-path ==0.0.0.1, any.audacity ==0.0.2, - any.aur ==7.0.4, - any.aura ==3.1.9, + any.aur ==7.0.7, + any.aura ==3.2.5, any.authenticate ==1.3.5, any.authenticate-oauth ==1.6.0.1, - any.auto ==0.4.3.1, any.auto-update ==0.1.6, - any.autoexporter ==1.1.18, - any.avers ==0.0.17.1, + any.autoexporter ==1.1.20, any.avro ==0.5.2.0, - any.aws-cloudfront-signed-cookies ==0.2.0.6, - any.bank-holidays-england ==0.2.0.5, - any.base-compat ==0.11.1, - any.base-compat-batteries ==0.11.1, - any.base-noprelude ==4.13.0.0, - any.base-orphans ==0.8.2, - any.base-prelude ==1.3, + any.aws-cloudfront-signed-cookies ==0.2.0.10, + any.aws-xray-client ==0.1.0.1, + any.aws-xray-client-wai ==0.1.0.1, + any.backprop ==0.2.6.4, + any.backtracking ==0.1.0, + any.bank-holidays-england ==0.2.0.6, + any.barbies ==2.0.3.0, + any.base-compat ==0.11.2, + any.base-compat-batteries ==0.11.2, + any.base-orphans ==0.8.6, + any.base-prelude ==1.4, any.base-unicode-symbols ==0.2.4.2, - any.base16 ==0.2.1.0, - any.base16-bytestring ==0.1.1.7, - any.base16-lens ==0.1.2.0, - any.base32 ==0.1.1.2, - any.base32-lens ==0.1.0.0, + any.base16 ==0.3.0.2, + any.base16-bytestring ==1.0.2.0, + any.base16-lens ==0.1.3.2, + any.base32 ==0.2.1.0, + any.base32-lens ==0.1.1.1, any.base32string ==0.9.1, any.base58-bytestring ==0.1.0, any.base58string ==0.10.0, - any.base64 ==0.4.2.2, - any.base64-bytestring ==1.0.0.3, + any.base64 ==0.4.2.3, + any.base64-bytestring ==1.1.0.0, any.base64-bytestring-type ==1.0.1, - any.base64-lens ==0.3.0, + any.base64-lens ==0.3.1, any.base64-string ==0.2, - any.basement ==0.0.11, + any.basement ==0.0.12, any.basic-prelude ==0.7.0, any.bazel-runfiles ==0.12, any.bbdb ==0.8, + any.bcp47 ==0.2.0.4, + any.bcp47-orphans ==0.1.0.4, any.bcrypt ==0.0.11, - any.bech32 ==1.0.2, + any.bech32 ==1.1.2, any.bech32-th ==1.0.2, any.bench ==1.0.12, - any.benchpress ==0.2.2.14, + any.benchpress ==0.2.2.18, any.between ==0.11.0.0, any.bibtex ==0.1.0.6, - any.bifunctors ==5.5.7, + any.bifunctors ==5.5.11, any.bimap ==0.4.0, any.bimap-server ==0.1.0.1, any.bimaps ==0.1.0.2, - any.bin ==0.1, + any.bin ==0.1.1, any.binary-conduit ==1.3.1, any.binary-ext ==2.0.4, any.binary-ieee754 ==0.1.0.0, + any.binary-instances ==1.0.2, any.binary-list ==1.1.1.2, any.binary-orphans ==1.0.1, - any.binary-parser ==0.5.6, + any.binary-parser ==0.5.7, any.binary-parsers ==0.2.4.0, - any.binary-search ==1.0.0.3, + any.binary-search ==2.0.0, any.binary-shared ==0.8.3, - any.binary-tagged ==0.3, + any.binary-tagged ==0.3.1, any.bindings-DSL ==1.0.25, any.bindings-GLFW ==3.3.2.0, any.bindings-libzip ==1.0.1, any.bindings-uname ==0.1, any.bins ==0.1.2.0, any.bitarray ==0.0.1.1, - any.bits ==0.5.2, + any.bits ==0.5.3, any.bits-extra ==0.0.2.0, any.bitset-word8 ==0.1.1.2, - any.bitvec ==1.0.3.0, + any.bitvec ==1.1.1.0, + any.bitwise-enum ==1.0.1.0, any.blake2 ==0.3.0, - any.blanks ==0.3.0, + any.blanks ==0.5.0, any.blas-carray ==0.1.0.1, - any.blas-comfort-array ==0.0.0.2, + any.blas-comfort-array ==0.0.0.3, any.blas-ffi ==0.1, any.blaze-bootstrap ==0.1.0.1, - any.blaze-builder ==0.4.1.0, + any.blaze-builder ==0.4.2.2, any.blaze-html ==0.9.1.2, - any.blaze-markup ==0.8.2.7, + any.blaze-markup ==0.8.2.8, any.blaze-svg ==0.3.6.1, - any.blaze-textual ==0.2.1.0, + any.blaze-textual ==0.2.2.1, any.bmp ==1.2.6.3, + any.board-games ==0.3, any.boltzmann-samplers ==0.1.1.0, any.boolean-like ==0.1.1.0, - any.boolean-normal-forms ==0.0.1.1, any.boolsimplifier ==0.1.8, any.boots ==0.2.0.1, any.bordacount ==0.1.0.0, - any.boring ==0.1.3, - any.both ==0.1.1.1, - any.bound ==2.0.1, + any.boring ==0.2, + any.both ==0.1.1.2, + any.bound ==2.0.4, any.bounded-queue ==1.0.0, any.boundingboxes ==0.2.3, any.bower-json ==1.0.0.1, any.boxes ==0.1.5, brick +demos, - any.brick ==0.52.1, - any.brittany ==0.12.1.1, + any.brick ==0.62, any.broadcast-chan ==0.2.1.1, any.bsb-http-chunked ==0.0.0.4, bson -_old-network, @@ -375,65 +389,82 @@ constraints: any.AC-Angle ==1.0, any.btrfs ==0.2.0.0, any.buffer-builder ==0.2.4.7, any.buffer-pipe ==0.0, - any.bugsnag-hs ==0.1.0.3, + any.bugsnag-haskell ==0.0.4.1, + any.bugsnag-hs ==0.2.0.7, + any.bugzilla-redhat ==0.3.3, + any.burrito ==1.2.0.3, any.butcher ==1.3.3.2, + any.buttplug-hs-core ==0.1.0.1, any.bv ==0.5, any.bv-little ==1.1.1, - any.byte-count-reader ==0.10.1.1, + any.byte-count-reader ==0.10.1.7, any.byte-order ==0.1.2.0, any.byteable ==0.1.1, any.bytedump ==1.0, any.byteorder ==1.0.4, - any.bytes ==0.17, + any.bytes ==0.17.1, any.byteset ==0.1.1.0, any.bytestring-builder ==0.10.8.2.0, any.bytestring-conversion ==0.3.1, - any.bytestring-lexing ==0.5.0.2, + any.bytestring-lexing ==0.5.0.8, any.bytestring-mmap ==0.2.2, - any.bytestring-strict-builder ==0.4.5.3, + any.bytestring-strict-builder ==0.4.5.4, any.bytestring-to-vector ==0.3.0.1, - any.bytestring-tree-builder ==0.2.7.3, - any.bz2 ==1.0.0.1, + any.bytestring-tree-builder ==0.2.7.9, + bz2 -with-bzlib, + any.bz2 ==1.0.1.0, + any.bzlib ==0.5.1.0, any.bzlib-conduit ==0.3.0.2, - any.c2hs ==0.28.6, + any.c-enum ==0.1.0.1, + any.c-struct ==0.1.0.1, + any.c14n ==0.1.0.1, + any.c2hs ==0.28.8, any.ca-province-codes ==1.0.0.0, - any.cabal-appimage ==0.3.0.0, - any.cabal-debian ==5.0.3, - any.cabal-doctest ==1.0.8, + any.cabal-appimage ==0.3.0.3, + any.cabal-clean ==0.1.20210924, + any.cabal-debian ==5.1, + any.cabal-doctest ==1.0.9, + any.cabal-file ==0.1.1, + any.cabal-flatpak ==0.1.0.2, + any.cabal-plan ==0.7.2.0, cabal-rpm -old-locale, - any.cabal-rpm ==2.0.6, - any.cabal2nix ==2.15.1, - any.cabal2spec ==2.5, + any.cabal-rpm ==2.0.10, + any.cabal2nix ==2.17.0, + any.cabal2spec ==2.6.2, any.cache ==0.1.3.0, + any.cached-json-file ==0.1.0, any.cacophony ==0.10.1, any.calendar-recycling ==0.0.0.1, - any.call-stack ==0.2.0, + any.call-stack ==0.3.0, any.can-i-haz ==0.3.1.0, + any.capability ==0.4.0.0, any.cardano-coin-selection ==1.0.1, any.carray ==0.1.6.8, any.casa-client ==0.0.1, - any.casa-types ==0.0.1, + any.casa-types ==0.0.2, any.case-insensitive ==1.2.1.0, any.cased ==0.1.0.0, - any.cases ==0.1.4, + any.cases ==0.1.4.1, any.casing ==0.1.4.1, cassava -bytestring--lt-0_10_4, any.cassava ==0.5.2.0, - any.cassava-conduit ==0.5.1, - any.cassava-megaparsec ==2.0.2, + any.cassava-conduit ==0.6.0, + any.cassava-megaparsec ==2.0.4, any.cast ==0.1.0.2, any.category ==0.2.5.0, - any.cayley-client ==0.4.13, - any.cborg ==0.2.4.0, - any.cborg-json ==0.2.2.0, - any.cereal ==0.5.8.1, + any.cayley-client ==0.4.16, + any.cborg ==0.2.6.0, + any.cborg-json ==0.2.3.0, + any.cdar-mBound ==0.1.0.4, + any.cereal ==0.5.8.2, any.cereal-conduit ==0.8.0, any.cereal-text ==0.1.0.2, any.cereal-vector ==0.2.0.1, any.cfenv ==0.1.0.0, + any.cgi ==3001.5.0.0, any.chan ==0.0.4.1, - any.character-cases ==0.1.0.4, - any.charset ==0.3.7.1, + any.character-cases ==0.1.0.6, + any.charset ==0.3.9, any.charsetdetect-ae ==1.1.0.4, any.chaselev-deque ==0.5.0.5, any.cheapskate ==0.1.1.2, @@ -441,8 +472,8 @@ constraints: any.AC-Angle ==1.0, any.cheapskate-lucid ==0.1.0.0, any.checkers ==0.5.6, any.checksum ==0.0, - any.chimera ==0.3.1.0, - any.chiphunk ==0.1.2.1, + any.chimera ==0.3.2.0, + any.chiphunk ==0.1.4.0, any.choice ==0.2.2, any.chronologique ==0.3.1.3, any.chronos ==1.1.1, @@ -453,100 +484,105 @@ constraints: any.AC-Angle ==1.0, any.cipher-des ==0.0.6, any.cipher-rc4 ==0.1.4, any.circle-packing ==0.1.0.6, - any.clash-ghc ==1.2.4, - any.clash-lib ==1.2.4, - any.clash-prelude ==1.2.4, + any.circular ==0.4.0.1, + any.citeproc ==0.4.0.1, + any.clash-ghc ==1.4.6, + any.clash-lib ==1.4.6, + any.clash-prelude ==1.4.6, any.classy-prelude ==1.5.0, any.classy-prelude-conduit ==1.5.0, - any.classy-prelude-yesod ==1.5.0, any.clay ==0.13.3, any.clientsession ==0.9.1.2, any.climb ==0.3.3, - any.clock ==0.8, - any.clock-extras ==0.1.0.2, + any.clock ==0.8.2, + any.closed ==0.2.0.1, any.clumpiness ==0.17.0.2, any.cmark ==0.6, - any.cmark-gfm ==0.2.1, + any.cmark-gfm ==0.2.2, any.cmark-lucid ==0.1.0.0, - any.cmdargs ==0.10.20, - any.co-log ==0.4.0.1, - any.co-log-concurrent ==0.5.0.0, + any.cmdargs ==0.10.21, + any.co-log-concurrent ==0.5.1.0, any.co-log-core ==0.2.1.1, - any.co-log-polysemy ==0.0.1.2, - any.code-page ==0.2, + any.code-page ==0.2.1, any.codec-beam ==0.2.0, - any.codec-rpm ==0.2.2, - any.coercible-utils ==0.1.0, + any.collect-errors ==0.1.5.0, any.colorful-monoids ==0.2.1.3, any.colorize-haskell ==1.0.1, - any.colour ==2.3.5, - any.colourista ==0.1.0.0, + any.colour ==2.3.6, any.combinatorial ==0.1.0.1, - any.comfort-array ==0.4, + any.comfort-array ==0.4.1, any.comfort-graph ==0.0.3.1, + any.commonmark ==0.2.1.1, + any.commonmark-extensions ==0.2.2.1, + any.commonmark-pandoc ==0.2.1.1, any.commutative ==0.0.2, - any.comonad ==5.0.6, + any.comonad ==5.0.8, + any.comonad-extras ==4.0.1, any.compactmap ==0.1.4.2.1, - any.compensated ==0.8.1, + any.compdata ==0.12.1, + any.compensated ==0.8.3, any.compiler-warnings ==0.1.0, any.composable-associations ==0.1.0.0, - any.composable-associations-aeson ==0.1.0.0, - any.composition ==1.0.2.1, + any.composable-associations-aeson ==0.1.0.1, + any.composition ==1.0.2.2, any.composition-extra ==2.0.0, any.concise ==0.1.0.1, - any.concurrency ==1.11.0.0, + any.concurrency ==1.11.0.2, any.concurrent-extra ==0.7.0.12, any.concurrent-output ==1.10.12, any.concurrent-split ==0.0.1.1, any.concurrent-supply ==0.1.8, any.cond ==0.4.1.1, - any.conduit ==1.3.2.1, + any.conduino ==0.2.2.0, + any.conduit ==1.3.4.2, any.conduit-algorithms ==0.0.11.0, any.conduit-combinators ==1.3.0, any.conduit-concurrent-map ==0.1.1, any.conduit-extra ==1.3.5, any.conduit-parse ==0.2.1.0, any.conduit-zstd ==0.0.2.0, - any.conferer ==0.4.1.1, - any.conferer-hspec ==0.4.0.1, - any.conferer-source-json ==0.4.0.1, - any.conferer-warp ==0.4.0.1, + any.conferer ==1.1.0.0, + any.conferer-aeson ==1.1.0.1, + any.conferer-hspec ==1.1.0.0, + any.conferer-warp ==1.1.0.0, any.config-ini ==0.2.4.0, any.configurator ==0.3.0.0, any.configurator-export ==0.1.0.1, - any.configurator-pg ==0.2.4, + any.configurator-pg ==0.2.5, any.connection ==0.3.1, any.connection-pool ==0.2.2, any.console-style ==0.0.2.1, any.constraint ==0.1.4.0, any.constraint-tuples ==0.1.2, - any.constraints ==0.12, - any.contravariant ==1.5.2, - any.contravariant-extras ==0.3.5.2, + any.constraints ==0.13.2, + any.constraints-extras ==0.3.2.0, + any.construct ==0.3.0.2, + any.contravariant ==1.5.5, + any.contravariant-extras ==0.3.5.3, any.control-bool ==0.2.1, + any.control-dsl ==0.2.1.3, any.control-monad-free ==0.6.2, any.control-monad-omega ==0.3.2, any.convertible ==1.1.1.0, any.cookie ==0.4.5, - any.core-data ==0.2.1.8, - any.core-program ==0.2.4.5, - any.core-text ==0.2.3.6, + any.core-data ==0.2.1.11, + any.core-program ==0.2.12.0, + any.core-text ==0.3.5.0, any.countable ==1.0, - any.cpio-conduit ==0.7.0, + any.country ==0.2.1, any.cpphs ==1.20.9.1, any.cprng-aes ==0.6.1, any.cpu ==0.1.2, - any.cpuinfo ==0.1.0.1, - any.cql ==4.0.2, + any.cpuinfo ==0.1.0.2, + any.cql ==4.0.3, any.cql-io ==1.1.1, any.cql-io-tinylog ==0.1.0, - any.crackNum ==2.3, + any.crackNum ==3.1, any.crc32c ==0.0.0, any.credential-store ==0.1.2, - any.criterion ==1.5.6.2, - any.criterion-measurement ==0.1.2.0, + any.criterion ==1.5.11.0, + any.criterion-measurement ==0.1.3.0, any.cron ==0.7.0, - any.crypt-sha512 ==0, any.crypto-api ==0.13.3, any.crypto-cipher-types ==0.0.9, any.crypto-enigma ==0.1.1.6, @@ -555,21 +591,19 @@ constraints: any.AC-Angle ==1.0, any.crypto-pubkey-types ==0.4.3, any.crypto-random ==0.0.9, any.crypto-random-api ==0.2.0, - any.cryptocompare ==0.1.1, any.cryptohash ==0.11.9, any.cryptohash-cryptoapi ==0.1.4, - any.cryptohash-md5 ==0.11.100.1, - any.cryptohash-sha1 ==0.11.100.1, - any.cryptohash-sha256 ==0.11.101.0, - any.cryptohash-sha512 ==0.11.100.1, - any.cryptonite ==0.28, + any.cryptohash-md5 ==0.11.101.0, + any.cryptohash-sha1 ==0.11.101.0, + any.cryptohash-sha256 ==0.11.102.1, + any.cryptohash-sha512 ==0.11.101.0, + any.cryptonite ==0.29, any.cryptonite-conduit ==0.2.2, any.cryptonite-openssl ==0.7, any.csp ==1.4.0, any.css-syntax ==0.1.0.0, any.css-text ==0.1.3.0, any.csv ==0.1.2, - any.csv-conduit ==0.7.1.0, any.ctrie ==0.2, any.cubicbezier ==0.6.0.6, any.cubicspline ==0.1.2, @@ -586,17 +620,18 @@ constraints: any.AC-Angle ==1.0, any.cursor-gen ==0.3.0.0, any.cutter ==0.0, any.cyclotomic ==1.1.1, - any.czipwith ==1.0.1.3, + any.czipwith ==1.0.1.4, any.d10 ==0.2.1.6, any.data-accessor ==0.2.3, any.data-accessor-mtl ==0.2.0.4, + any.data-accessor-template ==0.2.1.16, any.data-accessor-transformers ==0.2.1.7, - any.data-ascii ==1.0.0.2, + any.data-ascii ==1.0.0.6, any.data-binary-ieee754 ==0.4.4, any.data-bword ==0.1.0.1, any.data-checked ==0.3, any.data-clist ==0.1.2.3, - any.data-compat ==0.1.0.2, + any.data-compat ==0.1.0.3, any.data-default ==0.7.1.1, any.data-default-class ==0.1.2.0, any.data-default-instances-containers ==0.0.1, @@ -605,112 +640,114 @@ constraints: any.AC-Angle ==1.0, any.data-diverse ==4.7.0.0, any.data-dword ==0.3.2, any.data-endian ==0.1.1, - any.data-fix ==0.2.1, - any.data-forest ==0.1.0.8, - any.data-has ==0.3.0.0, - any.data-interval ==2.0.1, + any.data-fix ==0.3.2, + any.data-forest ==0.1.0.9, + any.data-has ==0.4.0.0, + any.data-hash ==0.2.0.1, + any.data-interval ==2.1.1, any.data-inttrie ==0.1.4, - any.data-lens-light ==0.1.2.2, + any.data-lens-light ==0.1.2.3, any.data-memocombinators ==0.5.1, any.data-msgpack ==0.0.13, any.data-msgpack-types ==0.0.3, - any.data-or ==1.0.0.5, + any.data-or ==1.0.0.7, any.data-ordlist ==0.4.7.0, any.data-ref ==0.0.2, - any.data-reify ==0.6.1, - any.data-serializer ==0.3.4.1, + any.data-reify ==0.6.3, + any.data-serializer ==0.3.5, any.data-textual ==0.3.0.3, any.data-timeout ==0.3.1, - any.data-tree-print ==0.1.0.2, any.datadog ==0.2.5.0, any.dataurl ==0.1.0.0, - any.dbus ==1.2.16, + any.dbus ==1.2.17, any.dbus-hslogger ==0.1.0.1, any.debian ==4.0.2, - any.debian-build ==0.10.2.0, + any.debian-build ==0.10.2.1, any.debug-trace-var ==0.2.0, - any.dec ==0.0.3, - any.declarative ==0.5.3, + any.dec ==0.0.4, + any.declarative ==0.5.4, any.deepseq-generics ==0.2.0.0, any.deepseq-instances ==0.1.0.1, - any.deferred-folds ==0.9.10.1, - any.dejafu ==2.3.0.1, + any.deferred-folds ==0.9.17, + any.dejafu ==2.4.0.3, any.dense-linear-algebra ==0.1.0.0, - any.depq ==0.4.1.0, - any.deque ==0.4.3, + any.dependent-map ==0.4.0.0, + any.dependent-sum ==0.7.1.0, + any.dependent-sum-template ==0.1.0.3, + any.depq ==0.4.2, + any.deque ==0.4.4, + any.derive-topdown ==0.0.2.2, any.deriveJsonNoPrefix ==0.1.0.1, any.deriving-aeson ==0.2.5, - any.deriving-compat ==0.5.9, - any.derulo ==1.0.9, - any.detour-via-sci ==1.0.0, - any.dhall ==1.32.0, - any.dhall-bash ==1.0.30, - any.dhall-json ==1.6.4, - any.dhall-lsp-server ==1.0.8, - any.dhall-yaml ==1.1.0, + any.deriving-compat ==0.5.10, + any.derulo ==1.0.10, + any.dhall ==1.39.0, + any.dhall-bash ==1.0.37, + any.dhall-json ==1.7.7, + any.dhall-lsp-server ==1.0.16, + any.dhall-yaml ==1.2.7, any.di-core ==1.0.4, any.di-monad ==1.3.1, - any.diagrams ==1.4, - any.diagrams-contrib ==1.4.4, - any.diagrams-core ==1.4.2, - any.diagrams-lib ==1.4.3, - any.diagrams-postscript ==1.5, - any.diagrams-rasterific ==1.4.2, - any.diagrams-solve ==0.1.2, - any.diagrams-svg ==1.4.3, - any.dialogflow-fulfillment ==0.1.1.3, + any.diagrams-solve ==0.1.3, + any.dialogflow-fulfillment ==0.1.1.4, any.dictionary-sharing ==0.1.0.0, - any.digest ==0.0.1.2, + any.digest ==0.0.1.3, any.digits ==0.3.1, - any.dimensional ==1.3, + any.dimensional ==1.4, + any.direct-sqlite ==2.3.26, any.directory-tree ==0.12.1, + any.dirichlet ==0.1.0.5, any.discount ==0.1.1, any.disk-free-space ==0.1.0.1, any.distributed-closure ==0.4.2.0, - any.distribution-nixpkgs ==1.3.1, + any.distribution-nixpkgs ==1.5.0, any.distribution-opensuse ==1.1.1, - any.distributive ==0.6.2, - any.dl-fedora ==0.7.5, - any.dlist ==0.8.0.8, + any.distributive ==0.6.2.1, + any.dl-fedora ==0.9.2, + any.dlist ==1.0, any.dlist-instances ==0.1.1.1, any.dlist-nonempty ==0.1.1, any.dns ==4.0.1, any.do-list ==1.0.1, any.do-notation ==0.1.0.2, any.dockerfile ==0.2.0, - any.doclayout ==0.3, - any.doctemplates ==0.8.2, - any.doctest ==0.16.3, + any.doclayout ==0.3.1.1, + any.doctemplates ==0.9, + any.doctest ==0.17, any.doctest-discover ==0.2.0.0, - any.doctest-driver-gen ==0.3.0.2, + any.doctest-driver-gen ==0.3.0.5, + any.doctest-exitcode-stdio ==0.0, + any.doctest-extract ==0.1, + any.doctest-lib ==0.1, any.doldol ==0.4.1.2, + any.dot ==0.3, any.dotenv ==0.8.0.7, any.dotgen ==0.4.3, any.dotnet-timespan ==0.0.1.0, any.double-conversion ==2.0.2.0, any.download ==0.3.2.7, + any.download-curl ==0.1.4, any.drinkery ==0.4, any.dsp ==0.2.5.1, any.dual ==0.1.1.1, - any.dual-tree ==0.2.2.1, any.dublincore-xml-conduit ==0.1.0.2, any.dunai ==0.7.0, - any.duration ==0.1.0.0, + any.duration ==0.2.0.0, any.dvorak ==0.1.0.0, any.dynamic-state ==0.3.1, - any.dyre ==0.8.12, + any.dyre ==0.9.1, any.eap ==0.9.0.2, any.earcut ==0.1.0.4, any.easy-file ==0.2.2, - any.echo ==0.1.3, + any.echo ==0.1.4, any.ecstasy ==0.2.1.0, any.ed25519 ==0.0.5.0, any.edit-distance ==0.2.2.1, any.edit-distance-vector ==1.0.0.4, any.editor-open ==0.6.0.0, - any.egison ==4.0.3, - any.egison-pattern-src ==0.2.1.0, - any.egison-pattern-src-th-mode ==0.2.1.1, + any.egison ==4.1.2, + any.egison-pattern-src ==0.2.1.2, + any.egison-pattern-src-th-mode ==0.2.1.2, any.either ==5.0.1.1, any.either-both ==0.1.1.1, any.either-unwrap ==1.1, @@ -720,121 +757,139 @@ constraints: any.AC-Angle ==1.0, any.ekg-statsd ==0.2.5.0, any.elerea ==2.9.0, any.elf ==0.30, - any.eliminators ==0.6, + any.eliminators ==0.7, any.elm-bridge ==0.6.1, any.elm-core-sources ==1.0.0, any.elm-export ==0.6.0.1, - any.elm2nix ==0.2, - any.emacs-module ==0.1.1, - any.email-validate ==2.3.2.13, - any.emojis ==0.1, + any.elm2nix ==0.2.1, + any.elynx ==0.5.1.1, + any.elynx-markov ==0.5.1.1, + any.elynx-nexus ==0.5.1.1, + any.elynx-seq ==0.5.1.1, + any.elynx-tools ==0.5.1.1, + any.elynx-tree ==0.5.1.1, + any.email-validate ==2.3.2.15, + any.emd ==0.2.0.0, + any.emojis ==0.1.2, any.enclosed-exceptions ==1.0.3, - any.entropy ==0.4.1.6, + any.entropy ==0.4.1.7, any.enum-subset-generate ==0.1.0.0, any.enummapset ==0.6.0.3, any.enumset ==0.0.5, any.envelope ==0.2.2.0, + any.envparse ==0.4.1, any.envy ==2.1.0.0, any.epub-metadata ==4.5, - any.eq ==4.2, + any.eq ==4.2.1, any.equal-files ==0.0.5.3, - any.equational-reasoning ==0.6.0.3, + any.equational-reasoning ==0.7.0.1, + any.equivalence ==0.3.5, any.erf ==2.0.0.0, + any.error-or ==0.1.2.0, + any.error-or-utils ==0.1.1, any.errors ==2.3.0, any.errors-ext ==0.4.2, - any.ersatz ==0.4.8, - any.esqueleto ==3.3.3.3, - any.essence-of-live-coding ==0.1.0.3, - any.essence-of-live-coding-gloss ==0.1.0.3, - any.essence-of-live-coding-pulse ==0.1.0.3, - any.essence-of-live-coding-quickcheck ==0.1.0.3, + any.ersatz ==0.4.10, + any.esqueleto ==3.5.3.0, + any.essence-of-live-coding ==0.2.5, + any.essence-of-live-coding-gloss ==0.2.5, + any.essence-of-live-coding-pulse ==0.2.5, + any.essence-of-live-coding-quickcheck ==0.2.5, any.etc ==0.4.1.0, + any.eve ==0.1.9.0, any.event-list ==0.1.2, any.eventful-core ==0.2.0, any.eventful-test-helpers ==0.2.0, any.eventstore ==1.4.1, any.every ==0.0.1, - any.exact-combinatorics ==0.2.0.9, + any.exact-combinatorics ==0.2.0.11, any.exact-pi ==0.5.0.1, - any.exception-hierarchy ==0.1.0.3, + any.exception-hierarchy ==0.1.0.4, any.exception-mtl ==0.4.0.1, - any.exception-transformers ==0.4.0.9, + any.exception-transformers ==0.4.0.10, + any.exception-via ==0.1.0.0, any.exceptions ==0.10.4, any.executable-path ==0.0.3.1, any.exit-codes ==1.0.0, any.exomizer ==1.0.0, - any.exp-pairs ==0.2.0.0, + any.exp-pairs ==0.2.1.0, + any.experimenter ==0.1.0.12, any.expiring-cache-map ==0.0.6.1, any.explicit-exception ==0.1.10, - any.express ==0.1.3, + any.express ==0.1.16, any.extended-reals ==0.2.4.0, any.extensible-effects ==5.0.0.1, any.extensible-exceptions ==0.1.1.4, - any.extra ==1.7.8, + any.extra ==1.7.9, any.extractable-singleton ==0.0.1, - any.extrapolate ==0.4.2, + any.extrapolate ==0.4.6, any.fail ==4.9.0.0, any.failable ==1.2.4.0, - any.fakedata ==0.6.1, - any.farmhash ==0.1.0.5, - any.fast-digits ==0.3.0.0, - any.fast-logger ==3.0.1, + any.fakedata ==0.8.0, + any.fakedata-parser ==0.1.0.0, + any.fakefs ==0.3.0.2, + any.fakepull ==0.3.0.2, + any.faktory ==1.0.3.1, + any.fast-digits ==0.3.1.0, + any.fast-logger ==3.0.5, any.fast-math ==1.0.2, any.fb ==2.1.1, + any.fclabels ==2.0.5.1, any.feature-flags ==0.1.0.1, any.fedora-dists ==1.1.2, any.fedora-haskell-tools ==0.9, - any.feed ==1.3.0.1, - any.fft ==0.1.8.6, + any.feed ==1.3.2.0, + any.fft ==0.1.8.7, any.fgl ==5.7.0.3, - any.file-embed ==0.0.11.2, + any.file-embed ==0.0.15.0, any.file-embed-lzma ==0, - any.file-modules ==0.1.2.4, any.file-path-th ==0.1.0.0, - any.filecache ==0.4.1, any.filelock ==0.1.1.5, any.filemanip ==0.3.6.3, + any.filepath-bytestring ==1.4.2.1.8, any.filepattern ==0.1.2, any.fileplow ==0.1.0.0, any.filtrable ==0.1.4.0, - any.fin ==0.1.1, + any.fin ==0.2, any.fingertree ==0.1.4.2, any.finite-typelits ==0.1.4.2, - any.first-class-families ==0.8.0.0, + any.first-class-families ==0.8.0.1, any.first-class-patterns ==0.3.2.5, - any.fitspec ==0.4.8, + any.fitspec ==0.4.10, + any.fix-whitespace ==0.0.7, any.fixed ==0.3, - any.fixed-length ==0.2.2, + any.fixed-length ==0.2.3, any.fixed-vector ==1.2.0.0, - any.fixed-vector-hetero ==0.6.0.0, + any.fixed-vector-hetero ==0.6.1.1, any.flac ==0.2.0, any.flac-picture ==0.1.2, - any.flags-applicative ==0.1.0.2, + any.flags-applicative ==0.1.0.3, any.flat ==0.4.4, - any.flat-mcmc ==1.5.1, + any.flat-mcmc ==1.5.2, + any.flexible-defaults ==0.0.3, any.floatshow ==0.2.4, - any.flow ==1.0.21, + any.flow ==1.0.22, any.flush-queue ==1.0.0, any.fmlist ==0.9.4, - any.fmt ==0.6.1.2, + any.fmt ==0.6.3.0, any.fn ==0.3.0.2, - any.focus ==1.0.1.3, + any.focus ==1.0.3, any.focuslist ==0.1.0.2, any.fold-debounce ==0.2.0.9, - any.fold-debounce-conduit ==0.2.0.5, + any.fold-debounce-conduit ==0.2.0.6, any.foldable1 ==0.1.0.0, - any.foldl ==1.4.6, - any.folds ==0.7.5, + any.foldl ==1.4.12, + any.folds ==0.7.7, any.follow-file ==0.0.3, - any.force-layout ==0.4.0.6, any.foreign-store ==0.2, any.forkable-monad ==0.2.0.3, any.forma ==1.1.3, any.format-numbers ==0.1.0.1, - any.formatting ==6.3.7, - any.foundation ==0.0.25, - any.free ==5.1.3, - any.free-categories ==0.2.0.0, + any.formatting ==7.1.3, + any.foundation ==0.0.26.1, + any.fourmolu ==0.3.0.0, + any.free ==5.1.7, + any.free-categories ==0.2.0.2, any.free-vl ==0.1.4, any.freenect ==1.2.1, any.freer-simple ==1.2.1.1, @@ -849,34 +904,39 @@ constraints: any.AC-Angle ==1.0, any.funcmp ==1.9, any.function-builder ==0.3.0.1, functor-classes-compat +containers, - any.functor-classes-compat ==1, - any.fused-effects ==1.0.2.2, - any.fusion-plugin ==0.2.1, + any.functor-classes-compat ==1.0.1, + any.functor-combinators ==0.3.6.0, + any.fusion-plugin ==0.2.3, any.fusion-plugin-types ==0.1.0, any.fuzzcheck ==0.1.1, - any.fuzzy ==0.1.0.0, + any.fuzzy ==0.1.0.1, any.fuzzy-dates ==0.1.1.2, any.fuzzy-time ==0.1.0.0, - any.fuzzyset ==0.2.0, + any.fuzzyset ==0.2.2, any.gauge ==0.2.5, any.gd ==3000.7.3, any.gdp ==0.0.3.0, any.general-games ==1.1.1, + any.generic-aeson ==0.2.0.13, any.generic-arbitrary ==0.1.0, any.generic-constraints ==1.1.1.1, - any.generic-data ==0.8.3.0, - any.generic-deriving ==1.13.1, - any.generic-lens ==2.0.0.0, - any.generic-lens-core ==2.0.0.0, + any.generic-data ==0.9.2.1, + any.generic-data-surgery ==0.3.0.0, + any.generic-deriving ==1.14.1, + any.generic-functor ==0.2.0.0, + any.generic-lens ==2.1.0.0, + any.generic-lens-core ==2.1.0.0, any.generic-monoid ==0.1.0.1, - any.generic-optics ==2.0.0.0, - any.generic-random ==1.3.0.1, - any.generics-sop ==0.5.1.0, + any.generic-optics ==2.1.0.0, + any.generic-random ==1.4.0.0, + any.generics-eot ==0.4.0.1, + any.generics-sop ==0.5.1.1, any.generics-sop-lens ==0.2.0.1, - any.genvalidity ==0.11.0.0, + any.geniplate-mirror ==0.7.8, + any.genvalidity ==0.11.0.2, any.genvalidity-aeson ==0.3.0.0, any.genvalidity-bytestring ==0.6.0.0, - any.genvalidity-containers ==0.8.0.2, + any.genvalidity-containers ==0.9.0.0, any.genvalidity-criterion ==0.2.0.0, any.genvalidity-hspec ==0.7.0.4, any.genvalidity-hspec-aeson ==0.3.1.1, @@ -888,261 +948,286 @@ constraints: any.AC-Angle ==1.0, any.genvalidity-mergeful ==0.2.0.0, any.genvalidity-mergeless ==0.2.0.0, any.genvalidity-path ==0.3.0.4, + any.genvalidity-persistent ==0.0.0.0, any.genvalidity-property ==0.5.0.1, any.genvalidity-scientific ==0.2.1.1, + any.genvalidity-sydtest ==0.0.0.0, + any.genvalidity-sydtest-aeson ==0.0.0.0, + any.genvalidity-sydtest-hashable ==0.0.0.0, + any.genvalidity-sydtest-lens ==0.0.0.0, + any.genvalidity-sydtest-persistent ==0.0.0.1, any.genvalidity-text ==0.7.0.2, any.genvalidity-time ==0.3.0.0, any.genvalidity-typed-uuid ==0.0.0.2, any.genvalidity-unordered-containers ==0.3.0.1, any.genvalidity-uuid ==0.1.0.4, any.genvalidity-vector ==0.3.0.1, - any.geoip2 ==0.4.0.1, + any.geoip2 ==0.4.1.0, any.geojson ==4.0.2, any.getopt-generics ==0.13.0.4, any.ghc-byteorder ==4.11.0.0.10, - any.ghc-check ==0.5.0.1, - any.ghc-compact ==0.1.0.0, + any.ghc-check ==0.5.0.6, any.ghc-core ==0.5.6, - any.ghc-events ==0.13.0, - any.ghc-exactprint ==0.6.2, - any.ghc-lib ==8.10.2.20200808, + any.ghc-events ==0.17.0, + any.ghc-exactprint ==0.6.4, + any.ghc-lib ==8.10.7.20210828, any.ghc-lib-parser ==8.10.1.20200412, - any.ghc-lib-parser-ex ==8.10.0.16, - any.ghc-parser ==0.2.2.0, + any.ghc-lib-parser-ex ==8.10.0.23, + any.ghc-parser ==0.2.3.0, any.ghc-paths ==0.1.0.12, - any.ghc-prof ==1.4.1.7, - any.ghc-source-gen ==0.4.0.0, + any.ghc-prof ==1.4.1.9, + any.ghc-source-gen ==0.4.2.0, any.ghc-syntax-highlighter ==0.0.6.0, - any.ghc-tcplugins-extra ==0.4, - any.ghc-typelits-extra ==0.4, - any.ghc-typelits-knownnat ==0.7.3, - any.ghc-typelits-natnormalise ==0.7.2, - any.ghc-typelits-presburger ==0.3.0.1, + any.ghc-tcplugins-extra ==0.4.2, + any.ghc-trace-events ==0.1.2.3, + any.ghc-typelits-extra ==0.4.3, + any.ghc-typelits-knownnat ==0.7.6, + any.ghc-typelits-natnormalise ==0.7.6, + any.ghc-typelits-presburger ==0.6.1.0, any.ghci-hexcalc ==0.1.1.0, any.ghcid ==0.8.7, any.ghcjs-codemirror ==0.0.0.2, any.ghost-buster ==0.1.1.0, - any.gi-atk ==2.0.21, - any.gi-cairo ==1.0.23, - any.gi-cairo-connector ==0.0.1, - any.gi-cairo-render ==0.0.1, - any.gi-dbusmenu ==0.4.7, - any.gi-dbusmenugtk3 ==0.4.8, - any.gi-gdk ==3.0.22, - any.gi-gdkpixbuf ==2.0.23, - any.gi-gdkx11 ==3.0.9, - any.gi-gio ==2.0.26, - any.gi-glib ==2.0.23, - any.gi-gobject ==2.0.22, - any.gi-graphene ==1.0.1, - any.gi-gtk ==3.0.33, - any.gi-gtk-hs ==0.3.8.1, - any.gi-pango ==1.0.22, - any.gi-xlib ==2.0.8, + any.gi-atk ==2.0.23, + any.gi-cairo ==1.0.25, + any.gi-dbusmenu ==0.4.9, + any.gi-dbusmenugtk3 ==0.4.10, + any.gi-gdk ==3.0.24, + any.gi-gdkpixbuf ==2.0.26, + any.gi-gdkx11 ==3.0.11, + any.gi-gio ==2.0.28, + any.gi-glib ==2.0.25, + any.gi-gmodule ==2.0.1, + any.gi-gobject ==2.0.26, + any.gi-graphene ==1.0.3, + any.gi-gtk ==3.0.37, + any.gi-gtk-hs ==0.3.11, + any.gi-harfbuzz ==0.0.4, + any.gi-pango ==1.0.24, + any.gi-xlib ==2.0.10, any.ginger ==0.10.1.0, any.gingersnap ==0.3.1.0, - any.giphy-api ==0.7.0.0, - any.githash ==0.1.4.0, + any.githash ==0.1.6.2, + any.github-release ==1.3.8, any.github-rest ==1.0.3, any.github-types ==0.2.1, - any.gitlab-haskell ==0.1.8, + any.github-webhooks ==0.15.0, + any.gitlab-haskell ==0.2.5, any.gitrev ==1.3.1, any.gl ==0.9, - any.glabrous ==2.0.2, - any.gloss ==1.13.1.2, + any.glabrous ==2.0.5, + any.gloss ==1.13.2.1, any.gloss-rendering ==1.13.1.1, any.gluturtle ==0.0.58.1, any.gnuplot ==0.5.6.1, + any.goldplate ==0.2.0, any.google-isbn ==1.0.3, - any.gothic ==0.1.5, + any.gopher-proxy ==0.1.1.2, + any.gothic ==0.1.7, any.gpolyline ==0.1.0.1, any.graph-core ==0.3.0.0, any.graph-wrapper ==0.2.6.0, any.graphite ==0.10.0.1, + any.graphql-client ==1.1.1, any.graphs ==0.7.1, + any.graphula ==2.0.1.0, any.graphviz ==2999.20.1.0, any.gravatar ==0.8.0, greskell -hint-test, - any.greskell ==1.1.0.3, - any.greskell-core ==0.1.3.5, - any.greskell-websocket ==0.1.2.4, + any.greskell ==1.2.0.2, + any.greskell-core ==0.1.3.7, + any.greskell-websocket ==0.1.2.6, any.groom ==0.1.2.1, - any.group-by-date ==0.1.0.3, - any.groups ==0.4.1.0, - any.gtk-sni-tray ==0.1.6.0, + any.group-by-date ==0.1.0.4, + any.groups ==0.5.3, any.gtk-strut ==0.1.3.0, any.guarded-allocation ==0.0.1, - any.hOpenPGP ==2.9.4, - any.hackage-db ==2.1.0, + any.hOpenPGP ==2.9.5, + any.hackage-db ==2.1.2, any.hackage-security ==0.6.0.1, - any.haddock-library ==1.8.0, - any.hadolint ==1.18.0, + any.haddock-library ==1.10.0, any.hadoop-streaming ==0.2.0.3, - any.hakyll ==4.13.4.0, - any.half ==0.3, + any.hakyll-convert ==0.3.0.4, + any.hal ==0.4.8, + any.half ==0.3.1, any.hall-symbols ==0.1.0.6, any.hamtsolo ==1.0.3, - any.hapistrano ==0.4.1.2, - any.happstack-server ==7.6.1, - any.happy ==1.19.12, - any.hasbolt ==0.1.4.3, + any.hapistrano ==0.4.3.0, + any.happstack-server ==7.7.1.1, + any.happy ==1.20.0, + any.happy-meta ==0.2.0.11, + any.hasbolt ==0.1.6.1, any.hashable ==1.3.0.0, - any.hashable-time ==0.2.0.2, + any.hashable-time ==0.2.1, any.hashids ==1.0.2.4, + any.hashing ==0.1.0.1, any.hashmap ==1.3.3, - any.hashtables ==1.2.4.1, - any.haskeline ==0.7.5.0, - any.haskell-gi ==0.23.1, - any.haskell-gi-base ==0.23.0, + any.hashtables ==1.2.4.2, + any.haskeline ==0.8.2, + any.haskell-awk ==1.2.0.1, + any.haskell-gi ==0.25.0, + any.haskell-gi-base ==0.25.0, any.haskell-gi-overloading ==1.0, - any.haskell-igraph ==0.8.0, any.haskell-import-graph ==1.0.4, any.haskell-lexer ==1.1, - any.haskell-lsp ==0.22.0.0, - any.haskell-lsp-types ==0.22.0.0, + any.haskell-lsp ==0.24.0.0, + any.haskell-lsp-types ==0.24.0.0, any.haskell-names ==0.9.9, any.haskell-src ==1.0.3.1, any.haskell-src-exts ==1.23.1, any.haskell-src-exts-util ==0.2.5, - any.haskell-src-meta ==0.8.5, + any.haskell-src-meta ==0.8.7, any.haskey-btree ==0.3.0.1, - any.haskoin-core ==0.13.4, - any.haskoin-node ==0.13.0, - any.hasql ==1.4.3, + any.hasktags ==0.72.0, + any.hasql ==1.4.5.3, + any.hasql-notifications ==0.2.0.0, any.hasql-optparse-applicative ==0.3.0.6, any.hasql-pool ==0.5.2, - any.hasql-transaction ==1.0.0.1, - any.hasty-hamiltonian ==1.3.3, + any.hasql-queue ==1.2.0.2, + any.hasql-transaction ==1.0.1, + any.hasty-hamiltonian ==1.3.4, any.haxr ==3000.11.4.1, any.hdaemonize ==0.5.6, - any.headroom ==0.2.1.0, + any.headroom ==0.4.2.0, any.heap ==1.0.4, - any.heaps ==0.3.6.1, + any.heaps ==0.4, any.hebrew-time ==0.1.2, - any.hedgehog ==1.0.3, + any.hedgehog ==1.0.5, any.hedgehog-corpus ==0.2.0, - any.hedgehog-fakedata ==0.0.1.3, + any.hedgehog-fakedata ==0.0.1.4, any.hedgehog-fn ==1.0, any.hedgehog-quickcheck ==0.1.1, - any.hedis ==0.12.14, + any.hedis ==0.14.4, + any.hedn ==0.3.0.4, any.here ==1.2.13, any.heredoc ==0.2.0.0, - any.heterocephalus ==1.0.5.3, + any.heterocephalus ==1.0.5.4, any.hex ==0.2.0, any.hexml ==0.3.4, any.hexml-lens ==0.2.1, any.hexpat ==0.20.13, - any.hexstring ==0.11.1, any.hformat ==0.3.3.1, any.hfsevents ==0.1.6, - any.hi-file-parser ==0.1.0.0, - any.hidapi ==0.1.5, - any.hie-bios ==0.5.1, - any.higher-leveldb ==0.5.0.2, + any.hgeometry ==0.12.0.4, + any.hgeometry-combinatorial ==0.12.0.3, + any.hgrev ==0.2.6, + any.hi-file-parser ==0.1.2.0, + any.hidapi ==0.1.7, + any.hie-bios ==0.7.6, + any.higher-leveldb ==0.6.0.0, any.highlighting-kate ==0.6.4, any.hinfo ==0.0.3.0, - any.hinotify ==0.4, - any.hint ==0.9.0.3, + any.hinotify ==0.4.1, + any.hint ==0.9.0.4, any.hjsmin ==0.2.0.4, any.hkd-default ==1.1.0.0, - any.hkgr ==0.2.6.1, - any.hledger ==1.18.1, - any.hledger-iadd ==1.3.12, - any.hledger-lib ==1.18.1, - any.hledger-stockquotes ==0.1.0.0, - any.hledger-ui ==1.18.1, - any.hledger-web ==1.18.1, + any.hkgr ==0.3, + any.hledger ==1.21, + any.hledger-iadd ==1.3.14, + any.hledger-interest ==1.6.1, + any.hledger-lib ==1.21, + any.hledger-stockquotes ==0.1.2.0, + any.hledger-ui ==1.21, + any.hledger-web ==1.21, any.hlibcpuid ==0.2.0, any.hlibgit2 ==0.18.0.16, - any.hlint ==3.1.6, - any.hmatrix ==0.20.0.0, + any.hlibsass ==0.1.10.1, + any.hlint ==3.2.7, + any.hmatrix ==0.20.2, + any.hmatrix-backprop ==0.1.3.0, any.hmatrix-gsl ==0.19.0.1, any.hmatrix-gsl-stats ==0.4.1.8, any.hmatrix-morpheus ==0.1.1.2, any.hmatrix-vector-sized ==0.1.3.0, + any.hmm-lapack ==0.4, any.hmpfr ==0.4.4, any.hnock ==0.4.0, - any.hoauth2 ==1.14.0, - any.hopenpgp-tools ==0.23.1, + any.hoauth2 ==1.16.0, + any.hoogle ==5.0.18.2, + any.hopenpgp-tools ==0.23.6, any.hopenssl ==2.2.4, any.hopfli ==0.2.2.1, - any.hosc ==0.17, + any.hosc ==0.18.1, any.hostname ==1.0, any.hostname-validate ==1.0.0, any.hourglass ==0.2.12, any.hourglass-orphans ==0.1.0.0, - any.hp2pretty ==0.9, - any.hpack ==0.34.2, - any.hpack-dhall ==0.5.2, - any.hpc-codecov ==0.2.0.0, + any.hp2pretty ==0.10, + any.hpack ==0.34.5, + any.hpack-dhall ==0.5.3, + any.hpc-codecov ==0.3.0.0, any.hpc-lcov ==1.0.1, - any.hreader ==1.1.0, - any.hreader-lens ==0.1.3.0, - any.hruby ==0.3.8, + any.hprotoc ==2.4.17, + any.hruby ==0.3.8.1, any.hs-GeoIP ==0.3, any.hs-bibutils ==6.10.0.0, any.hs-functors ==0.1.7.1, any.hs-php-session ==0.0.9.3, - any.hsc2hs ==0.68.7, + any.hs-tags ==0.1.5.2, + any.hsass ==0.8.0, + any.hsc2hs ==0.68.8, any.hscolour ==1.24.4, any.hsdns ==1.8, any.hsebaysdk ==0.4.1.0, - any.hsemail ==2.2.0, - any.hset ==2.2.0, + any.hsemail ==2.2.1, any.hsini ==0.5.1.2, any.hsinstall ==2.6, any.hslogger ==1.3.1.0, - any.hslua ==1.0.3.2, - any.hslua-aeson ==1.0.3, - any.hslua-module-doclayout ==0.1.0, - any.hslua-module-system ==0.2.2, - any.hslua-module-text ==0.2.1, + any.hslua ==1.3.0.2, + any.hslua-aeson ==1.0.3.1, + any.hslua-module-doclayout ==0.2.0.1, + any.hslua-module-path ==0.1.0.1, + any.hslua-module-system ==0.2.2.1, + any.hslua-module-text ==0.3.0.1, any.hsp ==0.10.0, - any.hspec ==2.7.4, + any.hspec ==2.7.10, any.hspec-attoparsec ==0.1.0.2, any.hspec-checkers ==0.1.0.2, any.hspec-contrib ==0.5.1, - any.hspec-core ==2.7.4, - any.hspec-discover ==2.7.4, + any.hspec-core ==2.7.10, + any.hspec-discover ==2.7.10, any.hspec-expectations ==0.8.2, + any.hspec-expectations-json ==1.0.0.4, any.hspec-expectations-lifted ==0.10.0, any.hspec-expectations-pretty-diff ==0.7.2.5, any.hspec-golden ==0.1.0.3, any.hspec-golden-aeson ==0.7.0.0, any.hspec-hedgehog ==0.0.1.2, - any.hspec-leancheck ==0.0.4, - any.hspec-megaparsec ==2.1.0, - any.hspec-meta ==2.6.0, - any.hspec-need-env ==0.1.0.5, + any.hspec-junit-formatter ==1.0.0.5, + any.hspec-leancheck ==0.0.6, + any.hspec-megaparsec ==2.2.0, + any.hspec-meta ==2.7.8, + any.hspec-need-env ==0.1.0.8, any.hspec-parsec ==0, any.hspec-smallcheck ==0.5.2, any.hspec-tables ==0.0.1, - any.hspec-wai-json ==0.10.1, - any.hsshellscript ==3.4.5, + any.hspec-wai-json ==0.11.0, + any.hsshellscript ==3.5.0, any.hsyslog ==5.0.2, any.htaglib ==1.2.0, any.html ==1.0.1.2, - any.html-conduit ==1.3.2.1, - any.html-entities ==1.1.4.3, + any.html-conduit ==1.3.2.2, + any.html-entities ==1.1.4.5, any.html-entity-map ==0.1.0.0, any.htoml ==1.0.0.3, - any.http-api-data ==0.4.1.1, + any.http-api-data ==0.4.2, any.http-client-overrides ==0.1.1.0, - any.http-common ==0.8.2.1, - any.http-date ==0.0.8, + any.http-common ==0.8.3.4, + any.http-date ==0.0.11, any.http-directory ==0.1.8, any.http-download ==0.2.0.0, - any.http-link-header ==1.0.3.1, + any.http-link-header ==1.2.1, any.http-media ==0.8.0.0, + any.http-query ==0.1.0.1, any.http-reverse-proxy ==0.6.0, - any.http-streams ==0.8.7.2, + any.http-streams ==0.8.9.4, any.http-types ==0.12.3, any.httpd-shed ==0.4.1.1, any.human-readable-duration ==0.2.1.4, - any.hunit-dejafu ==2.0.0.4, + any.hunit-dejafu ==2.0.0.5, any.hvect ==0.4.0.0, - any.hvega ==0.9.1.0, - any.hw-balancedparens ==0.4.1.0, + any.hvega ==0.11.0.1, + any.hw-balancedparens ==0.4.1.1, any.hw-bits ==0.7.2.1, any.hw-conduit ==0.2.1.0, any.hw-conduit-merges ==0.2.1.0, @@ -1154,147 +1239,169 @@ constraints: any.AC-Angle ==1.0, any.hw-hspec-hedgehog ==0.1.1.0, any.hw-int ==0.0.2.0, any.hw-json-simd ==0.1.1.0, - any.hw-mquery ==0.2.1.0, + any.hw-kafka-client ==4.0.3, + any.hw-packed-vector ==0.2.1.0, any.hw-parser ==0.1.1.0, any.hw-prim ==0.6.3.0, + any.hw-rankselect ==0.13.4.0, any.hw-rankselect-base ==0.3.4.1, + any.hw-simd ==0.1.2.0, any.hw-streams ==0.0.1.0, any.hw-string-parse ==0.0.0.4, + any.hw-succinct ==0.1.0.1, any.hweblib ==0.6.3, hxt +network-uri, - any.hxt ==9.3.1.18, - any.hxt-charproperties ==9.4.0.0, + any.hxt ==9.3.1.22, + any.hxt-charproperties ==9.5.0.0, any.hxt-css ==0.1.0.3, any.hxt-curl ==9.1.1.1, any.hxt-expat ==9.1.1, hxt-http +network-uri, any.hxt-http ==9.1.5.2, - any.hxt-regex-xmlschema ==9.2.0.3, + any.hxt-regex-xmlschema ==9.2.0.7, any.hxt-tagsoup ==9.1.4, any.hxt-unicode ==9.0.2.4, any.hybrid-vectors ==0.2.2, - any.hyperloglog ==0.4.3, - any.hyphenation ==0.8, - any.hyraxAbif ==0.2.3.21, + any.hyper ==0.2.1.1, + any.hyperloglog ==0.4.5, + any.hyphenation ==0.8.2, any.iconv ==0.4.1.3, any.identicon ==0.2.2, any.ieee754 ==0.8.0, any.if ==0.1.0.0, any.iff ==0.0.6, - any.ihaskell ==0.10.1.2, + any.ihaskell ==0.10.2.1, any.ihs ==0.1.0.3, any.ilist ==0.4.0.1, any.imagesize-conduit ==1.1, any.immortal ==0.3, any.immortal-queue ==0.1.0.1, - any.implicit-hie ==0.1.2.5, + any.implicit-hie ==0.1.2.6, + any.inbox ==0.1.0, any.include-file ==0.1.0.4, - any.incremental-parser ==0.4.0.2, + any.incremental-parser ==0.5.0.2, any.indents ==0.5.0.1, any.indexed ==0.1.3, any.indexed-containers ==0.1.0.2, any.indexed-list-literals ==0.2.1.3, - any.indexed-profunctors ==0.1, + any.indexed-profunctors ==0.1.1, + any.indexed-traversable ==0.1.2, + any.indexed-traversable-instances ==0.1, any.infer-license ==0.2.0, any.inflections ==0.4.0.6, - any.influxdb ==1.7.1.6, + any.influxdb ==1.9.2.1, any.ini ==0.4.1, any.inj ==1.0, - any.inline-c ==0.9.1.0, - any.inline-c-cpp ==0.4.0.2, + any.inline-c ==0.9.1.5, + any.inline-c-cpp ==0.4.0.3, + any.inline-r ==0.10.5, any.inliterate ==0.1.0, - any.insert-ordered-containers ==0.2.3.1, - any.inspection-testing ==0.4.2.4, + any.input-parsers ==0.2.3.1, + any.insert-ordered-containers ==0.2.5.1, + any.inspection-testing ==0.4.6.0, any.instance-control ==0.1.2.0, any.int-cast ==0.2.0.0, - any.integer-logarithms ==1.0.3, - any.integer-roots ==1.0, + any.integer-logarithms ==1.0.3.1, + any.integer-roots ==1.0.1.0, any.integration ==0.2.1, - any.intern ==0.9.2, + any.intern ==0.9.4, any.interpolate ==0.2.1, any.interpolatedstring-perl6 ==1.0.2, - any.interpolation ==0.1.1.1, - any.interpolator ==1.0.0, - any.intervals ==0.9.1, - any.intro ==0.7.0.0, + any.interpolation ==0.1.1.2, + any.interpolator ==1.1.0.2, + any.intervals ==0.9.2, + any.intro ==0.9.0.0, any.intset-imperative ==0.1.0.0, - any.invariant ==0.5.3, + any.invariant ==0.5.5, any.invertible ==0.2.0.7, - any.invertible-grammar ==0.1.3, + any.invertible-grammar ==0.1.3.2, any.invertible-hxt ==0.1, any.io-machine ==0.2.0.0, any.io-manager ==0.1.0.3, any.io-memoize ==1.1.1.0, any.io-region ==0.1.1, any.io-storage ==0.3, - any.io-streams ==1.5.2.0, + any.io-streams ==1.5.2.1, any.io-streams-haproxy ==1.0.1.0, - any.ip6addr ==1.0.1, - any.iproute ==1.7.9, - any.ipynb ==0.1.0.1, + any.ip6addr ==1.0.2, + any.ipa ==0.3.1.1, + any.iproute ==1.7.12, + any.ipynb ==0.1.0.2, any.ipython-kernel ==0.10.2.1, any.irc ==0.6.1.0, - any.irc-client ==1.1.1.1, - any.irc-conduit ==0.3.0.4, - any.irc-ctcp ==0.1.3.0, - any.isbn ==1.0.0.0, + any.irc-client ==1.1.2.2, + any.irc-conduit ==0.3.0.5, + any.irc-ctcp ==0.1.3.1, + any.isbn ==1.1.0.2, any.islink ==0.1.0.0, any.iso3166-country-codes ==0.20140203.8, any.iso639 ==0.1.0.3, any.iso8601-time ==0.1.5, - any.it-has ==0.2.0.0, any.iterable ==3.0, any.ix-shapable ==0.1.0, any.ixset-typed ==0.5, - any.jack ==0.7.1.4, + any.ixset-typed-binary-instance ==0.1.0.2, + any.ixset-typed-conversions ==0.1.2.0, + any.ixset-typed-hashable-instance ==0.1.0.2, + any.jack ==0.7.2, any.jailbreak-cabal ==1.3.5, - any.jira-wiki-markup ==1.1.4, - any.jose ==0.8.3.1, - any.jose-jwt ==0.8.0, + any.jalaali ==1.0.0.0, + any.java-adt ==0.2018.11.4, + any.jira-wiki-markup ==1.4.0, + any.jose ==0.8.4, + any.jose-jwt ==0.9.2, + any.js-chart ==2.9.4.1, any.js-dgtable ==0.5.2, any.js-flot ==0.8.3, any.js-jquery ==3.3.1, - any.json-alt ==1.0.0, - any.json-feed ==1.0.11, + any.json ==0.10, + any.json-feed ==1.0.15, any.json-rpc ==1.0.3, - any.json-rpc-generic ==0.2.1.5, + any.json-rpc-generic ==0.2.1.6, + any.jsonifier ==0.1.1, any.jsonpath ==0.2.0.0, - any.junit-xml ==0.1.0.1, + any.junit-xml ==0.1.0.2, any.justified-containers ==0.3.0.0, any.jwt ==0.10.0, - any.kan-extensions ==5.2, + any.kan-extensions ==5.2.3, any.kanji ==3.4.1, - any.katip ==0.8.5.0, + any.katip ==0.8.7.0, + any.katip-logstash ==0.1.0.0, any.kawhi ==0.3.0, any.kazura-queue ==0.1.0.4, any.kdt ==0.2.4, + any.keep-alive ==0.2.0.0, any.keycode ==0.2.2, any.keys ==3.12.3, + any.ki ==0.2.0.1, any.kind-apply ==0.3.2.0, any.kind-generics ==0.4.1.0, - any.kind-generics-th ==0.2.2.0, + any.kind-generics-th ==0.2.2.2, any.kmeans ==0.1.3, + any.koji ==0.0.2, any.koofr-client ==1.0.0.3, - any.krank ==0.2.2, + any.krank ==0.2.3, any.kubernetes-webhook-haskell ==0.2.0.3, any.l10n ==0.1.0.1, any.labels ==0.3.3, - any.lackey ==1.0.13, + any.lackey ==1.0.16, + any.lambdabot-core ==5.3.0.2, any.lame ==0.2.0, any.language-avro ==0.1.3.1, any.language-bash ==0.9.2, - any.language-c ==0.8.3, - any.language-c-quote ==0.12.2.1, - any.language-docker ==9.1.1, - any.language-haskell-extract ==0.2.4, + any.language-c ==0.9.0.1, + any.language-c-quote ==0.13, + any.language-docker ==10.0.2, any.language-java ==0.2.9, any.language-javascript ==0.7.1.0, any.language-nix ==2.2.0, any.language-protobuf ==1.0.1, - any.language-puppet ==1.4.6.5, + any.language-python ==0.5.8, + any.language-thrift ==0.12.0.0, + any.lapack ==0.3.2, any.lapack-carray ==0.0.3, - any.lapack-comfort-array ==0.0.0.1, - any.lapack-ffi ==0.0.2, + any.lapack-comfort-array ==0.0.1, + any.lapack-ffi ==0.0.3, any.lapack-ffi-tools ==0.1.2.1, any.largeword ==1.2.5, any.latex ==0.1.0.4, @@ -1302,84 +1409,104 @@ constraints: any.AC-Angle ==1.0, any.lawful ==0.1.0.0, any.lazy-csv ==0.5.1, any.lazyio ==0.1.0.4, - any.lca ==0.3.1, - any.leancheck ==0.9.3, + any.lazysmallcheck ==0.6, + any.lca ==0.4, + any.leancheck ==0.9.10, any.leancheck-instances ==0.0.4, any.leapseconds-announced ==2017.1.0.1, any.learn-physics ==0.6.5, - any.lens ==4.18.1, - any.lens-action ==0.2.4, - any.lens-aeson ==1.1, + any.lens ==4.19.2, + any.lens-action ==0.2.6, + any.lens-aeson ==1.1.3, + any.lens-csv ==0.1.1.0, any.lens-datetime ==0.3, any.lens-family ==2.0.0, any.lens-family-core ==2.0.0, - any.lens-family-th ==0.5.1.0, + any.lens-family-th ==0.5.2.1, any.lens-misc ==0.0.2.0, + any.lens-process ==0.4.0.0, any.lens-properties ==4.11.1, - any.lens-regex ==0.1.1, + any.lens-regex ==0.1.3, + any.lens-regex-pcre ==1.1.0.0, any.lenz ==0.4.2.0, any.leveldb-haskell ==0.6.5, + any.libBF ==0.6.2, any.libffi ==0.1, any.libgit ==0.3.1, any.libgraph ==1.14, - any.libmpd ==0.9.1.0, + any.libjwt-typed ==0.2, + any.libmpd ==0.10.0.0, + any.liboath-hs ==0.0.1.2, any.libyaml ==0.1.2, - any.life-sync ==1.1.1.0, - any.lift-generics ==0.1.3, - any.lifted-async ==0.10.1.2, + any.lift-generics ==0.2.1, + any.lift-type ==0.1.0.1, + any.lifted-async ==0.10.2.2, any.lifted-base ==0.2.3.12, any.line ==4.0.1, - any.linear ==1.21.1, + any.linear ==1.21.6, + any.linear-circuit ==0.1.0.2, any.linenoise ==0.3.2, + any.linux-capabilities ==0.1.0.0, any.linux-file-extents ==0.2.0.0, any.linux-namespaces ==0.1.3.0, + any.liquid-fixpoint ==0.8.10.2, any.list-predicate ==0.1.0.1, - any.list-singleton ==1.0.0.4, - any.list-t ==1.0.4, + any.list-singleton ==1.0.0.5, + any.list-t ==1.0.5, + any.list-transformer ==1.0.7, any.listsafe ==0.1.0.1, - any.little-logger ==0.1.0, - any.little-rio ==0.1.1, + any.literatex ==0.1.0.2, + any.little-rio ==0.2.2, any.llvm-hs ==9.0.1, any.llvm-hs-pure ==9.0.0, any.lmdb ==0.2.5, any.load-env ==0.2.1.0, - any.loc ==0.1.3.8, + any.loc ==0.1.3.10, + any.locators ==0.3.0.3, any.loch-th ==0.2.2, any.lockfree-queue ==0.2.3.1, - any.log-base ==0.8.0.1, - any.log-domain ==0.13, - any.logfloat ==0.13.3.3, + any.log-domain ==0.13.2, + any.logfloat ==0.13.4, any.logging ==3.0.5, - any.logging-facade ==0.3.0, + any.logging-facade ==0.3.1, any.logging-facade-syslog ==1, - any.logict ==0.7.0.3, + any.logict ==0.7.1.0, + any.logstash ==0.1.0.1, any.loop ==0.3.0, - any.loopbreaker ==0.1.1.1, any.lrucache ==1.2.0.1, any.lrucaching ==0.3.3, - any.lsp-test ==0.10.3.0, - any.lucid ==2.9.12, + any.lsp ==1.2.0.0, + any.lsp-test ==0.14.0.0, + any.lsp-types ==1.2.0.0, + any.lucid ==2.9.12.1, + any.lucid-cdn ==0.2.2.0, any.lucid-extras ==0.2.2, - any.lukko ==0.1.1.2, + any.lukko ==0.1.1.3, + any.lz4-frame-conduit ==0.1.0.1, any.lzma ==0.0.0.3, - any.lzma-conduit ==1.2.1, - any.machines ==0.7, + any.lzma-clib ==5.2.2, + any.lzma-conduit ==1.2.2, + any.machines ==0.7.2, + any.machines-binary ==7.0.0.0, any.magic ==1.1, + any.magico ==0.0.2.1, any.main-tester ==0.2.0.1, - any.mainland-pretty ==0.7.0.1, + any.mainland-pretty ==0.7.1, any.makefile ==1.1.0.0, any.managed ==1.0.8, - any.markdown ==0.1.17.4, - any.markdown-unlit ==0.5.0, + any.markdown ==0.1.17.5, + any.markdown-unlit ==0.5.1, any.markov-chain ==0.0.3.4, any.markov-chain-usage-model ==0.0.0, - any.massiv ==0.5.4.0, - any.massiv-io ==0.2.1.0, - any.massiv-test ==0.1.4, + any.massiv ==0.6.1.0, + any.massiv-io ==0.4.1.0, + any.massiv-persist ==0.1.0.0, + any.massiv-serialise ==0.1.0.0, + any.massiv-test ==0.1.6.1, any.math-extras ==0.1.1.0, - any.math-functions ==0.3.4.1, + any.math-functions ==0.3.4.2, any.mathexpr ==0.3.0.0, - any.matplotlib ==0.7.5, + any.matplotlib ==0.7.7, any.matrices ==0.5.0, any.matrix ==0.3.6.1, any.matrix-as-xyz ==0.1.2.2, @@ -1388,78 +1515,83 @@ constraints: any.AC-Angle ==1.0, any.maximal-cliques ==0.1.1, any.mbox ==0.3.4, any.mbox-utility ==0.0.3.1, + any.mcmc ==0.5.0.0, any.mcmc-types ==1.0.3, - any.medea ==1.1.2, + any.med-module ==0.1.2.1, + any.medea ==1.2.0, any.median-stream ==0.7.0.0, - any.megaparsec ==8.0.0, - any.megaparsec-tests ==8.0.0, + any.megaparsec ==9.0.1, + any.megaparsec-tests ==9.0.1, any.membrain ==0.0.0.2, any.memory ==0.15.0, any.mercury-api ==0.1.0.2, any.mergeful ==0.2.0.0, any.mergeless ==0.3.0.0, + any.mersenne-random ==1.0.0.1, mersenne-random-pure64 -small_base, any.mersenne-random-pure64 ==0.2.2.0, any.messagepack ==0.5.4, any.metrics ==0.4.1.1, any.mfsolve ==0.3.2.0, - any.microlens ==0.4.11.2, + any.microlens ==0.4.12.0, any.microlens-aeson ==2.3.1, any.microlens-contra ==0.1.0.2, - any.microlens-ghc ==0.4.12, + any.microlens-ghc ==0.4.13.1, any.microlens-mtl ==0.2.0.1, - any.microlens-platform ==0.4.1, + any.microlens-platform ==0.4.2.1, any.microlens-process ==0.2.0.2, - any.microlens-th ==0.4.3.5, + any.microlens-th ==0.4.3.10, any.microspec ==0.2.1.3, - any.microstache ==1.0.1.1, + any.microstache ==1.0.2, any.midair ==0.2.0.1, any.midi ==0.2.2.2, any.mighty-metropolis ==2.0.0, any.mime ==0.4.0.2, - any.mime-mail ==0.5.0, + any.mime-mail ==0.5.1, any.mime-mail-ses ==0.4.3, any.mime-types ==0.1.0.9, any.min-max-pqueue ==0.1.0.2, any.mini-egison ==1.0.0, any.minimal-configuration ==0.1.4, - any.minimorph ==0.2.2.0, - any.minio-hs ==1.5.2, - any.miniutter ==0.5.1.0, - mintty +win32-2-5-3, - any.mintty ==0.1.2, - any.miso ==1.6.0.0, + any.minimorph ==0.3.0.0, + any.minio-hs ==1.5.3, + any.miniutter ==0.5.1.1, + mintty +win32-2-13-1, + any.mintty ==0.1.3, any.missing-foreign ==0.1.1, - any.mixed-types-num ==0.4.0.2, - any.mixpanel-client ==0.2.1, + any.mixed-types-num ==0.5.9.1, any.mltool ==0.2.0.1, any.mmap ==0.5.9, any.mmark ==0.0.7.2, any.mmark-cli ==0.0.5.0, - any.mmark-ext ==0.2.1.2, - any.mmorph ==1.1.3, + any.mmark-ext ==0.2.1.3, + any.mmorph ==1.1.5, any.mnist-idx ==0.1.2.8, + any.mnist-idx-conduit ==0.4.0.0, + any.mock-time ==0.1.0, any.mockery ==0.3.5, - any.mod ==0.1.2.0, + any.mod ==0.1.2.2, any.model ==0.5, - any.modern-uri ==0.3.2.0, + any.modern-uri ==0.3.4.2, any.modular ==0.1.0.8, - any.monad-bayes ==0.1.1.0, - any.monad-control ==1.0.2.3, + any.monad-chronicle ==1.0.0.1, + any.monad-control ==1.0.3.1, any.monad-control-aligned ==0.0.1.1, - any.monad-coroutine ==0.9.0.4, + any.monad-coroutine ==0.9.1.3, any.monad-extras ==0.6.0, any.monad-journal ==0.8.1, - any.monad-logger ==0.3.35, + any.monad-logger ==0.3.36, any.monad-logger-json ==0.1.0.0, - any.monad-logger-prefix ==0.1.11, + any.monad-logger-logstash ==0.1.0.0, + any.monad-logger-prefix ==0.1.12, any.monad-loops ==0.4.3, - any.monad-memo ==0.5.1, - any.monad-metrics ==0.2.1.4, + any.monad-memo ==0.5.3, + any.monad-metrics ==0.2.2.0, any.monad-par ==0.3.5, any.monad-par-extras ==0.3.3, - any.monad-parallel ==0.7.2.3, + any.monad-parallel ==0.7.2.5, any.monad-peel ==0.2.1.2, + any.monad-primitive ==0.1, any.monad-products ==4.0.1, any.monad-resumption ==0.1.4.0, any.monad-skeleton ==0.1.5, @@ -1468,18 +1600,22 @@ constraints: any.AC-Angle ==1.0, any.monad-unlift ==0.2.0, any.monad-unlift-ref ==0.2.1, any.monadic-arrays ==0.2.2, + any.monadlist ==0.0.2, any.monads-tf ==0.1.0.3, mongoDB -_old-network, - any.mongoDB ==2.7.0.0, - any.mono-traversable ==1.0.15.1, + any.mongoDB ==2.7.1.1, + any.mono-traversable ==1.0.15.3, any.mono-traversable-instances ==0.1.1.0, any.mono-traversable-keys ==0.1.0, - any.monoid-extras ==0.5.1, - any.monoid-subclasses ==1.0.1, + any.monoid-subclasses ==1.1.2, any.monoid-transformer ==0.0.4, - any.more-containers ==0.2.2.0, - any.morpheus-graphql ==0.12.0, - any.morpheus-graphql-core ==0.12.0, + any.more-containers ==0.2.2.2, + any.morpheus-graphql ==0.17.0, + any.morpheus-graphql-app ==0.17.0, + any.morpheus-graphql-client ==0.17.0, + any.morpheus-graphql-core ==0.17.0, + any.morpheus-graphql-subscriptions ==0.17.0, + any.moss ==0.2.0.0, any.mountpoints ==1.0.2, any.mpi-hs ==0.7.2.0, any.mpi-hs-binary ==0.1.1.0, @@ -1489,17 +1625,19 @@ constraints: any.AC-Angle ==1.0, any.multi-containers ==0.1.1, any.multiarg ==0.30.0.10, any.multimap ==1.2.1, + any.multipart ==0.2.1, any.multiset ==0.3.4.3, any.multistate ==0.8.0.3, - any.murmur-hash ==0.1.0.9, - any.murmur3 ==1.0.4, + any.murmur-hash ==0.1.0.10, + any.murmur3 ==1.0.5, any.mustache ==2.3.1, any.mutable-containers ==0.3.4, any.mwc-probability ==2.3.1, - any.mwc-random ==0.14.0.0, + any.mwc-random ==0.15.0.2, + any.mwc-random-monad ==0.7.3.1, any.mx-state-codes ==1.0.0.0, - any.mysql ==0.1.7, - any.mysql-simple ==0.4.5, + any.mysql ==0.2.1, + any.mysql-simple ==0.4.7, any.n2o ==0.11.1, any.nagios-check ==0.3.2, any.names-th ==0.3.0.1, @@ -1510,105 +1648,116 @@ constraints: any.AC-Angle ==1.0, any.natural-sort ==0.1.2, any.natural-transformation ==0.4, any.ndjson-conduit ==0.1.0.5, - any.neat-interpolation ==0.3.2.6, + any.neat-interpolation ==0.5.1.2, + any.net-mqtt ==0.7.1.1, + any.net-mqtt-lens ==0.1.1.0, + any.netcode-io ==0.0.3, any.netlib-carray ==0.1, - any.netlib-comfort-array ==0.0.0.1, + any.netlib-comfort-array ==0.0.0.2, any.netlib-ffi ==0.1.1, - any.netpbm ==1.0.3, - any.netrc ==0.2.0.0, + any.netpbm ==1.0.4, any.nettle ==0.3.0, any.netwire ==5.0.3, any.netwire-input ==0.0.7, any.netwire-input-glfw ==0.0.11, any.network ==3.1.1.1, any.network-bsd ==2.8.1.0, - any.network-byte-order ==0.1.5, + any.network-byte-order ==0.1.6, any.network-conduit-tls ==1.3.2, any.network-info ==0.2.0.10, any.network-ip ==0.3.0.3, any.network-messagepack-rpc ==0.1.2.0, any.network-messagepack-rpc-websocket ==0.1.1.1, + any.network-run ==0.2.4, any.network-simple ==0.4.5, any.network-simple-tls ==0.4, any.network-transport ==0.5.4, any.network-transport-composed ==0.2.1, - any.network-uri ==2.6.3.0, + any.network-uri ==2.6.4.1, any.newtype ==0.2.2.0, - any.newtype-generics ==0.5.4, + any.newtype-generics ==0.6.1, any.nicify-lib ==1.0.1, + any.nix-derivation ==1.1.2, nix-paths +allow-relative-paths, any.nix-paths ==1.0.1, any.no-value ==1.0.0.0, - any.non-empty ==0.3.2, + any.non-empty ==0.3.3, any.non-empty-sequence ==0.2.0.4, any.non-negative ==0.1.2, any.nonce ==1.0.7, any.nondeterminism ==1.4, - any.nonempty-containers ==0.3.4.1, - any.nonempty-vector ==0.2.0.2, + any.nonempty-containers ==0.3.4.4, + any.nonempty-vector ==0.2.1.0, + any.nonempty-zipper ==1.0.0.3, any.nonemptymap ==0.0.6.0, any.not-gloss ==0.7.7.0, any.nowdoc ==0.1.1.0, any.nqe ==0.6.3, + any.nri-env-parser ==0.1.0.7, + any.nri-observability ==0.1.1.3, + any.nri-prelude ==0.6.0.5, any.nsis ==0.3.3, any.numbers ==3000.2.0.2, any.numeric-extras ==0.1, - any.numeric-prelude ==0.4.3.2, - any.numhask ==0.4.0, - any.numtype-dk ==0.5.0.2, + any.numeric-limits ==0.1.0.0, + any.numeric-prelude ==0.4.3.3, + any.numhask ==0.7.1.0, + any.numtype-dk ==0.5.0.3, any.nuxeo ==0.3.2, - any.o-clock ==1.1.0, + any.nvim-hs ==2.1.0.4, + any.nvim-hs-contrib ==2.0.0.0, + any.nvim-hs-ghcid ==2.0.0.0, + any.o-clock ==1.2.1, any.oauthenticated ==0.2.1.0, - any.odbc ==0.2.2, - any.oeis2 ==1.0.4, + any.odbc ==0.2.5, + any.oeis2 ==1.0.5, any.ofx ==0.4.4.0, any.old-locale ==1.0.0.7, any.old-time ==1.1.0.3, any.once ==0.4, any.one-liner ==1.0, - any.one-liner-instances ==0.1.2.1, any.oo-prototypes ==0.1.0.0, - any.opaleye ==0.6.7006.1, + any.opaleye ==0.7.6.2, any.open-browser ==0.2.1.0, + any.openapi3 ==3.1.0, any.openexr-write ==0.1.0.2, any.openpgp-asciiarmor ==0.1.2, any.opensource ==0.1.1.0, any.openssl-streams ==1.2.3.0, - any.opentelemetry ==0.4.2, - any.opentelemetry-extra ==0.4.2, - any.opentelemetry-lightstep ==0.4.2, - any.opentelemetry-wai ==0.4.2, - any.operational ==0.2.3.5, + any.opentelemetry ==0.7.0, + any.opentelemetry-extra ==0.7.0, + any.opentelemetry-lightstep ==0.7.0, + any.opentelemetry-wai ==0.7.0, + any.operational ==0.2.4.1, any.operational-class ==0.3.0.0, - any.optics ==0.2, - any.optics-core ==0.2, - any.optics-extra ==0.2, - any.optics-th ==0.2, - any.optics-vl ==0.2, + any.optics ==0.3, + any.optics-core ==0.3.0.1, + any.optics-extra ==0.3, + any.optics-th ==0.3.0.2, + any.optics-vl ==0.2.1, any.optional-args ==1.0.2, any.options ==1.2.1.1, - any.optparse-applicative ==0.15.1.0, - any.optparse-generic ==1.3.1, - any.optparse-simple ==0.1.1.3, + any.optparse-applicative ==0.16.1.0, + any.optparse-generic ==1.4.7, + any.optparse-simple ==0.1.1.4, any.optparse-text ==0.1.1.0, any.ordered-containers ==0.2.2, any.ormolu ==0.1.4.1, any.overhang ==1.0.0, any.packcheck ==0.5.1, + any.packdeps ==0.6.0.0, any.pager ==0.1.1.0, - any.pagination ==0.2.1, + any.pagination ==0.2.2, any.pagure-cli ==0.2, - any.pandoc ==2.9.2.1, - any.pandoc-citeproc ==0.17.0.1, - any.pandoc-csv2table ==1.0.8, - any.pandoc-plot ==0.6.1.0, - any.pandoc-pyplot ==2.3.0.1, - any.pandoc-types ==1.20, - any.pantry ==0.4.0.2, - any.papillon ==0.1.1.1, + any.pandoc ==2.14.0.3, + any.pandoc-dhall-decoder ==0.1.0.1, + any.pandoc-plot ==1.2.3, + any.pandoc-throw ==0.1.0.0, + any.pandoc-types ==1.22.1, + any.pantry ==0.5.2.3, any.parallel ==3.2.2.0, - any.parallel-io ==0.3.3, - any.paripari ==0.6.0.1, + any.parameterized ==0.5.0.0, + any.paripari ==0.7.0.0, any.parseargs ==0.2.0.9, any.parsec-class ==1.0.0.0, any.parsec-numbers ==0.1.0, @@ -1618,51 +1767,60 @@ constraints: any.AC-Angle ==1.0, any.parsers ==0.12.10, any.partial-handler ==1.0.3, any.partial-isomorphisms ==0.2.2.1, - any.partial-semigroup ==0.5.1.8, - any.password ==2.0.1.1, - any.password-instances ==2.0.0.1, - any.path ==0.7.0, + any.partial-semigroup ==0.5.1.12, + any.password ==3.0.0.0, + any.password-instances ==3.0.0.0, + any.password-types ==1.0.0.0, + any.path ==0.8.0, + any.path-binary-instance ==0.1.0.1, + any.path-extensions ==0.1.1.0, any.path-extra ==0.2.0, - any.path-io ==1.6.0, + any.path-io ==1.6.3, + any.path-like ==0.2.0.2, any.path-pieces ==0.2.1, - any.path-text-utf8 ==0.0.1.6, + any.path-text-utf8 ==0.0.1.8, pathtype -old-time, any.pathtype ==0.8.1.1, any.pathwalk ==0.3.1.2, any.pattern-arrows ==0.0.2, - any.pattern-trie ==0.1.0, - any.pcg-random ==0.1.3.6, + any.pattern-trie ==0.1.1, + any.pava ==0.1.1.2, + any.pcg-random ==0.1.3.7, any.pcre-heavy ==1.0.0.2, any.pcre-light ==0.4.1.0, - any.pcre-utils ==0.1.8.1.1, + any.pcre-utils ==0.1.8.2, + any.pcre2 ==1.1.5, any.pdfinfo ==1.5.4, any.peano ==0.1.0.1, any.pem ==0.2.4, - any.percent-format ==0.0.1, + any.percent-format ==0.0.2, + any.peregrin ==0.3.1, any.perfect-hash-generator ==0.2.0.6, any.perfect-vector-shuffle ==0.1.1.1, any.persist ==0.1.1.5, any.persistable-record ==0.6.0.5, any.persistable-types-HDBC-pg ==0.0.3.5, - any.persistent ==2.10.5.2, - any.persistent-mysql ==2.10.2.3, - any.persistent-pagination ==0.1.1.1, - any.persistent-postgresql ==2.10.1.2, - any.persistent-qq ==2.9.1.1, - any.persistent-sqlite ==2.10.6.2, - any.persistent-template ==2.8.2.3, - any.persistent-test ==2.0.3.1, - any.persistent-typed-db ==0.1.0.1, + any.persistent ==2.13.2.1, + any.persistent-mtl ==0.2.2.0, + any.persistent-mysql ==2.13.0.2, + any.persistent-pagination ==0.1.1.2, + any.persistent-postgresql ==2.13.2.1, + any.persistent-qq ==2.12.0.1, + any.persistent-sqlite ==2.13.0.3, + any.persistent-template ==2.12.0.0, + any.persistent-test ==2.13.0.3, + any.persistent-typed-db ==0.1.0.5, any.pg-harness-client ==0.6.0, - any.pg-transact ==0.3.1.1, + any.pg-transact ==0.3.2.0, any.pgp-wordlist ==0.1.0.3, any.phantom-state ==0.2.1.2, - any.pid1 ==0.1.2.0, - any.pipes ==4.3.14, + any.pid1 ==0.1.3.0, + any.pinboard ==0.10.2.0, + any.pipes ==4.3.16, any.pipes-aeson ==0.4.1.8, any.pipes-attoparsec ==0.5.1.5, - any.pipes-binary ==0.4.2, - any.pipes-bytestring ==2.1.6, + any.pipes-binary ==0.4.3, + any.pipes-bytestring ==2.1.7, any.pipes-concurrency ==2.0.12, any.pipes-csv ==1.4.3, any.pipes-extras ==1.0.15, @@ -1671,100 +1829,108 @@ constraints: any.AC-Angle ==1.0, any.pipes-http ==1.0.6, any.pipes-network ==0.6.5, any.pipes-network-tls ==0.4, - any.pipes-ordered-zip ==1.1.0, - any.pipes-parse ==3.0.8, + any.pipes-ordered-zip ==1.2.1, + any.pipes-parse ==3.0.9, any.pipes-random ==1.0.0.5, - any.pipes-safe ==2.3.2, + any.pipes-safe ==2.3.3, any.pipes-wai ==3.2.0, any.pkcs10 ==0.2.0.0, + any.pkgtreediff ==0.4.1, + any.place-cursor-at ==1.0.1, any.placeholders ==0.1, any.plaid ==0.1.0.4, - any.planb-token-introspection ==0.1.4.0, any.plotlyhs ==0.2.1, - any.pointed ==5.0.1, + any.pointed ==5.0.3, any.pointedlist ==0.6.1, - any.pointless-fun ==1.1.0.6, - any.poll ==0.0.0.1, - any.poly ==0.4.0.0, + any.pointless-fun ==1.1.0.8, + any.poll ==0.0.0.2, + any.polling-cache ==0.1.1.0, + any.poly ==0.5.0.0, any.poly-arity ==0.1.0, any.polynomials-bernstein ==1.1.2, any.polyparse ==1.13, - any.polysemy ==1.7.0.0, - any.polysemy-check ==0.8.1.0, - any.polysemy-mocks ==0.2.0.0, + any.polysemy ==1.7.1.0, + any.polysemy-check ==0.9.0.0, any.polysemy-plugin ==0.4.2.0, any.pooled-io ==0.0.2.2, any.port-utils ==0.2.1.0, - any.posix-paths ==0.2.1.6, + any.posix-paths ==0.3.0.0, any.possibly ==1.0.0.0, any.post-mess-age ==0.2.1.0, any.postgres-options ==0.2.0.0, - any.postgresql-binary ==0.12.2, - any.postgresql-libpq ==0.9.4.2, + any.postgresql-binary ==0.12.4.1, + any.postgresql-libpq ==0.9.4.3, + any.postgresql-libpq-notify ==0.2.0.0, any.postgresql-orm ==0.5.1, - any.postgresql-simple ==0.6.2, - any.postgrest ==7.0.0, + any.postgresql-simple ==0.6.4, + any.postgresql-typed ==0.6.2.0, + any.postgrest ==7.0.1, any.pptable ==0.3.0.0, any.pqueue ==1.4.1.3, + any.prairie ==0.0.1.0, any.prefix-units ==0.2.0, any.prelude-compat ==0.0.0.2, - any.prelude-safeenum ==0.1.1.2, + any.prelude-safeenum ==0.1.1.3, any.pretty-class ==1.0.1.1, + any.pretty-diff ==0.4.0.3, any.pretty-hex ==1.1, any.pretty-relative-time ==0.2.0.0, any.pretty-show ==1.10, - any.pretty-simple ==3.2.3.0, + any.pretty-simple ==4.0.0.0, any.pretty-sop ==0.2.0.3, any.pretty-terminal ==0.1.0.0, - any.pretty-types ==0.3.0.1, any.prettyclass ==1.0.0.0, - any.prettyprinter ==1.6.2, - any.prettyprinter-ansi-terminal ==1.1.2, - any.prettyprinter-compat-annotated-wl-pprint ==1, - any.prettyprinter-compat-ansi-wl-pprint ==1.0.1, - any.prettyprinter-compat-wl-pprint ==1.0.0.1, - any.prettyprinter-convert-ansi-wl-pprint ==1.1.1, + any.prettyprinter ==1.7.1, + any.prettyprinter-ansi-terminal ==1.1.3, + any.prettyprinter-compat-annotated-wl-pprint ==1.1, + any.prettyprinter-compat-ansi-wl-pprint ==1.0.2, + any.prettyprinter-compat-wl-pprint ==1.0.1, + any.prettyprinter-convert-ansi-wl-pprint ==1.1.2, + any.prim-uniq ==0.2, any.primes ==0.2.1.0, - any.primitive ==0.7.0.1, + any.primitive ==0.7.3.0, any.primitive-addr ==0.1.0.2, - any.primitive-extras ==0.8, + any.primitive-extras ==0.10.1.1, any.primitive-unaligned ==0.1.1.1, - any.primitive-unlifted ==0.1.2.0, + any.primitive-unlifted ==1.0.0.0, any.print-console-colors ==0.1.0.0, + any.probability ==0.2.7, any.process-extras ==0.7.4, any.product-isomorphic ==0.0.3.3, - any.product-profunctors ==0.10.0.1, + any.product-profunctors ==0.11.0.2, any.profiterole ==0.1, - any.profunctors ==5.5.2, + any.profunctors ==5.6.2, any.project-template ==0.2.1.0, any.projectroot ==0.2.0.1, any.prometheus ==2.2.2, any.prometheus-client ==1.0.1, + any.prometheus-metrics-ghc ==1.0.1.2, + any.prometheus-wai-middleware ==1.0.1.0, any.promises ==0.3, any.prompt ==0.1.1.2, any.prospect ==0.1.0.0, - any.proto-lens ==0.7.0.0, - any.proto-lens-arbitrary ==0.1.2.9, - any.proto-lens-optparse ==0.1.1.7, - any.proto-lens-protobuf-types ==0.7.0.0, - any.proto-lens-protoc ==0.7.0.0, - any.proto-lens-runtime ==0.7.0.0, - any.proto-lens-setup ==0.4.0.4, - any.proto3-wire ==1.1.0, + any.proto-lens ==0.7.1.0, + any.proto-lens-protoc ==0.7.1.0, + any.proto-lens-runtime ==0.7.0.1, + any.proto-lens-setup ==0.4.0.5, + any.proto3-wire ==1.2.2, any.protobuf ==0.2.1.3, - any.protobuf-simple ==0.1.1.0, + any.protobuf-simple ==0.1.1.1, + any.protocol-buffers ==2.4.17, + any.protocol-buffers-descriptor ==2.4.17, any.protocol-radius ==0.0.1.1, any.protocol-radius-test ==0.1.0.1, - any.protolude ==0.2.4, + any.protolude ==0.3.0, any.proxied ==0.3.1, - any.psqueues ==0.2.7.2, + any.psqueues ==0.2.7.3, + any.ptr-poker ==0.1.1.4, any.publicsuffix ==0.20200526, any.pulse-simple ==0.1.14, - any.pureMD5 ==2.1.3, + any.pureMD5 ==2.1.4, any.purescript-bridge ==0.14.0.0, any.pushbullet-types ==0.4.1.0, - any.pusher-http-haskell ==1.5.1.14, - any.pvar ==0.2.0.0, + any.pusher-http-haskell ==2.1.0.7, + any.pvar ==1.0.0.0, any.qchas ==1.1.0.1, any.qm-interpolated-string ==0.3.0.0, any.qrcode-core ==0.9.4, @@ -1772,347 +1938,394 @@ constraints: any.AC-Angle ==1.0, any.quadratic-irrational ==0.1.1, any.quickcheck-arbitrary-adt ==0.3.1.0, any.quickcheck-assertions ==0.3.0, - any.quickcheck-classes ==0.6.4.0, - any.quickcheck-classes-base ==0.6.1.0, - any.quickcheck-instances ==0.3.23, + any.quickcheck-classes ==0.6.5.0, + any.quickcheck-classes-base ==0.6.2.0, + any.quickcheck-higherorder ==0.1.0.0, + any.quickcheck-instances ==0.3.25.2, any.quickcheck-io ==0.2.0, any.quickcheck-simple ==0.1.1.1, any.quickcheck-special ==0.1.0.6, - any.quickcheck-state-machine ==0.6.0, + any.quickcheck-state-machine ==0.7.1, any.quickcheck-text ==0.1.2.1, any.quickcheck-transformer ==0.3.1.1, any.quickcheck-unicode ==1.0.1.0, any.quiet ==0.2, - any.radius ==0.6.1.0, + any.quote-quot ==0.2.0.0, + any.radius ==0.7.1.0, any.rainbow ==0.34.2.2, any.rainbox ==0.26.0.0, - any.ral ==0.1, + any.ral ==0.2, + any.rampart ==1.1.0.4, any.ramus ==0.1.2, any.rando ==0.0.0.4, - any.random ==1.1, - any.random-bytestring ==0.1.3.2, + any.random ==1.2.0, + any.random-bytestring ==0.1.4, + any.random-fu ==0.2.7.7, any.random-shuffle ==0.0.4, + any.random-source ==0.3.0.11, any.random-tree ==0.6.0.5, any.range ==0.3.0.2, any.range-set-list ==0.1.3.1, - any.rank1dynamic ==0.4.0, - any.rank2classes ==1.3.2.1, + any.ranged-list ==0.1.0.0, + any.rank1dynamic ==0.4.1, + any.rank2classes ==1.4.3, any.rasterific-svg ==0.3.3.2, any.rate-limit ==1.4.2, - any.ratel ==1.0.12, - any.ratel-wai ==1.1.3, + any.ratel ==1.0.17, + any.ratel-wai ==1.1.5, + any.rattle ==0.2, + any.rattletrap ==11.1.1, any.raw-strings-qq ==1.1, any.rawfilepath ==0.2.4, any.rawstring-qm ==0.2.3.0, - any.rcu ==0.2.4, - any.rdf ==0.1.0.4, + any.rcu ==0.2.5, + any.rdf ==0.1.0.5, any.rdtsc ==1.3.0.1, any.re2 ==0.3, any.read-editor ==0.1.0.2, any.read-env-var ==1.0.0.0, any.readable ==0.3.1, - any.reanimate ==0.3.3.0, - any.reanimate-svg ==0.9.8.0, - any.rebase ==1.6.1, - any.record-dot-preprocessor ==0.2.6, + any.reanimate ==1.1.4.0, + any.reanimate-svg ==0.13.0.1, + any.rebase ==1.13.1, + any.record-dot-preprocessor ==0.2.13, any.record-hasfield ==1.0, - any.records-sop ==0.1.0.3, - any.recursion-schemes ==5.1.3, + any.record-wrangler ==0.1.1.0, + any.records-sop ==0.1.1.0, + any.recursion-schemes ==5.2.2.2, any.redis-io ==1.1.0, any.redis-resp ==1.0.0, - any.reducers ==3.12.3, - any.ref-fd ==0.4.0.2, + any.reducers ==3.12.4, + any.ref-fd ==0.5, + any.ref-tf ==0.5, any.refact ==0.3.0.2, + any.refined ==0.6.2, any.reflection ==2.1.6, any.reform ==0.2.7.4, any.reform-blaze ==0.2.4.3, any.reform-hamlet ==0.0.5.3, - any.reform-happstack ==0.2.5.3, + any.reform-happstack ==0.2.5.4, any.regex ==1.1.0.0, - any.regex-applicative ==0.3.3.1, + any.regex-applicative ==0.3.4, any.regex-applicative-text ==0.1.0.1, - any.regex-base ==0.94.0.0, - any.regex-compat ==0.95.2.0, + any.regex-base ==0.94.0.2, + any.regex-compat ==0.95.2.1, any.regex-compat-tdfa ==0.95.1.4, any.regex-pcre ==0.95.0.0, - any.regex-pcre-builtin ==0.95.1.2.8.43, - any.regex-posix ==0.96.0.0, - any.regex-tdfa ==1.3.1.0, + any.regex-pcre-builtin ==0.95.2.3.8.44, + any.regex-posix ==0.96.0.1, + any.regex-posix-clib ==2.7, + any.regex-tdfa ==1.3.1.1, any.regex-with-pcre ==1.1.0.0, - any.registry ==0.1.9.3, + any.registry ==0.2.0.3, any.reinterpret-cast ==0.1.0, any.relapse ==1.0.0.0, - any.relational-query ==0.12.2.3, + any.relational-query ==0.12.3.0, any.relational-query-HDBC ==0.7.2.0, any.relational-record ==0.2.2.0, any.relational-schemas ==0.1.8.0, + any.reliable-io ==0.0.1, any.relude ==0.7.0.0, any.renderable ==0.2.0.1, - any.replace-attoparsec ==1.4.1.0, - any.replace-megaparsec ==1.4.2.0, - any.repline ==0.2.2.0, - any.req ==3.2.0, - any.req-conduit ==1.0.0, - any.rerebase ==1.6.1, + any.replace-attoparsec ==1.4.5.0, + any.replace-megaparsec ==1.4.4.0, + any.repline ==0.4.0.0, + any.req ==3.9.0, + any.req-conduit ==1.0.1, + any.rerebase ==1.13.1, + any.rescue ==0.4.2.1, + any.resistor-cube ==0.0.1.2, any.resolv ==0.1.2.0, any.resource-pool ==0.2.3.2, - any.resourcet ==1.2.4.2, + any.resourcet ==1.2.4.3, any.result ==0.2.6.0, any.rethinkdb-client-driver ==0.0.25, any.retry ==0.8.1.2, any.rev-state ==0.1.2, any.rfc1751 ==0.1.3, - any.rfc5051 ==0.1.0.4, - any.rhine ==0.6.0, - any.rhine-gloss ==0.6.0.1, + any.rfc5051 ==0.2, + any.rhbzquery ==0.4.4, + any.rhine ==0.7.0, + any.rhine-gloss ==0.7.0, any.rigel-viz ==0.2.0.0, - any.rio ==0.1.18.0, - any.rio-orphans ==0.1.1.0, + any.rio ==0.1.21.0, + any.rio-orphans ==0.1.2.0, any.rio-prettyprint ==0.1.1.0, any.roc-id ==0.1.0.0, any.rocksdb-haskell ==1.0.1, - any.rocksdb-query ==0.3.2, - any.roles ==0.2.0.0, - any.rope-utf16-splay ==0.3.1.0, + any.rocksdb-haskell-jprupp ==2.1.3, + any.rocksdb-query ==0.4.2, + any.roles ==0.2.1.0, + any.rope-utf16-splay ==0.3.2.0, any.rosezipper ==0.2, any.rot13 ==0.2.0.1, - any.rpmbuild-order ==0.3.1, + any.rp-tree ==0.6, + any.rpm-nvr ==0.1.1, + any.rpmbuild-order ==0.4.5, any.runmemo ==1.0.0.1, + any.rvar ==0.2.0.6, any.safe ==0.3.19, - any.safe-decimal ==0.2.0.0, - any.safe-exceptions ==0.1.7.1, - any.safe-exceptions-checked ==0.1.0, + any.safe-coloured-text ==0.1.0.0, + any.safe-coloured-text-terminfo ==0.0.0.0, + any.safe-decimal ==0.2.1.0, + any.safe-exceptions ==0.1.7.2, any.safe-foldable ==0.1.0.0, - any.safe-json ==1.1.1, - any.safe-money ==0.9, - any.safecopy ==0.10.3, + any.safe-json ==1.1.1.1, + any.safe-money ==0.9.1, + any.safe-tensor ==0.2.1.1, + any.safecopy ==0.10.4.2, any.safeio ==0.0.5.0, - any.salak ==0.3.6, - any.salak-yaml ==0.3.5.3, - any.saltine ==0.1.1.0, - any.salve ==1.0.10, + any.saltine ==0.1.1.1, + any.salve ==1.0.11, any.sample-frame ==0.0.3, any.sample-frame-np ==0.0.4.1, any.sampling ==0.3.5, + any.sandwich ==0.1.0.9, + any.sandwich-quickcheck ==0.1.0.6, + any.sandwich-slack ==0.1.0.6, + any.sandwich-webdriver ==0.1.0.6, any.say ==0.1.0.1, any.sbp ==2.6.3, + any.sbv ==8.15, any.scalpel ==0.6.2, any.scalpel-core ==0.6.2, any.scanf ==0.1.0.0, any.scanner ==0.3.1, - any.scheduler ==1.4.2.3, - any.scientific ==0.3.6.2, - any.scotty ==0.11.6, + any.scheduler ==1.5.0, + any.scientific ==0.3.7.0, + any.scotty ==0.12, any.scrypt ==0.5.0, - any.sdl2 ==2.5.2.0, + any.sdl2 ==2.5.3.0, any.sdl2-gfx ==0.2, any.sdl2-image ==2.0.0, any.sdl2-mixer ==1.1.0, - any.sdl2-ttf ==2.1.1, + any.sdl2-ttf ==2.1.2, any.search-algorithms ==0.3.1, - any.secp256k1-haskell ==0.2.5, + any.secp256k1-haskell ==0.5.0, any.securemem ==0.1.10, any.selda ==0.5.1.0, any.selda-json ==0.1.1.0, - any.selective ==0.4.1.1, + any.selda-postgresql ==0.1.8.1, + any.selda-sqlite ==0.1.7.1, + any.selections ==0.3.0.0, + any.selective ==0.4.2, any.semialign ==1.1.0.1, any.semialign-indexed ==1.1, any.semialign-optics ==1.1, any.semigroupoid-extras ==5, - any.semigroupoids ==5.3.4, - any.semigroups ==0.19.1, + any.semigroupoids ==5.3.6, + any.semigroups ==0.19.2, any.semiring-simple ==1.0.0.1, - any.semirings ==0.5.4, - any.semver ==0.3.4, + any.semirings ==0.6, + any.semver ==0.4.0.1, any.sendfile ==0.7.11.1, + any.sendgrid-v3 ==0.3.0.0, any.seqalign ==0.2.0.4, - any.sequence-formats ==1.4.1, - any.sequenceTools ==1.4.0.5, + any.seqid ==0.6.2, + any.seqid-streams ==0.7.2, + any.sequence-formats ==1.6.1, + any.sequenceTools ==1.5.0, any.serf ==0.1.1.0, - any.serialise ==0.2.3.0, - any.servant-JuicyPixels ==0.3.0.5, - any.servant-auth ==0.3.2.0, + any.serialise ==0.2.4.0, + any.servant-auth ==0.4.0.0, + any.servant-auth-client ==0.4.1.0, any.servant-auth-docs ==0.2.10.0, - any.servant-auth-server ==0.4.5.1, - any.servant-auth-swagger ==0.2.10.0, - any.servant-blaze ==0.9, - any.servant-cassava ==0.10, - any.servant-checked-exceptions ==2.2.0.0, - any.servant-checked-exceptions-core ==2.2.0.0, + any.servant-auth-server ==0.4.6.0, + any.servant-auth-swagger ==0.2.10.1, + any.servant-auth-wordpress ==1.0.0.2, + any.servant-blaze ==0.9.1, any.servant-conduit ==0.15.1, - any.servant-docs ==0.11.4, - any.servant-docs-simple ==0.2.0.1, + any.servant-docs ==0.11.9, any.servant-elm ==0.7.2, any.servant-errors ==0.1.6.0, - any.servant-foreign ==0.15, - any.servant-js ==0.9.4.2, - any.servant-lucid ==0.9, + any.servant-exceptions ==0.2.1, + any.servant-exceptions-server ==0.2.1, + any.servant-foreign ==0.15.4, + any.servant-http-streams ==0.18.3, any.servant-machines ==0.15.1, any.servant-mock ==0.8.7, - any.servant-multipart ==0.11.5, - any.servant-pipes ==0.15.2, - any.servant-purescript ==0.10.0.0, - any.servant-rawm ==0.3.2.0, - any.servant-static-th ==0.2.4.0, - any.servant-subscriber ==0.7.0.0, - any.servant-swagger-ui ==0.3.4.3.36.1, - any.servant-swagger-ui-core ==0.3.3, - any.servant-swagger-ui-redoc ==0.3.3.1.22.3, - any.servant-websockets ==2.0.0, - any.servant-yaml ==0.1.0.1, - any.serverless-haskell ==0.11.3, - any.serversession ==1.0.1, + any.servant-multipart ==0.12.1, + any.servant-multipart-api ==0.12.1, + any.servant-openapi3 ==2.0.1.2, + any.servant-pipes ==0.15.3, + any.servant-rawm ==1.0.0.0, + any.servant-swagger-ui ==0.3.5.3.52.5, + any.servant-swagger-ui-core ==0.3.5, + any.serverless-haskell ==0.12.6, + any.serversession ==1.0.2, any.serversession-frontend-wai ==1.0, any.ses-html ==0.4.0.0, any.set-cover ==0.1.1, any.setenv ==0.1.1.3, - any.setlocale ==1.0.0.9, - any.sexp-grammar ==2.1.0, - any.shake ==0.19.1, - any.shake-plus ==0.1.10.0, + any.setlocale ==1.0.0.10, + any.sexp-grammar ==2.3.3.1, + any.shake ==0.19.6, + any.shake-language-c ==0.12.0, + any.shake-plus ==0.3.4.0, + any.shake-plus-extended ==0.4.1.0, any.shakespeare ==2.0.25, any.shared-memory ==0.2.0.0, - any.shell-conduit ==4.7.0, + any.shell-conduit ==5.0.0, any.shell-escape ==0.2.0, any.shell-utility ==0.1, - any.shellmet ==0.0.3.1, + any.shellmet ==0.0.4.0, any.shelltestrunner ==1.9, any.shelly ==1.9.0, + any.shikensu ==0.3.11, + any.shortcut-links ==0.5.1.1, any.should-not-typecheck ==2.1.0, any.show-combinators ==0.2.0.0, any.siggy-chardust ==1.0.0, any.signal ==0.1.0.4, - any.silently ==1.2.5.1, + any.silently ==1.2.5.2, any.simple-affine-space ==0.1.1, - any.simple-cabal ==0.1.2, - any.simple-cmd ==0.2.2, - any.simple-cmd-args ==0.1.6, + any.simple-cabal ==0.1.3, + any.simple-cmd ==0.2.3, + any.simple-cmd-args ==0.1.7, any.simple-log ==0.9.12, any.simple-reflect ==0.3.3, any.simple-sendfile ==0.2.30, any.simple-templates ==1.0.0, any.simple-vec3 ==0.6.0.1, - any.simplest-sqlite ==0.1.0.2, any.simplistic-generics ==2.0.0, any.since ==0.0.0, any.singleton-bool ==0.1.5, any.singleton-nats ==0.4.5, - any.singletons ==2.6, - any.singletons-presburger ==0.3.0.1, + any.singletons ==2.7, + any.singletons-presburger ==0.6.1.0, any.siphash ==1.0.3, any.sitemap-gen ==0.1.0.0, - any.size-based ==0.1.2.0, - any.sized ==0.4.0.0, + any.sized ==1.0.0.0, any.skein ==1.0.9.4, any.skews ==0.1.0.3, any.skip-var ==0.1.1.0, - any.skylighting ==0.8.5, - any.skylighting-core ==0.8.5, + any.skylighting ==0.10.5.2, + any.skylighting-core ==0.10.5.2, any.slack-api ==0.12, - any.slist ==0.1.1.0, - any.smallcheck ==1.1.7, - any.smash ==0.1.1.0, + any.slack-progressbar ==0.1.0.1, + any.slick ==1.1.2.2, + any.slist ==0.2.0.0, + any.slynx ==0.5.1.1, + any.smallcheck ==1.2.1, + any.smash ==0.1.2, any.smash-aeson ==0.1.0.0, - any.smash-lens ==0.1.0.0, + any.smash-lens ==0.1.0.1, any.smash-microlens ==0.1.0.0, any.smoothie ==0.4.2.11, - any.smtp-mail ==0.2.0.0, + any.smtp-mail ==0.3.0.0, any.snap-blaze ==0.2.1.5, any.snap-core ==1.0.4.2, - any.snap-server ==1.1.1.2, + any.snap-server ==1.1.2.0, any.snowflake ==0.1.1.1, any.soap ==0.2.3.6, + any.soap-openssl ==0.1.0.2, any.soap-tls ==0.1.1.4, + any.socket ==0.8.3.0, any.socks ==0.6.1, - any.some ==1.0.1, + any.some ==1.0.2, any.sop-core ==0.5.0.1, any.sort ==1.0.0.0, any.sorted-list ==0.2.1.0, - any.sourcemap ==0.1.6, + any.sourcemap ==0.1.6.1, any.sox ==0.2.3.1, any.soxlib ==0.0.3.1, + any.spacecookie ==1.0.0.0, any.sparse-linear-algebra ==0.3.1, - any.sparse-tensor ==0.2.1.4, + any.sparse-tensor ==0.2.1.5, any.spatial-math ==0.5.0.1, any.special-values ==0.1.0.0, - any.speculate ==0.4.2, - any.speedy-slice ==0.3.1, + any.speculate ==0.4.10, + any.speedy-slice ==0.3.2, any.splice ==0.6.1.1, + any.splint ==1.0.1.4, any.split ==0.2.3.4, - any.splitmix ==0.0.4, + any.splitmix ==0.1.0.4, + any.splitmix-distributions ==0.9.0.0, any.spoon ==0.3.1, any.spreadsheet ==0.1.3.8, any.sql-words ==0.1.6.4, any.sqlcli ==0.2.2.0, any.sqlcli-odbc ==0.2.0.1, - any.squeather ==0.4.0.0, - any.srcloc ==0.5.1.2, - any.stache ==2.1.1, - any.stack ==2.3.3, + any.sqlite-simple ==0.4.18.0, + any.squeal-postgresql ==0.7.0.1, + any.squeather ==0.8.0.0, + any.srcloc ==0.6, + any.stache ==2.3.0, + any.stack ==2.7.3, any.stack-templatizer ==0.1.0.2, - any.stackcollapse-ghc ==0.0.1.2, - any.starter ==0.3.0, + any.stackcollapse-ghc ==0.0.1.3, any.stateref ==0.3, - any.statestack ==0.3, - any.static-text ==0.2.0.6, + any.static-text ==0.2.0.7, any.statistics ==0.15.2.0, - any.status-notifier-item ==0.3.0.5, + any.status-notifier-item ==0.3.1.0, any.stb-image-redux ==0.2.1.3, any.step-function ==0.2, - any.stm-chans ==3.0.0.4, + any.stm-chans ==3.0.0.6, any.stm-conduit ==4.0.1, - any.stm-containers ==1.1.0.4, + any.stm-containers ==1.2, any.stm-delay ==0.1.1.1, any.stm-extras ==0.1.0.3, - any.stm-hamt ==1.2.0.4, + any.stm-hamt ==1.2.0.6, + any.stm-lifted ==2.5.0.0, any.stm-split ==0.0.2.1, - any.stomp-queue ==0.3.1, - any.stompl ==0.5.0, + any.stomp-queue ==0.5.1, + any.stompl ==0.6.0, any.stopwatch ==0.1.0.6, any.storable-complex ==0.2.3.0, + any.storable-endian ==0.2.6, any.storable-record ==0.0.5, any.storable-tuple ==0.0.3.3, any.storablevector ==0.2.13.1, - any.stratosphere ==0.53.0, + any.store ==0.7.14, + any.store-core ==0.4.4.4, + any.store-streaming ==0.2.0.3, + any.stratosphere ==0.59.1, any.streaming ==0.2.3.0, - any.streaming-bytestring ==0.1.6, - any.streaming-commons ==0.2.2.1, - any.streamly ==0.7.2, - any.streamly-bytestring ==0.1.2, + any.streaming-attoparsec ==1.0.0.1, + any.streaming-bytestring ==0.2.1, + any.streaming-commons ==0.2.2.2, + any.streamly ==0.7.3, any.streams ==3.3, - any.strict ==0.3.2, - any.strict-base-types ==0.6.1, + any.streamt ==0.5.0.0, + any.strict ==0.4.0.1, any.strict-concurrency ==0.2.4.3, - any.strict-list ==0.1.5, - any.strict-tuple ==0.1.3, + any.strict-list ==0.1.6, + any.strict-tuple ==0.1.4, any.strict-tuple-lens ==0.1.0.1, any.string-class ==0.1.7.0, any.string-combinators ==0.6.0.5, any.string-conv ==0.1.2, any.string-conversions ==0.4.0.1, - any.string-interpolate ==0.2.1.0, + any.string-interpolate ==0.3.1.1, any.string-qq ==0.0.4, + any.string-random ==0.1.4.1, any.string-transform ==1.1.1, any.stringbuilder ==0.5.1, any.stringsearch ==0.3.6.6, - any.stripe-concepts ==1.0.2.4, - any.stripe-signature ==1.0.0.6, - any.strive ==5.0.12, - any.structs ==0.1.3, - any.structured ==0.1, - any.structured-cli ==2.5.2.0, - any.stylish-haskell ==0.11.0.3, + any.stripe-concepts ==1.0.3, + any.stripe-core ==2.6.2, + any.stripe-haskell ==2.6.2, + any.stripe-http-client ==2.6.2, + any.strive ==5.0.16, + any.structs ==0.1.6, + any.structured ==0.1.1, + any.structured-cli ==2.7.0.1, + any.subcategories ==0.1.1.0, any.sum-type-boilerplate ==0.1.1, - any.summoner ==2.0.1.1, - any.summoner-tui ==2.0.1.1, any.sundown ==0.6, any.superbuffer ==0.3.1.1, - any.svg-builder ==0.1.1, any.svg-tree ==0.6.2.4, any.swagger ==0.3.0, - any.swagger2 ==2.5, - any.swish ==0.10.0.4, - any.syb ==0.7.1, + any.swagger2 ==2.6, + any.sweet-egison ==0.1.1.3, + any.swish ==0.10.0.8, + any.syb ==0.7.2.1, + any.sydtest ==0.2.0.0, + any.sydtest-discover ==0.0.0.1, + any.sydtest-persistent-sqlite ==0.1.0.0, + any.sydtest-servant ==0.1.0.0, + any.sydtest-wai ==0.1.0.0, + any.sydtest-yesod ==0.1.0.0, any.symbol ==0.2.4, any.symengine ==0.1.2.0, any.symmetry-operations-symbols ==0.0.2.1, @@ -2120,12 +2333,11 @@ constraints: any.AC-Angle ==1.0, any.system-argv0 ==0.1.1, any.system-fileio ==0.3.16.4, any.system-filepath ==0.4.14, - any.system-info ==0.5.1, + any.system-info ==0.5.2, any.systemd ==2.3.0, any.tabular ==0.2.2.8, - any.taffybar ==3.2.2, any.tagchup ==0.4.1.1, - any.tagged ==0.8.6, + any.tagged ==0.8.6.1, any.tagged-binary ==0.2.0.1, any.tagged-identity ==0.1.3, any.tagged-transformer ==0.8.1, @@ -2136,98 +2348,108 @@ constraints: any.AC-Angle ==1.0, tar -old-time, any.tar ==0.5.1.1, any.tar-conduit ==0.3.2, - any.tardis ==0.4.1.0, - any.tasty ==1.2.3, - any.tasty-ant-xml ==1.1.6, - any.tasty-dejafu ==2.0.0.6, - any.tasty-discover ==4.2.1, - any.tasty-expected-failure ==0.11.1.2, - any.tasty-golden ==2.3.3.2, - any.tasty-hedgehog ==1.0.0.2, - any.tasty-hspec ==1.1.5.1, - any.tasty-hunit ==0.10.0.2, + any.tardis ==0.4.3.0, + any.tasty ==1.4.2, + any.tasty-ant-xml ==1.1.8, + any.tasty-bench ==0.2.5, + any.tasty-dejafu ==2.0.0.8, + any.tasty-discover ==4.2.2, + any.tasty-expected-failure ==0.12.3, + any.tasty-focus ==1.0.1, + any.tasty-golden ==2.3.4, + any.tasty-hedgehog ==1.1.0.0, + any.tasty-hspec ==1.1.6, + any.tasty-hunit ==0.10.0.3, + any.tasty-hunit-compat ==0.2.0.1, + any.tasty-inspection-testing ==0.1, any.tasty-kat ==0.0.3, - any.tasty-leancheck ==0.0.1, - any.tasty-lua ==0.2.3, + any.tasty-leancheck ==0.0.2, + any.tasty-lua ==0.2.3.2, any.tasty-program ==1.0.5, - any.tasty-quickcheck ==0.10.1.1, - any.tasty-rerun ==1.1.17, - any.tasty-silver ==3.1.15, - any.tasty-smallcheck ==0.8.1, + any.tasty-quickcheck ==0.10.1.2, + any.tasty-rerun ==1.1.18, + any.tasty-silver ==3.2.3, + any.tasty-smallcheck ==0.8.2, + any.tasty-test-reporter ==0.1.1.4, any.tasty-th ==0.1.7, - any.tasty-wai ==0.1.1.0, + any.tasty-wai ==0.1.1.1, any.tce-conf ==1.3, - any.tdigest ==0.2.1, + any.tdigest ==0.2.1.1, any.template ==0.2.0.10, - any.template-haskell-compat-v0208 ==0.1.5, + any.template-haskell-compat-v0208 ==0.1.7, any.temporary ==1.3, any.temporary-rc ==1.2.0.3, any.temporary-resourcet ==0.1.0.1, any.tensorflow-test ==0.1.0.0, - any.tensors ==0.1.4, + any.tensors ==0.1.5, + any.termbox ==0.3.0, any.terminal-progress-bar ==0.4.1, any.terminal-size ==0.3.2.1, any.test-framework ==0.8.2.0, any.test-framework-hunit ==0.3.0.2, - any.test-framework-leancheck ==0.0.1, + any.test-framework-leancheck ==0.0.4, any.test-framework-quickcheck2 ==0.3.0.5, any.test-framework-smallcheck ==0.2, - any.test-framework-th ==0.2.4, - any.testing-feat ==1.1.0.0, + any.test-fun ==0.1.0.0, any.testing-type-modifiers ==0.1.0.1, - any.texmath ==0.12.0.2, + any.texmath ==0.12.3.2, + any.text-ansi ==0.1.1, any.text-binary ==0.2.1.1, - any.text-builder ==0.6.6.1, - any.text-conversions ==0.3.0, + any.text-builder ==0.6.6.3, + any.text-conversions ==0.3.1, any.text-format ==0.3.2, - any.text-icu ==0.7.0.1, + any.text-icu ==0.7.1.0, any.text-icu-translit ==0.1.0.7, any.text-latin1 ==0.3.1, - any.text-ldap ==0.1.1.13, - any.text-manipulate ==0.2.0.1, - any.text-metrics ==0.3.0, + any.text-ldap ==0.1.1.14, + any.text-manipulate ==0.3.0.0, + any.text-metrics ==0.3.1, any.text-postgresql ==0.0.3.1, - any.text-printer ==0.5.0.1, + any.text-printer ==0.5.0.2, + any.text-regex-replace ==0.1.1.4, any.text-region ==0.3.1.0, any.text-short ==0.1.3, - any.text-show ==3.8.5, - any.text-show-instances ==3.8.3, - any.text-zipper ==0.10.1, + any.text-show ==3.9.2, + any.text-show-instances ==3.8.4, + any.text-zipper ==0.11, any.textlocal ==0.1.0.5, any.tf-random ==0.5, - any.tfp ==1.0.1.1, - any.th-abstraction ==0.3.2.0, + any.tfp ==1.0.2, + any.th-abstraction ==0.4.3.0, any.th-bang-compat ==0.0.1.0, + any.th-compat ==0.1.3, any.th-constraint-compat ==0.0.1.0, any.th-data-compat ==0.1.0.0, - any.th-desugar ==1.10, - any.th-env ==0.1.0.2, - any.th-expand-syns ==0.4.6.0, - any.th-extras ==0.0.0.4, - any.th-lift ==0.8.1, - any.th-lift-instances ==0.1.17, + any.th-desugar ==1.11, + any.th-env ==0.1.0.3, + any.th-expand-syns ==0.4.8.0, + any.th-extras ==0.0.0.5, + any.th-lift ==0.8.2, + any.th-lift-instances ==0.1.18, any.th-nowq ==0.1.0.5, - any.th-orphans ==0.13.10, + any.th-orphans ==0.13.12, any.th-printf ==0.7, any.th-reify-compat ==0.0.1.5, - any.th-reify-many ==0.1.9, + any.th-reify-many ==0.1.10, any.th-strict-compat ==0.1.0.1, - any.th-test-utils ==1.0.2, + any.th-test-utils ==1.1.1, + any.th-utilities ==0.2.4.3, any.these ==1.1.1.1, - any.these-lens ==1.0.0.1, - any.these-optics ==1, + any.these-lens ==1.0.1.2, + any.these-optics ==1.0.1.2, + any.these-skinny ==0.7.4, any.thread-hierarchy ==0.3.0.2, any.thread-local-storage ==0.2, - any.thread-supervisor ==0.1.0.1, + any.thread-supervisor ==0.2.0.0, any.threads ==0.5.1.6, - any.threepenny-gui ==0.9.0.0, + any.threepenny-gui ==0.9.1.0, any.throttle-io-stream ==0.2.0.1, any.through-text ==0.1.0.0, any.throwable-exceptions ==0.1.0.9, any.thyme ==0.3.5.5, - any.tidal ==1.5.2, + any.tidal ==1.7.8, any.tile ==0.3.0.0, - any.time-compat ==1.9.3, + any.time-compat ==1.9.5, any.time-lens ==0.4.0.2, time-locale-compat -old-locale, any.time-locale-compat ==0.1.1.5, @@ -2237,175 +2459,195 @@ constraints: any.AC-Angle ==1.0, any.time-units ==1.0.0, any.timeit ==2.0, any.timelens ==0.2.0.2, - any.timerep ==2.0.0.2, + any.timer-wheel ==0.3.0, + any.timerep ==2.0.1.0, any.timezone-olson ==0.2.0, any.timezone-series ==0.1.9, any.tinylog ==0.15.0, any.titlecase ==1.0.1, - any.tldr ==0.6.4, + any.tldr ==0.9.2, any.tls ==1.5.5, any.tls-debug ==0.4.8, any.tls-session-manager ==0.0.4, + any.tlynx ==0.5.1.1, any.tmapchan ==0.0.3, any.tmapmvar ==0.0.4, any.tmp-postgres ==1.34.1.0, - any.tomland ==1.3.0.0, - any.tonalude ==0.1.1.0, + any.tomland ==1.3.2.0, + any.tonalude ==0.1.1.1, any.topograph ==1.0.0.1, any.torsor ==0.1, any.tostring ==0.2.1.1, - any.tracing ==0.0.5.1, + any.tracing ==0.0.7.2, any.transaction ==0.1.1.3, - any.transformers-base ==0.4.5.2, + any.transformers-base ==0.4.6, any.transformers-bifunctors ==0.1, transformers-compat +five-three, - any.transformers-compat ==0.6.5, + any.transformers-compat ==0.6.6, any.transformers-fix ==1.0, - any.traverse-with-class ==1.0.1.0, - any.tree-diff ==0.1, + any.traverse-with-class ==1.0.1.1, + any.tree-diff ==0.2.1, any.tree-fun ==0.8.1.0, - any.trifecta ==2.1, + any.tree-view ==0.5.1, + any.trifecta ==2.1.2, any.triplesec ==0.2.2.1, - any.trivial-constraint ==0.6.0.0, + any.trivial-constraint ==0.7.0.0, any.tsv2csv ==0.1.0.2, - any.ttc ==0.2.2.0, + any.ttc ==1.1.0.2, any.ttl-hashtables ==1.4.1.0, - any.ttrie ==0.1.2.1, + any.ttrie ==0.1.2.2, any.tuple ==0.3.0.2, any.tuple-sop ==0.3.1.0, any.tuple-th ==0.2.5, any.tuples-homogenous-h98 ==0.1.1.0, - any.turtle ==1.5.20, + any.turtle ==1.5.23, any.type-equality ==1, any.type-errors ==0.2.0.0, - any.type-errors-pretty ==0.0.1.1, - any.type-fun ==0.1.1, + any.type-errors-pretty ==0.0.1.2, any.type-hint ==0.1, any.type-level-integers ==0.0.1, any.type-level-kv-list ==1.1.0, + any.type-level-natural-number ==2.0, any.type-level-numbers ==0.1.1.1, any.type-map ==0.1.6.0, - any.type-natural ==0.8.3.1, - any.type-of-html ==1.5.1.0, + any.type-natural ==1.1.0.0, + any.type-of-html ==1.6.2.0, any.type-of-html-static ==0.1.0.2, any.type-operators ==0.2.0.0, any.type-spec ==0.4.0.0, - any.typed-process ==0.2.6.0, - any.typed-uuid ==0.0.0.2, - any.typenums ==0.1.2.1, + any.typecheck-plugin-nat-simple ==0.1.0.2, + any.typed-process ==0.2.7.0, + any.typed-uuid ==0.1.0.0, + any.typelits-witnesses ==0.4.0.0, + any.typenums ==0.1.4, any.typerep-map ==0.3.3.0, - any.tzdata ==0.1.20190911.0, - any.ua-parser ==0.7.5.1, + any.tzdata ==0.2.20201021.0, + any.ua-parser ==0.7.6.0, any.uglymemo ==0.1.0.1, - any.ulid ==0.3.0.0, any.unagi-chan ==0.4.1.3, - any.unbounded-delays ==0.1.1.0, + any.unbounded-delays ==0.1.1.1, any.unboxed-ref ==0.4.0.0, - any.unboxing-vector ==0.1.1.0, + any.unboxing-vector ==0.2.0.0, + any.uncaught-exception ==0.1.0, any.uncertain ==0.3.1.0, any.unconstrained ==0.1.0.2, any.unexceptionalio ==0.5.1, any.unexceptionalio-trans ==0.5.1, any.unicode ==0.0.1.1, - any.unicode-show ==0.1.0.4, - any.unicode-transforms ==0.3.7, - any.unification-fd ==0.10.0.1, + any.unicode-collation ==0.1.3.1, + any.unicode-show ==0.1.1.0, + any.unicode-transforms ==0.3.7.1, + any.unification-fd ==0.11.1, + any.union-angle ==0.1.0.1, any.union-find ==0.2, - any.uniplate ==1.6.12, + any.unipatterns ==0.0.0.0, + any.uniplate ==1.6.13, any.uniprot-kb ==0.1.2.0, - any.uniq-deep ==1.2.0, - any.unique ==0, + any.uniq-deep ==1.2.1, + any.unique ==0.0.1, any.unique-logic ==0.4, any.unique-logic-tf ==0.5.1, any.unit-constraint ==0.0.0, - any.universe ==1.2, - any.universe-base ==1.1.1, + any.universe ==1.2.1, + any.universe-base ==1.1.2, + any.universe-dependent-sum ==1.3, any.universe-instances-base ==1.1, - any.universe-instances-extended ==1.1.1, + any.universe-instances-extended ==1.1.2, any.universe-instances-trans ==1.1, - any.universe-reverse-instances ==1.1, - any.universe-some ==1.2, - any.universum ==1.6.1, - any.unix-bytestring ==0.3.7.3, - any.unix-compat ==0.5.2, + any.universe-reverse-instances ==1.1.1, + any.universe-some ==1.2.1, + any.universum ==1.7.2, + any.unix-bytestring ==0.3.7.6, + any.unix-compat ==0.5.3, any.unix-time ==0.4.7, - any.unliftio ==0.2.13, - any.unliftio-core ==0.1.2.0, + any.unliftio ==0.2.20, + any.unliftio-core ==0.2.0.1, any.unliftio-pool ==0.2.1.1, + any.unliftio-streams ==0.1.1.1, any.unlit ==0.4.0.0, - any.unordered-containers ==0.2.10.0, - any.unordered-intmap ==0.1.1, + any.unordered-containers ==0.2.15.0, any.unsafe ==0.0, any.urbit-hob ==0.3.3, - any.uri-bytestring ==0.3.2.2, + any.uri-bytestring ==0.3.3.1, any.uri-bytestring-aeson ==0.1.0.8, - any.uri-encode ==1.5.0.6, + any.uri-encode ==1.5.0.7, any.url ==2.1.3, any.users ==0.5.0.0, any.utf8-conversions ==0.1.0.4, any.utf8-light ==0.4.2, - any.utf8-string ==1.0.1.1, + any.utf8-string ==1.0.2, any.util ==0.1.17.1, - any.utility-ht ==0.0.15, - any.uuid ==1.3.13, - any.uuid-types ==1.0.3, - any.validation ==1.1, - any.validation-selective ==0.1.0.0, - any.validity ==0.11.0.0, + any.utility-ht ==0.0.16, + any.uuid ==1.3.15, + any.uuid-types ==1.0.5, + any.validation ==1.1.2, + any.validation-selective ==0.1.0.1, + any.validity ==0.11.0.1, any.validity-aeson ==0.2.0.4, any.validity-bytestring ==0.4.1.1, any.validity-containers ==0.5.0.4, any.validity-path ==0.4.0.1, + any.validity-persistent ==0.0.0.0, any.validity-primitive ==0.0.0.1, any.validity-scientific ==0.2.0.3, any.validity-text ==0.3.1.1, - any.validity-time ==0.3.0.0, + any.validity-time ==0.4.0.0, any.validity-unordered-containers ==0.2.0.3, any.validity-uuid ==0.1.0.3, any.validity-vector ==0.2.0.3, any.valor ==0.1.0.0, - any.vault ==0.3.1.4, - any.vec ==0.3, - any.vector ==0.12.1.2, - any.vector-algorithms ==0.8.0.3, - any.vector-binary-instances ==0.2.5.1, + any.vault ==0.3.1.5, + any.vcs-ignore ==0.0.1.0, + any.vec ==0.4, + any.vector ==0.12.3.1, + any.vector-algorithms ==0.8.0.4, + any.vector-binary-instances ==0.2.5.2, any.vector-buffer ==0.4.1, - any.vector-builder ==0.3.8, + any.vector-builder ==0.3.8.2, any.vector-bytes-instances ==0.1.1, + any.vector-circular ==0.1.3, any.vector-instances ==3.4, any.vector-mmap ==0.0.3, - any.vector-rotcev ==0.1.0.0, - any.vector-sized ==1.4.2, + any.vector-rotcev ==0.1.0.1, + any.vector-sized ==1.4.4, any.vector-space ==0.16, any.vector-split ==1.0.0.2, - any.vector-th-unbox ==0.2.1.7, + any.vector-th-unbox ==0.2.2, any.verbosity ==0.4.0.0, - any.versions ==3.5.4, + any.versions ==5.0.0, any.vformat ==0.14.1.0, any.vformat-aeson ==0.1.0.1, any.vformat-time ==0.1.0.0, + any.vinyl ==0.13.3, any.void ==0.7.3, - any.vty ==5.28.2, - any.wai ==3.2.2.1, + any.vty ==5.33, + any.wai ==3.2.3, any.wai-app-static ==3.1.7.2, any.wai-conduit ==3.0.0.4, any.wai-cors ==0.2.7, any.wai-enforce-https ==0.0.2.1, any.wai-eventsource ==3.0.0, - any.wai-extra ==3.0.29.2, + any.wai-extra ==3.1.7, + any.wai-feature-flags ==0.1.0.2, any.wai-handler-launch ==3.0.3.1, any.wai-logger ==2.3.6, + any.wai-middleware-auth ==0.2.5.1, any.wai-middleware-caching ==0.1.0.2, any.wai-middleware-clacks ==0.1.0.1, any.wai-middleware-gunzip ==0.0.2, - any.wai-middleware-static ==0.8.3, + any.wai-middleware-static ==0.9.1, any.wai-predicates ==1.0.0, + any.wai-rate-limit ==0.1.0.0, + any.wai-rate-limit-redis ==0.1.0.0, any.wai-route ==0.4.0, + any.wai-saml2 ==0.2.1.2, any.wai-session ==0.3.3, + any.wai-session-redis ==0.1.0.4, any.wai-slack-middleware ==0.2.0, any.wai-websockets ==3.0.1.2, + any.wakame ==0.1.0.0, any.warp ==3.3.17, - any.warp-tls ==3.2.12, + any.warp-tls ==3.3.2, any.warp-tls-uid ==0.2.0.6, any.wave ==0.2.0, any.wcwidth ==0.0.2, @@ -2413,21 +2655,22 @@ constraints: any.AC-Angle ==1.0, any.webex-teams-api ==0.2.0.1, any.webex-teams-conduit ==0.2.0.1, any.webex-teams-pipes ==0.2.0.1, + any.webgear-server ==0.2.1, any.webrtc-vad ==0.1.0.3, - any.websockets ==0.12.7.1, + any.websockets ==0.12.7.3, any.websockets-snap ==0.10.3.1, any.weigh ==0.0.16, - any.wide-word ==0.1.1.1, - any.wikicfp-scraper ==0.1.0.11, - any.wild-bind ==0.1.2.6, - any.wild-bind-x11 ==0.2.0.10, + any.wide-word ==0.1.1.2, + any.wikicfp-scraper ==0.1.0.12, + any.wild-bind ==0.1.2.7, + any.wild-bind-x11 ==0.2.0.13, windns +allow-non-windows, any.windns ==0.1.0.1, + any.witch ==0.3.4.0, any.with-location ==0.1.0, - any.with-utf8 ==1.0.2.1, - any.witherable-class ==0, - any.within ==0.1.1.0, - any.witness ==0.4, + any.with-utf8 ==1.0.2.3, + any.witherable ==0.4.2, + any.within ==0.2.0.1, any.wizards ==1.0.3, any.wl-pprint-annotated ==0.1.0.1, any.wl-pprint-console ==0.1.0.2, @@ -2436,34 +2679,33 @@ constraints: any.AC-Angle ==1.0, any.word-wrap ==0.4.1, any.word24 ==2.0.1, any.word8 ==0.1.3, + any.wordpress-auth ==1.0.0.1, any.world-peace ==1.0.2.0, any.wrap ==0.0.0, - any.wreq ==0.5.3.2, + any.wreq ==0.5.3.3, any.writer-cps-exceptions ==0.1.0.1, any.writer-cps-mtl ==0.1.1.6, any.writer-cps-transformers ==0.5.6.1, any.wss-client ==0.3.0.0, - any.wuss ==1.1.17, + any.wuss ==1.1.18, any.x11-xim ==0.0.9.0, any.x509 ==1.7.5, any.x509-system ==1.6.6, any.x509-validation ==1.6.11, any.xdg-basedir ==0.2.2, - any.xdg-desktop-entry ==0.1.1.1, any.xdg-userdirs ==0.1.0.2, - any.xeno ==0.4.2, - any.xls ==0.1.3, - any.xlsx ==0.8.1, + any.xeno ==0.4.3, + any.xlsx ==0.8.4, any.xlsx-tabular ==0.2.2.1, any.xml ==1.3.14, any.xml-basic ==0.1.3.1, - any.xml-conduit ==1.9.0.0, + any.xml-conduit ==1.9.1.1, any.xml-conduit-writer ==0.1.1.2, any.xml-hamlet ==0.5.0.1, any.xml-helpers ==1.0.0, any.xml-html-qq ==0.1.0.1, any.xml-indexed-cursor ==0.1.1.0, - any.xml-lens ==0.2, + any.xml-lens ==0.3, any.xml-picklers ==0.3.6, any.xml-to-json ==2.0.1, any.xml-to-json-fast ==2.0.0, @@ -2471,46 +2713,51 @@ constraints: any.AC-Angle ==1.0, any.xmlgen ==0.6.2.2, any.xmonad ==0.15, any.xmonad-contrib ==0.16, - any.xmonad-extras ==0.15.2, + any.xmonad-extras ==0.15.3, any.xss-sanitize ==0.3.6, - any.xturtle ==0.2.0.0, any.xxhash-ffi ==0.2.0.0, - any.yaml ==0.11.5.0, - any.yamlparse-applicative ==0.1.0.1, + any.yaml ==0.11.7.0, + any.yamlparse-applicative ==0.2.0.1, any.yes-precure5-command ==5.5.3, - any.yesod ==1.6.1.0, - any.yesod-auth ==1.6.10, - any.yesod-auth-fb ==1.10.1, - any.yesod-auth-hashdb ==1.7.1.2, - any.yesod-bin ==1.6.0.6, - any.yesod-core ==1.6.18, + any.yesod ==1.6.1.2, + any.yesod-auth ==1.6.10.5, + any.yesod-auth-hashdb ==1.7.1.7, + any.yesod-auth-oauth2 ==0.6.3.4, + any.yesod-bin ==1.6.1, + any.yesod-core ==1.6.21.0, any.yesod-fb ==0.6.1, - any.yesod-form ==1.6.7, - any.yesod-form-bootstrap4 ==3.0.0, - any.yesod-gitrev ==0.2.1, + any.yesod-form ==1.7.0, + any.yesod-gitrev ==0.2.2, + any.yesod-markdown ==0.12.6.12, any.yesod-newsfeed ==1.7.0.0, - any.yesod-persistent ==1.6.0.4, - any.yesod-recaptcha2 ==1.0.1, + any.yesod-page-cursor ==2.0.0.9, + any.yesod-paginator ==1.1.1.0, + any.yesod-persistent ==1.6.0.7, any.yesod-sitemap ==1.6.0, any.yesod-static ==1.6.1.0, - any.yesod-test ==1.6.10, - any.yesod-websockets ==0.3.0.2, + any.yesod-test ==1.6.12, + any.yesod-websockets ==0.3.0.3, any.yi-rope ==0.11, any.yjsvg ==0.2.0.1, any.yjtools ==0.9.18, any.yoga ==0.0.0.5, any.youtube ==0.2.1.1, - any.zasni-gerna ==0.0.7.1, + any.zenacy-html ==2.0.4, + any.zenacy-unicode ==1.0.1, any.zero ==0.1.5, any.zeromq4-haskell ==0.8.0, any.zeromq4-patterns ==0.3.1.0, any.zim-parser ==0.2.1.0, - any.zip ==1.5.0, + any.zio ==0.1.0.2, + any.zip ==1.7.2, any.zip-archive ==0.4.1, - any.zip-stream ==0.2.0.1, - any.zippers ==0.3, - any.zlib ==0.6.2.2, + any.zip-stream ==0.2.1.0, + any.zipper-extra ==0.1.3.2, + any.zippers ==0.3.2, + any.zlib ==0.6.2.3, any.zlib-bindings ==0.1.1.5, any.zlib-lens ==0.1.2.1, any.zot ==0.0.3, - any.zstd ==0.1.2.0 + any.zstd ==0.1.3.0, + any.ztail ==1.2.0.2, + any.zydiskell ==0.2.0.0 diff --git a/charts/backoffice/README.md b/charts/backoffice/README.md index b91a361128a..58b69d05586 100644 --- a/charts/backoffice/README.md +++ b/charts/backoffice/README.md @@ -1,7 +1,7 @@ Backoffice frontend =================== -This chart provides a basic frontend app that is composed of nginx serving swagger and will soon be found here [here](https://github.com/wireapp/wire-server/blob/develop/tools/backoffice-frontend/README.md). It serves as a tool to perform operations on users and teams such as visualising their user profiles, suspending or even deleting accounts. It is used internally at Wire to provide customer support the means to respond to certain queries from our customers and can be used by anyone that decides to deploy it on their cluster(s). +This chart provides a [basic frontend app called *backoffice* or *stern*](https://github.com/wireapp/wire-server/blob/develop/tools/stern/README.md) that is built using a simple UI for browsing swagger. It serves as a tool to perform operations on users and teams such as visualising their user profiles, suspending or even deleting accounts. It is used internally at Wire to provide customer support the means to respond to certain queries from our customers and can be used by anyone that decides to deploy it on their cluster(s). It is intended to be accessed, at the moment, only by means of port forwarding and therefore only available to cluster admins (or more generally, clusters users able to port forward). diff --git a/charts/brig/templates/configmap.yaml b/charts/brig/templates/configmap.yaml index e01d29bd9a7..f2374810aba 100644 --- a/charts/brig/templates/configmap.yaml +++ b/charts/brig/templates/configmap.yaml @@ -204,7 +204,8 @@ data: suspendTimeout: {{ .setSuspendInactiveUsers.suspendTimeout }} {{- end }} setRichInfoLimit: {{ .setRichInfoLimit }} - setDefaultLocale: en + setDefaultTemplateLocale: en + setDefaultUserLocale: {{ .setDefaultUserLocale }} setMaxTeamSize: {{ .setMaxTeamSize }} setMaxConvSize: {{ .setMaxConvSize }} setEmailVisibility: {{ .setEmailVisibility }} diff --git a/charts/brig/templates/tests/configmap.yaml b/charts/brig/templates/tests/configmap.yaml index 1842519cd7c..5ebf029a33a 100644 --- a/charts/brig/templates/tests/configmap.yaml +++ b/charts/brig/templates/tests/configmap.yaml @@ -65,6 +65,10 @@ data: host: galley.{{ .Release.Namespace }}-fed2.svc.cluster.local port: 8080 + cargohold: + host: cargohold.{{ .Release.Namespace }}-fed2.svc.cluster.local + port: 8080 + # TODO remove this federator: host: federator.{{ .Release.Namespace }}-fed2.svc.cluster.local diff --git a/charts/brig/values.yaml b/charts/brig/values.yaml index e609dbd00e4..bb67cc4c495 100644 --- a/charts/brig/values.yaml +++ b/charts/brig/values.yaml @@ -29,7 +29,7 @@ config: # -- If set to false, 'dynamoDBEndpoint' _must_ be set. randomPrekeys: true useSES: true - enableFederator: false # keep enableFederator default in sync with galley chart's config.enableFederator as well as wire-server chart's tag.federator + enableFederator: false # keep enableFederator default in sync with galley and cargohold chart's config.enableFederator as well as wire-server chart's tag.federator emailSMS: general: templateBranding: @@ -63,7 +63,8 @@ config: stdDev: 3000 retryAfter: 86400 setRichInfoLimit: 5000 - setDefaultLocale: en + setDefaultTemplateLocale: en + setDefaultUserLocale: en setMaxTeamSize: 500 setMaxConvSize: 500 # Allowed values: https://github.com/wireapp/wire-server/blob/0126651a25aabc0c5589edc2b1988bb06550a03a/services/brig/src/Brig/Options.hs#L304-L306 diff --git a/charts/cargohold/templates/configmap.yaml b/charts/cargohold/templates/configmap.yaml index 3e1f4ce9b2b..22390d9a0b5 100644 --- a/charts/cargohold/templates/configmap.yaml +++ b/charts/cargohold/templates/configmap.yaml @@ -11,6 +11,12 @@ data: host: 0.0.0.0 port: {{ .Values.service.internalPort }} + {{- if .Values.config.enableFederator }} + federator: + host: federator + port: 8080 + {{- end }} + aws: {{- with .Values.config.aws }} s3Bucket: {{ .s3Bucket }} @@ -30,5 +36,8 @@ data: {{- end }} settings: + {{- with .Values.config.settings }} maxTotalBytes: 5368709120 downloadLinkTTL: 300 # Seconds + federationDomain: {{ .federationDomain }} + {{- end }} diff --git a/charts/cargohold/templates/tests/cargohold-integration.yaml b/charts/cargohold/templates/tests/cargohold-integration.yaml index 30939c2f535..3a4d1ed94b7 100644 --- a/charts/cargohold/templates/tests/cargohold-integration.yaml +++ b/charts/cargohold/templates/tests/cargohold-integration.yaml @@ -9,6 +9,9 @@ spec: - name: "cargohold-integration" configMap: name: "cargohold-integration" + - name: "cargohold-config" + configMap: + name: "cargohold" containers: # NOTE: the bucket for these tests must be created. # If using the wire-server/fake-aws-s3 chart, `dummy-bucket` will already be created. @@ -17,6 +20,8 @@ spec: volumeMounts: - name: "cargohold-integration" mountPath: "/etc/wire/integration" + - name: "cargohold-config" + mountPath: "/etc/wire/cargohold/conf" env: # these dummy values are necessary for Amazonka's "Discover" - name: AWS_ACCESS_KEY_ID diff --git a/charts/cargohold/values.yaml b/charts/cargohold/values.yaml index be73a6dd34e..91d97e1d996 100644 --- a/charts/cargohold/values.yaml +++ b/charts/cargohold/values.yaml @@ -14,7 +14,8 @@ resources: cpu: "500m" config: logLevel: Info + enableFederator: false # keep enableFederator default in sync with brig and galley chart's config.enableFederator as well as wire-server chart's tag.federator aws: region: "eu-west-1" s3Bucket: assets - proxy: {} \ No newline at end of file + proxy: {} diff --git a/charts/fake-aws-s3/values.yaml b/charts/fake-aws-s3/values.yaml index 3c7ffd4774d..a736eb82cb0 100644 --- a/charts/fake-aws-s3/values.yaml +++ b/charts/fake-aws-s3/values.yaml @@ -21,7 +21,7 @@ minio: memory: 200Mi buckets: - name: dummy-bucket - purge: true + purge: false policy: none - name: assets purge: false diff --git a/charts/galley/values.yaml b/charts/galley/values.yaml index f50aa5dc17c..59b458237fb 100644 --- a/charts/galley/values.yaml +++ b/charts/galley/values.yaml @@ -19,7 +19,7 @@ config: cassandra: host: aws-cassandra replicaCount: 3 - enableFederator: false # keep enableFederator default in sync with brig chart's config.enableFederator as well as wire-server chart's tag.federator + enableFederator: false # keep enableFederator default in sync with brig and cargohold chart's config.enableFederator as well as wire-server chart's tag.federator settings: maxTeamSize: 500 maxConvSize: 500 diff --git a/charts/restund/Chart.yaml b/charts/restund/Chart.yaml new file mode 100644 index 00000000000..423fbbe799a --- /dev/null +++ b/charts/restund/Chart.yaml @@ -0,0 +1,14 @@ +apiVersion: v2 +name: restund +description: Restund - a modular STUN/TURN server +type: application + +# This is the chart version. This version number should be incremented each time you make changes +# to the chart and its templates, including the app version. +# Versions are expected to follow Semantic Versioning (https://semver.org/) +version: 0.0.1 + +# 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: 0.4.17 diff --git a/charts/restund/README.md b/charts/restund/README.md new file mode 100644 index 00000000000..8af0d2d3446 --- /dev/null +++ b/charts/restund/README.md @@ -0,0 +1,14 @@ +This chart deploys [Restund](https://docs.wire.com/understand/restund.html), a +STUN and TURN server. + +You need to supply the zrestSecret at key `secrets.zrestSecret`. Make sure this +matches `secrets.turn.secret` of the brig chart. + +Restund pods are deployed with `hostNetwork: true`, because restund needs to +listen on a wide range of udp ports. See `values.yaml` for additional tcp ports +that need to be exposed on the hosting node. + +The Restund server might also expose the internal network to which the hosting +node is connected to. It is therefore recommended to run restund on a separate +network (cluster) than the rest of wire's services. See +[details](https://docs.wire.com/understand/restund.html#network). diff --git a/charts/restund/templates/_helpers.tpl b/charts/restund/templates/_helpers.tpl new file mode 100644 index 00000000000..2aff503be05 --- /dev/null +++ b/charts/restund/templates/_helpers.tpl @@ -0,0 +1,45 @@ +{{- define "restund.name" -}} +{{- default .Chart.Name .Values.nameOverride | trunc 63 | trimSuffix "-" }} +{{- end }} + +{{/* +Create chart name and version as used by the chart label. +*/}} +{{- define "restund.chart" -}} +{{- printf "%s-%s" .Chart.Name .Chart.Version | replace "+" "_" | trunc 63 | trimSuffix "-" }} +{{- end }} + +{{/* +Common labels +*/}} +{{- define "restund.labels" -}} +helm.sh/chart: {{ include "restund.chart" . }} +{{ include "restund.selectorLabels" . }} +{{- if .Chart.AppVersion }} +app.kubernetes.io/version: {{ .Values.image.tag | default .Chart.AppVersion | quote }} +{{- end }} +app.kubernetes.io/managed-by: {{ .Release.Service }} +{{- end }} + +{{/* +Create a default fully qualified app name. +We truncate at 63 chars because some Kubernetes name fields are limited to this (by the DNS naming spec). +If release name contains chart name it will be used as a full name. +*/}} +{{- define "restund.fullname" -}} +{{- if .Values.fullnameOverride }} +{{- .Values.fullnameOverride | trunc 63 | trimSuffix "-" }} +{{- else }} +{{- $name := default .Chart.Name .Values.nameOverride }} +{{- if contains $name .Release.Name }} +{{- .Release.Name | trunc 63 | trimSuffix "-" }} +{{- else }} +{{- printf "%s-%s" .Release.Name $name | trunc 63 | trimSuffix "-" }} +{{- end }} +{{- end }} +{{- end }} + +{{- define "restund.selectorLabels" -}} +app.kubernetes.io/name: {{ include "restund.name" . }} +app.kubernetes.io/instance: {{ .Release.Name }} +{{- end }} diff --git a/charts/restund/templates/configmap-restund-conf-template.yaml b/charts/restund/templates/configmap-restund-conf-template.yaml new file mode 100644 index 00000000000..b25263f79f6 --- /dev/null +++ b/charts/restund/templates/configmap-restund-conf-template.yaml @@ -0,0 +1,51 @@ +apiVersion: v1 +kind: ConfigMap +metadata: + name: {{ include "restund.fullname" . }} + labels: + {{- include "restund.selectorLabels" . | nindent 4 }} + +data: + restund.conf.template: | + ## core + daemon no + debug no + realm dummy.io + syncinterval 600 + udp_listen ${RESTUND_HOST}:{{ .Values.restundUDPListenPort }} + udp_sockbuf_size 524288 + tcp_listen ${RESTUND_HOST}:{{ .Values.restundTCPListenPort }} + # tls_listen + + ## modules + module_path /usr/local/lib/restund/modules + module stat.so + module drain.so + module binding.so + module auth.so + module turn.so + module zrest.so + module status.so + + ## auth + auth_nonce_expiry 3600 + + ## turn + turn_max_allocations 64000 + turn_max_lifetime 3600 + turn_relay_addr ${RESTUND_HOST} + # # turn_public_addr is an IP which must be reachable for UDP traffic from other restund servers (and from this server itself). If unset, defaults to 'turn_relay_addr' + # turn_public_addr + + # syslog + syslog_facility 24 + + ## status + status_http_addr ${POD_IP} + status_http_port {{ .Values.restundHTTPStatusPort }} + # status_udp_addr + # status_udp_port + + # zrest + zrest_listen ${POD_IP} + zrest_secret ${ZREST_SECRET} diff --git a/charts/restund/templates/secret.yaml b/charts/restund/templates/secret.yaml new file mode 100644 index 00000000000..f5652f9dacc --- /dev/null +++ b/charts/restund/templates/secret.yaml @@ -0,0 +1,11 @@ +apiVersion: v1 +kind: Secret +metadata: + name: restund + labels: + chart: {{ .Chart.Name }}-{{ .Chart.Version | replace "+" "_" }} + release: "{{ .Release.Name }}" + heritage: "{{ .Release.Service }}" +type: Opaque +data: + zrest_secret.txt: {{ .Values.secrets.zrestSecret | b64enc | quote }} diff --git a/charts/restund/templates/service-account.yaml b/charts/restund/templates/service-account.yaml new file mode 100644 index 00000000000..1708744dd63 --- /dev/null +++ b/charts/restund/templates/service-account.yaml @@ -0,0 +1,33 @@ +--- +apiVersion: v1 +kind: ServiceAccount +metadata: + name: {{ include "restund.fullname" . }} + labels: + {{- include "restund.labels" . | nindent 4 }} +--- +apiVersion: rbac.authorization.k8s.io/v1 +kind: ClusterRole +metadata: + name: {{ include "restund.fullname" . }} + labels: + {{- include "restund.labels" . | nindent 4 }} +rules: + - apiGroups: [""] + resources: [nodes] + verbs: [get] +--- +apiVersion: rbac.authorization.k8s.io/v1 +kind: ClusterRoleBinding +metadata: + name: {{ include "restund.fullname" . }} + labels: + {{- include "restund.labels" . | nindent 4 }} +roleRef: + kind: ClusterRole + apiGroup: rbac.authorization.k8s.io + name: {{ include "restund.fullname" . }} +subjects: + - kind: ServiceAccount + name: {{ include "restund.fullname" . }} + namespace: {{ .Release.Namespace }} diff --git a/charts/restund/templates/service.yaml b/charts/restund/templates/service.yaml new file mode 100644 index 00000000000..d5f0a7b9409 --- /dev/null +++ b/charts/restund/templates/service.yaml @@ -0,0 +1,20 @@ +--- +apiVersion: v1 +kind: Service +metadata: + name: {{ include "restund.fullname" . }} + labels: + {{- include "restund.labels" . | nindent 4 }} +spec: + # Needs to be headless + # See: https://kubernetes.io/docs/concepts/workloads/controllers/statefulset/ + clusterIP: None + ports: + - name: restund-tcp + port: 3478 + targetPort: restund-tcp + - name: sft-config + port: 8000 + targetPort: sft-config + selector: + {{- include "restund.selectorLabels" . | nindent 4 }} diff --git a/charts/restund/templates/statefulset.yaml b/charts/restund/templates/statefulset.yaml new file mode 100644 index 00000000000..1b5715cde32 --- /dev/null +++ b/charts/restund/templates/statefulset.yaml @@ -0,0 +1,129 @@ +apiVersion: apps/v1 +kind: StatefulSet +metadata: + name: {{ include "restund.fullname" . }} + labels: + {{- include "restund.labels" . | nindent 4 }} + +spec: + replicas: {{ .Values.replicaCount }} + + # Allows restund to start up and shut down in parallel when scaling up and down. + # However this does not affect upgrades. + podManagementPolicy: Parallel + + serviceName: {{ include "restund.fullname" . }} + selector: + matchLabels: + {{- include "restund.selectorLabels" . | nindent 6 }} + template: + metadata: + {{- with .Values.podAnnotations }} + annotations: + {{- toYaml . | nindent 8 }} + {{- end }} + + labels: + {{- include "restund.selectorLabels" . | nindent 8 }} + spec: + securityContext: + {{- toYaml .Values.podSecurityContext | nindent 8 }} + hostNetwork: true + serviceAccountName: {{ include "restund.fullname" . }} + volumes: + - name: external-ip + emptyDir: {} + - name: restund-config-template + configMap: + name: {{ include "restund.fullname" . }} + - name: secrets + secret: + secretName: restund + initContainers: + - name: get-external-ip + image: bitnami/kubectl:1.19.7 + volumeMounts: + - name: external-ip + mountPath: /external-ip + command: + - /bin/sh + - -c + - | + set -e + + # In the cloud, this setting is available to indicate the true IP address + addr=$(kubectl get node $HOSTNAME -ojsonpath='{.status.addresses[?(@.type=="ExternalIP")].address}') + + # On on-prem we allow people to set "wire.com/external-ip" to override this + if [ -z "$addr" ]; then + addr=$(kubectl get node $HOSTNAME -ojsonpath='{.metadata.annotations.wire\.com/external-ip}') + fi + echo -n "$addr" | tee /dev/stderr > /external-ip/ip + containers: + - name: {{ .Chart.Name }} + image: "{{ .Values.image.repository }}:{{ .Values.image.tag | default .Chart.AppVersion }}" + imagePullPolicy: {{ .Values.image.pullPolicy }} + env: + - name: POD_IP + valueFrom: + fieldRef: + fieldPath: status.podIP + - name: POD_NAME + valueFrom: + fieldRef: + fieldPath: metadata.name + volumeMounts: + - name: external-ip + mountPath: /external-ip + - name: restund-config-template + mountPath: /restund-template/restund.conf.template + subPath: restund.conf.template + - name: secrets + mountPath: /secrets/ + readOnly: true + command: + - /bin/sh + - -c + - | + set -e + EXTERNAL_IP=$(cat /external-ip/ip) + export RESTUND_HOST="$EXTERNAL_IP" + export ZREST_SECRET="$(cat /secrets/zrest_secret.txt)" + envsubst '$RESTUND_HOST $POD_IP $ZREST_SECRET' < /restund-template/restund.conf.template > /home/restund/restund.conf + exec /usr/local/sbin/restund -n -f /home/restund/restund.conf + + ports: + - name: restund-tcp + containerPort: 3478 + protocol: TCP + - name: sft-config + containerPort: 8000 + protocol: TCP + - name: status-http + containerPort: {{ .Values.restundHTTPStatusPort }} + protocol: TCP + + livenessProbe: + httpGet: + path: / + port: status-http + + readinessProbe: + httpGet: + path: / + port: status-http + + resources: + {{- toYaml .Values.resources | nindent 12 }} + {{- with .Values.nodeSelector }} + nodeSelector: + {{- toYaml . | nindent 8 }} + {{- end }} + {{- with .Values.affinity }} + affinity: + {{- toYaml . | nindent 8 }} + {{- end }} + {{- with .Values.tolerations }} + tolerations: + {{- toYaml . | nindent 8 }} + {{- end }} diff --git a/charts/restund/values.yaml b/charts/restund/values.yaml new file mode 100644 index 00000000000..2a8b04cf0fc --- /dev/null +++ b/charts/restund/values.yaml @@ -0,0 +1,29 @@ +# The amount of Restund instances to run. NOTE: Only one Restund can run per node due +# to `hostNetwork`. If this number is higher than the amount of nodes that can +# be used for scheduling (Also see `nodeSelector`) pods will remain in a +# pending state untill you add more capacity. +replicaCount: 1 + +image: + repository: quay.io/wire/restund + pullPolicy: IfNotPresent + # overwrite the tag here, otherwise `appVersion` of the chart will be used + tag: "" + +# If you have multiple deployments of Restund running in one cluster, it is +# important that they run on disjoint sets of nodes, you can use nodeSelector to enforce this +nodeSelector: {} + +podSecurityContext: + fsGroup: 31337 + +securityContext: + # Pick a high number that is unlikely to conflict with the host + # https://kubesec.io/basics/containers-securitycontext-runasuser/ + runAsUser: 31337 + +restundUDPListenPort: 3478 +restundTCPListenPort: 3478 +restundUDPStatusPort: 33000 +restundHTTPStatusPort: 8080 +restundMetricsListenPort: 8443 diff --git a/charts/sftd/templates/configmap-join-call.yaml b/charts/sftd/templates/configmap-join-call.yaml index fd4ec86717a..523d741a2b5 100644 --- a/charts/sftd/templates/configmap-join-call.yaml +++ b/charts/sftd/templates/configmap-join-call.yaml @@ -17,4 +17,8 @@ data: proxy_pass http://$1.{{ include "sftd.fullname" . }}.${POD_NAMESPACE}.svc.cluster.local:8585/$2; } + location ~ ^/sft_servers_all.json$ { + root /etc/wire/sftd-disco/; + } + } diff --git a/charts/sftd/templates/deployment-join-call.yaml b/charts/sftd/templates/deployment-join-call.yaml index 0c247f7e6f7..3574bf04815 100644 --- a/charts/sftd/templates/deployment-join-call.yaml +++ b/charts/sftd/templates/deployment-join-call.yaml @@ -26,7 +26,20 @@ spec: - name: nginx-config configMap: name: {{ include "sftd.fullname" . }}-join-call + - name: sftd-disco + emptyDir: {} containers: + - name: sftd-disco + image: quay.io/wire/sftd_disco:wip-2 # TODO configure + version + volumeMounts: + - name: sftd-disco + mountPath: /etc/wire/sftd-disco + readOnly: false + command: + - "/bin/sh" + - "-c" + - | + /usr/bin/sftd_disco.sh _sft._tcp.{{ include "sftd.fullname" . }}.{{ .Release.Namespace }}.svc.cluster.local - name: nginx securityContext: {{- toYaml .Values.securityContext | nindent 12 }} @@ -50,6 +63,9 @@ spec: - mountPath: /etc/nginx/conf.d/default.conf.template name: nginx-config subPath: default.conf.template + - name: sftd-disco + mountPath: /etc/wire/sftd-disco + readOnly: true env: - name: POD_NAMESPACE valueFrom: diff --git a/charts/sftd/templates/ingress.yaml b/charts/sftd/templates/ingress.yaml index a14c53981a6..9bf7958fa0b 100644 --- a/charts/sftd/templates/ingress.yaml +++ b/charts/sftd/templates/ingress.yaml @@ -25,3 +25,7 @@ spec: backend: serviceName: "{{ include "sftd.fullname" . }}-join-call" servicePort: http + - path: /sft_servers_all.json + backend: + serviceName: "{{ include "sftd.fullname" . }}-join-call" + servicePort: http diff --git a/charts/sftd/templates/statefulset.yaml b/charts/sftd/templates/statefulset.yaml index 2c5d52fce40..3027ccf601d 100644 --- a/charts/sftd/templates/statefulset.yaml +++ b/charts/sftd/templates/statefulset.yaml @@ -30,10 +30,13 @@ spec: {{- toYaml .Values.podSecurityContext | nindent 8 }} terminationGracePeriodSeconds: {{ .Values.terminationGracePeriodSeconds }} hostNetwork: true + dnsPolicy: ClusterFirstWithHostNet serviceAccountName: {{ include "sftd.fullname" . }} volumes: - name: external-ip emptyDir: {} + - name: multi-sft-config + emptyDir: {} initContainers: - name: get-external-ip image: bitnami/kubectl:1.19.7 @@ -54,6 +57,47 @@ spec: addr=$(kubectl get node $HOSTNAME -ojsonpath='{.metadata.annotations.wire\.com/external-ip}') fi echo -n "$addr" | tee /dev/stderr > /external-ip/ip + - name: get-multi-sft-config + image: "{{ .Values.image.repository }}:{{ .Values.image.tag | default .Chart.AppVersion }}" + + volumeMounts: + - name: multi-sft-config + mountPath: /multi-sft-config + + command: + - /bin/sh + - -c + - | + set -e + + {{- if .Values.multiSFT.enabled }} + + response=$(curl "{{ .Values.multiSFT.turnDiscoveryURL }}") + if [ -z "$response" ]; then + echo "No response from restund server." + exit 1 + fi + + echo "$response" | jq -r '.username' > /multi-sft-config/username + if [ ! -s /multi-sft-config/username ]; then + echo "Response does not contain a username" + exit 1 + fi + + echo "$response" | jq -r '.password' > /multi-sft-config/password + if [ ! -s /multi-sft-config/password ]; then + echo "Response does not contain a password" + exit 1 + fi + + echo "$response" | jq -r '.uris[0]' > /multi-sft-config/turn_server + if [ ! -s /multi-sft-config/turn_server ]; then + echo "Response does not contain a turn server" + exit 1 + fi + + {{- end }} + containers: - name: {{ .Chart.Name }} securityContext: @@ -72,6 +116,8 @@ spec: volumeMounts: - name: external-ip mountPath: /external-ip + - name: multi-sft-config + mountPath: /multi-sft-config command: - /bin/sh - -c @@ -83,11 +129,20 @@ spec: else ACCESS_ARGS="-A ${EXTERNAL_IP}" fi + + {{- if .Values.multiSFT.enabled }} + MULTI_SFT_ARGS="-t $(cat /multi-sft-config/turn_server) \ + -x $(cat /multi-sft-config/username) \ + -c $(cat /multi-sft-config/password)" + {{- else }} + MULTI_SFT_ARGS="" + {{- end }} + exec sftd \ -I "${POD_IP}" \ -M "${POD_IP}" \ ${ACCESS_ARGS} \ - {{ .Values.additionalArgs }} \ + ${MULTI_SFT_ARGS} \ {{ 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 a34ae175892..5e90388b66d 100644 --- a/charts/sftd/values.yaml +++ b/charts/sftd/values.yaml @@ -86,6 +86,10 @@ joinCall: # 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: "" +# Allow establishing calls involving remote SFT servers (e.g. for Federation) +# Requires appVersion 3.0.9 or later +multiSFT: + enabled: False + # Required. URL that provides TURN connection configuration. These configured + # TURN servers will be used to connect to remote SFT servers. + turnDiscoveryURL: "" diff --git a/deploy/services-demo/conf/brig.demo-docker.yaml b/deploy/services-demo/conf/brig.demo-docker.yaml index 6de26fd1e66..ff9c1417d13 100644 --- a/deploy/services-demo/conf/brig.demo-docker.yaml +++ b/deploy/services-demo/conf/brig.demo-docker.yaml @@ -109,7 +109,8 @@ optSettings: stdDev: 3000 # 50 minutes retryAfter: 86400 # 1 day setRichInfoLimit: 5000 # should be in sync with Spar - setDefaultLocale: en + setDefaultTemplateLocale: en + setDefaultUserLocale: en setMaxTeamSize: 128 setMaxConvSize: 128 setEmailVisibility: visible_to_self diff --git a/deploy/services-demo/conf/brig.demo.yaml b/deploy/services-demo/conf/brig.demo.yaml index 90072befc8f..c4243c2942c 100644 --- a/deploy/services-demo/conf/brig.demo.yaml +++ b/deploy/services-demo/conf/brig.demo.yaml @@ -109,7 +109,8 @@ optSettings: stdDev: 3000 # 50 minutes retryAfter: 86400 # 1 day setRichInfoLimit: 5000 # should be in sync with Spar - setDefaultLocale: en + setDefaultTemplateLocale: en + setDefaultUserLocale: en setMaxTeamSize: 128 setMaxConvSize: 128 setEmailVisibility: visible_to_self diff --git a/deploy/services-demo/conf/cargohold.demo-docker.yaml b/deploy/services-demo/conf/cargohold.demo-docker.yaml index 0290f1fc0e3..c9dda863aad 100644 --- a/deploy/services-demo/conf/cargohold.demo-docker.yaml +++ b/deploy/services-demo/conf/cargohold.demo-docker.yaml @@ -11,6 +11,7 @@ aws: settings: maxTotalBytes: 27262976 downloadLinkTTL: 300 # Seconds + federationDomain: example.com logLevel: Info logNetStrings: false diff --git a/deploy/services-demo/conf/cargohold.demo.yaml b/deploy/services-demo/conf/cargohold.demo.yaml index b4200096b44..0f1228dcbaa 100644 --- a/deploy/services-demo/conf/cargohold.demo.yaml +++ b/deploy/services-demo/conf/cargohold.demo.yaml @@ -11,6 +11,7 @@ aws: settings: maxTotalBytes: 27262976 downloadLinkTTL: 300 # Seconds + federationDomain: example.com logLevel: Info logNetStrings: false diff --git a/dev-packages.nix b/dev-packages.nix index 3747cc9ae2a..73522c868eb 100644 --- a/dev-packages.nix +++ b/dev-packages.nix @@ -51,15 +51,15 @@ let }; pinned = { - stack = staticBinaryInTarball { + stack = staticBinaryInTarball rec { pname = "stack"; - version = "2.3.1"; + version = "2.7.3"; - darwinAmd64Url = "https://github.com/commercialhaskell/stack/releases/download/v2.3.1/stack-2.3.1-osx-x86_64.tar.gz"; - darwinAmd64Sha256 = "089nrb8mxf76a0r0hdccaxfvx1ly24b5zc0cy05gs4adybjygvkk"; + darwinAmd64Url = "https://github.com/commercialhaskell/stack/releases/download/v${version}/stack-${version}-osx-x86_64.tar.gz"; + darwinAmd64Sha256 = "0c7yx670h1qi2g5l4xx9s4552pz77k31lhjjd2rafi5g00501ra2"; - linuxAmd64Url = "https://github.com/commercialhaskell/stack/releases/download/v2.3.1/stack-2.3.1-linux-x86_64-static.tar.gz"; - linuxAmd64Sha256 = "0iqfqcd88rvlwgm2h8avs0rsi9f3pdxilvcacgrxskb1n8q8ibjb"; + linuxAmd64Url = "https://github.com/commercialhaskell/stack/releases/download/v${version}/stack-${version}-linux-x86_64-static.tar.gz"; + linuxAmd64Sha256 = "sha256-xbziTe+isrhvG7sUvtTx7oO+wUxu2fzIEXTVRz+/NFA="; }; helm = staticBinaryInTarball { @@ -109,6 +109,19 @@ let }; }; + c-lib-out-deps = [ + pkgs.cryptobox + pkgs.icu.out + pkgs.libsodium.out + pkgs.libxml2.out + pkgs.ncurses.out + pkgs.openssl.out + pkgs.pcre.out + pkgs.snappy.out + pkgs.zlib.out + pkgs.lzma.out + ]; + compile-deps = pkgs.buildEnv { name = "wire-server-compile-deps"; paths = [ @@ -120,30 +133,20 @@ let pkgs.gawk pkgs.git - pkgs.haskell.compiler.ghc884 + pkgs.haskell.compiler.ghc8107 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 - ]; + ] ++ c-lib-out-deps; }; # This performs roughly the same setup as direnv's load_prefix function, but @@ -163,7 +166,7 @@ in pkgs.cfssl pkgs.docker-compose pkgs.gnumake - pkgs.haskell-language-server + (pkgs.haskell-language-server.override {supportedGhcVersions = ["8107"];}) pkgs.jq pkgs.ormolu pkgs.telepresence @@ -187,4 +190,6 @@ in # 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 + pkgs.haskellPackages.implicit-hie ] +++ c-lib-out-deps # Required to run HLS diff --git a/docs/developer/dependencies.md b/docs/developer/dependencies.md index 878132cebfc..0d5d01619f3 100644 --- a/docs/developer/dependencies.md +++ b/docs/developer/dependencies.md @@ -4,11 +4,6 @@ This page documents how to install necessary dependencies to work with the wire- This repository makes use of git submodules. When cloning or updating, use `git submodule update --init --recursive` to check out the code dependencies. -In addition to the information below, you can also consult the Dockerfiles for Alpine Linux, that could serve as inspiration: - -* [alpine setup for Haskell services](../../build/alpine/Dockerfile.builder) -* [alpine setup for nginz](../../services/nginz/Dockerfile) - ## General package dependencies (needed to compile Haskell services) *Note: all the below sections for getting compile-time dependencies necessary to compile all of wire-server may potentially go out of date; if you spot a mistake please open an issue or PR* @@ -89,7 +84,7 @@ sudo installer -pkg /Library/Developer/CommandLineTools/Packages/macOS_SDK_heade Please refer to [Stack's installation instructions](https://docs.haskellstack.org/en/stable/README/#how-to-install). -When you're done, ensure `stack --version` is the same as `STACK_ALPINE_VERSION` in [`build/alpine/Dockerfile.prebuilder`](../../build/alpine/Dockerfile.prebuilder). +When you're done, ensure `stack --version` is the same as `STACK_VERSION` in [`build/ubuntu/Dockerfile.prebuilder`](../../build/ubuntu/Dockerfile.prebuilder). If you have to, you can downgrade stack with this command: diff --git a/docs/developer/editor-setup.md b/docs/developer/editor-setup.md index 249529677d9..4e030f88b08 100644 --- a/docs/developer/editor-setup.md +++ b/docs/developer/editor-setup.md @@ -110,4 +110,8 @@ 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 +- Reload the window as proposed by the `Nix Environment Selector` plugin + +An alternative way to make these dependencies accessible to VSCode is to start it in the `direnv` environment. +I.e. from a shell that's current working directory is in the project. The drawbacks of this approach are +that it only works locally (not on a remote connection) and one VSCode process needs to be started per project. \ No newline at end of file diff --git a/docs/developer/linting.md b/docs/developer/linting.md new file mode 100644 index 00000000000..5dcbf75ab0f --- /dev/null +++ b/docs/developer/linting.md @@ -0,0 +1,55 @@ +# Linting + +# HLint + +To run [HLint](https://github.com/ndmitchell/hlint) you need it's binary, e.g. +by executing: + +```sh +nix-shell -p hlint +``` + +To run it on the whole project (Warning: This takes a long time!): + +```sh +hlint . +``` + +To run it on a sub-project: + +```sh +hlint services/federator +``` + +# Stan + +To run [Stan](https://github.com/kowainik/stan), you need it's binary compiled +by the same GHC version as used in the project. + +```sh +nix-shell -p haskell.packages.ghc884.stan +``` + +Stan depends on [*hie*](https://www.haskell.org/ghc/blog/20190626-HIEFiles.html) +database files that are created during compilation. To generate them for all +packages add this to your `cabal.project.local` file: + +``` +package * + ghc-options: -fwrite-ide-info -hiedir=.hie +``` + +Of course, you can append the `ghc-options` to the respective entry of a package or +add a new one: + +```sh +package cargohold + ghc-options: -fwrite-ide-info -hiedir=.hie +``` + +To analyze a sub-project with stan: + +```sh +cd services/cargohold +stan +``` diff --git a/docs/reference/config-options.md b/docs/reference/config-options.md index ce3535eb736..c5143212ac4 100644 --- a/docs/reference/config-options.md +++ b/docs/reference/config-options.md @@ -169,18 +169,25 @@ This record should have entries which lead to the federator. **IMPORTANT** Once this option is set, it cannot be changed without breaking experience for all the users which are already using the backend. -This configuration needs to be made in brig and in galley. (note the slighly different spelling of the config options) +This configuration needs to be made in brig, cargohold and galley (note the +slighly different spelling of the config options). ```yaml -# galley.yaml +# brig.yaml +optSettings: + setFederationDomain: example.com +``` + +```yaml +# cargohold.yaml settings: federationDomain: example.com ``` ```yaml -# brig.yaml -optSettings: - setFederationDomain: example.com +# galley.yaml +settings: + federationDomain: example.com ``` ### Federation allow list @@ -312,3 +319,30 @@ When a `null` value is encountered, it is assumed to be `defaultForNull`. (Introduced in https://github.com/wireapp/wire-server/pull/1811.) + +### Locale + + +#### setDefaultLocale (deprecated / ignored) + +The brig server config option `setDefaultLocale` has been replaced by `setDefaultUserLocale` and `setDefaultTemplateLocale`. Both settings are optional and `setDefaultTemplateLocale` defaults to `EN` and `setDefaultLocale` defaults to `setDefaultTemplateLocale`. If `setDefaultLocale` was not set or set to `EN` before this change, nothing needs to be done. If `setDefaultLocale` was set to any other language other than `EN` the name of the setting should be changed to `setDefaultTemplateLocale`. + +#### `setDefaultTemplateLocale` + +This option determines the default locale for email templates. The language of the email communication is determined by the user locale (see above). Only if templates of the the locale of the user do not exist or if user locale is not set the `setDefaultTemplateLocale` is used as a fallback. If not set the default is `EN`. This setting should not be changed unless a complete set of templates is available for the given language. + +``` +# [brig.yaml] +optSettings: + setDefaultTemplateLocale: en +``` + +#### `setDefaultUserLocale` + +This option is the default user locale to be used if it is not set in the user profile. This can be the case if the users are provisioned by SCIM e.g. This option determines which language to use for email communication. If not set the default is the value that is configured for `setDefaultTemplateLocale`. + +``` +# [brig.yaml] +optSettings: + setDefaultUserLocale: en +``` diff --git a/hack/bin/buildah-compile.sh b/hack/bin/buildah-compile.sh index 713cc19f637..ff257b4c5ed 100755 --- a/hack/bin/buildah-compile.sh +++ b/hack/bin/buildah-compile.sh @@ -1,6 +1,6 @@ #!/usr/bin/env bash -# This compiles wire-server inside an alpine-based container based on quay.io/wire/alpine-builder. +# This compiles wire-server inside an ubuntu-based container based on quay.io/wire/ubuntu20-builder. # the tool 'buildah' is used to mount some folders in, and to # keep the stack caches of .stack and .stack-work (renamed to avoid conflicts) for the next compilation @@ -20,9 +20,9 @@ CONTAINER_NAME=wire-server-dev # check for the existence of; or create a working container buildah containers | awk '{print $5}' | grep "$CONTAINER_NAME" \ - || buildah from --name "$CONTAINER_NAME" -v "${TOP_LEVEL}":/src --pull quay.io/wire/alpine-builder:develop + || buildah from --name "$CONTAINER_NAME" -v "${TOP_LEVEL}":/src --pull quay.io/wire/ubuntu20-builder:develop -# The first time round, we want to copy the .stack folder from the alpine-builder for future use. Afterwards, we want to re-use the "dirty" stack root folder. +# The first time round, we want to copy the .stack folder from the ubuntu20-builder for future use. Afterwards, we want to re-use the "dirty" stack root folder. # Current check hinges on the existence of a config file, and hardcodes some paths ls "$TOP_LEVEL/.stack-root-buildah/config.yaml" 2> /dev/null \ || buildah run "$CONTAINER_NAME" -- cp -a /root/.stack/. /src/.stack-root-buildah/ diff --git a/hack/bin/buildah-make-images.sh b/hack/bin/buildah-make-images.sh index a52c470282d..4fa80899116 100755 --- a/hack/bin/buildah-make-images.sh +++ b/hack/bin/buildah-make-images.sh @@ -10,7 +10,7 @@ CONTAINER_NAME="output" DOCKER_TAG=${DOCKER_TAG:-$USER} buildah containers | awk '{print $5}' | grep "$CONTAINER_NAME" || - buildah from --name "$CONTAINER_NAME" -v "${TOP_LEVEL}":/src --pull quay.io/wire/alpine-deps:develop + buildah from --name "$CONTAINER_NAME" -v "${TOP_LEVEL}":/src --pull quay.io/wire/ubuntu20-deps:develop # Only brig needs these templates, but for simplicity we add them to all resulting images (optimization FUTUREWORK) buildah run "$CONTAINER_NAME" -- sh -c 'mkdir -p /usr/share/wire/ && cp -r "/src/services/brig/deb/opt/brig/templates/." "/usr/share/wire/templates"' diff --git a/hack/bin/cabal-install-artefacts.sh b/hack/bin/cabal-install-artefacts.sh index c80ef37de18..5307fd30931 100755 --- a/hack/bin/cabal-install-artefacts.sh +++ b/hack/bin/cabal-install-artefacts.sh @@ -6,6 +6,8 @@ TOP_LEVEL="$(cd "$DIR/../.." && pwd)" DIST="$TOP_LEVEL/dist" +mkdir -p "$DIST" + if [[ "$1" == "all" ]]; then pattern='*' else diff --git a/hack/bin/cabal-run-integration.sh b/hack/bin/cabal-run-integration.sh index c68bd2a97b5..c15f86d71cd 100755 --- a/hack/bin/cabal-run-integration.sh +++ b/hack/bin/cabal-run-integration.sh @@ -1,26 +1,67 @@ #!/usr/bin/env bash set -euo pipefail +# +# this script runs the integration test suite for the given service, after it +# has started all services integration test configuration. +# +# Usage: +# +# ./cabal-run-integration.sh brig +# ./cabal-run-integration.sh brig -p '$2 == "provider" && $3 == "account"' +# +# Any additional arguments are passed as-is to the integration test executable. +# brig uses tasty, so you specify patterns with -p. The above example runs all +# tests in the test tree +# +# Brig API Integration +# provider +# account +# +# Federator uses hspec, where you specify patterns like so: +# +# ./cabal-run-integration.sh federator -m rejectRequestsWithoutClientCertIngress +# +# To run all integration tests without arguments run: +# +# ./cabal-run-integration.sh all +# +# If you're not sure what test suite is being used call for help +# ./cabal-run-integration.sh spar --help DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )" TOP_LEVEL="$(cd "$DIR/../.." && pwd)" package=${1:-all} -pattern=${2:-} -opts="" +run_integration_tests() { + package=${1} -if [[ "$package" != "all" ]]; then - opts="$opts -C services/$package" -fi + service_dir="$TOP_LEVEL/services/$package" + + cd "$service_dir" + "$TOP_LEVEL/services/integration.sh" \ + "$TOP_LEVEL/dist/$package-integration" \ + -s "$service_dir/$package.integration.yaml" \ + -i "$TOP_LEVEL/services/integration.yaml" \ + "${@:2}" +} -if [[ -n "$pattern" ]]; then - if [[ "$package" == "all" ]]; then - echo -e "\e[31mGlobal pattern not supported\e[0m" >&2 +run_all_integration_tests() { + for d in "$TOP_LEVEL/services/"*/; do + package=$(basename "$d") + service_dir="$TOP_LEVEL/services/$package" + if [ -d "$service_dir/test/integration" ] || [ -d "$service_dir/test-integration" ]; then + run_integration_tests "$package" + fi + done +} + +if [ "$package" == "all" ]; then + if [ -n "${2:-}" ]; then + echo -e "\e[31mCannot pass additional args to all integrations tests.\e[0m" >&2 exit 1 fi - opts="$opts i-$pattern" + run_all_integration_tests else - opts="$opts i" + run_integration_tests "$package" "${@:2}" fi - -exec make $opts diff --git a/hack/bin/cabal-run-tests.sh b/hack/bin/cabal-run-tests.sh index a9b17b4c462..46a9099ecad 100755 --- a/hack/bin/cabal-run-tests.sh +++ b/hack/bin/cabal-run-tests.sh @@ -4,15 +4,19 @@ set -euo pipefail DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )" TOP_LEVEL="$(cd "$DIR/../.." && pwd)" -pkgName=${1:-Please specify package name} +package=${1:-all} -# This is required because some tests (e.g. golden tests) depend on the path -# where they are run from. -pkgDir=$(find "$TOP_LEVEL" -name "$pkgName.cabal" | grep -v dist-newstyle | head -1 | xargs -n 1 dirname) -cd "$pkgDir" - -test_suites=$(cabal-plan list-bins "$pkgName"':test:*' | awk '{print $2}') - -for test_suite in $test_suites; do +if [[ "$package" == all ]]; then + pattern='*.cabal' +else + pattern="$package.cabal" +fi +for cabal in $(find "$TOP_LEVEL" -name "$pattern" | grep -v dist-newstyle); do + # This is required because some tests (e.g. golden tests) must be run from + # the package root. + cd "$(dirname $cabal)" + package="$(basename ${cabal%.*})" + for test_suite in $(cabal-plan list-bins "$package:test:*" | awk '{print $2}'); do $test_suite "${@:2}" + done done diff --git a/hack/helm_vars/wire-server/values.yaml.gotmpl b/hack/helm_vars/wire-server/values.yaml.gotmpl index c872b4c04a6..107aec9f9d3 100644 --- a/hack/helm_vars/wire-server/values.yaml.gotmpl +++ b/hack/helm_vars/wire-server/values.yaml.gotmpl @@ -51,7 +51,7 @@ brig: sessionTokenTimeout: 20 accessTokenTimeout: 30 providerTokenTimeout: 60 - enableFederator: true # keep in sync with galley.config.enableFederator and tags.federator! + enableFederator: true # keep in sync with galley.config.enableFederator, cargohold.config.enableFederator and tags.federator! optSettings: setActivationTimeout: 5 # keep this in sync with brigSettingsTeamInvitationTimeout in spar/templates/tests/configmap.yaml @@ -69,7 +69,8 @@ brig: retryLimit: 5 # how many times can you have a failed login in that timeframe. setSuspendInactiveUsers: suspendTimeout: 10 - setDefaultLocale: en + setDefaultTemplateLocale: en + setDefaultUserLocale: en setMaxConvAndTeamSize: 16 setMaxTeamSize: 32 setMaxConvSize: 16 @@ -125,6 +126,7 @@ cargohold: aws: s3Bucket: dummy-bucket s3Endpoint: http://fake-aws-s3:9000 + enableFederator: true # keep in sync with brig.config.enableFederator, galley.config.enableFederator and tags.federator! secrets: awsKeyId: dummykey awsSecretKey: dummysecret @@ -135,7 +137,7 @@ galley: cassandra: host: cassandra-ephemeral replicaCount: 1 - enableFederator: true # keep in sync with brig.config.enableFederator and tags.federator! + enableFederator: true # keep in sync with brig.config.enableFederator, cargohold.config.enableFederator and tags.federator! settings: maxConvAndTeamSize: 16 maxTeamSize: 32 diff --git a/hack/helmfile.yaml b/hack/helmfile.yaml index 578cef0d9a4..e345085bc1d 100644 --- a/hack/helmfile.yaml +++ b/hack/helmfile.yaml @@ -108,6 +108,8 @@ releases: value: {{ .Values.federationDomain }} - name: galley.config.settings.federationDomain value: {{ .Values.federationDomain }} + - name: cargohold.config.settings.federationDomain + value: {{ .Values.federationDomain }} - name: '{{ .Values.namespace }}-wire-server-2' namespace: '{{ .Values.namespaceFed2 }}' @@ -120,3 +122,5 @@ releases: value: {{ .Values.federationDomainFed2 }} - name: galley.config.settings.federationDomain value: {{ .Values.federationDomainFed2 }} + - name: cargohold.config.settings.federationDomain + value: {{ .Values.federationDomainFed2 }} diff --git a/libs/api-bot/api-bot.cabal b/libs/api-bot/api-bot.cabal index 5edff02e242..e7d323890ee 100644 --- a/libs/api-bot/api-bot.cabal +++ b/libs/api-bot/api-bot.cabal @@ -1,10 +1,10 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack -- --- hash: 75d171e4af4336949458672c5c82f2cc7fb00e0e5ef4823cb10692f903396df1 +-- hash: e1d75e3473601a708c1154cd12e54b8990937ab09168ea17d8359c4573dd5987 name: api-bot version: 0.4.2 @@ -36,7 +36,46 @@ library Paths_api_bot 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 + 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 build-depends: HaskellNet >=0.5 diff --git a/libs/api-client/api-client.cabal b/libs/api-client/api-client.cabal index 0401f2be7df..810e6bd5fc8 100644 --- a/libs/api-client/api-client.cabal +++ b/libs/api-client/api-client.cabal @@ -1,10 +1,10 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack -- --- hash: d476963623ad1a6ebc3261c3e3abea13a40f95682c9d0a696fb423037fc6360b +-- hash: 55c2d2915aedb6a1fffd5a9cf920729e473ce67d106d456c5f499572967e8034 name: api-client version: 0.4.2 @@ -35,7 +35,46 @@ library Paths_api_client 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 + 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 build-depends: aeson >=0.11 diff --git a/libs/bilge/bilge.cabal b/libs/bilge/bilge.cabal index ca21e9ed253..443c91a643d 100644 --- a/libs/bilge/bilge.cabal +++ b/libs/bilge/bilge.cabal @@ -1,10 +1,10 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack -- --- hash: 8edb13a7bddfafe7d2906bff5e3671bd529be1c1726e113907c70a373cfc2606 +-- hash: 35c665e33076366baa18f5cac9e0d715b8d137004bf07f93b69eb9ae99c93195 name: bilge version: 0.22.0 @@ -35,7 +35,46 @@ library Paths_bilge 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 + 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 build-depends: aeson >=0.6 diff --git a/libs/brig-types/brig-types.cabal b/libs/brig-types/brig-types.cabal index 2ce16e19919..f7dad9b128b 100644 --- a/libs/brig-types/brig-types.cabal +++ b/libs/brig-types/brig-types.cabal @@ -1,10 +1,10 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack -- --- hash: 42d648b07cd5a5d45e2ca36fd4631c37047fc74aea88fce77073a3efa99327a2 +-- hash: 7d28adb77d06047d2fb59e1470865a151254230ed48075e7ea0d68d35366147c name: brig-types version: 1.35.0 @@ -45,7 +45,46 @@ library Paths_brig_types 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 + 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 -funbox-strict-fields build-depends: QuickCheck >=2.9 @@ -80,7 +119,46 @@ test-suite brig-types-tests Paths_brig_types hs-source-dirs: test/unit - 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 + 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-depends: QuickCheck >=2.9 diff --git a/libs/cargohold-types/cargohold-types.cabal b/libs/cargohold-types/cargohold-types.cabal index 6626e3dd6f5..b9e414d9a53 100644 --- a/libs/cargohold-types/cargohold-types.cabal +++ b/libs/cargohold-types/cargohold-types.cabal @@ -1,10 +1,8 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack --- --- hash: 6e7a4ce0ec22392573f2b2764073d89b1096322eff38e0af765761e6bb2257a2 name: cargohold-types version: 1.5.0 @@ -21,12 +19,50 @@ library exposed-modules: CargoHold.Types CargoHold.Types.V3 - CargoHold.Types.V3.Resumable other-modules: Paths_cargohold_types 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 + 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 build-depends: base ==4.* diff --git a/libs/cargohold-types/src/CargoHold/Types/V3.hs b/libs/cargohold-types/src/CargoHold/Types/V3.hs index b4c3f2531ef..e0b8ee3fe1f 100644 --- a/libs/cargohold-types/src/CargoHold/Types/V3.hs +++ b/libs/cargohold-types/src/CargoHold/Types/V3.hs @@ -58,7 +58,7 @@ where import Data.ByteString.Conversion import Data.Id import Imports -import Wire.API.Asset.V3 +import Wire.API.Asset -------------------------------------------------------------------------------- -- Principal diff --git a/libs/cargohold-types/src/CargoHold/Types/V3/Resumable.hs b/libs/cargohold-types/src/CargoHold/Types/V3/Resumable.hs deleted file mode 100644 index f84ac4bdf08..00000000000 --- a/libs/cargohold-types/src/CargoHold/Types/V3/Resumable.hs +++ /dev/null @@ -1,36 +0,0 @@ --- 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 CargoHold.Types.V3.Resumable - ( -- * re-exports - ResumableSettings, - mkResumableSettings, - setResumableType, - setResumablePublic, - setResumableRetention, - ResumableAsset, - TotalSize (..), - ChunkSize (..), - Offset (..), - mkResumableAsset, - resumableAsset, - resumableExpires, - resumableChunkSize, - ) -where - -import Wire.API.Asset.V3.Resumable diff --git a/libs/cassandra-util/cassandra-util.cabal b/libs/cassandra-util/cassandra-util.cabal index d68adc82518..cc43fe634ae 100644 --- a/libs/cassandra-util/cassandra-util.cabal +++ b/libs/cassandra-util/cassandra-util.cabal @@ -1,10 +1,10 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack -- --- hash: 0e7f101562d82c7e04fbc1824f5bc9ef427915eacf3bd7370a2412a016a022be +-- hash: a517eff209060dd72d3ddfdf3d5af57021c95a989da62cca8c98584144cbb7e3 name: cassandra-util version: 0.16.5 @@ -29,7 +29,46 @@ library Paths_cassandra_util 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 + 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 build-depends: aeson >=0.7 diff --git a/libs/deriving-swagger2/deriving-swagger2.cabal b/libs/deriving-swagger2/deriving-swagger2.cabal index 258c590d500..1f2e7539bb6 100644 --- a/libs/deriving-swagger2/deriving-swagger2.cabal +++ b/libs/deriving-swagger2/deriving-swagger2.cabal @@ -1,10 +1,10 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack -- --- hash: 70e4168ab448671990c8ab35db93f44679a06283813db5aeb53fe33442d4ecac +-- hash: 314df46c4097fb6a56f853e430a9148ccc7ee76375387bec6d03b68c1827f51f name: deriving-swagger2 version: 0.1.0 @@ -24,10 +24,49 @@ library Paths_deriving_swagger2 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 + 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 build-depends: - base >=4 && <5 + base ==4.* , extra , imports , swagger2 >=0.6 diff --git a/libs/dns-util/dns-util.cabal b/libs/dns-util/dns-util.cabal index 023ad5af62f..a674dc74860 100644 --- a/libs/dns-util/dns-util.cabal +++ b/libs/dns-util/dns-util.cabal @@ -1,10 +1,8 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack --- --- hash: eb1c3d83585fec582c135dbe676c68498f2546468581882f07fdba8f0d16aec3 name: dns-util version: 0.1.0 @@ -27,12 +25,52 @@ library Paths_dns_util 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 + 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 build-depends: base >=4.6 && <5.0 , dns , imports + , iproute , polysemy , random default-language: Haskell2010 @@ -45,7 +83,46 @@ test-suite spec Paths_dns_util 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 + 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 -rtsopts -with-rtsopts=-N build-tool-depends: hspec-discover:hspec-discover @@ -55,6 +132,7 @@ test-suite spec , dns-util , hspec , imports + , iproute , polysemy , random default-language: Haskell2010 diff --git a/libs/dns-util/package.yaml b/libs/dns-util/package.yaml index 2a5cb7b9cc2..b0f2b30d5a6 100644 --- a/libs/dns-util/package.yaml +++ b/libs/dns-util/package.yaml @@ -14,6 +14,7 @@ dependencies: - dns - random - imports +- iproute - polysemy library: source-dirs: src diff --git a/libs/dns-util/src/Wire/Network/DNS/Effect.hs b/libs/dns-util/src/Wire/Network/DNS/Effect.hs index 5484d971d12..0b55358f46b 100644 --- a/libs/dns-util/src/Wire/Network/DNS/Effect.hs +++ b/libs/dns-util/src/Wire/Network/DNS/Effect.hs @@ -21,10 +21,10 @@ import Imports import Network.DNS (Domain, Resolver) import qualified Network.DNS as DNS import Polysemy -import Wire.Network.DNS.SRV +import qualified Wire.Network.DNS.SRV as SRV data DNSLookup m a where - LookupSRV :: Domain -> DNSLookup m SrvResponse + LookupSRV :: Domain -> DNSLookup m SRV.SrvResponse makeSem ''DNSLookup @@ -33,8 +33,8 @@ runDNSLookupDefault = interpret $ \(LookupSRV domain) -> embed $ do rs <- DNS.makeResolvSeed DNS.defaultResolvConf DNS.withResolver rs $ \resolver -> - interpretResponse <$> DNS.lookupSRV resolver domain + SRV.interpretResponse <$> DNS.lookupSRV resolver domain runDNSLookupWithResolver :: Member (Embed IO) r => Resolver -> Sem (DNSLookup ': r) a -> Sem r a -runDNSLookupWithResolver resolver = - interpret $ \(LookupSRV domain) -> embed (interpretResponse <$> DNS.lookupSRV resolver domain) +runDNSLookupWithResolver resolver = interpret $ \(LookupSRV domain) -> + embed (SRV.interpretResponse <$> DNS.lookupSRV resolver domain) diff --git a/libs/extended/extended.cabal b/libs/extended/extended.cabal index aee67e062f1..b3070542fe5 100644 --- a/libs/extended/extended.cabal +++ b/libs/extended/extended.cabal @@ -1,10 +1,10 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack -- --- hash: 3aab57e8600541201e0b0f8cd7308f624eb479a4f5601e800399b4787656c449 +-- hash: 380f8ec2858bc5b11252ece06a472e4458f97cff4803d261b6d9624d2d0793bf name: extended version: 0.1.0 @@ -30,7 +30,46 @@ library Paths_extended 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 + 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 build-depends: aeson @@ -61,7 +100,46 @@ test-suite extended-tests 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 + 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 diff --git a/libs/extended/src/System/Logger/Extended.hs b/libs/extended/src/System/Logger/Extended.hs index ec51ba4870e..6bb4cb8ebba 100644 --- a/libs/extended/src/System/Logger/Extended.hs +++ b/libs/extended/src/System/Logger/Extended.hs @@ -36,7 +36,7 @@ import Cassandra (MonadClient) import Control.Monad.Catch import Data.Aeson as Aeson import Data.Aeson.Encoding (list, pair, text) -import qualified Data.ByteString.Lazy.Builder as B +import qualified Data.ByteString.Builder as B import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.Map.Lazy as Map import Data.String.Conversions (cs) diff --git a/libs/galley-types/galley-types.cabal b/libs/galley-types/galley-types.cabal index 60a176f4a1d..ace5070f043 100644 --- a/libs/galley-types/galley-types.cabal +++ b/libs/galley-types/galley-types.cabal @@ -1,10 +1,10 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack -- --- hash: ccecf8384a3050034fc05928ae9bd039006f4479289f73de11832052791a691f +-- hash: fa648be72eab493846729545f4f4ec2a9cdc0f69add8e39150054510a9e9ac24 name: galley-types version: 0.81.0 @@ -33,12 +33,51 @@ library Paths_galley_types 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 + 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 build-depends: QuickCheck , aeson >=0.6 - , base >=4 && <5 + , base ==4.* , bytestring , bytestring-conversion , containers >=0.5 @@ -68,7 +107,46 @@ test-suite galley-types-tests Paths_galley_types hs-source-dirs: test/unit - 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 + 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-depends: QuickCheck diff --git a/libs/galley-types/src/Galley/Types/Conversations/Intra.hs b/libs/galley-types/src/Galley/Types/Conversations/Intra.hs index 0cb0ba9afd7..e41823f3cef 100644 --- a/libs/galley-types/src/Galley/Types/Conversations/Intra.hs +++ b/libs/galley-types/src/Galley/Types/Conversations/Intra.hs @@ -72,7 +72,7 @@ instance ToSchema UpsertOne2OneConversationRequest where <*> (qUntagged . uooRemoteUser) .= field "remote_user" (qTagUnsafe <$> schema) <*> uooActor .= field "actor" schema <*> uooActorDesiredMembership .= field "actor_desired_membership" schema - <*> uooConvId .= field "conversation_id" (optWithDefault A.Null schema) + <*> uooConvId .= optField "conversation_id" (maybeWithDefault A.Null schema) newtype UpsertOne2OneConversationResponse = UpsertOne2OneConversationResponse { uuorConvId :: Qualified ConvId diff --git a/libs/galley-types/src/Galley/Types/Teams.hs b/libs/galley-types/src/Galley/Types/Teams.hs index f1251eff0a5..a37bbdc466d 100644 --- a/libs/galley-types/src/Galley/Types/Teams.hs +++ b/libs/galley-types/src/Galley/Types/Teams.hs @@ -65,16 +65,17 @@ module Galley.Types.Teams teamListHasMore, TeamMember, userId, + nUserId, permissions, + nPermissions, invitation, + nInvitation, legalHoldStatus, - teamMemberJson, TeamMemberList, ListType (..), newTeamMemberList, teamMembers, teamMemberListType, - teamMemberListJson, TeamConversation, newTeamConversation, conversationId, @@ -105,8 +106,6 @@ module Galley.Types.Teams newTeamIconKey, newTeamMembers, NewTeamMember, - newNewTeamMember, - ntmNewTeamMember, Event, newEvent, eventType, diff --git a/libs/gundeck-types/gundeck-types.cabal b/libs/gundeck-types/gundeck-types.cabal index 50727bb8026..021a011e806 100644 --- a/libs/gundeck-types/gundeck-types.cabal +++ b/libs/gundeck-types/gundeck-types.cabal @@ -1,10 +1,10 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack -- --- hash: f194c41b1f0f872204ed3e86abc49b16601caef978949cee922fe4fa08cd7b89 +-- hash: dba11fae094eb5ca67d599427dc30c857a0263eb293cf917e14442c7101bdb97 name: gundeck-types version: 1.45.0 @@ -31,12 +31,51 @@ library Paths_gundeck_types 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 + 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 build-depends: aeson >=0.6 , attoparsec >=0.10 - , base >=4 && <5 + , base ==4.* , bytestring >=0.10 , bytestring-conversion >=0.2 , containers >=0.5 diff --git a/libs/hscim/hscim.cabal b/libs/hscim/hscim.cabal index d9c9a0732e6..381f3bc0939 100644 --- a/libs/hscim/hscim.cabal +++ b/libs/hscim/hscim.cabal @@ -1,10 +1,10 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack -- --- hash: 8daa0bcbe43125e8d9749dd38e62f67cb01f62a1bcd57a0391e684860203e60c +-- hash: cca3008213a478b2de914ed4e3bb1946613cc6cf4103168bacbe9b002e73764b name: hscim version: 0.3.6 @@ -69,7 +69,23 @@ library Paths_hscim hs-source-dirs: src - default-extensions: ConstraintKinds DataKinds DeriveFunctor DeriveGeneric FlexibleContexts FlexibleInstances KindSignatures LambdaCase MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeApplications TypeFamilies TypeOperators TypeSynonymInstances + default-extensions: + ConstraintKinds + DataKinds + DeriveFunctor + DeriveGeneric + FlexibleContexts + FlexibleInstances + KindSignatures + LambdaCase + MultiParamTypeClasses + OverloadedStrings + RankNTypes + ScopedTypeVariables + TypeApplications + TypeFamilies + TypeOperators + TypeSynonymInstances ghc-options: -Wall -Werror build-depends: aeson >=1.4.5 && <1.5 @@ -118,7 +134,23 @@ executable hscim-server Paths_hscim hs-source-dirs: server - default-extensions: ConstraintKinds DataKinds DeriveFunctor DeriveGeneric FlexibleContexts FlexibleInstances KindSignatures LambdaCase MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeApplications TypeFamilies TypeOperators TypeSynonymInstances + default-extensions: + ConstraintKinds + DataKinds + DeriveFunctor + DeriveGeneric + FlexibleContexts + FlexibleInstances + KindSignatures + LambdaCase + MultiParamTypeClasses + OverloadedStrings + RankNTypes + ScopedTypeVariables + TypeApplications + TypeFamilies + TypeOperators + TypeSynonymInstances ghc-options: -Wall -Werror -threaded -rtsopts -with-rtsopts=-N build-depends: aeson >=1.4.5 && <1.5 @@ -183,7 +215,23 @@ test-suite spec Paths_hscim hs-source-dirs: test - default-extensions: ConstraintKinds DataKinds DeriveFunctor DeriveGeneric FlexibleContexts FlexibleInstances KindSignatures LambdaCase MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeApplications TypeFamilies TypeOperators TypeSynonymInstances + default-extensions: + ConstraintKinds + DataKinds + DeriveFunctor + DeriveGeneric + FlexibleContexts + FlexibleInstances + KindSignatures + LambdaCase + MultiParamTypeClasses + OverloadedStrings + RankNTypes + ScopedTypeVariables + TypeApplications + TypeFamilies + TypeOperators + TypeSynonymInstances ghc-options: -Wall -Werror -threaded -rtsopts -with-rtsopts=-N build-tool-depends: hspec-discover:hspec-discover diff --git a/libs/imports/imports.cabal b/libs/imports/imports.cabal index 5a7862cd301..10933ff8a24 100644 --- a/libs/imports/imports.cabal +++ b/libs/imports/imports.cabal @@ -1,10 +1,10 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack -- --- hash: 5bcdd74f4b3651bbe5b4f894d0e285677e39b1f7c4ae2992bcad1fbe3ad9310c +-- hash: 09458f8cad6c5214c9692291bb633f780944463c5690e2af99d7e516dc93e0f2 name: imports version: 0.1.0 @@ -29,7 +29,46 @@ library Paths_imports 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 + 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 build-depends: base diff --git a/libs/metrics-core/metrics-core.cabal b/libs/metrics-core/metrics-core.cabal index 9920cd291ba..e9e4be85d41 100644 --- a/libs/metrics-core/metrics-core.cabal +++ b/libs/metrics-core/metrics-core.cabal @@ -1,10 +1,10 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack -- --- hash: 39576413f564e6922f09dafea8363144a30845c18008270e2f357ea3b32534b9 +-- hash: ed00633977e31daad2e0efcc5e21e8e4a800a2737e5848e9b0770091f9a94b3d name: metrics-core version: 0.3.2 @@ -25,7 +25,46 @@ library Paths_metrics_core 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 + 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 build-depends: base >=4.9 diff --git a/libs/metrics-wai/metrics-wai.cabal b/libs/metrics-wai/metrics-wai.cabal index 7658bf9348a..422bc7598ba 100644 --- a/libs/metrics-wai/metrics-wai.cabal +++ b/libs/metrics-wai/metrics-wai.cabal @@ -1,10 +1,10 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack -- --- hash: aefa1a394ca2caa5cad577e67967aace67b79d4c94afeba4dd399b77de826a6c +-- hash: aa7fa2126e1b9420894641828a3548c191a7daa9c997585531827b092557e393 name: metrics-wai version: 0.5.7 @@ -29,7 +29,46 @@ library Paths_metrics_wai 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 + 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 ghc-prof-options: -fprof-auto build-depends: @@ -57,7 +96,46 @@ test-suite unit Paths_metrics_wai 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 + 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 diff --git a/libs/metrics-wai/src/Data/Metrics/Servant.hs b/libs/metrics-wai/src/Data/Metrics/Servant.hs index 1bcac5d86e1..eadfcf50164 100644 --- a/libs/metrics-wai/src/Data/Metrics/Servant.hs +++ b/libs/metrics-wai/src/Data/Metrics/Servant.hs @@ -104,6 +104,12 @@ instance where getRoutes = getRoutes @rest +instance + (RoutesToPaths rest) => + RoutesToPaths (StreamBody' opts framing ct a :> rest) + where + getRoutes = getRoutes @rest + instance (RoutesToPaths rest) => RoutesToPaths (Summary summary :> rest) @@ -131,6 +137,9 @@ instance RoutesToPaths (Verb method status cts a) where instance RoutesToPaths (NoContentVerb method) where getRoutes = [] +instance RoutesToPaths (Stream method status framing ct a) where + getRoutes = [] + -- route :<|> routes instance ( RoutesToPaths route, diff --git a/libs/polysemy-wire-zoo/polysemy-wire-zoo.cabal b/libs/polysemy-wire-zoo/polysemy-wire-zoo.cabal index f573732a8b0..9467c73c9cc 100644 --- a/libs/polysemy-wire-zoo/polysemy-wire-zoo.cabal +++ b/libs/polysemy-wire-zoo/polysemy-wire-zoo.cabal @@ -1,10 +1,10 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack -- --- hash: 27700378ec8705a58122804d0ac5c5da8f428b037271401e27abab3cce46ab9f +-- hash: 4b1ed885b5ee0e7a49013f134724d41277e8cc3ff45a6023404e24793c6303c5 name: polysemy-wire-zoo version: 0.1.0 @@ -24,7 +24,46 @@ library Paths_polysemy_wire_zoo 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 + 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 build-depends: base >=4.6 && <5.0 diff --git a/libs/ropes/ropes.cabal b/libs/ropes/ropes.cabal index 58fbbe9d87e..58b7ae927f0 100644 --- a/libs/ropes/ropes.cabal +++ b/libs/ropes/ropes.cabal @@ -1,10 +1,10 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack -- --- hash: d71b49463ed7862c72fa0f2ce5e50bb9735fddc8270de52ec3d30e29043b6b59 +-- hash: 037e046804ad490d6ca65048cb0f7809f2b15ff57a4b513a64cf34153a2a7342 name: ropes version: 0.4.20 @@ -25,7 +25,46 @@ library Paths_ropes 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 + 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 build-depends: aeson >=0.6 diff --git a/libs/schema-profunctor/README.md b/libs/schema-profunctor/README.md index 282b9fdd263..9f1421f77d4 100644 --- a/libs/schema-profunctor/README.md +++ b/libs/schema-profunctor/README.md @@ -45,8 +45,8 @@ structure of lists when using the `Applicative` interface of ## Tutorial -To learn how to use `SchemaP` in practice, let us walk through two -basic examples, one for a record, and one for a sum type. +To learn how to use `SchemaP` in practice, let us walk through some +basic examples, including records and sum types. ### Records @@ -345,9 +345,8 @@ represented on the Haskell side. ### Optional fields and default values -To define a schema for a JSON object, there are multiple ways to deal -with the serialisation of optional fields, which we will illustrate -here. +To define a schema for a JSON object, there are multiple ways to deal with the +serialisation of optional fields, which we will illustrate here. The simplest (and most common) scenario is an optional field represented by a `Maybe` type, that is simply omitted from the generated JSON if it happens to @@ -365,42 +364,48 @@ data User = User userSchema = object "User" $ User <$> userName .= field "name" schema - <*> userHandle .= opt (field "handle" schema) - <*> userExpire .= opt (field "expire" schema) + <*> userHandle .= maybe_ (optField "handle" schema) + <*> userExpire .= maybe_ (optField "expire" schema) ``` -Here we apply the `opt` combinator to the optional field, to turn it from a -schema for `Text` into a schema for `Maybe Text`. The parser for `userHandle` -will return `Nothing` when the field is missing (or is `null`), and -correspondingly the serialiser will not produce the field at all when its value -is `Nothing`. +Here we use `optField` to define schemas for optional fields, and apply the +`maybe_` combinator to the result, which has the effect of making the +serialiser omit the field when the corresponding value is `Nothing`. + +In detail, `optField "handle" schema` returns a schema from `Text` to `Maybe +Text`, i.e. a schema that is able to parse an optional text value, but does not +know how to serialise `Nothing`. Wrapping it in `maybe_` changes the first type +to `Maybe Text`, and gives the serialiser the ability to serialise `Nothing` as +well. Another possibility is a field that, when missing, is assumed to have a given default value. Most likely, in this case we do not want the field to be omitted -when serialising. The schema can then be defined simply by using the -`Alternative` instance of `SchemaP` to provide the default value: +when serialising. Such a schema can be defined simply by omitting the call to +`maybe_`, and instead converting a `Nothing` value coming from the parser into +the desired default value. ```haskell userSchemaWithDefaultName :: ValueSchema NamedSwaggerDoc User userSchemaWithDefaultName = object "User" $ User - <$> userName .= (field "name" schema <|> pure "") - <*> userHandle .= opt (field "handle" schema) - <*> userExpire .= opt (field "expire" schema) + <$> userName .= (fromMaybe "" <$> optField "name" schema) + <*> userHandle .= maybe_ (optField "handle" schema) + <*> userExpire .= maybe_ (optField "expire" schema) ``` -Now the `name` field is optional, and it is set to the empty string when missing. -However, the field will still be present in the generated JSON when its value -is the empty string. If we want the field to be omitted in that case, we can -use the previous approach, and then convert back and forth from `Maybe Text`: +Now the `name` field is optional, and it is set to the empty string when +missing. However, the field will still be present in the generated JSON when +its value is the empty string. If we want the field to be omitted in that case, +we can instead use the first approach, and manually convert back and forth from +`Maybe Text`. ```haskell userSchemaWithDefaultName' :: ValueSchema NamedSwaggerDoc User userSchemaWithDefaultName' = object "User" $ User - <$> (getOptText . userName) .= (fromMaybe "" <$> opt (field "name" schema)) + <$> (getOptText . userName) .= maybe_ (fromMaybe "" <$> field "name" schema) <*> userHandle .= opt (field "handle" schema) <*> userExpire .= opt (field "expire" schema) where @@ -417,60 +422,47 @@ techniques of the previous two examples: userSchema' :: ValueSchema NamedSwaggerDoc User userSchema' = object "User" $ User <$> field "name" schema - <*> lax (field "handle" (optWithDefault Aeson.null schema)) + <*> optField "handle" (maybeWithDefault Aeson.Null schema) <*> opt (field "expire" schema) ``` Two things to note here: - - the `optWithDefault` combinator is applied to the schema value *inside* - `field`, because the value to use if the value is `Nothing` (`Aeson.null` in - this case) applies to the value of the field, and not the containing object. - - we have wrapped the whole field inside a call to the `lax` combinator. All - this does is to add a `pure Nothing` alternative for the field, which ensures - we get a `Nothing` value (as opposed to a failure) when the field is not - present at all in the JSON object. + - we are now using `maybeWithDefault` instead of `maybe_`. This is a more + general version of `maybe_` that takes as an argument the value to use when + serialising `Nothing`. Not that `maybe_` is simply `maybeWithDefault mempty`. + - the `maybeWithDefault` combinator is applied to the schema value *inside* + `field`, because the value to use when serialising `Nothing` (`Aeson.null` in + this case) applies to the value of the field, and not the containing + (one-field) object, as in the previous examples. -One might wonder why we are using the special combinator `optWithDefault` here +One might wonder why we are using the special combinator `optField` here instead of simply using the `Alternative` instance (via `optional` or -directly). The reason is that the `Alternative` instance only really affects -the parser (and its return type), whereas here we also want to encode the fact -that the serialiser should output the default when the value of the field is -`Nothing`. That means we need to also change the input type to a `Maybe`, which -is what `opt` and `optWithDefault` do. +directly), on the schema returned by the `field` combinator. The reason is that +the `Alternative` instance would result in a slightly surprising behaviour in +case of errors in the JSON value contained in a field. -There is a subtlety here related to error messages, which can sometimes result -in surprising behaviour when parsing optional fields with default values. -Namely, given a field of the form +For example, given a field of the form ```haskell -opt (field "name" schema) +optional (field "name" schema) ``` the corresponding parser will return `Nothing` not only in the case where the `"name"` field is missing, but also if it is fails to parse correctly (for example, if it has an unexpected type). This behaviour is caused by the fact -that `opt` (and the `optWithDefault` / `lax` combo described above) are -implemented in terms of the `Alternative` instance for `Aeson.Parser`, which -cannot distinguish between "recoverable" and "unrecoverable" failures. +that `optional` is implemented in terms of the `Alternative` instance for +`Aeson.Parser`, which cannot distinguish between "recoverable" and +"unrecoverable" failures. -There are plans to improve on this behaviour in the future by directly changing -the `Alternative` instance that `SchemaP` relies on, but for the moment, if -this behaviour is not desirable, then one can use the ad-hoc `optField` -combinator to introduce optional fields. - -For example, the above schema can be implemented using `optField` as follow: +In some cases, this behaviour can be acceptable (or even desired), but in most +circumstances, it is better to define the above schema using the dedicated +`optField` combinator, as in: ```haskell -userSchema'' :: ValueSchema NamedSwaggerDoc User -userSchema'' = object "User" $ User - <$> field "name" schema - <*> optField "handle" (Just Aeson.Null) schema - <*> optField "expire" Nothing schema +optField "name" schema ``` -The argument after the field name determines how the `Nothing` case is rendered in the generated JSON. If it is itself `Nothing`, that means that the field is completely omitted in that case. - ### Redundant fields Sometimes, JSON encoding of haskell types is not as straightforward as diff --git a/libs/schema-profunctor/schema-profunctor.cabal b/libs/schema-profunctor/schema-profunctor.cabal index 2fd553cb16f..a3c1e5841a9 100644 --- a/libs/schema-profunctor/schema-profunctor.cabal +++ b/libs/schema-profunctor/schema-profunctor.cabal @@ -1,10 +1,10 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack -- --- hash: 0ae8ea501bb947c4d9d743cdd9ea56a104dcc8791c62288e99bff1e8399c8ebb +-- hash: 83646796a68e282b2b169035619c5d5ca2c53e12d08311ae712682f24cd90658 name: schema-profunctor version: 0.1.0 @@ -24,11 +24,50 @@ library Paths_schema_profunctor 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 + 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 build-depends: aeson >=1.0 && <1.6 - , base >=4 && <5 + , base ==4.* , bifunctors , comonad , containers @@ -49,12 +88,51 @@ test-suite schemas-tests Paths_schema_profunctor hs-source-dirs: test/unit - 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 + 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 build-depends: aeson , aeson-qq - , base >=4 && <5 + , base ==4.* , imports , insert-ordered-containers , lens diff --git a/libs/schema-profunctor/src/Data/Schema.hs b/libs/schema-profunctor/src/Data/Schema.hs index 9369ed4f79f..0e8c5e8cacb 100644 --- a/libs/schema-profunctor/src/Data/Schema.hs +++ b/libs/schema-profunctor/src/Data/Schema.hs @@ -26,7 +26,9 @@ module Data.Schema ( SchemaP, ValueSchema, + ValueSchemaP, ObjectSchema, + ObjectSchemaP, ToSchema (..), Schema (..), mkSchema, @@ -34,6 +36,8 @@ module Data.Schema schemaIn, schemaOut, HasDoc (..), + doc', + HasSchemaRef (..), withParser, SwaggerDoc, swaggerDoc, @@ -44,25 +48,28 @@ module Data.Schema objectWithDocModifier, objectOver, jsonObject, + FieldFunctor, field, fieldWithDocModifier, fieldOver, optField, optFieldWithDocModifier, - optFieldOver, + fieldF, + fieldOverF, + fieldWithDocModifierF, array, set, nonEmptyArray, map_, enum, - opt, - optWithDefault, - lax, + maybe_, + maybeWithDefault, bind, dispatch, text, parsedText, null_, + nullable, element, tag, unnamed, @@ -243,15 +250,20 @@ instance Choice (SchemaP doc v v') where instance HasDoc (SchemaP doc v v' a b) (SchemaP doc' v v' a b) doc doc' where doc = lens schemaDoc $ \(SchemaP d i o) d' -> SchemaP (Lens.set doc d' d) i o +doc' :: Lens' (SchemaP doc v w a b) doc +doc' = doc + withParser :: SchemaP doc v w a b -> (b -> A.Parser b') -> SchemaP doc v w a b' withParser (SchemaP (SchemaDoc d) (SchemaIn p) (SchemaOut o)) q = SchemaP (SchemaDoc d) (SchemaIn (p >=> q)) (SchemaOut o) -type SchemaP' doc v v' a = SchemaP doc v v' a a +type ObjectSchemaP doc = SchemaP doc A.Object [A.Pair] + +type ObjectSchema doc a = ObjectSchemaP doc a a -type ObjectSchema doc a = SchemaP' doc A.Object [A.Pair] a +type ValueSchemaP doc = SchemaP doc A.Value A.Value -type ValueSchema doc a = SchemaP' doc A.Value A.Value a +type ValueSchema doc a = ValueSchemaP doc a a schemaDoc :: SchemaP ss v m a b -> ss schemaDoc (SchemaP (SchemaDoc d) _ _) = d @@ -262,6 +274,18 @@ schemaIn (SchemaP _ (SchemaIn i) _) = i schemaOut :: SchemaP ss v m a b -> a -> Maybe m schemaOut (SchemaP _ _ (SchemaOut o)) = o +class Functor f => FieldFunctor doc f where + parseFieldF :: (A.Value -> A.Parser a) -> A.Object -> Text -> A.Parser (f a) + mkDocF :: doc -> doc + +instance FieldFunctor doc Identity where + parseFieldF f obj key = Identity <$> A.explicitParseField f obj key + mkDocF = id + +instance HasOpt doc => FieldFunctor doc Maybe where + parseFieldF = A.explicitParseFieldMaybe + mkDocF = mkOpt + -- | A schema for a one-field JSON object. field :: HasField doc' doc => @@ -274,13 +298,19 @@ field = fieldOver id optField :: (HasOpt doc, HasField doc' doc) => Text -> - -- | The value to use when serialising Nothing. - Maybe A.Value -> SchemaP doc' A.Value A.Value a b -> - SchemaP doc A.Object [A.Pair] (Maybe a) (Maybe b) -optField = optFieldOver id + SchemaP doc A.Object [A.Pair] a (Maybe b) +optField = fieldF -newtype Negative x y a = Negative {runNegative :: (a -> x) -> y} +-- | A schema for a JSON object with a single optional field. +fieldF :: + (HasOpt doc, HasField doc' doc, FieldFunctor doc f) => + Text -> + SchemaP doc' A.Value A.Value a b -> + SchemaP doc A.Object [A.Pair] a (f b) +fieldF = fieldOverF id + +newtype Positive x y a = Positive {runPositive :: (a -> x) -> y} deriving (Functor) -- | A version of 'field' for more general input values. @@ -288,52 +318,36 @@ newtype Negative x y a = Negative {runNegative :: (a -> x) -> y} -- This can be used when the input type 'v' of the parser is not exactly a -- 'A.Object', but it contains one. The first argument is a lens that can -- extract the 'A.Object' contained in 'v'. -fieldOver :: - forall doc' doc v v' a b. - HasField doc' doc => +fieldOverF :: + forall f doc' doc v v' a b. + (HasField doc' doc, FieldFunctor doc f) => Lens v v' A.Object A.Value -> Text -> SchemaP doc' v' A.Value a b -> - SchemaP doc v [A.Pair] a b -fieldOver l name sch = SchemaP (SchemaDoc s) (SchemaIn r) (SchemaOut w) + SchemaP doc v [A.Pair] a (f b) +fieldOverF l name sch = SchemaP (SchemaDoc s) (SchemaIn r) (SchemaOut w) where - parseField :: A.Object -> Negative (A.Parser b) (A.Parser b) A.Value - parseField obj = Negative $ \k -> A.explicitParseField k obj name + parseField :: A.Object -> Positive (A.Parser b) (A.Parser (f b)) A.Value + parseField obj = Positive $ \k -> parseFieldF @doc k obj name - r :: v -> A.Parser b - r obj = runNegative (l parseField obj) (schemaIn sch) + r :: v -> A.Parser (f b) + r obj = runPositive (l parseField obj) (schemaIn sch) w x = do v <- schemaOut sch x pure [name A..= v] - s = mkField name (schemaDoc sch) + s = mkDocF @doc @f (mkField name (schemaDoc sch)) --- | A version of 'optField' for more general input values. --- --- See documentation of 'fieldOver' for more details. -optFieldOver :: +-- | Like 'fieldOver', but specialised to the identity functor. +fieldOver :: forall doc' doc v v' a b. - (HasOpt doc, HasField doc' doc) => + (HasField doc' doc) => Lens v v' A.Object A.Value -> Text -> - Maybe A.Value -> SchemaP doc' v' A.Value a b -> - SchemaP doc v [A.Pair] (Maybe a) (Maybe b) -optFieldOver l name def sch = SchemaP (SchemaDoc s) (SchemaIn r) (SchemaOut w) - where - parseField :: A.Object -> Negative (A.Parser b) (A.Parser (Maybe b)) A.Value - parseField obj = Negative $ \k -> A.explicitParseFieldMaybe k obj name - - r :: v -> A.Parser (Maybe b) - r obj = runNegative (l parseField obj) (schemaIn sch) - - w (Just x) = do - v <- schemaOut sch x - pure [name A..= v] - w Nothing = pure (maybeToList (fmap (name A..=) def)) - - s = mkOpt (mkField name (schemaDoc sch)) + SchemaP doc v [A.Pair] a b +fieldOver l name = fmap runIdentity . fieldOverF l name -- | Like 'field', but apply an arbitrary function to the -- documentation of the field. @@ -350,11 +364,20 @@ fieldWithDocModifier name modify sch = field name (over doc modify sch) optFieldWithDocModifier :: (HasOpt doc, HasField doc' doc) => Text -> - Maybe A.Value -> (doc' -> doc') -> SchemaP doc' A.Value A.Value a b -> - SchemaP doc A.Object [A.Pair] (Maybe a) (Maybe b) -optFieldWithDocModifier name def modify sch = optField name def (over doc modify sch) + SchemaP doc A.Object [A.Pair] a (Maybe b) +optFieldWithDocModifier name modify sch = optField name (over doc modify sch) + +-- | Like 'fieldF', but apply an arbitrary function to the +-- documentation of the field. +fieldWithDocModifierF :: + (HasOpt doc, HasField doc' doc, FieldFunctor doc f) => + Text -> + (doc' -> doc') -> + SchemaP doc' A.Value A.Value a b -> + SchemaP doc A.Object [A.Pair] a (f b) +fieldWithDocModifierF name modify sch = fieldF name (over doc modify sch) -- | Change the input type of a schema. (.=) :: Profunctor p => (a -> a') -> p a' b -> p a b @@ -477,6 +500,9 @@ instance With Text where instance With Integer where with _ = (A.parseJSON >=>) +instance With Bool where + with = A.withBool + -- | A schema for a single value of an enumeration. element :: forall a b. @@ -508,32 +534,17 @@ enum name sch = SchemaP (SchemaDoc d) (SchemaIn i) (SchemaOut o) <|> fail ("Unexpected value for enum " <> T.unpack name) o = fmap A.toJSON . (getAlt <=< schemaOut sch) --- | An optional schema. +-- | A schema for 'Maybe' that omits a field on serialisation. -- --- This is most commonly used for optional fields. The parser will --- return 'Nothing' if the field is missing, and conversely the --- serialiser will simply omit the field when its value is 'Nothing'. -opt :: HasOpt d => Monoid w => SchemaP d v w a b -> SchemaP d v w (Maybe a) (Maybe b) -opt = optWithDefault mempty +-- This is most commonly used for optional fields, and it will cause the field +-- to be omitted from the output of the serialiser. +maybe_ :: HasOpt d => Monoid w => SchemaP d v w a b -> SchemaP d v w (Maybe a) b +maybe_ = maybeWithDefault mempty --- | An optional schema with a specified failure value --- --- This is a more general version of 'opt' that allows a custom --- serialisation 'Nothing' value. -optWithDefault :: HasOpt d => w -> SchemaP d v w a b -> SchemaP d v w (Maybe a) (Maybe b) -optWithDefault w0 sch = SchemaP (SchemaDoc d) (SchemaIn i) (SchemaOut o) - where - d = mkOpt (schemaDoc sch) - i = optional . schemaIn sch - o = maybe (pure w0) (schemaOut sch) - --- | A schema that ignores failure. --- --- Given a schema @sch :: SchemaP d v w a (Maybe b)@, the parser for --- @lax sch@ is just like the one for @sch@, except that it returns --- 'Nothing' in case of failure. -lax :: Alternative f => f (Maybe a) -> f (Maybe a) -lax = (<|> pure Nothing) +-- | A schema for 'Maybe', producing the given default value on serialisation. +maybeWithDefault :: HasOpt d => w -> SchemaP d v w a b -> SchemaP d v w (Maybe a) b +maybeWithDefault w0 (SchemaP (SchemaDoc d) (SchemaIn i) (SchemaOut o)) = + SchemaP (SchemaDoc d) (SchemaIn i) (SchemaOut (maybe (pure w0) o)) -- | A schema depending on a parsed value. -- @@ -598,12 +609,28 @@ jsonObject = mkSchema mempty pure (pure . (^.. ifolded . withIndex)) -- | A schema for a null value. -null_ :: Monoid d => SchemaP d A.Value A.Value () () +null_ :: Monoid d => ValueSchemaP d () () null_ = mkSchema mempty i o where i x = guard (x == A.Null) o _ = pure A.Null +-- | A schema for a nullable value. +-- +-- The parser accepts a JSON null as a valid value, and converts it to +-- 'Nothing'. Any non-null value is parsed using the underlying schema. +-- +-- The serialiser behaves similarly, but in the other direction. +nullable :: + (Monoid d, HasOpt d) => + ValueSchema d a -> + ValueSchema d (Maybe a) +nullable s = + mconcat + [ tag _Nothing null_, + tag _Just s + ] + data WithDeclare s = WithDeclare (Declare ()) s deriving (Functor) @@ -742,6 +769,9 @@ instance HasEnum Text NamedSwaggerDoc where instance HasEnum Integer NamedSwaggerDoc where mkEnum = mkSwaggerEnum S.SwaggerInteger +instance HasEnum Bool NamedSwaggerDoc where + mkEnum = mkSwaggerEnum S.SwaggerBoolean + mkSwaggerEnum :: S.SwaggerType 'S.SwaggerKindSchema -> Text -> diff --git a/libs/schema-profunctor/test/unit/Test/Data/Schema.hs b/libs/schema-profunctor/test/unit/Test/Data/Schema.hs index 356729e9a4c..484f9fb413b 100644 --- a/libs/schema-profunctor/test/unit/Test/Data/Schema.hs +++ b/libs/schema-profunctor/test/unit/Test/Data/Schema.hs @@ -65,7 +65,8 @@ tests = testRefField, testRmClientWrong, testRmClient, - testEnumType + testEnumType, + testNullable ] testFooToJSON :: TestTree @@ -338,6 +339,23 @@ testEnumType = (s2 ^. S.type_) (Just S.SwaggerInteger) +testNullable :: TestTree +testNullable = + let sch = nullable (unnamed schema) :: ValueSchema SwaggerDoc (Maybe Int) + in testGroup + "Nullable schemas" + [ testCase "Nullable schemas should parse both null and non-null values" $ do + A.parse (schemaIn sch) (A.Number 5) @?= Success (Just 5) + A.parse (schemaIn sch) A.Null @?= Success Nothing, + testCase "Nullable schemas should produce either a value or null" $ do + schemaOut sch (Just 5) @?= Just (A.Number 5) + schemaOut sch Nothing @?= Just (A.Null), + testCase "Nullable schemas should return an error when parsing invalid non-null values" $ do + case A.parse (schemaIn sch) (A.String "foo") of + Success _ -> assertFailure "fromJSON should fail" + Error _ -> pure () + ] + --- data A = A {thing :: Text, other :: Int} @@ -445,8 +463,8 @@ instance ToSchema User where object "User" $ User <$> userName .= field "name" schema - <*> userHandle .= opt (field "handle" schema) - <*> userExpire .= opt (field "expire" schema) + <*> userHandle .= maybe_ (optField "handle" schema) + <*> userExpire .= maybe_ (optField "expire" schema) exampleUser1 :: User exampleUser1 = User "Alice" (Just "alice") Nothing @@ -554,13 +572,13 @@ rmClientSchema :: ValueSchema NamedSwaggerDoc RmClient rmClientSchema = object "RmClient" $ RmClient - <$> rmPassword .= lax (field "password" (optWithDefault Null passwordSchema)) + <$> rmPassword .= optional (field "password" (maybeWithDefault Null passwordSchema)) instance ToSchema RmClient where schema = object "RmClient" $ RmClient - <$> rmPassword .= optField "password" Nothing passwordSchema + <$> rmPassword .= maybe_ (optField "password" passwordSchema) -- examples from documentation (only type-checked) @@ -601,9 +619,9 @@ userSchemaWithDefaultName' :: ValueSchema NamedSwaggerDoc User userSchemaWithDefaultName' = object "User" $ User - <$> (getOptText . userName) .= (fromMaybe "" <$> opt (field "name" schema)) - <*> userHandle .= opt (field "handle" schema) - <*> userExpire .= opt (field "expire" schema) + <$> (getOptText . userName) .= maybe_ (fromMaybe "" <$> optField "name" schema) + <*> userHandle .= maybe_ (optField "handle" schema) + <*> userExpire .= maybe_ (optField "expire" schema) where getOptText :: Text -> Maybe Text getOptText "" = Nothing @@ -614,5 +632,5 @@ userSchemaWithDefaultName = object "User" $ User <$> userName .= (field "name" schema <|> pure "") - <*> userHandle .= opt (field "handle" schema) - <*> userExpire .= opt (field "expire" schema) + <*> userHandle .= maybe_ (optField "handle" schema) + <*> userExpire .= maybe_ (optField "expire" schema) diff --git a/libs/sodium-crypto-sign/sodium-crypto-sign.cabal b/libs/sodium-crypto-sign/sodium-crypto-sign.cabal index a1cd7844cdb..d8701b66da4 100644 --- a/libs/sodium-crypto-sign/sodium-crypto-sign.cabal +++ b/libs/sodium-crypto-sign/sodium-crypto-sign.cabal @@ -1,10 +1,10 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack -- --- hash: f1ee42f25a00c893e5fa4a2dd1fde6c9aa2b39c8f0b558bfc8e217f21ecc78dd +-- hash: 7f0ee2a8b0a69d4f589716632e47f0b9bd431ca5cbfd7a8bf5dfe273c6489de0 name: sodium-crypto-sign version: 0.1.2 @@ -25,7 +25,46 @@ library Paths_sodium_crypto_sign 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 + 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 pkgconfig-depends: libsodium >= 0.4.5 diff --git a/libs/ssl-util/ssl-util.cabal b/libs/ssl-util/ssl-util.cabal index 6b76590b4f9..c9a1cd65b47 100644 --- a/libs/ssl-util/ssl-util.cabal +++ b/libs/ssl-util/ssl-util.cabal @@ -1,10 +1,10 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack -- --- hash: 3699fbc088cccb96703289fb6f01c595b9dbb41fb871090b5665305eede020b3 +-- hash: d91dea84564b802aae13b5514b1babf2f1a50b0d33a58bc7dade37d6c60c2182 name: ssl-util version: 0.1.0 @@ -25,7 +25,46 @@ library Paths_ssl_util 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 + 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 build-depends: HsOpenSSL >=0.11 diff --git a/libs/tasty-cannon/tasty-cannon.cabal b/libs/tasty-cannon/tasty-cannon.cabal index 11de15b68e6..106ce076031 100644 --- a/libs/tasty-cannon/tasty-cannon.cabal +++ b/libs/tasty-cannon/tasty-cannon.cabal @@ -1,10 +1,10 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack -- --- hash: 3e4d6b79f93c721b5df897b6653023feaa197910713bf3a2a759ea37ca05427f +-- hash: 2d2de3cb5a7dcf524d840d49e590bea00dd40610a5488224cf4b25b15991f64b name: tasty-cannon version: 0.4.0 @@ -24,7 +24,46 @@ library Paths_tasty_cannon 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 + 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 build-depends: aeson diff --git a/libs/types-common-aws/types-common-aws.cabal b/libs/types-common-aws/types-common-aws.cabal index 7f9bc911d05..9c3ca1dd1b3 100644 --- a/libs/types-common-aws/types-common-aws.cabal +++ b/libs/types-common-aws/types-common-aws.cabal @@ -1,10 +1,10 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack -- --- hash: 78e336e58361643ff6e3248bd8893419b6b9984cf680fe6e26614b22d222c542 +-- hash: 4b83070073d35300a38f4eeaac64a4d3ad4822df651b881a6a8eea293aa4dfcf name: types-common-aws version: 0.16.0 @@ -35,7 +35,46 @@ library Paths_types_common_aws 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 + 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 ghc-prof-options: -fprof-auto-exported build-depends: diff --git a/libs/types-common/src/Data/Domain.hs b/libs/types-common/src/Data/Domain.hs index 7656834b433..ecbac67e280 100644 --- a/libs/types-common/src/Data/Domain.hs +++ b/libs/types-common/src/Data/Domain.hs @@ -30,7 +30,7 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Builder as Builder import qualified Data.ByteString.Char8 as BS.Char8 import Data.ByteString.Conversion -import Data.Schema hiding (opt) +import Data.Schema import Data.String.Conversions (cs) import qualified Data.Swagger as S import qualified Data.Text as Text diff --git a/libs/types-common/src/Data/Id.hs b/libs/types-common/src/Data/Id.hs index 60f418eba18..44df9477eb8 100644 --- a/libs/types-common/src/Data/Id.hs +++ b/libs/types-common/src/Data/Id.hs @@ -325,6 +325,7 @@ newtype BotId = BotId Ord, FromByteString, ToByteString, + FromHttpApiData, Hashable, NFData, FromJSON, diff --git a/libs/types-common/src/Data/Range.hs b/libs/types-common/src/Data/Range.hs index d244a6fa656..6eb80f5de71 100644 --- a/libs/types-common/src/Data/Range.hs +++ b/libs/types-common/src/Data/Range.hs @@ -122,14 +122,12 @@ instance (Within a n m, FromJSON a) => FromJSON (Range n m a) where msg sn sm = fail (errorMsg (fromSing sn) (fromSing sm) "") rangedSchema :: + forall n m d v w a b. (Within a n m, HasRangedSchemaDocModifier d b) => - SNat n -> - SNat m -> SchemaP d v w a b -> SchemaP d v w a (Range n m b) -rangedSchema sn sm sch = Range <$> untypedRangedSchema (get sn) (get sm) sch - where - get = toInteger . fromSing +rangedSchema sch = + Range <$> untypedRangedSchema (toInteger (demote @n)) (toInteger (demote @m)) sch untypedRangedSchema :: forall d v w a b. @@ -181,7 +179,7 @@ instance S.HasSchema d S.Schema => HasRangedSchemaDocModifier d Word32 where ran instance S.HasSchema d S.Schema => HasRangedSchemaDocModifier d Word64 where rangedSchemaDocModifier _ = numRangedSchemaDocModifier instance (Within a n m, ToSchema a, HasRangedSchemaDocModifier NamedSwaggerDoc a) => ToSchema (Range n m a) where - schema = fromRange .= rangedSchema sing sing schema + schema = fromRange .= rangedSchema schema instance (Within a n m, Cql a) => Cql (Range n m a) where ctype = retag (ctype :: Tagged a ColumnType) diff --git a/libs/types-common/src/Data/Text/Ascii.hs b/libs/types-common/src/Data/Text/Ascii.hs index bb01459f607..9edd77b13cb 100644 --- a/libs/types-common/src/Data/Text/Ascii.hs +++ b/libs/types-common/src/Data/Text/Ascii.hs @@ -339,9 +339,7 @@ encodeBase16 = unsafeFromByteString . B16.encode -- | Decode a text containing only hex characters. -- Decoding only succeeds if the text is a multiple of 2 bytes in length. decodeBase16 :: AsciiBase16 -> Maybe ByteString -decodeBase16 t = case B16.decode (toByteString' t) of - (b, r) | r == mempty -> Just b - (_, _) -> Nothing +decodeBase16 t = either (const Nothing) Just (B16.decode (toByteString' t)) -------------------------------------------------------------------------------- -- Safe Widening diff --git a/libs/types-common/types-common.cabal b/libs/types-common/types-common.cabal index a5fb47da135..03402763a91 100644 --- a/libs/types-common/types-common.cabal +++ b/libs/types-common/types-common.cabal @@ -1,10 +1,10 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack -- --- hash: 53508b02f4785530bef7924e0bafe2862b003cac226877857f99805418ffcf6d +-- hash: 00836419e46c5f3ba70a9a8c3048fe32fb28f3d7176f97a681722bfb63807bd3 name: types-common version: 0.16.0 @@ -45,7 +45,46 @@ library Paths_types_common 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 + 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 ghc-prof-options: -fprof-auto-exported build-depends: @@ -107,7 +146,46 @@ test-suite tests Paths_types_common 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 + 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 build-depends: QuickCheck diff --git a/libs/wai-utilities/wai-utilities.cabal b/libs/wai-utilities/wai-utilities.cabal index 04ee8c4afb7..8b0d7a76ba4 100644 --- a/libs/wai-utilities/wai-utilities.cabal +++ b/libs/wai-utilities/wai-utilities.cabal @@ -1,10 +1,10 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack -- --- hash: 22be42374e2a06d9a91beff690fe12864bae17c8960db23f9f8d30e230bf1507 +-- hash: 52a60b4f6f7985a3b05c720cb7f00a1034117a09c5d39bbf1d9bb4f0828b86c8 name: wai-utilities version: 0.16.1 @@ -31,7 +31,46 @@ library Paths_wai_utilities 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 + 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 build-depends: aeson >=0.6 diff --git a/libs/wire-api-federation/package.yaml b/libs/wire-api-federation/package.yaml index 6b4ff64da17..8fb6f5d3003 100644 --- a/libs/wire-api-federation/package.yaml +++ b/libs/wire-api-federation/package.yaml @@ -25,6 +25,7 @@ dependencies: - http-types - http2 - imports +- kan-extensions - lifted-base - metrics-wai - mtl 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 961859a06ff..719af7baca0 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/API.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/API.hs @@ -17,34 +17,48 @@ module Wire.API.Federation.API ( FedApi, - clientRoutes, + HasFedEndpoint, + fedClient, + fedClientIn, -- * Re-exports Component (..), ) where -import Servant.Client.Generic +import Data.Proxy +import GHC.TypeLits +import Imports +import Servant.Client +import Servant.Client.Core 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 +import Wire.API.Federation.Endpoint -class HasFederationAPI (comp :: Component) where - -- Note: this type family being injective means that in most cases there is no need - -- to add component annotations when invoking the federator client - type FedApi comp = (api :: * -> *) | api -> comp - clientRoutes :: FedApi comp (AsClientT (FederatorClient comp)) +-- Note: this type family being injective means that in most cases there is no need +-- to add component annotations when invoking the federator client +type family FedApi (comp :: Component) = (api :: *) | api -> comp -instance HasFederationAPI 'Galley where - type FedApi 'Galley = GalleyApi - clientRoutes = genericClient +type instance FedApi 'Galley = GalleyApi -instance HasFederationAPI 'Brig where - type FedApi 'Brig = BrigApi - clientRoutes = genericClient +type instance FedApi 'Brig = BrigApi -instance HasFederationAPI 'Cargohold where - type FedApi 'Cargohold = CargoholdApi - clientRoutes = genericClient +type instance FedApi 'Cargohold = CargoholdApi + +type HasFedEndpoint comp api name = ('Just api ~ LookupEndpoint (FedApi comp) name) + +-- | Return a client for a named endpoint. +fedClient :: + forall (comp :: Component) (name :: Symbol) m api. + (HasFedEndpoint comp api name, HasClient m api, m ~ FederatorClient comp) => + Client m api +fedClient = clientIn (Proxy @api) (Proxy @m) + +fedClientIn :: + forall (comp :: Component) (name :: Symbol) m api. + (HasFedEndpoint comp api name, HasClient m api) => + Client m api +fedClientIn = clientIn (Proxy @api) (Proxy @m) diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API/Brig.hs b/libs/wire-api-federation/src/Wire/API/Federation/API/Brig.hs index 38fa01ad792..3c90019f9f9 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/API/Brig.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/API/Brig.hs @@ -23,11 +23,10 @@ import Data.Id import Data.Range import Imports import Servant.API -import Servant.API.Generic import Test.QuickCheck (Arbitrary) import Wire.API.Arbitrary (GenericUniform (..)) import Wire.API.Federation.API.Common -import Wire.API.Federation.Domain (OriginDomainHeader) +import Wire.API.Federation.Endpoint import Wire.API.Message (UserClients) import Wire.API.User (UserProfile) import Wire.API.User.Client (PubClient, UserClientPrekeyMap) @@ -47,58 +46,18 @@ instance FromJSON SearchRequest -- | For conventions see /docs/developer/federation-api-conventions.md -- -- Maybe this module should be called Brig -data BrigApi routes = BrigApi - { getUserByHandle :: - routes - :- "get-user-by-handle" - :> ReqBody '[JSON] Handle - :> Post '[JSON] (Maybe UserProfile), - getUsersByIds :: - routes - :- "get-users-by-ids" - :> ReqBody '[JSON] [UserId] - :> Post '[JSON] [UserProfile], - claimPrekey :: - routes - :- "claim-prekey" - :> ReqBody '[JSON] (UserId, ClientId) - :> Post '[JSON] (Maybe ClientPrekey), - claimPrekeyBundle :: - routes - :- "claim-prekey-bundle" - :> ReqBody '[JSON] UserId - :> Post '[JSON] PrekeyBundle, - claimMultiPrekeyBundle :: - routes - :- "claim-multi-prekey-bundle" - :> ReqBody '[JSON] UserClients - :> Post '[JSON] UserClientPrekeyMap, - searchUsers :: - routes - :- "search-users" - -- FUTUREWORK(federation): do we want to perform some type-level validation like length checks? - -- (handles can be up to 256 chars currently) - :> ReqBody '[JSON] SearchRequest - :> Post '[JSON] [Contact], - getUserClients :: - routes - :- "get-user-clients" - :> ReqBody '[JSON] GetUserClients - :> Post '[JSON] (UserMap (Set PubClient)), - sendConnectionAction :: - routes - :- "send-connection-action" - :> OriginDomainHeader - :> ReqBody '[JSON] NewConnectionRequest - :> Post '[JSON] NewConnectionResponse, - onUserDeleted :: - routes - :- "on-user-deleted-connections" - :> OriginDomainHeader - :> ReqBody '[JSON] UserDeletedConnectionsNotification - :> Post '[JSON] EmptyResponse - } - deriving (Generic) +type BrigApi = + FedEndpoint "get-user-by-handle" Handle (Maybe UserProfile) + :<|> FedEndpoint "get-users-by-ids" [UserId] [UserProfile] + :<|> FedEndpoint "claim-prekey" (UserId, ClientId) (Maybe ClientPrekey) + :<|> FedEndpoint "claim-prekey-bundle" UserId PrekeyBundle + :<|> FedEndpoint "claim-multi-prekey-bundle" UserClients UserClientPrekeyMap + -- FUTUREWORK(federation): do we want to perform some type-level validation like length checks? + -- (handles can be up to 256 chars currently) + :<|> FedEndpoint "search-users" SearchRequest [Contact] + :<|> FedEndpoint "get-user-clients" GetUserClients (UserMap (Set PubClient)) + :<|> FedEndpoint "send-connection-action" NewConnectionRequest NewConnectionResponse + :<|> FedEndpoint "on-user-deleted-connections" UserDeletedConnectionsNotification EmptyResponse newtype GetUserClients = GetUserClients { gucUsers :: [UserId] 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 index 45573476280..44a3e022b7f 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/API/Cargohold.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/API/Cargohold.hs @@ -17,15 +17,35 @@ module Wire.API.Federation.API.Cargohold where +import Data.Aeson (FromJSON (..), ToJSON (..)) +import Data.Id +import Imports import Servant.API -import Servant.API.Generic -import Wire.API.Federation.API.Common +import Wire.API.Arbitrary (Arbitrary, GenericUniform (..)) +import Wire.API.Asset +import Wire.API.Federation.Endpoint +import Wire.API.Routes.AssetBody +import Wire.API.Util.Aeson -data CargoholdApi routes = CargoholdApi - { getAsset :: - routes - :- "get-asset" - :> ReqBody '[JSON] () - :> Post '[JSON] EmptyResponse +data GetAsset = GetAsset + { -- | User requesting the asset. Implictly qualified with the source domain. + gaUser :: UserId, + -- | Asset key for the asset to download. Implictly qualified with the + -- target domain. + gaKey :: AssetKey, + -- | Optional asset token. + gaToken :: Maybe AssetToken } - deriving (Generic) + deriving stock (Eq, Show, Generic) + deriving (Arbitrary) via (GenericUniform GetAsset) + deriving (ToJSON, FromJSON) via (CustomEncoded GetAsset) + +data GetAssetResponse = GetAssetResponse + {gaAvailable :: Bool} + deriving stock (Eq, Show, Generic) + deriving (Arbitrary) via (GenericUniform GetAssetResponse) + deriving (ToJSON, FromJSON) via (CustomEncoded GetAssetResponse) + +type CargoholdApi = + FedEndpoint "get-asset" GetAsset GetAssetResponse + :<|> StreamingFedEndpoint "stream-asset" GetAsset AssetSource diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs b/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs index d2d74e5e9d4..85862695ceb 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs @@ -25,8 +25,7 @@ import Data.Qualified import Data.Range import Data.Time.Clock (UTCTime) import Imports -import Servant.API (JSON, Post, ReqBody, Summary, (:>)) -import Servant.API.Generic +import Servant.API import Wire.API.Arbitrary (Arbitrary, GenericUniform (..)) import Wire.API.Conversation ( Access, @@ -39,7 +38,7 @@ import Wire.API.Conversation.Action import Wire.API.Conversation.Member (OtherMember) import Wire.API.Conversation.Role (RoleName) import Wire.API.Federation.API.Common -import Wire.API.Federation.Domain (OriginDomainHeader) +import Wire.API.Federation.Endpoint import Wire.API.Message (MessageNotSent, MessageSendingStatus, PostOtrResponse, Priority) import Wire.API.User.Client (UserClientMap) import Wire.API.Util.Aeson (CustomEncoded (..)) @@ -49,59 +48,21 @@ import Wire.API.Util.Aeson (CustomEncoded (..)) -- for the current list we need. -- | For conventions see /docs/developer/federation-api-conventions.md -data GalleyApi routes = GalleyApi - { -- | Register a new conversation - onConversationCreated :: - routes - :- Summary "Register users to be in a new remote conversation" - :> "on-conversation-created" - :> OriginDomainHeader - :> ReqBody '[JSON] (NewRemoteConversation ConvId) - :> Post '[JSON] (), - getConversations :: - routes - :- "get-conversations" - :> OriginDomainHeader - :> ReqBody '[JSON] GetConversationsRequest - :> Post '[JSON] GetConversationsResponse, +type GalleyApi = + -- | Register a new conversation + FedEndpoint "on-conversation-created" (NewRemoteConversation ConvId) () + :<|> FedEndpoint "get-conversations" GetConversationsRequest GetConversationsResponse -- used by the backend that owns a conversation to inform this backend of -- changes to the conversation - onConversationUpdated :: - routes - :- "on-conversation-updated" - :> OriginDomainHeader - :> ReqBody '[JSON] ConversationUpdate - :> Post '[JSON] (), - leaveConversation :: - routes - :- "leave-conversation" - :> OriginDomainHeader - :> ReqBody '[JSON] LeaveConversationRequest - :> Post '[JSON] LeaveConversationResponse, + :<|> FedEndpoint "on-conversation-updated" ConversationUpdate () + :<|> FedEndpoint "leave-conversation" LeaveConversationRequest LeaveConversationResponse -- used to notify this backend that a new message has been posted to a -- remote conversation - onMessageSent :: - routes - :- "on-message-sent" - :> OriginDomainHeader - :> ReqBody '[JSON] (RemoteMessage ConvId) - :> Post '[JSON] (), + :<|> FedEndpoint "on-message-sent" (RemoteMessage ConvId) () -- used by a remote backend to send a message to a conversation owned by -- this backend - sendMessage :: - routes - :- "send-message" - :> OriginDomainHeader - :> ReqBody '[JSON] MessageSendRequest - :> Post '[JSON] MessageSendResponse, - onUserDeleted :: - routes - :- "on-user-deleted-conversations" - :> OriginDomainHeader - :> ReqBody '[JSON] UserDeletedConversationsNotification - :> Post '[JSON] EmptyResponse - } - deriving (Generic) + :<|> FedEndpoint "send-message" MessageSendRequest MessageSendResponse + :<|> FedEndpoint "on-user-deleted-conversations" UserDeletedConversationsNotification EmptyResponse data GetConversationsRequest = GetConversationsRequest { gcrUserId :: UserId, diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Client.hs b/libs/wire-api-federation/src/Wire/API/Federation/Client.hs index 4215def0283..4dae263caf3 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/Client.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/Client.hs @@ -22,13 +22,17 @@ module Wire.API.Federation.Client ( FederatorClientEnv (..), FederatorClient, runFederatorClient, + runFederatorClientToCodensity, performHTTP2Request, + withHTTP2Request, + streamingResponseStrictBody, headersFromTable, ) where import qualified Control.Exception as E import Control.Monad.Catch +import Control.Monad.Codensity import Control.Monad.Except import qualified Data.Aeson as Aeson import qualified Data.ByteString as BS @@ -52,6 +56,7 @@ import Network.TLS as TLS import qualified Network.Wai.Utilities.Error as Wai import Servant.Client import Servant.Client.Core +import Servant.Types.SourceT import qualified System.TimeManager import Util.Options (Endpoint (..)) import Wire.API.Federation.Component @@ -65,7 +70,7 @@ data FederatorClientEnv = FederatorClientEnv } newtype FederatorClient (c :: Component) a = FederatorClient - {unFederatorClient :: ReaderT FederatorClientEnv (ExceptT FederatorClientError IO) a} + {unFederatorClient :: ReaderT FederatorClientEnv (ExceptT FederatorClientError (Codensity IO)) a} deriving newtype ( Functor, Applicative, @@ -75,6 +80,9 @@ newtype FederatorClient (c :: Component) a = FederatorClient MonadIO ) +liftCodensity :: Codensity IO a -> FederatorClient c a +liftCodensity = FederatorClient . lift . lift + headersFromTable :: HTTP2.HeaderTable -> [HTTP.Header] headersFromTable (headerList, _) = flip map headerList $ \(token, headerValue) -> (HTTP2.tokenKey token, headerValue) @@ -90,93 +98,136 @@ performHTTP2Request :: HTTP2.Request -> ByteString -> Int -> - IO (Either FederatorClientHTTP2Error (HTTP.Status, [HTTP.Header], Builder)) -performHTTP2Request mtlsConfig req hostname port = do - let drainResponse resp = go mempty - where - go acc = do - chunk <- HTTP2.getResponseBodyChunk resp - if BS.null chunk - then pure acc - else go (acc <> byteString chunk) + IO (Either FederatorClientHTTP2Error (ResponseF Builder)) +performHTTP2Request mtlsConfig req hostname port = try $ do + withHTTP2Request mtlsConfig req hostname port $ \resp -> do + b <- + fmap (either (const mempty) id) + . runExceptT + . runSourceT + . responseBody + $ resp + pure $ resp $> foldMap byteString b + +withHTTP2Request :: + Maybe TLS.ClientParams -> + HTTP2.Request -> + ByteString -> + Int -> + (StreamingResponse -> IO a) -> + IO a +withHTTP2Request mtlsConfig req hostname port k = do let clientConfig = HTTP2.ClientConfig "https" hostname {- cacheLimit: -} 20 - flip - E.catches - [ -- catch FederatorClientHTTP2Error (e.g. connection and TLS errors) - E.Handler (pure . Left), - -- catch HTTP2 exceptions - E.Handler (pure . Left . FederatorClientHTTP2Exception) - ] - $ bracket (connectSocket hostname port) NS.close $ \sock -> do - let withHTTP2Config k = case mtlsConfig of - Nothing -> bracket (HTTP2.allocSimpleConfig sock 4096) HTTP2.freeSimpleConfig k + E.handle (E.throw . FederatorClientHTTP2Exception) $ + bracket (connectSocket hostname port) NS.close $ \sock -> do + let withHTTP2Config k' = case mtlsConfig of + Nothing -> bracket (HTTP2.allocSimpleConfig sock 4096) HTTP2.freeSimpleConfig k' -- FUTUREWORK(federation): Use openssl Just tlsConfig -> do ctx <- E.handle (E.throw . FederatorClientTLSException) $ do ctx <- TLS.contextNew sock tlsConfig TLS.handshake ctx pure ctx - bracket (allocTLSConfig ctx 4096) freeTLSConfig k - withHTTP2Config $ \conf -> - HTTP2.run clientConfig conf $ \sendRequest -> do + bracket (allocTLSConfig ctx 4096) freeTLSConfig k' + withHTTP2Config $ \conf -> do + HTTP2.run clientConfig conf $ \sendRequest -> sendRequest req $ \resp -> do - result <- drainResponse resp let headers = headersFromTable (HTTP2.responseHeaders resp) - pure $ case HTTP2.responseStatus resp of - Nothing -> Left FederatorClientNoStatusCode - Just status -> Right (status, headers, result) + result = fromAction BS.null (HTTP2.getResponseBodyChunk resp) + case HTTP2.responseStatus resp of + Nothing -> E.throw FederatorClientNoStatusCode + Just status -> + k + Response + { responseStatusCode = status, + responseHeaders = Seq.fromList headers, + responseHttpVersion = HTTP.http20, + responseBody = result + } instance KnownComponent c => RunClient (FederatorClient c) where runRequestAcceptStatus expectedStatuses req = do - env <- ask - let baseUrlPath = - HTTP.encodePathSegments - [ "rpc", - domainText (ceTargetDomain env), - componentName (componentVal @c) - ] - let path = baseUrlPath <> requestPath req - body <- case requestBody req of - Just (RequestBodyLBS lbs, _) -> pure lbs - Just (RequestBodyBS bs, _) -> pure (LBS.fromStrict bs) - Just (RequestBodySource _, _) -> - throwError FederatorClientStreamingNotSupported - Nothing -> pure mempty - let req' = - HTTP2.requestBuilder - (requestMethod req) - (LBS.toStrict (toLazyByteString path)) - (toList (requestHeaders req) <> [(originDomainHeaderName, toByteString' (ceOriginDomain env))]) - (lazyByteString body) - let Endpoint (Text.encodeUtf8 -> hostname) (fromIntegral -> port) = ceFederator env - eresp <- liftIO $ performHTTP2Request Nothing req' hostname port - case eresp of - Left err -> throwError (FederatorClientHTTP2Error err) - Right (status, headers, result) - | maybe (HTTP.statusIsSuccessful status) (elem status) expectedStatuses -> - pure $ - Response - { responseStatusCode = status, - responseHeaders = Seq.fromList headers, - responseHttpVersion = HTTP.http20, - responseBody = toLazyByteString result - } - | otherwise -> - throwError $ - FederatorClientError - ( mkFailureResponse - status - (ceTargetDomain env) - (toLazyByteString (requestPath req)) - (toLazyByteString result) - ) + let successfulStatus status = + maybe + (HTTP.statusIsSuccessful status) + (elem status) + expectedStatuses + withHTTP2StreamingRequest successfulStatus req $ \resp -> do + bdy <- + fmap (either (const mempty) (toLazyByteString . foldMap byteString)) + . runExceptT + . runSourceT + . responseBody + $ resp + pure $ resp $> bdy throwClientError = throwError . FederatorClientServantError +instance KnownComponent c => RunStreamingClient (FederatorClient c) where + withStreamingRequest = withHTTP2StreamingRequest HTTP.statusIsSuccessful + +streamingResponseStrictBody :: StreamingResponse -> IO Builder +streamingResponseStrictBody resp = + fmap (either stringUtf8 (foldMap byteString)) + . runExceptT + . runSourceT + . responseBody + $ resp + +withHTTP2StreamingRequest :: + forall c a. + KnownComponent c => + (HTTP.Status -> Bool) -> + Request -> + (StreamingResponse -> IO a) -> + FederatorClient c a +withHTTP2StreamingRequest successfulStatus req handleResponse = do + env <- ask + let baseUrlPath = + HTTP.encodePathSegments + [ "rpc", + domainText (ceTargetDomain env), + componentName (componentVal @c) + ] + let path = baseUrlPath <> requestPath req + body <- case requestBody req of + Just (RequestBodyLBS lbs, _) -> pure lbs + Just (RequestBodyBS bs, _) -> pure (LBS.fromStrict bs) + Just (RequestBodySource _, _) -> + throwError FederatorClientStreamingNotSupported + Nothing -> pure mempty + let req' = + HTTP2.requestBuilder + (requestMethod req) + (LBS.toStrict (toLazyByteString path)) + (toList (requestHeaders req) <> [(originDomainHeaderName, toByteString' (ceOriginDomain env))]) + (lazyByteString body) + let Endpoint (Text.encodeUtf8 -> hostname) (fromIntegral -> port) = ceFederator env + resp <- + (either throwError pure =<<) . liftCodensity $ + Codensity $ \k -> + E.catch + (withHTTP2Request Nothing req' hostname port (k . Right)) + (k . Left . FederatorClientHTTP2Error) + + if successfulStatus (responseStatusCode resp) + then liftIO $ handleResponse resp + else do + -- in case of an error status code, read the whole body to construct the error + bdy <- liftIO $ streamingResponseStrictBody resp + throwError $ + FederatorClientError + ( mkFailureResponse + (responseStatusCode resp) + (ceTargetDomain env) + (toLazyByteString (requestPath req)) + (toLazyByteString bdy) + ) + mkFailureResponse :: HTTP.Status -> Domain -> LByteString -> LByteString -> Wai.Error mkFailureResponse status domain path body -- If the outward federator fails with 403, that means that there was an @@ -211,12 +262,25 @@ mkFailureResponse status domain path body "unknown-federation-error" (LText.decodeUtf8With Text.lenientDecode body) +-- | Run federator client synchronously. runFederatorClient :: KnownComponent c => FederatorClientEnv -> FederatorClient c a -> IO (Either FederatorClientError a) -runFederatorClient env action = runExceptT (runReaderT (unFederatorClient action) env) +runFederatorClient env = + lowerCodensity + . runFederatorClientToCodensity env + +runFederatorClientToCodensity :: + KnownComponent c => + FederatorClientEnv -> + FederatorClient c a -> + Codensity IO (Either FederatorClientError a) +runFederatorClientToCodensity env = + runExceptT + . flip runReaderT env + . unFederatorClient freeTLSConfig :: HTTP2.Config -> IO () freeTLSConfig cfg = free (HTTP2.confWriteBuffer cfg) diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Endpoint.hs b/libs/wire-api-federation/src/Wire/API/Federation/Endpoint.hs new file mode 100644 index 00000000000..2a8864e4f00 --- /dev/null +++ b/libs/wire-api-federation/src/Wire/API/Federation/Endpoint.hs @@ -0,0 +1,47 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Wire.API.Federation.Endpoint where + +import Imports +import Servant.API +import Wire.API.Federation.Domain +import Wire.API.Routes.Named + +type FedEndpoint name input output = + Named + name + (name :> OriginDomainHeader :> ReqBody '[JSON] input :> Post '[JSON] output) + +type StreamingFedEndpoint name input output = + Named + name + ( name :> OriginDomainHeader :> ReqBody '[JSON] input + :> StreamPost NoFraming OctetStream output + ) + +type family MappendMaybe (x :: Maybe k) (y :: Maybe k) :: Maybe k where + MappendMaybe 'Nothing y = y + MappendMaybe ('Just x) y = 'Just x + +type family LookupEndpoint api name :: Maybe * where + LookupEndpoint (Named name endpoint) name = 'Just endpoint + LookupEndpoint (api1 :<|> api2) name = + MappendMaybe + (LookupEndpoint api1 name) + (LookupEndpoint api2 name) + LookupEndpoint api name = 'Nothing diff --git a/libs/wire-api-federation/wire-api-federation.cabal b/libs/wire-api-federation/wire-api-federation.cabal index a1592e461ea..aa0dc39024a 100644 --- a/libs/wire-api-federation/wire-api-federation.cabal +++ b/libs/wire-api-federation/wire-api-federation.cabal @@ -1,10 +1,8 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack --- --- hash: 621c254076cf520b525269ca4fc550df57f410aea52a288f6cb68bd2d6f1ada3 name: wire-api-federation version: 0.1.0 @@ -28,13 +26,53 @@ library Wire.API.Federation.Client Wire.API.Federation.Component Wire.API.Federation.Domain + Wire.API.Federation.Endpoint Wire.API.Federation.Error Wire.API.Federation.Event other-modules: Paths_wire_api_federation 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 + 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 build-depends: QuickCheck >=2.13 @@ -51,6 +89,7 @@ library , http-types , http2 , imports + , kan-extensions , lifted-base , metrics-wai , mtl @@ -88,7 +127,46 @@ test-suite spec Paths_wire_api_federation 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 + 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 -rtsopts -with-rtsopts=-N build-tool-depends: hspec-discover:hspec-discover @@ -110,6 +188,7 @@ test-suite spec , http-types , http2 , imports + , kan-extensions , lifted-base , metrics-wai , mtl diff --git a/libs/wire-api/package.yaml b/libs/wire-api/package.yaml index b69330dc9ff..187e761ff4b 100644 --- a/libs/wire-api/package.yaml +++ b/libs/wire-api/package.yaml @@ -35,6 +35,7 @@ library: - cassava >= 0.5 - cereal - comonad + - conduit - cookie - cryptonite - currency-codes >=2.0 @@ -68,6 +69,7 @@ library: - resourcet - servant-client - servant-client-core + - servant-conduit - servant-multipart - servant-server - servant-swagger @@ -86,6 +88,8 @@ library: - wire-message-proto-lens - x509 - wai + - wai-websockets + - websockets tests: wire-api-tests: diff --git a/libs/wire-api/src/Wire/API/Arbitrary.hs b/libs/wire-api/src/Wire/API/Arbitrary.hs index 3df8c80d4c4..70ca21c7510 100644 --- a/libs/wire-api/src/Wire/API/Arbitrary.hs +++ b/libs/wire-api/src/Wire/API/Arbitrary.hs @@ -25,7 +25,6 @@ module Wire.API.Arbitrary ( Arbitrary (..), GenericUniform (..), listOf', - list1Of', setOf', mapOf', generateExample, @@ -39,7 +38,7 @@ import qualified Data.Currency as Currency import qualified Data.HashMap.Strict as HashMap import Data.ISO3166_CountryCodes (CountryCode) import Data.LanguageCodes (ISO639_1 (..)) -import Data.List1 (List1, list1) +import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.Map.Strict as Map import qualified Data.Set as Set import GHC.Generics (Rep) @@ -79,17 +78,18 @@ instance -- | We want plug in custom generators for all occurences of '[]' and 'List1'. type CustomSizedOpts = Generic.Options + 'Generic.INCOHERENT 'Generic.Sized - (Generic.Gen1 [] :+ Generic.Gen1 List1 :+ ()) + (Generic.Gen1 [] :+ Generic.Gen1 NonEmpty :+ ()) customSizedOpts :: CustomSizedOpts customSizedOpts = Generic.setGenerators - (Generic.Gen1 listOf' :+ Generic.Gen1 list1Of' :+ ()) + (Generic.Gen1 listOf' :+ Generic.Gen1 nonEmptyListOf' :+ ()) Generic.sizedOpts -list1Of' :: Gen a -> Gen (List1 a) -list1Of' g = list1 <$> g <*> Generic.listOf' g +nonEmptyListOf' :: Gen a -> Gen (NonEmpty a) +nonEmptyListOf' g = (:|) <$> g <*> listOf' g setOf' :: Ord a => Gen a -> Gen (Set a) setOf' g = Set.fromList <$> Generic.listOf' g diff --git a/libs/wire-api/src/Wire/API/Asset.hs b/libs/wire-api/src/Wire/API/Asset.hs index 544dca0df52..49044a4e150 100644 --- a/libs/wire-api/src/Wire/API/Asset.hs +++ b/libs/wire-api/src/Wire/API/Asset.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} + -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2020 Wire Swiss GmbH @@ -16,9 +20,405 @@ -- with this program. If not, see . module Wire.API.Asset - ( module V3, + ( -- * Asset + Asset, + Asset', + mkAsset, + assetKey, + assetExpires, + assetToken, + + -- * AssetKey + AssetKey (..), + assetKeyToText, + + -- * AssetToken + AssetToken (..), + NewAssetToken (..), + + -- * Body Construction + buildMultipartBody, + beginMultipartBody, + endMultipartBody, + + -- * AssetHeaders + AssetHeaders (..), + mkHeaders, + + -- * AssetSettings + AssetSettings, + defAssetSettings, + setAssetPublic, + setAssetRetention, + AssetRetention (..), + assetRetentionSeconds, + assetExpiringSeconds, + assetVolatileSeconds, + retentionToTextRep, + + -- * Streaming + AssetLocation (..), + LocalOrRemoteAsset (..), ) where -import Wire.API.Asset.V3 as V3 -import Wire.API.Asset.V3.Resumable as V3 +import qualified Codec.MIME.Type as MIME +import Control.Lens (makeLenses, (?~)) +import Data.Aeson (FromJSON (..), ToJSON (..)) +import qualified Data.Aeson as Aeson +import Data.Attoparsec.ByteString.Char8 hiding (I) +import Data.Bifunctor +import Data.ByteString.Builder +import Data.ByteString.Conversion +import qualified Data.ByteString.Lazy as LBS +import Data.Id +import Data.Json.Util (UTCTimeMillis (fromUTCTimeMillis), toUTCTimeMillis) +import Data.Proxy +import Data.Qualified +import Data.SOP +import Data.Schema +import qualified Data.Swagger as S +import qualified Data.Text as T +import Data.Text.Ascii (AsciiBase64Url) +import qualified Data.Text.Encoding as T +import qualified Data.Text.Encoding.Error as T +import Data.Time.Clock +import qualified Data.UUID as UUID +import GHC.TypeLits +import Imports +import Servant +import URI.ByteString +import Wire.API.Arbitrary (Arbitrary (..), GenericUniform (..)) +import Wire.API.ErrorDescription +import Wire.API.Routes.MultiVerb + +-------------------------------------------------------------------------------- +-- Asset + +type Asset = Asset' (Qualified AssetKey) + +-- | A newly uploaded asset. +data Asset' key = Asset + { _assetKey :: key, + _assetExpires :: Maybe UTCTime, + _assetToken :: Maybe AssetToken + } + deriving stock (Eq, Show, Generic, Functor) + +deriving via Schema (Asset' key) instance ToSchema (Asset' key) => (ToJSON (Asset' key)) + +deriving via Schema (Asset' key) instance ToSchema (Asset' key) => (FromJSON (Asset' key)) + +deriving via Schema (Asset' key) instance ToSchema (Asset' key) => (S.ToSchema (Asset' key)) + +-- Generate expiry time with millisecond precision +instance Arbitrary key => Arbitrary (Asset' key) where + arbitrary = Asset <$> arbitrary <*> (fmap milli <$> arbitrary) <*> arbitrary + where + milli = fromUTCTimeMillis . toUTCTimeMillis + +mkAsset :: key -> Asset' key +mkAsset k = Asset k Nothing Nothing + +instance ToSchema Asset where + schema = + object "Asset" $ + Asset + <$> _assetKey + .= ( Qualified + <$> qUnqualified .= field "key" schema + <*> qDomain .= field "domain" schema + ) + <*> (fmap toUTCTimeMillis . _assetExpires) + .= maybe_ + (optField "expires" (fromUTCTimeMillis <$> schema)) + <*> _assetToken .= maybe_ (optField "token" schema) + +-------------------------------------------------------------------------------- +-- AssetKey + +-- | A unique, versioned asset identifier. +-- Note: Can be turned into a sum type with additional constructors +-- for future versions. +data AssetKey = AssetKeyV3 AssetId AssetRetention + deriving stock (Eq, Show, Generic) + deriving (Arbitrary) via (GenericUniform AssetKey) + deriving (FromJSON, ToJSON, S.ToSchema) via (Schema AssetKey) + +instance FromByteString AssetKey where + parser = do + v <- decimal + _ <- char '-' + case (v :: Word) of + 3 -> parseV3 + _ -> fail $ "Invalid asset version: " ++ show v + where + -- AssetKeyV3 ::= Retention "-" uuid + -- Retention ::= decimal + parseV3 = do + r <- parser + _ <- char '-' + b <- takeByteString + case UUID.fromASCIIBytes b of + Just i -> return $! AssetKeyV3 (Id i) r + Nothing -> fail "Invalid asset ID" + +instance ToByteString AssetKey where + builder (AssetKeyV3 i r) = + builder '3' + <> builder '-' + <> builder r + <> builder '-' + <> builder (UUID.toASCIIBytes (toUUID i)) + +assetKeyToText :: AssetKey -> Text +assetKeyToText = T.decodeUtf8 . toByteString' + +instance ToSchema AssetKey where + schema = + (T.decodeUtf8 . toByteString') + .= parsedText "AssetKey" (runParser parser . T.encodeUtf8) + & doc' . S.schema . S.example ?~ toJSON ("3-1-47de4580-ae51-4650-acbb-d10c028cb0ac" :: Text) + +instance S.ToParamSchema AssetKey where + toParamSchema _ = S.toParamSchema (Proxy @Text) + +instance FromHttpApiData AssetKey where + parseUrlPiece = first T.pack . runParser parser . T.encodeUtf8 + +-------------------------------------------------------------------------------- +-- AssetToken + +-- | Asset tokens are bearer tokens that grant access to a single asset. +newtype AssetToken = AssetToken {assetTokenAscii :: AsciiBase64Url} + deriving stock (Eq, Show) + deriving newtype (FromByteString, ToByteString, Arbitrary) + deriving (FromJSON, ToJSON) via (Schema AssetToken) + +instance ToSchema AssetToken where + schema = + AssetToken <$> assetTokenAscii + .= schema + & doc' . S.schema . S.example ?~ toJSON ("aGVsbG8" :: Text) + +instance S.ToParamSchema AssetToken where + toParamSchema _ = S.toParamSchema (Proxy @Text) + +instance FromHttpApiData AssetToken where + parseUrlPiece = first T.pack . runParser parser . T.encodeUtf8 + +-- | A newly (re)generated token for an existing asset. +newtype NewAssetToken = NewAssetToken + {newAssetToken :: AssetToken} + deriving stock (Eq, Show) + deriving newtype (Arbitrary) + deriving (FromJSON, ToJSON, S.ToSchema) via (Schema NewAssetToken) + +instance ToSchema NewAssetToken where + schema = + object "NewAssetToken" $ + NewAssetToken <$> newAssetToken .= field "token" schema + +-------------------------------------------------------------------------------- +-- Body Construction + +-- | Build a complete @multipart/mixed@ request body for a one-shot, +-- non-resumable asset upload. +buildMultipartBody :: AssetSettings -> MIME.Type -> LByteString -> Builder +buildMultipartBody sets typ bs = + let hdrs = mkHeaders typ bs + in beginMultipartBody sets hdrs <> lazyByteString bs <> endMultipartBody + +-- | Begin building a @multipart/mixed@ request body for a non-resumable upload. +-- The returned 'Builder' can be immediately followed by the actual asset bytes. +beginMultipartBody :: AssetSettings -> AssetHeaders -> Builder +beginMultipartBody sets (AssetHeaders t l) = + byteString + "--frontier\r\n\ + \Content-Type: application/json\r\n\ + \Content-Length: " + <> int64Dec (LBS.length settingsJson) + <> byteString + "\r\n\ + \\r\n" + <> lazyByteString settingsJson + <> byteString + "\r\n\ + \--frontier\r\n\ + \Content-Type: " + <> byteString (T.encodeUtf8 (MIME.showType t)) + <> byteString + "\r\n\ + \Content-Length: " + <> wordDec l + <> "\r\n\ + \\r\n" + where + settingsJson = Aeson.encode (schemaToJSON sets) + +-- | The trailer of a non-resumable @multipart/mixed@ request body initiated +-- via 'beginMultipartBody'. +endMultipartBody :: Builder +endMultipartBody = byteString "\r\n--frontier--\r\n" + +-------------------------------------------------------------------------------- +-- AssetHeaders + +-- | Headers provided during upload. +data AssetHeaders = AssetHeaders + { hdrType :: MIME.Type, + hdrLength :: Word + } + +mkHeaders :: MIME.Type -> LByteString -> AssetHeaders +mkHeaders t b = AssetHeaders t (fromIntegral (LBS.length b)) + +-------------------------------------------------------------------------------- +-- AssetSettings + +-- | Settings provided during upload. +data AssetSettings = AssetSettings + { _setAssetPublic :: Bool, + _setAssetRetention :: Maybe AssetRetention + } + deriving stock (Eq, Show, Generic) + deriving (Arbitrary) via (GenericUniform AssetSettings) + deriving (FromJSON, ToJSON, S.ToSchema) via (Schema AssetSettings) + +defAssetSettings :: AssetSettings +defAssetSettings = AssetSettings False Nothing + +instance ToSchema AssetSettings where + schema = + object "AssetSettings" $ + AssetSettings + <$> _setAssetPublic .= (fromMaybe False <$> optField "public" schema) + <*> _setAssetRetention .= maybe_ (optField "retention" schema) + +-------------------------------------------------------------------------------- +-- AssetRetention + +-- | The desired asset retention. +data AssetRetention + = -- | The asset is retained indefinitely. Typically used + -- for profile pictures / assets frequently accessed. + AssetEternal + | -- | DEPRECATED: should not be used by clients for new assets + -- The asset is retained indefinitely. + AssetPersistent + | -- | The asset is retained for a short period of time. + AssetVolatile + | -- | The asset is retained indefinitely, storage is optimised + -- for infrequent access + AssetEternalInfrequentAccess + | -- | The asset is retained for an extended period of time, + -- but not indefinitely. + AssetExpiring + deriving stock (Eq, Show, Enum, Bounded, Generic) + deriving (Arbitrary) via (GenericUniform AssetRetention) + deriving (FromJSON, ToJSON, S.ToSchema) via (Schema AssetRetention) + +-- | The minimum TTL in seconds corresponding to a chosen retention. +assetRetentionSeconds :: AssetRetention -> Maybe NominalDiffTime +assetRetentionSeconds AssetEternal = Nothing +assetRetentionSeconds AssetPersistent = Nothing +assetRetentionSeconds AssetVolatile = Just assetVolatileSeconds +assetRetentionSeconds AssetEternalInfrequentAccess = Nothing +assetRetentionSeconds AssetExpiring = Just assetExpiringSeconds + +assetVolatileSeconds :: NominalDiffTime +assetVolatileSeconds = 28 * 24 * 3600 -- 28 days + +assetExpiringSeconds :: NominalDiffTime +assetExpiringSeconds = 365 * 24 * 3600 -- 365 days + +instance ToByteString AssetRetention where + builder AssetEternal = builder '1' + builder AssetPersistent = builder '2' + builder AssetVolatile = builder '3' + builder AssetEternalInfrequentAccess = builder '4' + builder AssetExpiring = builder '5' + +-- | ByteString representation is used in AssetKey +instance FromByteString AssetRetention where + parser = + decimal >>= \d -> case (d :: Word) of + 1 -> return AssetEternal + 2 -> return AssetPersistent + 3 -> return AssetVolatile + 4 -> return AssetEternalInfrequentAccess + 5 -> return AssetExpiring + _ -> fail $ "Invalid asset retention: " ++ show d + +retentionToTextRep :: AssetRetention -> Text +retentionToTextRep AssetEternal = "eternal" +retentionToTextRep AssetPersistent = "persistent" +retentionToTextRep AssetVolatile = "volatile" +retentionToTextRep AssetEternalInfrequentAccess = "eternal-infrequent_access" +retentionToTextRep AssetExpiring = "expiring" + +instance ToSchema AssetRetention where + schema = + enum @Text "AssetRetention" $ + foldMap + (\value -> element (retentionToTextRep value) value) + [minBound .. maxBound] + +-- FUTUREWORK: switch to a better URI library (e.g. modern-uri) +-- +-- This URI type is error-prone, since its internal representation is based on +-- ByteString, whereas URLs are defined in terms of characters, not octets (RFC +-- 3986). +newtype AssetLocation r = AssetLocation {getAssetLocation :: URIRef r} + +instance ToHttpApiData (AssetLocation r) where + toUrlPiece = T.decodeUtf8With T.lenientDecode . toHeader + toHeader = serializeURIRef' . getAssetLocation + +instance FromHttpApiData (AssetLocation Relative) where + parseUrlPiece = parseHeader . T.encodeUtf8 + parseHeader = + bimap (T.pack . show) AssetLocation + . parseRelativeRef strictURIParserOptions + +instance FromHttpApiData (AssetLocation Absolute) where + parseUrlPiece = parseHeader . T.encodeUtf8 + parseHeader = + bimap (T.pack . show) AssetLocation + . parseURI strictURIParserOptions + +instance S.ToParamSchema (AssetLocation r) where + toParamSchema _ = + mempty + & S.type_ ?~ S.SwaggerString + & S.format ?~ "url" + +instance AsHeaders '[AssetLocation r] Asset (Asset, AssetLocation r) where + toHeaders (asset, loc) = (I loc :* Nil, asset) + fromHeaders (I loc :* Nil, asset) = (asset, loc) + +-- | An asset as returned by the download API: if the asset is local, only a +-- URL is returned, and if it is remote the content of the asset is streamed. +data LocalOrRemoteAsset + = LocalAsset (AssetLocation Absolute) + | RemoteAsset (SourceIO ByteString) + +instance + ( ResponseType r0 ~ ErrorDescription code label desc, + ResponseType r1 ~ AssetLocation Absolute, + ResponseType r2 ~ SourceIO ByteString, + KnownSymbol desc + ) => + AsUnion '[r0, r1, r2] (Maybe LocalOrRemoteAsset) + where + toUnion Nothing = Z (I mkErrorDescription) + toUnion (Just (LocalAsset loc)) = S (Z (I loc)) + toUnion (Just (RemoteAsset asset)) = S (S (Z (I asset))) + + fromUnion (Z (I _)) = Nothing + fromUnion (S (Z (I loc))) = Just (LocalAsset loc) + fromUnion (S (S (Z (I asset)))) = Just (RemoteAsset asset) + fromUnion (S (S (S x))) = case x of + +makeLenses ''Asset' +makeLenses ''AssetSettings diff --git a/libs/wire-api/src/Wire/API/Asset/V3.hs b/libs/wire-api/src/Wire/API/Asset/V3.hs deleted file mode 100644 index db55ca96908..00000000000 --- a/libs/wire-api/src/Wire/API/Asset/V3.hs +++ /dev/null @@ -1,333 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE StrictData #-} -{-# LANGUAGE TemplateHaskell #-} - --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2020 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module Wire.API.Asset.V3 - ( -- * Asset - Asset, - mkAsset, - assetKey, - assetExpires, - assetToken, - - -- * AssetKey - AssetKey (..), - - -- * AssetToken - AssetToken (..), - NewAssetToken (..), - - -- * Body Construction - buildMultipartBody, - beginMultipartBody, - endMultipartBody, - - -- * AssetHeaders - AssetHeaders (..), - mkHeaders, - - -- * AssetSettings - AssetSettings, - defAssetSettings, - setAssetPublic, - setAssetRetention, - AssetRetention (..), - assetRetentionSeconds, - assetExpiringSeconds, - assetVolatileSeconds, - retentionToTextRep, - ) -where - -import qualified Codec.MIME.Type as MIME -import Control.Lens (makeLenses) -import Data.Aeson -import Data.Attoparsec.ByteString.Char8 -import Data.ByteString.Builder -import Data.ByteString.Conversion -import qualified Data.ByteString.Lazy as LBS -import Data.Id -import Data.Json.Util (UTCTimeMillis (fromUTCTimeMillis), toUTCTimeMillis, (#)) -import Data.Text.Ascii (AsciiBase64Url) -import qualified Data.Text.Encoding as T -import Data.Time.Clock -import qualified Data.UUID as UUID -import Imports -import Wire.API.Arbitrary (Arbitrary (..), GenericUniform (..)) - --------------------------------------------------------------------------------- --- Asset - --- | A newly uploaded asset. -data Asset = Asset - { _assetKey :: AssetKey, - _assetExpires :: Maybe UTCTime, - _assetToken :: Maybe AssetToken - } - deriving stock (Eq, Show, Generic) - --- Generate expiry time with millisecond precision -instance Arbitrary Asset where - arbitrary = Asset <$> arbitrary <*> (fmap milli <$> arbitrary) <*> arbitrary - where - milli = fromUTCTimeMillis . toUTCTimeMillis - -mkAsset :: AssetKey -> Asset -mkAsset k = Asset k Nothing Nothing - -instance ToJSON Asset where - toJSON a = - object $ - "key" .= _assetKey a - # "expires" .= fmap toUTCTimeMillis (_assetExpires a) - # "token" .= _assetToken a - # [] - -instance FromJSON Asset where - parseJSON = withObject "Asset" $ \o -> - Asset - <$> o .: "key" - <*> o .:? "expires" - <*> o .:? "token" - --------------------------------------------------------------------------------- --- AssetKey - --- | A unique, versioned asset identifier. --- Note: Can be turned into a sum type with additional constructors --- for future versions. -data AssetKey = AssetKeyV3 AssetId AssetRetention - deriving stock (Eq, Show, Generic) - deriving (Arbitrary) via (GenericUniform AssetKey) - -instance FromByteString AssetKey where - parser = do - v <- decimal - _ <- char '-' - case (v :: Word) of - 3 -> parseV3 - _ -> fail $ "Invalid asset version: " ++ show v - where - -- AssetKeyV3 ::= Retention "-" uuid - -- Retention ::= decimal - parseV3 = do - r <- parser - _ <- char '-' - b <- takeByteString - case UUID.fromASCIIBytes b of - Just i -> return $! AssetKeyV3 (Id i) r - Nothing -> fail "Invalid asset ID" - -instance ToByteString AssetKey where - builder (AssetKeyV3 i r) = - builder '3' - <> builder '-' - <> builder r - <> builder '-' - <> builder (UUID.toASCIIBytes (toUUID i)) - -instance ToJSON AssetKey where - toJSON = String . T.decodeUtf8 . toByteString' - -instance FromJSON AssetKey where - parseJSON = - withText "AssetKey" $ - either fail pure . runParser parser . T.encodeUtf8 - --------------------------------------------------------------------------------- --- AssetToken - --- | Asset tokens are bearer tokens that grant access to a single asset. -newtype AssetToken = AssetToken {assetTokenAscii :: AsciiBase64Url} - deriving stock (Eq, Show) - deriving newtype (FromByteString, ToByteString, FromJSON, ToJSON, Arbitrary) - --- | A newly (re)generated token for an existing asset. -newtype NewAssetToken = NewAssetToken - {newAssetToken :: AssetToken} - deriving stock (Eq, Show) - deriving newtype (Arbitrary) - -instance FromJSON NewAssetToken where - parseJSON = withObject "NewAssetToken" $ \o -> - NewAssetToken <$> o .: "token" - -instance ToJSON NewAssetToken where - toJSON (NewAssetToken tok) = - object ["token" .= tok] - --------------------------------------------------------------------------------- --- Body Construction - --- | Build a complete @multipart/mixed@ request body for a one-shot, --- non-resumable asset upload. -buildMultipartBody :: AssetSettings -> MIME.Type -> LByteString -> Builder -buildMultipartBody sets typ bs = - let hdrs = mkHeaders typ bs - in beginMultipartBody sets hdrs <> lazyByteString bs <> endMultipartBody - --- | Begin building a @multipart/mixed@ request body for a non-resumable upload. --- The returned 'Builder' can be immediately followed by the actual asset bytes. -beginMultipartBody :: AssetSettings -> AssetHeaders -> Builder -beginMultipartBody sets (AssetHeaders t l) = - byteString - "--frontier\r\n\ - \Content-Type: application/json\r\n\ - \Content-Length: " - <> int64Dec (LBS.length settingsJson) - <> byteString - "\r\n\ - \\r\n" - <> lazyByteString settingsJson - <> byteString - "\r\n\ - \--frontier\r\n\ - \Content-Type: " - <> byteString (T.encodeUtf8 (MIME.showType t)) - <> byteString - "\r\n\ - \Content-Length: " - <> wordDec l - <> "\r\n\ - \\r\n" - where - settingsJson = encode sets - --- | The trailer of a non-resumable @multipart/mixed@ request body initiated --- via 'beginMultipartBody'. -endMultipartBody :: Builder -endMultipartBody = byteString "\r\n--frontier--\r\n" - --------------------------------------------------------------------------------- --- AssetHeaders - --- | Headers provided during upload. -data AssetHeaders = AssetHeaders - { hdrType :: MIME.Type, - hdrLength :: Word - } - -mkHeaders :: MIME.Type -> LByteString -> AssetHeaders -mkHeaders t b = AssetHeaders t (fromIntegral (LBS.length b)) - --------------------------------------------------------------------------------- --- AssetSettings - --- | Settings provided during upload. -data AssetSettings = AssetSettings - { _setAssetPublic :: Bool, - _setAssetRetention :: Maybe AssetRetention - } - deriving stock (Eq, Show, Generic) - deriving (Arbitrary) via (GenericUniform AssetSettings) - -defAssetSettings :: AssetSettings -defAssetSettings = AssetSettings False Nothing - -instance ToJSON AssetSettings where - toJSON s = - object $ - "public" .= _setAssetPublic s - # "retention" .= _setAssetRetention s - # [] - -instance FromJSON AssetSettings where - parseJSON = withObject "AssetSettings" $ \o -> - AssetSettings - <$> o .:? "public" .!= False - <*> o .:? "retention" - --------------------------------------------------------------------------------- --- AssetRetention - --- | The desired asset retention. -data AssetRetention - = -- | The asset is retained indefinitely. Typically used - -- for profile pictures / assets frequently accessed. - AssetEternal - | -- | DEPRECATED: should not be used by clients for new assets - -- The asset is retained indefinitely. - AssetPersistent - | -- | The asset is retained for a short period of time. - AssetVolatile - | -- | The asset is retained indefinitely, storage is optimised - -- for infrequent access - AssetEternalInfrequentAccess - | -- | The asset is retained for an extended period of time, - -- but not indefinitely. - AssetExpiring - deriving stock (Eq, Show, Enum, Bounded, Generic) - deriving (Arbitrary) via (GenericUniform AssetRetention) - --- | The minimum TTL in seconds corresponding to a chosen retention. -assetRetentionSeconds :: AssetRetention -> Maybe NominalDiffTime -assetRetentionSeconds AssetEternal = Nothing -assetRetentionSeconds AssetPersistent = Nothing -assetRetentionSeconds AssetVolatile = Just assetVolatileSeconds -assetRetentionSeconds AssetEternalInfrequentAccess = Nothing -assetRetentionSeconds AssetExpiring = Just assetExpiringSeconds - -assetVolatileSeconds :: NominalDiffTime -assetVolatileSeconds = 28 * 24 * 3600 -- 28 days - -assetExpiringSeconds :: NominalDiffTime -assetExpiringSeconds = 365 * 24 * 3600 -- 365 days - -instance ToByteString AssetRetention where - builder AssetEternal = builder '1' - builder AssetPersistent = builder '2' - builder AssetVolatile = builder '3' - builder AssetEternalInfrequentAccess = builder '4' - builder AssetExpiring = builder '5' - --- | ByteString representation is used in AssetKey -instance FromByteString AssetRetention where - parser = - decimal >>= \d -> case (d :: Word) of - 1 -> return AssetEternal - 2 -> return AssetPersistent - 3 -> return AssetVolatile - 4 -> return AssetEternalInfrequentAccess - 5 -> return AssetExpiring - _ -> fail $ "Invalid asset retention: " ++ show d - -instance ToJSON AssetRetention where - toJSON = String . retentionToTextRep - -retentionToTextRep :: AssetRetention -> Text -retentionToTextRep AssetEternal = "eternal" -retentionToTextRep AssetPersistent = "persistent" -retentionToTextRep AssetVolatile = "volatile" -retentionToTextRep AssetEternalInfrequentAccess = "eternal-infrequent_access" -retentionToTextRep AssetExpiring = "expiring" - --- | JSON representation, used by AssetSettings are -instance FromJSON AssetRetention where - parseJSON = withText "AssetRetention" $ \t -> - case t of - "eternal" -> pure AssetEternal - "persistent" -> pure AssetPersistent - "volatile" -> pure AssetVolatile - "eternal-infrequent_access" -> pure AssetEternalInfrequentAccess - "expiring" -> pure AssetExpiring - _ -> fail $ "Invalid asset retention: " ++ show t - -makeLenses ''Asset -makeLenses ''AssetSettings diff --git a/libs/wire-api/src/Wire/API/Asset/V3/Resumable.hs b/libs/wire-api/src/Wire/API/Asset/V3/Resumable.hs deleted file mode 100644 index 60e23ed9a32..00000000000 --- a/libs/wire-api/src/Wire/API/Asset/V3/Resumable.hs +++ /dev/null @@ -1,141 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE StrictData #-} -{-# LANGUAGE TemplateHaskell #-} - --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2020 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module Wire.API.Asset.V3.Resumable - ( -- * ResumableSettings - ResumableSettings, - mkResumableSettings, - setResumableType, - setResumablePublic, - setResumableRetention, - - -- * ResumableAsset - ResumableAsset, - mkResumableAsset, - TotalSize (..), - ChunkSize (..), - Offset (..), - resumableAsset, - resumableExpires, - resumableChunkSize, - ) -where - -import qualified Codec.MIME.Parse as MIME -import qualified Codec.MIME.Type as MIME -import Control.Lens (makeLenses) -import Data.Aeson -import Data.Aeson.Types -import Data.ByteString.Conversion -import Data.Json.Util (UTCTimeMillis (fromUTCTimeMillis), toUTCTimeMillis, (#)) -import Data.Time.Clock -import Imports -import Wire.API.Arbitrary (Arbitrary (..), GenericUniform (..)) -import Wire.API.Asset.V3 - --------------------------------------------------------------------------------- --- ResumableSettings - --- | Settings for initiating a resumable upload. -data ResumableSettings = ResumableSettings - { _setResumableRetention :: AssetRetention, - _setResumablePublic :: Bool, - _setResumableType :: MIME.Type - } - deriving stock (Eq, Show, Generic) - deriving (Arbitrary) via (GenericUniform ResumableSettings) - -makeLenses ''ResumableSettings - -mkResumableSettings :: AssetRetention -> Bool -> MIME.Type -> ResumableSettings -mkResumableSettings = ResumableSettings - -instance ToJSON ResumableSettings where - toJSON (ResumableSettings ret pub typ) = - object $ - "retention" .= ret - # "type" .= MIME.showType typ - # "public" .= pub - # [] - -instance FromJSON ResumableSettings where - parseJSON = withObject "ResumableSettings" $ \o -> - ResumableSettings - <$> o .:? "retention" .!= AssetPersistent - <*> o .:? "public" .!= False - <*> (parseMime =<< o .: "type") - -parseMime :: Text -> Parser MIME.Type -parseMime v = - maybe - (fail "Invalid MIME type") - return - (MIME.parseMIMEType v) - --------------------------------------------------------------------------------- --- ResumableAsset - -newtype TotalSize = TotalSize - {totalSizeBytes :: Word} - deriving stock (Eq, Ord, Show) - deriving newtype (Enum, Num, Real, Integral, FromJSON, ToJSON, FromByteString, ToByteString, Arbitrary) - -newtype ChunkSize = ChunkSize - {chunkSizeBytes :: Word} - deriving stock (Eq, Ord, Show) - deriving newtype (Enum, Num, Real, Integral, FromJSON, ToJSON, FromByteString, ToByteString, Arbitrary) - -newtype Offset = Offset - {offsetBytes :: Word} - deriving stock (Eq, Ord, Show) - deriving newtype (Enum, Num, Real, Integral, FromJSON, ToJSON, FromByteString, ToByteString, Arbitrary) - -data ResumableAsset = ResumableAsset - { _resumableAsset :: Asset, - _resumableExpires :: UTCTime, - _resumableChunkSize :: ChunkSize - } - deriving stock (Eq, Show, Generic) - -instance Arbitrary ResumableAsset where - arbitrary = ResumableAsset <$> arbitrary <*> (milli <$> arbitrary) <*> arbitrary - where - milli = fromUTCTimeMillis . toUTCTimeMillis - -makeLenses ''ResumableAsset - -mkResumableAsset :: Asset -> UTCTime -> ChunkSize -> ResumableAsset -mkResumableAsset = ResumableAsset - -instance ToJSON ResumableAsset where - toJSON r = - object $ - "asset" .= _resumableAsset r - # "expires" .= toUTCTimeMillis (_resumableExpires r) - # "chunk_size" .= _resumableChunkSize r - # [] - -instance FromJSON ResumableAsset where - parseJSON = withObject "ResumableAsset" $ \o -> - ResumableAsset - <$> o .: "asset" - <*> o .: "expires" - <*> o .: "chunk_size" diff --git a/libs/wire-api/src/Wire/API/Call/Config.hs b/libs/wire-api/src/Wire/API/Call/Config.hs index c239de17344..2a68c3025f7 100644 --- a/libs/wire-api/src/Wire/API/Call/Config.hs +++ b/libs/wire-api/src/Wire/API/Call/Config.hs @@ -25,6 +25,7 @@ module Wire.API.Call.Config rtcConfiguration, rtcConfIceServers, rtcConfSftServers, + rtcConfSftServersAll, rtcConfTTL, -- * RTCIceServer @@ -104,12 +105,18 @@ import Wire.API.Arbitrary (Arbitrary (arbitrary), GenericUniform (..)) data RTCConfiguration = RTCConfiguration { _rtcConfIceServers :: NonEmpty RTCIceServer, _rtcConfSftServers :: Maybe (NonEmpty SFTServer), - _rtcConfTTL :: Word32 + _rtcConfTTL :: Word32, + _rtcConfSftServersAll :: Maybe [SFTServer] } deriving stock (Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform RTCConfiguration) -rtcConfiguration :: NonEmpty RTCIceServer -> Maybe (NonEmpty SFTServer) -> Word32 -> RTCConfiguration +rtcConfiguration :: + NonEmpty RTCIceServer -> + Maybe (NonEmpty SFTServer) -> + Word32 -> + Maybe [SFTServer] -> + RTCConfiguration rtcConfiguration = RTCConfiguration modelRtcConfiguration :: Doc.Model @@ -121,19 +128,26 @@ modelRtcConfiguration = Doc.defineModel "RTCConfiguration" $ do Doc.description "Array of 'SFTServer' objects (optional)" Doc.property "ttl" Doc.int32' $ Doc.description "Number of seconds after which the configuration should be refreshed (advisory)" + Doc.property "sft_servers_all" (Doc.array (Doc.ref modelRtcSftServerUrl)) $ + Doc.description "Array of all SFT servers" instance ToJSON RTCConfiguration where - toJSON (RTCConfiguration srvs sfts ttl) = + toJSON (RTCConfiguration srvs sfts ttl all_servers) = object ( [ "ice_servers" .= srvs, "ttl" .= ttl ] <> ["sft_servers" .= sfts | isJust sfts] + <> ["sft_servers_all" .= all_servers | isJust all_servers] ) instance FromJSON RTCConfiguration where parseJSON = withObject "RTCConfiguration" $ \o -> - RTCConfiguration <$> o .: "ice_servers" <*> o .:? "sft_servers" <*> o .: "ttl" + RTCConfiguration + <$> o .: "ice_servers" + <*> o .:? "sft_servers" + <*> o .: "ttl" + <*> o .:? "sft_servers_all" -------------------------------------------------------------------------------- -- SFTServer @@ -165,6 +179,12 @@ modelRtcSftServer = Doc.defineModel "RTC SFT Server" $ do Doc.property "urls" (Doc.array Doc.string') $ Doc.description "Array containing exactly one SFT server address of the form 'https://:'" +modelRtcSftServerUrl :: Doc.Model +modelRtcSftServerUrl = Doc.defineModel "RTC SFT Server URL" $ do + Doc.description "Inspired by WebRTC 'RTCIceServer' object, contains details of SFT servers" + Doc.property "urls" (Doc.array Doc.string') $ + Doc.description "Array containing exactly one SFT server URL" + -------------------------------------------------------------------------------- -- RTCIceServer diff --git a/libs/wire-api/src/Wire/API/Connection.hs b/libs/wire-api/src/Wire/API/Connection.hs index 612c867f265..53fa98758a4 100644 --- a/libs/wire-api/src/Wire/API/Connection.hs +++ b/libs/wire-api/src/Wire/API/Connection.hs @@ -47,13 +47,13 @@ where import Control.Applicative (optional) import Control.Lens ((?~)) -import Data.Aeson as Aeson +import Data.Aeson (FromJSON (..), ToJSON (..)) import Data.Id import Data.Json.Util (UTCTimeMillis) import Data.Qualified (Qualified (qUnqualified), deprecatedSchema) import Data.Range -import qualified Data.Schema as P -import Data.Swagger as S +import Data.Schema +import qualified Data.Swagger as S import qualified Data.Swagger.Build.Api as Doc import Data.Text as Text import Imports @@ -85,14 +85,14 @@ data UserConnectionList = UserConnectionList } deriving stock (Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform UserConnectionList) - deriving (FromJSON, ToJSON, S.ToSchema) via (P.Schema UserConnectionList) + deriving (FromJSON, ToJSON, S.ToSchema) via (Schema UserConnectionList) -instance P.ToSchema UserConnectionList where +instance ToSchema UserConnectionList where schema = - P.object "UserConnectionList" $ + object "UserConnectionList" $ UserConnectionList - <$> clConnections P..= P.field "connections" (P.array P.schema) - <*> clHasMore P..= P.fieldWithDocModifier "has_more" (P.description ?~ "Indicator that the server has more connections than returned.") P.schema + <$> clConnections .= field "connections" (array schema) + <*> clHasMore .= fieldWithDocModifier "has_more" (description ?~ "Indicator that the server has more connections than returned.") schema modelConnectionList :: Doc.Model modelConnectionList = Doc.defineModel "UserConnectionList" $ do @@ -119,21 +119,21 @@ data UserConnection = UserConnection } deriving stock (Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform UserConnection) - deriving (FromJSON, ToJSON, S.ToSchema) via (P.Schema UserConnection) + deriving (FromJSON, ToJSON, S.ToSchema) via (Schema UserConnection) -instance P.ToSchema UserConnection where +instance ToSchema UserConnection where schema = - P.object "UserConnection" $ + object "UserConnection" $ UserConnection - <$> ucFrom P..= P.field "from" P.schema - <*> ucTo P..= P.field "qualified_to" P.schema + <$> ucFrom .= field "from" schema + <*> ucTo .= field "qualified_to" schema <* (qUnqualified . ucTo) - P..= optional (P.field "to" (deprecatedSchema "qualified_to" P.schema)) - <*> ucStatus P..= P.field "status" P.schema - <*> ucLastUpdate P..= P.field "last_update" P.schema - <*> ucConvId P..= P.optField "qualified_conversation" Nothing P.schema + .= optional (field "to" (deprecatedSchema "qualified_to" schema)) + <*> ucStatus .= field "status" schema + <*> ucLastUpdate .= field "last_update" schema + <*> ucConvId .= maybe_ (optField "qualified_conversation" schema) <* (fmap qUnqualified . ucConvId) - P..= P.optField "conversation" Nothing (deprecatedSchema "qualified_conversation" P.schema) + .= maybe_ (optField "conversation" (deprecatedSchema "qualified_conversation" schema)) modelConnection :: Doc.Model modelConnection = Doc.defineModel "Connection" $ do @@ -170,7 +170,7 @@ data Relation MissingLegalholdConsent deriving stock (Eq, Ord, Show, Generic) deriving (Arbitrary) via (GenericUniform Relation) - deriving (FromJSON, ToJSON, S.ToSchema) via (P.Schema Relation) + deriving (FromJSON, ToJSON, S.ToSchema) via (Schema Relation) instance S.ToParamSchema Relation where toParamSchema _ = mempty & S.type_ ?~ S.SwaggerString @@ -234,17 +234,17 @@ typeRelation = "missing-legalhold-consent" ] -instance P.ToSchema Relation where +instance ToSchema Relation where schema = - P.enum @Text "Relation" $ + enum @Text "Relation" $ mconcat - [ P.element "accepted" Accepted, - P.element "blocked" Blocked, - P.element "pending" Pending, - P.element "ignored" Ignored, - P.element "sent" Sent, - P.element "cancelled" Cancelled, - P.element "missing-legalhold-consent" MissingLegalholdConsent + [ element "accepted" Accepted, + element "blocked" Blocked, + element "pending" Pending, + element "ignored" Ignored, + element "sent" Sent, + element "cancelled" Cancelled, + element "missing-legalhold-consent" MissingLegalholdConsent ] instance FromHttpApiData Relation where @@ -285,14 +285,14 @@ data ConnectionRequest = ConnectionRequest } deriving stock (Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform ConnectionRequest) - deriving (FromJSON, ToJSON, S.ToSchema) via (P.Schema ConnectionRequest) + deriving (FromJSON, ToJSON, S.ToSchema) via (Schema ConnectionRequest) -instance P.ToSchema ConnectionRequest where +instance ToSchema ConnectionRequest where schema = - P.object "ConnectionRequest" $ + object "ConnectionRequest" $ ConnectionRequest - <$> crUser P..= P.fieldWithDocModifier "user" (P.description ?~ "user ID of the user to request a connection with") P.schema - <*> crName P..= P.fieldWithDocModifier "name" (P.description ?~ "Name of the (pending) conversation being initiated (1 - 256) characters)") P.schema + <$> crUser .= fieldWithDocModifier "user" (description ?~ "user ID of the user to request a connection with") schema + <*> crName .= fieldWithDocModifier "name" (description ?~ "Name of the (pending) conversation being initiated (1 - 256) characters)") schema -- | Payload type for "please change the status of this connection". newtype ConnectionUpdate = ConnectionUpdate @@ -300,13 +300,13 @@ newtype ConnectionUpdate = ConnectionUpdate } deriving stock (Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform ConnectionUpdate) - deriving (FromJSON, ToJSON, S.ToSchema) via (P.Schema ConnectionUpdate) + deriving (FromJSON, ToJSON, S.ToSchema) via (Schema ConnectionUpdate) -instance P.ToSchema ConnectionUpdate where +instance ToSchema ConnectionUpdate where schema = - P.object "ConnectionUpdate" $ + object "ConnectionUpdate" $ ConnectionUpdate - <$> cuStatus P..= P.fieldWithDocModifier "status" (P.description ?~ "New relation status") P.schema + <$> cuStatus .= fieldWithDocModifier "status" (description ?~ "New relation status") schema modelConnectionUpdate :: Doc.Model modelConnectionUpdate = Doc.defineModel "ConnectionUpdate" $ do diff --git a/libs/wire-api/src/Wire/API/Conversation.hs b/libs/wire-api/src/Wire/API/Conversation.hs index f935a206049..36f6cc93dcc 100644 --- a/libs/wire-api/src/Wire/API/Conversation.hs +++ b/libs/wire-api/src/Wire/API/Conversation.hs @@ -100,7 +100,6 @@ import Data.Qualified (Qualified (qUnqualified), deprecatedSchema) import Data.Range (Range, fromRange, rangedSchema) import Data.Schema import qualified Data.Set as Set -import Data.Singletons (sing) import Data.String.Conversions (cs) import qualified Data.Swagger as S import qualified Data.Swagger.Build.Api as Doc @@ -148,19 +147,18 @@ conversationMetadataObjectSchema = schema <*> cnvmAccess .= field "access" (array schema) <*> cnvmAccessRole .= field "access_role" schema - <*> cnvmName .= lax (field "name" (optWithDefault A.Null schema)) + <*> cnvmName .= optField "name" (maybeWithDefault A.Null schema) <* const ("0.0" :: Text) .= optional (field "last_event" schema) <* const ("1970-01-01T00:00:00.000Z" :: Text) .= optional (field "last_event_time" schema) - <*> cnvmTeam .= lax (field "team" (optWithDefault A.Null schema)) + <*> cnvmTeam .= optField "team" (maybeWithDefault A.Null schema) <*> cnvmMessageTimer - .= lax - ( fieldWithDocModifier - "message_timer" - (description ?~ "Per-conversation message timer (can be null)") - (optWithDefault A.Null schema) - ) - <*> cnvmReceiptMode .= lax (field "receipt_mode" (optWithDefault A.Null schema)) + .= ( optFieldWithDocModifier + "message_timer" + (description ?~ "Per-conversation message timer (can be null)") + (maybeWithDefault A.Null schema) + ) + <*> cnvmReceiptMode .= optField "receipt_mode" (maybeWithDefault A.Null schema) instance ToSchema ConversationMetadata where schema = object "ConversationMetadata" conversationMetadataObjectSchema @@ -287,7 +285,7 @@ instance ToSchema ConversationCoverView where (description ?~ "Limited view of Conversation.") $ ConversationCoverView <$> cnvCoverConvId .= field "id" schema - <*> cnvCoverName .= lax (field "name" (optWithDefault A.Null schema)) + <*> cnvCoverName .= optField "name" (maybeWithDefault A.Null schema) data ConversationList a = ConversationList { convList :: [a], @@ -367,7 +365,7 @@ instance ToSchema ListConversations where "ListConversations" (description ?~ "A request to list some of a user's conversations, including remote ones. Maximum 1000 qualified conversation IDs") $ ListConversations - <$> (fromRange . lcQualifiedIds) .= field "qualified_ids" (rangedSchema sing sing (array schema)) + <$> (fromRange . lcQualifiedIds) .= field "qualified_ids" (rangedSchema (array schema)) data ConversationsResponse = ConversationsResponse { crFound :: [Conversation], @@ -618,27 +616,25 @@ newConvSchema = (array schema) <|> pure [] ) - <*> newConvName .= opt (field "name" schema) + <*> newConvName .= maybe_ (optField "name" schema) <*> (Set.toList . newConvAccess) - .= ( field "access" (Set.fromList <$> array schema) - <|> pure mempty - ) - <*> newConvAccessRole .= opt (field "access_role" schema) + .= (fromMaybe mempty <$> optField "access" (Set.fromList <$> array schema)) + <*> newConvAccessRole .= maybe_ (optField "access_role" schema) <*> newConvTeam - .= opt - ( fieldWithDocModifier + .= maybe_ + ( optFieldWithDocModifier "team" (description ?~ "Team information of this conversation") schema ) <*> newConvMessageTimer - .= opt - ( fieldWithDocModifier + .= maybe_ + ( optFieldWithDocModifier "message_timer" (description ?~ "Per-conversation message timer") schema ) - <*> newConvReceiptMode .= opt (field "receipt_mode" schema) + <*> newConvReceiptMode .= maybe_ (optField "receipt_mode" schema) <*> newConvUsersRole .= ( fieldWithDocModifier "conversation_role" (description ?~ usersRoleDesc) schema <|> pure roleNameWireAdmin @@ -711,10 +707,8 @@ instance ToSchema Invite where Invite <$> (toNonEmpty . invUsers) .= fmap List1 (field "users" (nonEmptyArray schema)) - <*> (Just . invRoleName) - .= fmap - (fromMaybe roleNameWireAdmin) - (optField "conversation_role" Nothing schema) + <*> invRoleName + .= (fromMaybe roleNameWireAdmin <$> optField "conversation_role" schema) data InviteQualified = InviteQualified { invQUsers :: NonEmpty (Qualified UserId), @@ -730,10 +724,8 @@ instance ToSchema InviteQualified where object "InviteQualified" $ InviteQualified <$> invQUsers .= field "qualified_users" (nonEmptyArray schema) - <*> (Just . invQRoleName) - .= fmap - (fromMaybe roleNameWireAdmin) - (optField "conversation_role" Nothing schema) + <*> invQRoleName + .= (fromMaybe roleNameWireAdmin <$> optField "conversation_role" schema) newInvite :: List1 UserId -> Invite newInvite us = Invite us roleNameWireAdmin @@ -836,7 +828,7 @@ instance ToSchema ConversationMessageTimerUpdate where "ConversationMessageTimerUpdate" (description ?~ "Contains conversation properties to update") $ ConversationMessageTimerUpdate - <$> cupMessageTimer .= lax (field "message_timer" (optWithDefault A.Null schema)) + <$> cupMessageTimer .= optField "message_timer" (maybeWithDefault A.Null schema) modelConversationMessageTimerUpdate :: Doc.Model modelConversationMessageTimerUpdate = Doc.defineModel "ConversationMessageTimerUpdate" $ do diff --git a/libs/wire-api/src/Wire/API/Conversation/Code.hs b/libs/wire-api/src/Wire/API/Conversation/Code.hs index 7e9cb9f74db..b30525fd7dc 100644 --- a/libs/wire-api/src/Wire/API/Conversation/Code.hs +++ b/libs/wire-api/src/Wire/API/Conversation/Code.hs @@ -82,8 +82,8 @@ instance ToSchema ConversationCode where (description ?~ "Conversation code (random)") schema <*> conversationUri - .= opt - ( fieldWithDocModifier + .= maybe_ + ( optFieldWithDocModifier "uri" (description ?~ "Full URI (containing key/code) to join a conversation") schema diff --git a/libs/wire-api/src/Wire/API/Conversation/Member.hs b/libs/wire-api/src/Wire/API/Conversation/Member.hs index e2abc40d069..e72ae9455d2 100644 --- a/libs/wire-api/src/Wire/API/Conversation/Member.hs +++ b/libs/wire-api/src/Wire/API/Conversation/Member.hs @@ -111,7 +111,7 @@ instance ToSchema Member where <$> memId .= field "qualified_id" schema <* (qUnqualified . memId) .= optional (field "id" (deprecatedSchema "qualified_id" schema)) - <*> memService .= lax (field "service" (optWithDefault A.Null schema)) + <*> memService .= optField "service" (maybeWithDefault A.Null schema) -- Remove ... <* const () .= optional (field "status" (c (0 :: Int))) <* const () .= optional (field "status_ref" (c ("0.0" :: Text))) @@ -122,13 +122,13 @@ instance ToSchema Member where (c ("1970-01-01T00:00:00.000Z" :: Text)) ) -- ... until here - <*> memOtrMutedStatus .= lax (field "otr_muted_status" (optWithDefault A.Null schema)) - <*> memOtrMutedRef .= lax (field "otr_muted_ref" (optWithDefault A.Null schema)) - <*> memOtrArchived .= (field "otr_archived" schema <|> pure False) - <*> memOtrArchivedRef .= lax (field "otr_archived_ref" (optWithDefault A.Null schema)) + <*> memOtrMutedStatus .= optField "otr_muted_status" (maybeWithDefault A.Null schema) + <*> memOtrMutedRef .= optField "otr_muted_ref" (maybeWithDefault A.Null schema) + <*> memOtrArchived .= (fromMaybe False <$> optField "otr_archived" schema) + <*> memOtrArchivedRef .= optField "otr_archived_ref" (maybeWithDefault A.Null schema) <*> memHidden .= (field "hidden" schema <|> pure False) - <*> memHiddenRef .= lax (field "hidden_ref" (optWithDefault A.Null schema)) - <*> memConvRoleName .= (field "conversation_role" schema <|> pure roleNameWireAdmin) + <*> memHiddenRef .= optField "hidden_ref" (maybeWithDefault A.Null schema) + <*> memConvRoleName .= (fromMaybe roleNameWireAdmin <$> optField "conversation_role" schema) where c :: ToJSON a => a -> ValueSchema SwaggerDoc () c val = mkSchema mempty (const (pure ())) (const (pure (toJSON val))) @@ -178,7 +178,7 @@ instance ToSchema OtherMember where OtherMember <$> omQualifiedId .= field "qualified_id" schema <* (qUnqualified . omQualifiedId) .= optional (field "id" schema) - <*> omService .= opt (fieldWithDocModifier "service" (description ?~ desc) schema) + <*> omService .= maybe_ (optFieldWithDocModifier "service" (description ?~ desc) schema) <*> omConvRoleName .= (field "conversation_role" schema <|> pure roleNameWireAdmin) <* const (0 :: Int) .= optional (fieldWithDocModifier "status" (description ?~ "deprecated") schema) -- TODO: remove where @@ -238,12 +238,12 @@ instance ToSchema MemberUpdate where (`withParser` (either fail pure . validateMemberUpdate)) . object "MemberUpdate" $ MemberUpdate - <$> mupOtrMuteStatus .= opt (field "otr_muted_status" schema) - <*> mupOtrMuteRef .= opt (field "otr_muted_ref" schema) - <*> mupOtrArchive .= opt (field "otr_archived" schema) - <*> mupOtrArchiveRef .= opt (field "otr_archived_ref" schema) - <*> mupHidden .= opt (field "hidden" schema) - <*> mupHiddenRef .= opt (field "hidden_ref" schema) + <$> mupOtrMuteStatus .= maybe_ (optField "otr_muted_status" schema) + <*> mupOtrMuteRef .= maybe_ (optField "otr_muted_ref" schema) + <*> mupOtrArchive .= maybe_ (optField "otr_archived" schema) + <*> mupOtrArchiveRef .= maybe_ (optField "otr_archived_ref" schema) + <*> mupHidden .= maybe_ (optField "hidden" schema) + <*> mupHiddenRef .= maybe_ (optField "hidden_ref" schema) instance Arbitrary MemberUpdate where arbitrary = @@ -290,7 +290,7 @@ instance ToSchema OtherMemberUpdate where "OtherMemberUpdate" (description ?~ "Update user properties of other members relative to a conversation") $ OtherMemberUpdate - <$> omuConvRoleName .= optField "conversation_role" Nothing schema + <$> omuConvRoleName .= maybe_ (optField "conversation_role" schema) validateOtherMemberUpdate :: OtherMemberUpdate -> Either String OtherMemberUpdate validateOtherMemberUpdate u diff --git a/libs/wire-api/src/Wire/API/ErrorDescription.hs b/libs/wire-api/src/Wire/API/ErrorDescription.hs index f02a37cc0f0..f6312d19f98 100644 --- a/libs/wire-api/src/Wire/API/ErrorDescription.hs +++ b/libs/wire-api/src/Wire/API/ErrorDescription.hs @@ -2,7 +2,6 @@ module Wire.API.ErrorDescription where import Control.Lens (at, (%~), (.~), (<>~), (?~)) import qualified Data.Aeson as A -import qualified Data.ByteString.Lazy as LBS import Data.Metrics.Servant import Data.SOP (I (..), NP (..), NS (..)) import Data.Schema @@ -13,12 +12,15 @@ import qualified Data.Text as Text import GHC.TypeLits (KnownSymbol, Symbol, natVal, symbolVal) import GHC.TypeNats (Nat) import Imports hiding (head) +import Network.HTTP.Types as HTTP import Servant hiding (Handler, addHeader, contentType, respond) import Servant.API (contentType) import Servant.API.ContentTypes (AllMimeRender, AllMimeUnrender) import Servant.API.Status (KnownStatus, statusVal) +import Servant.Client.Core import Servant.Swagger.Internal import Wire.API.Routes.MultiVerb +import Wire.API.Team.Permission -- This can be added to an endpoint to document a possible failure -- case outside its return type (usually through an exception). @@ -113,6 +115,7 @@ instance IsResponse cs (ErrorDescription s label desc) where type ResponseStatus (ErrorDescription s label desc) = s + type ResponseBody (ErrorDescription s label desc) = LByteString responseRender = responseRender @cs @(RespondWithErrorDescription s label desc) responseUnrender = responseUnrender @cs @(RespondWithErrorDescription s label desc) @@ -160,18 +163,20 @@ instance IsResponse cs (EmptyErrorForLegacyReasons s desc) where type ResponseStatus (EmptyErrorForLegacyReasons s desc) = s + type ResponseBody (EmptyErrorForLegacyReasons s desc) = () responseRender _ () = pure $ - roAddContentType + addContentType (contentType (Proxy @PlainText)) - (RenderOutput (statusVal (Proxy @s)) mempty mempty) + Response + { responseStatusCode = statusVal (Proxy @s), + responseHeaders = mempty, + responseBody = (), + responseHttpVersion = HTTP.http11 + } - responseUnrender _ output = - guard - ( LBS.null (roBody output) - && roStatus output == statusVal (Proxy @s) - ) + responseUnrender _ output = guard (responseStatusCode output == statusVal (Proxy @s)) instance (KnownStatus s, KnownSymbol desc) => @@ -230,6 +235,11 @@ noIdentity n = ErrorDescription (Text.pack (symbolVal (Proxy @desc)) <> " (code type OperationDenied = ErrorDescription 403 "operation-denied" "Insufficient permissions" +-- FUTUREWORK(leif): We need this to document possible (operation denied) errors in the servant routes. +-- Be aware that this is redundant and should be replaced by a more type safe solution in the future. +type family OperationDeniedError (a :: Perm) :: * where + OperationDeniedError 'SetTeamData = ErrorDescription 403 "operation-denied" "Insufficient permissions (missing SetTeamData)" + operationDeniedSpecialized :: String -> OperationDenied operationDeniedSpecialized p = ErrorDescription $ @@ -240,6 +250,8 @@ operationDenied = operationDeniedSpecialized . show type NotATeamMember = ErrorDescription 403 "no-team-member" "Requesting user is not a team member" +type Unauthorised = ErrorDescription 403 "unauthorised" "Unauthorised operation" + type ActionDenied = ErrorDescription 403 "action-denied" "Insufficient authorization" actionDenied :: Show a => a -> ActionDenied @@ -261,6 +273,8 @@ type HandleNotFound = ErrorDescription 404 "not-found" "Handle not found" type TooManyClients = ErrorDescription 403 "too-many-clients" "Too many clients" +type GuestLinksDisabled = ErrorDescription 409 "guest-links-disabled" "The guest link feature is disabled and all guest links have been revoked." + type MissingAuth = ErrorDescription 403 @@ -310,3 +324,9 @@ type InvalidOpOne2OneConv = InvalidOp "invalid operation for 1:1 conversations" type InvalidOpConnectConv = InvalidOp "invalid operation for connect conversation" type InvalidTargetAccess = InvalidOp "invalid target access" + +type AssetTooLarge = ErrorDescription 413 "client-error" "Asset too large" + +type InvalidLength = ErrorDescription 400 "invalid-length" "Invalid content length" + +type AssetNotFound = ErrorDescription 404 "not-found" "Asset not found" diff --git a/libs/wire-api/src/Wire/API/Event/Conversation.hs b/libs/wire-api/src/Wire/API/Event/Conversation.hs index d681659225f..de7d732d848 100644 --- a/libs/wire-api/src/Wire/API/Event/Conversation.hs +++ b/libs/wire-api/src/Wire/API/Event/Conversation.hs @@ -371,10 +371,10 @@ connectObjectSchema :: ObjectSchema SwaggerDoc Connect connectObjectSchema = Connect <$> cRecipient .= field "qualified_recipient" schema - <* (Just . qUnqualified . cRecipient) .= optField "recipient" Nothing schema - <*> cMessage .= lax (field "message" (optWithDefault A.Null schema)) - <*> cName .= lax (field "name" (optWithDefault A.Null schema)) - <*> cEmail .= lax (field "email" (optWithDefault A.Null schema)) + <* (qUnqualified . cRecipient) .= optional (field "recipient" schema) + <*> cMessage .= optField "message" (maybeWithDefault A.Null schema) + <*> cName .= optField "name" (maybeWithDefault A.Null schema) + <*> cEmail .= optField "email" (maybeWithDefault A.Null schema) modelConnect :: Doc.Model modelConnect = Doc.defineModel "Connect" $ do @@ -416,14 +416,14 @@ memberUpdateDataObjectSchema :: ObjectSchema SwaggerDoc MemberUpdateData memberUpdateDataObjectSchema = MemberUpdateData <$> misTarget .= field "qualified_target" schema - <* (Just . qUnqualified . misTarget) .= optField "target" Nothing schema - <*> misOtrMutedStatus .= opt (field "otr_muted_status" schema) - <*> misOtrMutedRef .= opt (field "otr_muted_ref" schema) - <*> misOtrArchived .= opt (field "otr_archived" schema) - <*> misOtrArchivedRef .= opt (field "otr_archived_ref" schema) - <*> misHidden .= opt (field "hidden" schema) - <*> misHiddenRef .= opt (field "hidden_ref" schema) - <*> misConvRoleName .= opt (field "conversation_role" schema) + <* (qUnqualified . misTarget) .= optional (field "target" schema) + <*> misOtrMutedStatus .= maybe_ (optField "otr_muted_status" schema) + <*> misOtrMutedRef .= maybe_ (optField "otr_muted_ref" schema) + <*> misOtrArchived .= maybe_ (optField "otr_archived" schema) + <*> misOtrArchivedRef .= maybe_ (optField "otr_archived_ref" schema) + <*> misHidden .= maybe_ (optField "hidden" schema) + <*> misHiddenRef .= maybe_ (optField "hidden_ref" schema) + <*> misConvRoleName .= maybe_ (optField "conversation_role" schema) modelMemberUpdateData :: Doc.Model modelMemberUpdateData = Doc.defineModel "MemberUpdateData" $ do @@ -478,8 +478,8 @@ otrMessageObjectSchema = (description ?~ textDesc) schema <*> otrData - .= opt - ( fieldWithDocModifier + .= maybe_ + ( optFieldWithDocModifier "data" (description ?~ dataDesc) schema diff --git a/libs/wire-api/src/Wire/API/Message.hs b/libs/wire-api/src/Wire/API/Message.hs index b9ee8acf812..e5b1c33cf9b 100644 --- a/libs/wire-api/src/Wire/API/Message.hs +++ b/libs/wire-api/src/Wire/API/Message.hs @@ -152,9 +152,9 @@ instance ToSchema NewOtrMessage where <*> newOtrRecipients .= field "recipients" schema <*> newOtrNativePush .= (field "native_push" schema <|> pure True) <*> newOtrTransient .= (field "transient" schema <|> pure False) - <*> newOtrNativePriority .= opt (field "native_priority" schema) - <*> newOtrData .= opt (field "data" schema) - <*> newOtrReportMissing .= opt (field "report_missing" (array schema)) + <*> newOtrNativePriority .= maybe_ (optField "native_priority" schema) + <*> newOtrData .= maybe_ (optField "data" schema) + <*> newOtrReportMissing .= maybe_ (optField "report_missing" (array schema)) instance FromProto NewOtrMessage where fromProto bs = protoToNewOtrMessage <$> runGetLazy Protobuf.decodeMessage bs diff --git a/libs/wire-api/src/Wire/API/Routes/AssetBody.hs b/libs/wire-api/src/Wire/API/Routes/AssetBody.hs new file mode 100644 index 00000000000..5f936ddd279 --- /dev/null +++ b/libs/wire-api/src/Wire/API/Routes/AssetBody.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- 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.Routes.AssetBody + ( AssetBody, + AssetSource (..), + ) +where + +import Conduit +import qualified Data.ByteString.Lazy as LBS +import Data.Swagger +import Data.Swagger.Internal.Schema +import Imports +import Network.HTTP.Media ((//)) +import Servant +import Servant.Conduit () +import Servant.Swagger.Internal.Orphans () + +data MultipartMixed + +instance Accept MultipartMixed where + contentType _ = "multipart" // "mixed" + +instance MimeUnrender MultipartMixed ByteString where + mimeUnrender _ = pure . LBS.toStrict + +newtype AssetSource = AssetSource + { getAssetSource :: + ConduitT () ByteString (ResourceT IO) () + } + deriving newtype (FromSourceIO ByteString, ToSourceIO ByteString) + +instance ToSchema AssetSource where + declareNamedSchema _ = pure $ named "AssetSource" mempty + +type AssetBody = + StreamBody' + '[ Description + "A body with content type `multipart/mixed body`. The first section's \ + \content type should be `application/json`. The second section's content \ + \type should be always be `application/octet-stream`. Other content types \ + \will be ignored by the server." + ] + NoFraming + MultipartMixed + AssetSource diff --git a/libs/wire-api/src/Wire/API/Routes/Internal/Brig/Connection.hs b/libs/wire-api/src/Wire/API/Routes/Internal/Brig/Connection.hs index 1132c6f920f..cf410a00f8a 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/Brig/Connection.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Brig/Connection.hs @@ -22,7 +22,7 @@ instance ToSchema ConnectionsStatusRequest where object "ConnectionsStatusRequest" $ ConnectionsStatusRequest <$> csrFrom .= field "from" (array schema) - <*> csrTo .= optField "to" Nothing (array schema) + <*> csrTo .= maybe_ (optField "to" (array schema)) data ConnectionsStatusRequestV2 = ConnectionsStatusRequestV2 { csrv2From :: ![UserId], @@ -37,8 +37,8 @@ instance ToSchema ConnectionsStatusRequestV2 where object "ConnectionsStatusRequestV2" $ ConnectionsStatusRequestV2 <$> csrv2From .= field "from" (array schema) - <*> csrv2To .= optField "to" Nothing (array schema) - <*> csrv2Relation .= optField "relation" Nothing schema + <*> csrv2To .= maybe_ (optField "to" (array schema)) + <*> csrv2Relation .= maybe_ (optField "relation" schema) data ConnectionStatus = ConnectionStatus { csFrom :: !UserId, diff --git a/libs/wire-api/src/Wire/API/Routes/MultiTablePaging.hs b/libs/wire-api/src/Wire/API/Routes/MultiTablePaging.hs index e05cbf6e987..0fd21bd3a21 100644 --- a/libs/wire-api/src/Wire/API/Routes/MultiTablePaging.hs +++ b/libs/wire-api/src/Wire/API/Routes/MultiTablePaging.hs @@ -90,8 +90,8 @@ instance RequestSchemaConstraint name tables max def => ToSchema (GetMultiTableP ("GetPaginated_" <> textFromSymbol @name) (description ?~ "A request to list some or all of a user's " <> textFromSymbol @name <> ", including remote ones") $ GetMultiTablePageRequest - <$> gmtprSize .= (fieldWithDocModifier "size" addSizeDoc schema <|> pure (toRange (Proxy @def))) - <*> gmtprState .= optFieldWithDocModifier "paging_state" Nothing addPagingStateDoc schema + <$> gmtprSize .= (fromMaybe (toRange (Proxy @def)) <$> optFieldWithDocModifier "size" addSizeDoc schema) + <*> gmtprState .= maybe_ (optFieldWithDocModifier "paging_state" addPagingStateDoc schema) textFromNat :: forall n. KnownNat n => Text textFromNat = Text.pack . show . natVal $ Proxy @n diff --git a/libs/wire-api/src/Wire/API/Routes/MultiVerb.hs b/libs/wire-api/src/Wire/API/Routes/MultiVerb.hs index 79b9f508253..0ce00f642ec 100644 --- a/libs/wire-api/src/Wire/API/Routes/MultiVerb.hs +++ b/libs/wire-api/src/Wire/API/Routes/MultiVerb.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE RecordWildCards #-} + -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2021 Wire Swiss GmbH @@ -20,6 +23,7 @@ module Wire.API.Routes.MultiVerb MultiVerb, Respond, RespondEmpty, + RespondStreaming, WithHeaders, DescHeader, AsHeaders (..), @@ -33,44 +37,48 @@ module Wire.API.Routes.MultiVerb IsResponse (..), IsSwaggerResponse (..), combineResponseSwagger, - RenderOutput (..), - roAddContentType, - roResponse, ResponseTypes, IsResponseList (..), + addContentType, ) where import Control.Applicative -import Control.Lens hiding (Context) +import Control.Lens hiding (Context, (<|)) +import Data.ByteString.Builder import qualified Data.ByteString.Lazy as LBS +import qualified Data.CaseInsensitive as CI import Data.Containers.ListUtils import Data.HashMap.Strict.InsOrd (InsOrdHashMap) import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap import Data.Metrics.Servant import Data.Proxy import Data.SOP +import Data.Sequence (Seq, (<|), pattern (:<|)) import qualified Data.Sequence as Seq import qualified Data.Swagger as S import qualified Data.Swagger.Declare as S import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import Data.Typeable import GHC.TypeLits import Generics.SOP as GSOP import Imports import qualified Network.HTTP.Media as M -import Network.HTTP.Types (HeaderName, hContentType) +import Network.HTTP.Types (hContentType) +import qualified Network.HTTP.Types as HTTP import Network.HTTP.Types.Status import qualified Network.Wai as Wai import Servant.API import Servant.API.ContentTypes -import Servant.API.ResponseHeaders import Servant.API.Status (KnownStatus (..)) import Servant.Client -import Servant.Client.Core +import Servant.Client.Core hiding (addHeader) import Servant.Server import Servant.Server.Internal import Servant.Swagger as S import Servant.Swagger.Internal as S +import Servant.Types.SourceT type Declare = S.Declare (S.Definitions S.Schema) @@ -84,11 +92,11 @@ data Respond (s :: Nat) (desc :: Symbol) (a :: *) -- Includes status code and description. data RespondEmpty (s :: Nat) (desc :: Symbol) -data RenderOutput = RenderOutput - { roStatus :: Status, - roBody :: LByteString, - roHeaders :: [(HeaderName, ByteString)] - } +-- | A type to describe a streaming 'MultiVerb' response. +-- +-- Includes status code, description, framing strategy and content type. Note +-- that the handler return type is hardcoded to be 'SourceIO ByteString'. +data RespondStreaming (s :: Nat) (desc :: Symbol) (framing :: *) (ct :: *) -- | The result of parsing a response as a union alternative of type 'a'. -- @@ -130,16 +138,18 @@ class IsSwaggerResponse a where type family ResponseType a :: * -class IsResponse cs a where +class IsWaiBody (ResponseBody a) => IsResponse cs a where type ResponseStatus a :: Nat + type ResponseBody a :: * - responseRender :: AcceptHeader -> ResponseType a -> Maybe RenderOutput - responseUnrender :: M.MediaType -> RenderOutput -> UnrenderResult (ResponseType a) + responseRender :: AcceptHeader -> ResponseType a -> Maybe (ResponseF (ResponseBody a)) + responseUnrender :: M.MediaType -> ResponseF (ResponseBody a) -> UnrenderResult (ResponseType a) type instance ResponseType (Respond s desc a) = a instance (AllMimeRender cs a, AllMimeUnrender cs a, KnownStatus s) => IsResponse cs (Respond s desc a) where type ResponseStatus (Respond s desc a) = s + type ResponseBody (Respond s desc a) = LByteString -- Note: here it seems like we are rendering for all possible content types, -- only to choose the correct one afterwards. However, render results besides the @@ -148,21 +158,22 @@ instance (AllMimeRender cs a, AllMimeUnrender cs a, KnownStatus s) => IsResponse responseRender (AcceptHeader acc) x = M.mapAcceptMedia (map (uncurry mkRenderOutput) (allMimeRender (Proxy @cs) x)) acc where - mkRenderOutput :: M.MediaType -> LByteString -> (M.MediaType, RenderOutput) + mkRenderOutput :: M.MediaType -> LByteString -> (M.MediaType, Response) mkRenderOutput c body = - (c,) . roAddContentType c $ - RenderOutput - { roStatus = statusVal (Proxy @s), - roBody = body, - roHeaders = [] + (c,) . addContentType c $ + Response + { responseStatusCode = statusVal (Proxy @s), + responseBody = body, + responseHeaders = mempty, + responseHttpVersion = HTTP.http11 } responseUnrender c output = do - guard (roStatus output == statusVal (Proxy @s)) + guard (responseStatusCode output == statusVal (Proxy @s)) let results = allMimeUnrender (Proxy @cs) case lookup c results of Nothing -> empty - Just f -> either UnrenderError UnrenderSuccess (f (roBody output)) + Just f -> either UnrenderError UnrenderSuccess (f (responseBody output)) instance (KnownStatus s, KnownSymbol desc, S.ToSchema a) => @@ -179,20 +190,19 @@ type instance ResponseType (RespondEmpty s desc) = () instance KnownStatus s => IsResponse cs (RespondEmpty s desc) where type ResponseStatus (RespondEmpty s desc) = s + type ResponseBody (RespondEmpty s desc) = () responseRender _ _ = - Just - RenderOutput - { roStatus = statusVal (Proxy @s), - roBody = mempty, - roHeaders = [] + Just $ + Response + { responseStatusCode = statusVal (Proxy @s), + responseBody = (), + responseHeaders = mempty, + responseHttpVersion = HTTP.http11 } responseUnrender _ output = - guard - ( roStatus output == statusVal (Proxy @s) - && LBS.null (roBody output) - ) + guard (responseStatusCode output == statusVal (Proxy @s)) instance (KnownStatus s, KnownSymbol desc) => IsSwaggerResponse (RespondEmpty s desc) where responseSwagger = @@ -200,6 +210,33 @@ instance (KnownStatus s, KnownSymbol desc) => IsSwaggerResponse (RespondEmpty s mempty & S.description .~ Text.pack (symbolVal (Proxy @desc)) +type instance ResponseType (RespondStreaming s desc framing ct) = SourceIO ByteString + +instance + (Accept ct, KnownStatus s) => + IsResponse cs (RespondStreaming s desc framing ct) + where + type ResponseStatus (RespondStreaming s desc framing ct) = s + type ResponseBody (RespondStreaming s desc framing ct) = SourceIO ByteString + responseRender _ x = + pure . addContentType (contentType (Proxy @ct)) $ + Response + { responseStatusCode = statusVal (Proxy @s), + responseBody = x, + responseHeaders = mempty, + responseHttpVersion = HTTP.http11 + } + + responseUnrender _ resp = do + guard (responseStatusCode resp == statusVal (Proxy @s)) + pure $ responseBody resp + +instance (KnownStatus s, KnownSymbol desc) => IsSwaggerResponse (RespondStreaming s desc framing ct) where + responseSwagger = + pure $ + mempty + & S.description .~ Text.pack (symbolVal (Proxy @desc)) + -- | This type adds response headers to a 'MultiVerb' response. -- -- Type variables: @@ -210,28 +247,61 @@ data WithHeaders (hs :: [*]) (a :: *) (r :: *) -- | This is used to convert a response containing headers to a custom type -- including the information in the headers. -class AsHeaders hs a b where - fromHeaders :: Headers hs a -> b - toHeaders :: b -> Headers hs a +class AsHeaders xs a b where + fromHeaders :: (NP I xs, a) -> b + toHeaders :: b -> (NP I xs, a) -instance AsHeaders hs a (Headers hs a) where - fromHeaders = id - toHeaders = id +-- single-header empty response +instance AsHeaders '[a] () a where + toHeaders a = (I a :* Nil, ()) + fromHeaders = unI . hd . fst data DescHeader (name :: Symbol) (desc :: Symbol) (a :: *) --- convert a list of 'Header's and 'HeaderDesc' to a list of 'Header's -type family ServantHeaders (hs :: [*]) :: [*] +class ServantHeaders hs xs | hs -> xs where + constructHeaders :: NP I xs -> [HTTP.Header] + extractHeaders :: Seq HTTP.Header -> Maybe (NP I xs) + +instance ServantHeaders '[] '[] where + constructHeaders Nil = [] + extractHeaders _ = Just Nil + +headerName :: forall name. KnownSymbol name => HTTP.HeaderName +headerName = + CI.mk + . Text.encodeUtf8 + . Text.pack + $ symbolVal (Proxy @name) + +instance + ( KnownSymbol name, + ServantHeader h name x, + ToHttpApiData x, + FromHttpApiData x, + ServantHeaders hs xs + ) => + ServantHeaders (h ': hs) (x ': xs) + where + constructHeaders (I x :* xs) = + (headerName @name, toHeader x) : + constructHeaders @hs xs + + -- FUTUREWORK: should we concatenate all the matching headers instead of just + -- taking the first one? + extractHeaders hs = do + let name = headerName @name + (hs0, hs1) = Seq.partition (\(h, _) -> h == name) hs + x <- case hs0 of + Seq.Empty -> empty + ((_, h) :<| _) -> either (const empty) pure (parseHeader h) + xs <- extractHeaders @hs hs1 + pure (I x :* xs) -type instance ServantHeaders '[] = '[] +class ServantHeader h (name :: Symbol) x | h -> name x -type instance - ServantHeaders (DescHeader name desc a ': hs) = - Header name a ': ServantHeaders hs +instance ServantHeader (Header' mods name x) name x -type instance - ServantHeaders (Header name a ': hs) = - Header name a ': ServantHeaders hs +instance ServantHeader (DescHeader name desc x) name x instance (KnownSymbol name, KnownSymbol desc, S.ToParamSchema a) => @@ -246,29 +316,28 @@ instance type instance ResponseType (WithHeaders hs a r) = a instance - ( AsHeaders (ServantHeaders hs) (ResponseType r) a, - GetHeaders' (ServantHeaders hs), - BuildHeadersTo (ServantHeaders hs), - AllToResponseHeader hs, + ( AsHeaders xs (ResponseType r) a, + ServantHeaders hs xs, IsResponse cs r ) => IsResponse cs (WithHeaders hs a r) where type ResponseStatus (WithHeaders hs a r) = ResponseStatus r + type ResponseBody (WithHeaders hs a r) = ResponseBody r - responseRender acc x = - fmap addHeaders - . responseRender @cs @r acc - . getResponse - $ h + responseRender acc x = fmap addHeaders $ responseRender @cs @r acc y where - h = toHeaders @(ServantHeaders hs) x - addHeaders r = r {roHeaders = roHeaders r ++ getHeaders h} + (hs, y) = toHeaders @xs x + addHeaders r = + r + { responseHeaders = responseHeaders r <> Seq.fromList (constructHeaders @hs hs) + } responseUnrender c output = do x <- responseUnrender @cs @r c output - let headers = Headers x (buildHeadersTo @(ServantHeaders hs) (roHeaders output)) - pure (fromHeaders headers) + case extractHeaders @hs (responseHeaders output) of + Nothing -> UnrenderError "Failed to parse headers" + Just hs -> pure $ fromHeaders @xs (hs, x) instance (AllToResponseHeader hs, IsSwaggerResponse r) => @@ -287,8 +356,8 @@ type family ResponseTypes (as :: [*]) where ResponseTypes (a ': as) = ResponseType a ': ResponseTypes as class IsResponseList cs as where - responseListRender :: AcceptHeader -> Union (ResponseTypes as) -> Maybe RenderOutput - responseListUnrender :: M.MediaType -> RenderOutput -> UnrenderResult (Union (ResponseTypes as)) + responseListRender :: AcceptHeader -> Union (ResponseTypes as) -> Maybe SomeResponse + responseListUnrender :: M.MediaType -> SomeResponse -> UnrenderResult (Union (ResponseTypes as)) responseListStatuses :: [Status] @@ -307,11 +376,11 @@ instance ) => IsResponseList cs (a ': as) where - responseListRender acc (Z (I x)) = responseRender @cs @a acc x + responseListRender acc (Z (I x)) = fmap SomeResponse (responseRender @cs @a acc x) responseListRender acc (S x) = responseListRender @cs @as acc x responseListUnrender c output = - Z . I <$> responseUnrender @cs @a c output + Z . I <$> (responseUnrender @cs @a c =<< fromSomeResponse output) <|> S <$> responseListUnrender @cs @as c output responseListStatuses = statusVal (Proxy @(ResponseStatus a)) : responseListStatuses @cs @as @@ -375,10 +444,13 @@ instance rs ~ ResponseTypes as => AsUnion as (Union rs) where toUnion = id fromUnion = id -instance AsUnion '[RespondEmpty code desc] () where - toUnion () = Z (I ()) - fromUnion (Z (I ())) = () - fromUnion (S x) = case x of +-- | A handler with a single response. +instance (ResponseType r ~ a) => AsUnion '[r] a where + toUnion = Z . I + fromUnion = unI . unZ + +_foo :: Union '[Int] +_foo = toUnion @'[Respond 200 "test" Int] @Int 3 class InjectAfter as bs where injectAfter :: Union bs -> Union (as .++ bs) @@ -549,11 +621,56 @@ instance cs = allMime (Proxy @cs) (defs, responses) = S.runDeclare (responseListSwagger @as) mempty -roResponse :: RenderOutput -> Wai.Response -roResponse ro = Wai.responseLBS (roStatus ro) (roHeaders ro) (roBody ro) +class Typeable a => IsWaiBody a where + responseToWai :: ResponseF a -> Wai.Response + +instance IsWaiBody LByteString where + responseToWai r = + Wai.responseLBS + (responseStatusCode r) + (toList (responseHeaders r)) + (responseBody r) + +instance IsWaiBody () where + responseToWai r = + Wai.responseLBS + (responseStatusCode r) + (toList (responseHeaders r)) + mempty + +instance IsWaiBody (SourceIO ByteString) where + responseToWai r = + Wai.responseStream + (responseStatusCode r) + (toList (responseHeaders r)) + $ \output flush -> do + foreach + (const (pure ())) + (\chunk -> output (byteString chunk) *> flush) + (responseBody r) -roAddContentType :: M.MediaType -> RenderOutput -> RenderOutput -roAddContentType c ro = ro {roHeaders = (hContentType, M.renderHeader c) : roHeaders ro} +data SomeResponse = forall a. IsWaiBody a => SomeResponse (ResponseF a) + +addContentType :: M.MediaType -> ResponseF a -> ResponseF a +addContentType c r = r {responseHeaders = (hContentType, M.renderHeader c) <| responseHeaders r} + +setEmptyBody :: SomeResponse -> SomeResponse +setEmptyBody (SomeResponse r) = SomeResponse (go r) + where + go :: ResponseF a -> ResponseF LByteString + go Response {..} = Response {responseBody = mempty, ..} + +someResponseToWai :: SomeResponse -> Wai.Response +someResponseToWai (SomeResponse r) = responseToWai r + +fromSomeResponse :: (Alternative m, Typeable a) => SomeResponse -> m (ResponseF a) +fromSomeResponse (SomeResponse Response {..}) = do + body <- maybe empty pure $ cast responseBody + pure $ + Response + { responseBody = body, + .. + } instance (AllMime cs, IsResponseList cs as, AsUnion as r, ReflectMethod method) => @@ -576,12 +693,11 @@ instance `addAcceptCheck` acceptCheck (Proxy @cs) acc runAction action' env req k $ \output -> do let mresp = responseListRender @cs @as acc (toUnion @as output) - resp' <- case mresp of + someResponseToWai <$> case mresp of Nothing -> FailFatal err406 Just resp - | allowedMethodHead method req -> pure $ resp {roBody = mempty} + | allowedMethodHead method req -> pure (setEmptyBody resp) | otherwise -> pure resp - pure (roResponse resp') where method = reflectMethod (Proxy @method) @@ -616,16 +732,15 @@ instance } c <- getResponseContentType response - let output = - RenderOutput - { roBody = responseBody response, - roHeaders = toList (responseHeaders response), - roStatus = responseStatusCode response - } - unless (any (M.matches c) accept) $ do throwClientError $ UnsupportedContentType c response - case responseListUnrender @cs @as c output of + + -- FUTUREWORK: support streaming + let sresp = + if LBS.null (responseBody response) + then SomeResponse response {responseBody = ()} + else SomeResponse response + case responseListUnrender @cs @as c sresp of StatusMismatch -> throwClientError (DecodeFailure "Status mismatch" response) UnrenderError e -> throwClientError (DecodeFailure (Text.pack e) response) UnrenderSuccess x -> pure (fromUnion @as x) diff --git a/libs/wire-api/src/Wire/API/Routes/Named.hs b/libs/wire-api/src/Wire/API/Routes/Named.hs new file mode 100644 index 00000000000..ea2fa27b195 --- /dev/null +++ b/libs/wire-api/src/Wire/API/Routes/Named.hs @@ -0,0 +1,40 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Wire.API.Routes.Named where + +import Data.Metrics.Servant +import Data.Proxy +import Imports +import Servant.Server +import Servant.Swagger + +newtype Named named x = Named {unnamed :: x} + deriving (Functor) + +instance HasSwagger api => HasSwagger (Named name api) where + toSwagger _ = toSwagger (Proxy @api) + +instance HasServer api ctx => HasServer (Named name api) ctx where + type ServerT (Named name api) m = Named name (ServerT api m) + + route _ ctx action = route (Proxy @api) ctx (fmap unnamed action) + hoistServerWithContext _ ctx f = + fmap (hoistServerWithContext (Proxy @api) ctx f) + +instance RoutesToPaths api => RoutesToPaths (Named name api) where + getRoutes = getRoutes @api diff --git a/libs/wire-api/src/Wire/API/Routes/Public.hs b/libs/wire-api/src/Wire/API/Routes/Public.hs index 9fd26ba7fe5..84787518919 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public.hs @@ -25,6 +25,8 @@ module Wire.API.Routes.Public ZConn, ZOptUser, ZOptConn, + ZBot, + ZProvider, -- * Swagger combinators OmitDocs, @@ -35,15 +37,17 @@ import Control.Lens ((<>~)) import Data.Domain import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap import Data.Id as Id -import Data.Kind import Data.Metrics.Servant import Data.Qualified import Data.Swagger import GHC.Base (Symbol) import GHC.TypeLits (KnownSymbol) import Imports hiding (All, head) +import qualified Network.Wai as Wai import Servant hiding (Handler, JSON, addHeader, respond) import Servant.API.Modifiers +import Servant.Server.Internal.Delayed +import Servant.Server.Internal.DelayedIO import Servant.Swagger (HasSwagger (toSwagger)) mapRequestArgument :: @@ -70,42 +74,67 @@ data ZType ZLocalAuthUser | -- | Get a 'ConnId' from the Z-Conn header ZAuthConn + | ZAuthBot + | ZAuthProvider class (KnownSymbol (ZHeader ztype), FromHttpApiData (ZParam ztype)) => - IsZType (ztype :: ZType) + IsZType (ztype :: ZType) ctx where type ZHeader ztype :: Symbol type ZParam ztype :: * type ZQualifiedParam ztype :: * - type ZConstraint ztype (ctx :: [*]) :: Constraint - qualifyZParam :: ZConstraint ztype ctx => Context ctx -> ZParam ztype -> ZQualifiedParam ztype + qualifyZParam :: Context ctx -> ZParam ztype -> ZQualifiedParam ztype -instance IsZType 'ZLocalAuthUser where +class HasTokenType ztype where + -- | The expected value of the "Z-Type" header. + tokenType :: Maybe ByteString + +instance {-# OVERLAPPABLE #-} HasTokenType ztype where + tokenType = Nothing + +instance HasContextEntry ctx Domain => IsZType 'ZLocalAuthUser ctx where type ZHeader 'ZLocalAuthUser = "Z-User" type ZParam 'ZLocalAuthUser = UserId type ZQualifiedParam 'ZLocalAuthUser = Local UserId - type ZConstraint 'ZLocalAuthUser ctx = HasContextEntry ctx Domain qualifyZParam ctx = toLocalUnsafe (getContextEntry ctx) -instance IsZType 'ZAuthUser where +instance IsZType 'ZAuthUser ctx where type ZHeader 'ZAuthUser = "Z-User" type ZParam 'ZAuthUser = UserId type ZQualifiedParam 'ZAuthUser = UserId - type ZConstraint 'ZAuthUser ctx = () qualifyZParam _ = id -instance IsZType 'ZAuthConn where +instance IsZType 'ZAuthConn ctx where type ZHeader 'ZAuthConn = "Z-Connection" type ZParam 'ZAuthConn = ConnId type ZQualifiedParam 'ZAuthConn = ConnId - type ZConstraint 'ZAuthConn ctx = () qualifyZParam _ = id +instance IsZType 'ZAuthBot ctx where + type ZHeader 'ZAuthBot = "Z-Bot" + type ZParam 'ZAuthBot = BotId + type ZQualifiedParam 'ZAuthBot = BotId + + qualifyZParam _ = id + +instance HasTokenType 'ZAuthBot where + tokenType = Just "bot" + +instance IsZType 'ZAuthProvider ctx where + type ZHeader 'ZAuthProvider = "Z-Provider" + type ZParam 'ZAuthProvider = ProviderId + type ZQualifiedParam 'ZAuthProvider = ProviderId + + qualifyZParam _ = id + +instance HasTokenType 'ZAuthProvider where + tokenType = Just "provider" + data ZAuthServant (ztype :: ZType) (opts :: [*]) type InternalAuthDefOpts = '[Servant.Required, Servant.Strict] @@ -122,6 +151,10 @@ type ZUser = ZAuthServant 'ZAuthUser InternalAuthDefOpts type ZConn = ZAuthServant 'ZAuthConn InternalAuthDefOpts +type ZBot = ZAuthServant 'ZAuthBot InternalAuthDefOpts + +type ZProvider = ZAuthServant 'ZAuthProvider InternalAuthDefOpts + type ZOptUser = ZAuthServant 'ZAuthUser '[Servant.Optional, Servant.Strict] type ZOptConn = ZAuthServant 'ZAuthConn '[Servant.Optional, Servant.Strict] @@ -129,7 +162,7 @@ type ZOptConn = ZAuthServant 'ZAuthConn '[Servant.Optional, Servant.Strict] instance HasSwagger api => HasSwagger (ZAuthServant 'ZAuthUser _opts :> api) where toSwagger _ = toSwagger (Proxy @api) - & securityDefinitions <>~ InsOrdHashMap.singleton "ZAuth" secScheme + & securityDefinitions <>~ SecurityDefinitions (InsOrdHashMap.singleton "ZAuth" secScheme) & security <>~ [SecurityRequirement $ InsOrdHashMap.singleton "ZAuth" []] where secScheme = @@ -141,13 +174,16 @@ instance HasSwagger api => HasSwagger (ZAuthServant 'ZAuthUser _opts :> api) whe instance HasSwagger api => HasSwagger (ZAuthServant 'ZLocalAuthUser opts :> api) where toSwagger _ = toSwagger (Proxy @(ZAuthServant 'ZAuthUser opts :> api)) -instance HasSwagger api => HasSwagger (ZAuthServant 'ZAuthConn _opts :> api) where +instance + {-# OVERLAPPABLE #-} + HasSwagger api => + HasSwagger (ZAuthServant ztype _opts :> api) + where toSwagger _ = toSwagger (Proxy @api) instance - ( IsZType ztype, + ( IsZType ztype ctx, HasContextEntry (ctx .++ DefaultErrorFormatters) ErrorFormatters, - ZConstraint ztype ctx, SBoolI (FoldLenient opts), SBoolI (FoldRequired opts), HasServer api ctx @@ -158,11 +194,27 @@ instance ServerT (ZAuthServant ztype opts :> api) m = RequestArgument opts (ZQualifiedParam ztype) -> ServerT api m - route _ ctx subserver = + route _ ctx subserver = do Servant.route (Proxy @(InternalAuth ztype opts :> api)) ctx - (fmap (. mapRequestArgument @opts (qualifyZParam @ztype ctx)) subserver) + ( fmap + (. mapRequestArgument @opts (qualifyZParam @ztype ctx)) + (addAcceptCheck subserver (withRequest (checkType (tokenType @ztype)))) + ) + where + checkType :: Maybe ByteString -> Wai.Request -> DelayedIO () + checkType token req = case (token, lookup "Z-Type" (Wai.requestHeaders req)) of + (Just t, value) + | value /= Just t -> + delayedFail + ServerError + { errHTTPCode = 403, + errReasonPhrase = "Access denied", + errBody = "", + errHeaders = [] + } + _ -> pure () hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TotalSize_user.hs b/libs/wire-api/src/Wire/API/Routes/Public/Cannon.hs similarity index 57% rename from libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TotalSize_user.hs rename to libs/wire-api/src/Wire/API/Routes/Public/Cannon.hs index d60539a5593..28f90c8f56c 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TotalSize_user.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Cannon.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedLists #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2021 Wire Swiss GmbH @@ -16,9 +14,30 @@ -- -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Test.Wire.API.Golden.Generated.TotalSize_user where -import Wire.API.Asset (TotalSize (..)) +module Wire.API.Routes.Public.Cannon where + +import Data.Id +import Data.Swagger +import Servant +import Servant.Swagger +import Wire.API.Routes.Public (ZConn, ZUser) +import Wire.API.Routes.WebSocket + +type ServantAPI = + Summary "Establish websocket connection" + :> "await" + :> ZUser + :> ZConn + :> QueryParam' + [ Optional, + Strict, + Description "Client ID" + ] + "client" + ClientId + -- FUTUREWORK: Consider higher-level web socket combinator + :> WebSocketPending -testObject_TotalSize_user_1 :: TotalSize -testObject_TotalSize_user_1 = TotalSize {totalSizeBytes = 9} +swaggerDoc :: Swagger +swaggerDoc = toSwagger (Proxy @ServantAPI) diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Cargohold.hs b/libs/wire-api/src/Wire/API/Routes/Public/Cargohold.hs new file mode 100644 index 00000000000..f08fdf1c3c5 --- /dev/null +++ b/libs/wire-api/src/Wire/API/Routes/Public/Cargohold.hs @@ -0,0 +1,215 @@ +-- 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.Routes.Public.Cargohold where + +import Data.Id +import Data.Metrics.Servant +import Data.Qualified +import Data.SOP +import qualified Data.Swagger as Swagger +import Imports +import Servant +import Servant.Swagger.Internal +import Servant.Swagger.Internal.Orphans () +import URI.ByteString +import Wire.API.Asset +import Wire.API.ErrorDescription +import Wire.API.Routes.AssetBody +import Wire.API.Routes.MultiVerb +import Wire.API.Routes.Public +import Wire.API.Routes.QualifiedCapture + +data PrincipalTag = UserPrincipalTag | BotPrincipalTag | ProviderPrincipalTag + deriving (Eq, Show) + +type family PrincipalId (tag :: PrincipalTag) = (id :: *) | id -> tag where + PrincipalId 'UserPrincipalTag = Local UserId + PrincipalId 'BotPrincipalTag = BotId + PrincipalId 'ProviderPrincipalTag = ProviderId + +type family ApplyPrincipalPath (tag :: PrincipalTag) api + +type instance ApplyPrincipalPath 'UserPrincipalTag api = ZLocalUser :> "assets" :> "v3" :> api + +type instance ApplyPrincipalPath 'BotPrincipalTag api = ZBot :> "bot" :> "assets" :> api + +type instance ApplyPrincipalPath 'ProviderPrincipalTag api = ZProvider :> "provider" :> "assets" :> api + +instance HasSwagger (ApplyPrincipalPath tag api) => HasSwagger (tag :> api) where + toSwagger _ = toSwagger (Proxy @(ApplyPrincipalPath tag api)) + +instance HasServer (ApplyPrincipalPath tag api) ctx => HasServer (tag :> api) ctx where + type ServerT (tag :> api) m = ServerT (ApplyPrincipalPath tag api) m + route _ = route (Proxy @(ApplyPrincipalPath tag api)) + hoistServerWithContext _ = hoistServerWithContext (Proxy @(ApplyPrincipalPath tag api)) + +instance RoutesToPaths (ApplyPrincipalPath tag api) => RoutesToPaths (tag :> api) where + getRoutes = getRoutes @(ApplyPrincipalPath tag api) + +type AssetLocationHeader r = + '[DescHeader "Location" "Asset location" (AssetLocation r)] + +type AssetRedirect = + WithHeaders + (AssetLocationHeader Absolute) + (AssetLocation Absolute) + (RespondEmpty 302 "Asset found") + +type AssetStreaming = + RespondStreaming + 200 + "Asset returned directly with content type `application/octet-stream`" + NoFraming + OctetStream + +type GetAsset = + MultiVerb + 'GET + '[JSON] + '[AssetNotFound, AssetRedirect] + (Maybe (AssetLocation Absolute)) + +type ServantAPI = + ( Summary "Renew an asset token" + :> CanThrow AssetNotFound + :> CanThrow Unauthorised + :> ZLocalUser + :> "assets" + :> "v3" + :> Capture "key" AssetKey + :> "token" + :> Post '[JSON] NewAssetToken + ) + :<|> ( Summary "Delete an asset token" + :> Description "**Note**: deleting the token makes the asset public." + :> ZLocalUser + :> "assets" + :> "v3" + :> Capture "key" AssetKey + :> "token" + :> MultiVerb + 'DELETE + '[JSON] + '[RespondEmpty 200 "Asset token deleted"] + () + ) + :<|> BaseAPIv3 'UserPrincipalTag + :<|> BaseAPIv3 'BotPrincipalTag + :<|> BaseAPIv3 'ProviderPrincipalTag + :<|> QualifiedAPI + :<|> LegacyAPI + :<|> InternalAPI + +type BaseAPIv3 (tag :: PrincipalTag) = + ( Summary "Upload an asset" + :> CanThrow AssetTooLarge + :> CanThrow InvalidLength + :> tag + :> AssetBody + :> MultiVerb + 'POST + '[JSON] + '[ WithHeaders + (AssetLocationHeader Relative) + (Asset, AssetLocation Relative) + (Respond 201 "Asset posted" Asset) + ] + (Asset, AssetLocation Relative) + ) + :<|> ( Summary "Download an asset" + :> tag + :> Capture "key" AssetKey + :> Header "Asset-Token" AssetToken + :> QueryParam "asset_token" AssetToken + :> GetAsset + ) + :<|> ( Summary "Delete an asset" + :> CanThrow AssetNotFound + :> CanThrow Unauthorised + :> tag + :> Capture "key" AssetKey + :> MultiVerb + 'DELETE + '[JSON] + '[RespondEmpty 200 "Asset deleted"] + () + ) + +type QualifiedAPI = + ( Summary "Download an asset" + :> Description + "**Note**: local assets result in a redirect, \ + \while remote assets are streamed directly." + :> ZLocalUser + :> "assets" + :> "v4" + :> QualifiedCapture "key" AssetKey + :> Header "Asset-Token" AssetToken + :> QueryParam "asset_token" AssetToken + :> MultiVerb + 'GET + '[JSON] + '[ AssetNotFound, + AssetRedirect, + AssetStreaming + ] + (Maybe LocalOrRemoteAsset) + ) + :<|> ( Summary "Delete an asset" + :> Description "**Note**: only local assets can be deleted." + :> CanThrow AssetNotFound + :> CanThrow Unauthorised + :> ZLocalUser + :> "assets" + :> "v4" + :> QualifiedCapture "key" AssetKey + :> MultiVerb + 'DELETE + '[JSON] + '[RespondEmpty 200 "Asset deleted"] + () + ) + +type LegacyAPI = + ( ZLocalUser + :> "assets" + :> QueryParam' [Required, Strict] "conv_id" ConvId + :> Capture "id" AssetId + :> GetAsset + ) + :<|> ( ZLocalUser + :> "conversations" + :> Capture "cnv" ConvId + :> "assets" + :> Capture "id" AssetId + :> GetAsset + ) + :<|> ( ZLocalUser + :> "conversations" + :> Capture "cnv" ConvId + :> "otr" + :> "assets" + :> Capture "id" AssetId + :> GetAsset + ) + +type InternalAPI = + "i" :> "status" :> MultiVerb 'GET '[PlainText] '[RespondEmpty 200 "OK"] () + +swaggerDoc :: Swagger.Swagger +swaggerDoc = toSwagger (Proxy @ServantAPI) 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 158fddcca3f..1e08d2099df 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -Wno-orphans #-} -- This file is part of the Wire Server implementation. @@ -25,11 +26,11 @@ import Data.CommaSeparatedList import Data.Id (ConvId, TeamId, UserId) import Data.Qualified (Qualified (..)) import Data.Range +import Data.SOP import qualified Data.Swagger as Swagger import GHC.TypeLits (AppendSymbol) import Imports hiding (head) import Servant -import Servant.API.Generic (ToServantApi, (:-)) import Servant.Swagger.Internal import Servant.Swagger.Internal.Orphans () import Wire.API.Conversation @@ -38,17 +39,21 @@ import Wire.API.ErrorDescription import Wire.API.Event.Conversation import Wire.API.Message import Wire.API.Routes.MultiVerb +import Wire.API.Routes.Named import Wire.API.Routes.Public import Wire.API.Routes.Public.Util import Wire.API.Routes.QualifiedCapture import Wire.API.ServantProto (Proto, RawProto) +import Wire.API.Team import Wire.API.Team.Conversation import Wire.API.Team.Feature +import Wire.API.Team.Permission (Perm (..)) -instance AsHeaders '[Header "Location" ConvId] Conversation Conversation where - -- FUTUREWORK: use addHeader - toHeaders c = Headers c (HCons (Header (qUnqualified (cnvQualifiedId c))) HNil) - fromHeaders = getResponse +-- import Wire.API.Team.Permission (Perm (..)) + +instance AsHeaders '[ConvId] Conversation Conversation where + toHeaders c = (I (qUnqualified (cnvQualifiedId c)) :* Nil, c) + fromHeaders = snd type ConversationResponse = ResponseForExistedCreated Conversation @@ -80,500 +85,584 @@ type RemoveFromConversationVerb = ] (Maybe Event) -data Api routes = Api - { -- Conversations +type ServantAPI = + ConversationAPI + :<|> TeamConversationAPI + :<|> MessagingAPI + :<|> TeamAPI + :<|> FeatureAPI - getUnqualifiedConversation :: - routes - :- Summary "Get a conversation by ID" - :> ZLocalUser - :> "conversations" - :> Capture "cnv" ConvId - :> Get '[Servant.JSON] Conversation, - getConversation :: - routes - :- Summary "Get a conversation by ID" - :> ZLocalUser - :> "conversations" - :> QualifiedCapture "cnv" ConvId - :> Get '[Servant.JSON] Conversation, - getConversationRoles :: - routes - :- Summary "Get existing roles available for the given conversation" +type ConversationAPI = + Named + "get-unqualified-conversation" + ( Summary "Get a conversation by ID" :> ZLocalUser :> "conversations" :> Capture "cnv" ConvId - :> "roles" - :> Get '[Servant.JSON] ConversationRolesList, - listConversationIdsUnqualified :: - routes - :- Summary "[deprecated] Get all local conversation IDs." - -- FUTUREWORK: add bounds to swagger schema for Range - :> ZLocalUser - :> "conversations" - :> "ids" - :> QueryParam' - [ Optional, - Strict, - Description "Conversation ID to start from (exclusive)" - ] - "start" - ConvId - :> QueryParam' - [ Optional, - Strict, - Description "Maximum number of IDs to return" - ] - "size" - (Range 1 1000 Int32) - :> Get '[Servant.JSON] (ConversationList ConvId), - listConversationIds :: - routes - :- Summary "Get all conversation IDs." - :> Description - "The IDs returned by this endpoint are paginated. To\ - \ get the first page, make a call with the `paging_state` field set to\ - \ `null` (or omitted). Whenever the `has_more` field of the response is\ - \ set to `true`, more results are available, and they can be obtained\ - \ by calling the endpoint again, but this time passing the value of\ - \ `paging_state` returned by the previous call. One can continue in\ - \ this fashion until all results are returned, which is indicated by\ - \ `has_more` being `false`. Note that `paging_state` should be\ - \ considered an opaque token. It should not be inspected, or stored, or\ - \ reused across multiple unrelated invokations of the endpoint." - :> ZLocalUser - :> "conversations" - :> "list-ids" - :> ReqBody '[Servant.JSON] GetPaginatedConversationIds - :> Post '[Servant.JSON] ConvIdsPage, - getConversations :: - routes - :- Summary "Get all *local* conversations." - :> Description - "Will not return remote conversations.\n\n\ - \Use `POST /conversations/list-ids` followed by \ - \`POST /conversations/list/v2` instead." - :> ZLocalUser - :> "conversations" - :> QueryParam' - [ Optional, - Strict, - Description "Mutually exclusive with 'start' (at most 32 IDs per request)" - ] - "ids" - (Range 1 32 (CommaSeparatedList ConvId)) - :> QueryParam' - [ Optional, - Strict, - Description "Conversation ID to start from (exclusive)" - ] - "start" - ConvId - :> QueryParam' - [ Optional, - Strict, - Description "Maximum number of conversations to return" - ] - "size" - (Range 1 500 Int32) - :> Get '[Servant.JSON] (ConversationList Conversation), - listConversations :: - routes - :- Summary "Get conversation metadata for a list of conversation ids" - :> ZLocalUser - :> "conversations" - :> "list" - :> "v2" - :> ReqBody '[Servant.JSON] ListConversations - :> Post '[Servant.JSON] ConversationsResponse, + :> Get '[Servant.JSON] Conversation + ) + :<|> Named + "get-conversation" + ( Summary "Get a conversation by ID" + :> ZLocalUser + :> "conversations" + :> QualifiedCapture "cnv" ConvId + :> Get '[Servant.JSON] Conversation + ) + :<|> Named + "get-conversation-roles" + ( Summary "Get existing roles available for the given conversation" + :> ZLocalUser + :> "conversations" + :> Capture "cnv" ConvId + :> "roles" + :> Get '[Servant.JSON] ConversationRolesList + ) + :<|> Named + "list-conversation-ids-unqualified" + ( Summary "[deprecated] Get all local conversation IDs." + -- FUTUREWORK: add bounds to swagger schema for Range + :> ZLocalUser + :> "conversations" + :> "ids" + :> QueryParam' + [ Optional, + Strict, + Description "Conversation ID to start from (exclusive)" + ] + "start" + ConvId + :> QueryParam' + [ Optional, + Strict, + Description "Maximum number of IDs to return" + ] + "size" + (Range 1 1000 Int32) + :> Get '[Servant.JSON] (ConversationList ConvId) + ) + :<|> Named + "list-conversation-ids" + ( Summary "Get all conversation IDs." + :> Description + "The IDs returned by this endpoint are paginated. To\ + \ get the first page, make a call with the `paging_state` field set to\ + \ `null` (or omitted). Whenever the `has_more` field of the response is\ + \ set to `true`, more results are available, and they can be obtained\ + \ by calling the endpoint again, but this time passing the value of\ + \ `paging_state` returned by the previous call. One can continue in\ + \ this fashion until all results are returned, which is indicated by\ + \ `has_more` being `false`. Note that `paging_state` should be\ + \ considered an opaque token. It should not be inspected, or stored, or\ + \ reused across multiple unrelated invokations of the endpoint." + :> ZLocalUser + :> "conversations" + :> "list-ids" + :> ReqBody '[Servant.JSON] GetPaginatedConversationIds + :> Post '[Servant.JSON] ConvIdsPage + ) + :<|> Named + "get-conversations" + ( Summary "Get all *local* conversations." + :> Description + "Will not return remote conversations.\n\n\ + \Use `POST /conversations/list-ids` followed by \ + \`POST /conversations/list/v2` instead." + :> ZLocalUser + :> "conversations" + :> QueryParam' + [ Optional, + Strict, + Description "Mutually exclusive with 'start' (at most 32 IDs per request)" + ] + "ids" + (Range 1 32 (CommaSeparatedList ConvId)) + :> QueryParam' + [ Optional, + Strict, + Description "Conversation ID to start from (exclusive)" + ] + "start" + ConvId + :> QueryParam' + [ Optional, + Strict, + Description "Maximum number of conversations to return" + ] + "size" + (Range 1 500 Int32) + :> Get '[Servant.JSON] (ConversationList Conversation) + ) + :<|> Named + "list-conversations" + ( Summary "Get conversation metadata for a list of conversation ids" + :> ZLocalUser + :> "conversations" + :> "list" + :> "v2" + :> ReqBody '[Servant.JSON] ListConversations + :> Post '[Servant.JSON] ConversationsResponse + ) -- This endpoint can lead to the following events being sent: -- - ConvCreate event to members - getConversationByReusableCode :: - routes - :- Summary "Get limited conversation information by key/code pair" - :> CanThrow NotATeamMember - :> CanThrow CodeNotFound - :> CanThrow ConvNotFound - :> CanThrow ConvAccessDenied - :> ZLocalUser - :> "conversations" - :> "join" - :> QueryParam' [Required, Strict] "key" Code.Key - :> QueryParam' [Required, Strict] "code" Code.Value - :> Get '[Servant.JSON] ConversationCoverView, - createGroupConversation :: - routes - :- Summary "Create a new conversation" - :> CanThrow NotConnected - :> CanThrow OperationDenied - :> CanThrow NotATeamMember - :> Description "This returns 201 when a new conversation is created, and 200 when the conversation already existed" - :> ZLocalUser - :> ZConn - :> "conversations" - :> ReqBody '[Servant.JSON] NewConvUnmanaged - :> ConversationVerb, - createSelfConversation :: - routes - :- Summary "Create a self-conversation" - :> ZLocalUser - :> "conversations" - :> "self" - :> ConversationVerb, + :<|> Named + "get-conversation-by-reusable-code" + ( Summary "Get limited conversation information by key/code pair" + :> CanThrow NotATeamMember + :> CanThrow CodeNotFound + :> CanThrow ConvNotFound + :> CanThrow ConvAccessDenied + :> CanThrow GuestLinksDisabled + :> ZLocalUser + :> "conversations" + :> "join" + :> QueryParam' [Required, Strict] "key" Code.Key + :> QueryParam' [Required, Strict] "code" Code.Value + :> Get '[Servant.JSON] ConversationCoverView + ) + :<|> Named + "create-group-conversation" + ( Summary "Create a new conversation" + :> CanThrow NotConnected + :> CanThrow OperationDenied + :> CanThrow NotATeamMember + :> Description "This returns 201 when a new conversation is created, and 200 when the conversation already existed" + :> ZLocalUser + :> ZConn + :> "conversations" + :> ReqBody '[Servant.JSON] NewConvUnmanaged + :> ConversationVerb + ) + :<|> Named + "create-self-conversation" + ( Summary "Create a self-conversation" + :> ZLocalUser + :> "conversations" + :> "self" + :> ConversationVerb + ) -- This endpoint can lead to the following events being sent: -- - ConvCreate event to members -- TODO: add note: "On 201, the conversation ID is the `Location` header" - createOne2OneConversation :: - routes - :- Summary "Create a 1:1 conversation" - :> ZLocalUser - :> ZConn - :> "conversations" - :> "one2one" - :> ReqBody '[Servant.JSON] NewConvUnmanaged - :> ConversationVerb, + :<|> Named + "create-one-to-one-conversation" + ( Summary "Create a 1:1 conversation" + :> ZLocalUser + :> ZConn + :> "conversations" + :> "one2one" + :> ReqBody '[Servant.JSON] NewConvUnmanaged + :> ConversationVerb + ) -- This endpoint can lead to the following events being sent: -- - MemberJoin event to members - addMembersToConversationUnqualified :: - routes - :- Summary "Add members to an existing conversation (deprecated)" - :> CanThrow ConvNotFound - :> CanThrow NotConnected - :> CanThrow ConvAccessDenied - :> CanThrow (InvalidOp "Invalid operation") - :> ZLocalUser - :> ZConn - :> "conversations" - :> Capture "cnv" ConvId - :> "members" - :> ReqBody '[JSON] Invite - :> MultiVerb 'POST '[JSON] ConvUpdateResponses (UpdateResult Event), - addMembersToConversation :: - routes - :- Summary "Add qualified members to an existing conversation." - :> ZLocalUser - :> ZConn - :> "conversations" - :> Capture "cnv" ConvId - :> "members" - :> "v2" - :> ReqBody '[Servant.JSON] InviteQualified - :> MultiVerb 'POST '[Servant.JSON] ConvUpdateResponses (UpdateResult Event), + :<|> Named + "add-members-to-conversation-unqualified" + ( Summary "Add members to an existing conversation (deprecated)" + :> CanThrow ConvNotFound + :> CanThrow NotConnected + :> CanThrow ConvAccessDenied + :> CanThrow (InvalidOp "Invalid operation") + :> ZLocalUser + :> ZConn + :> "conversations" + :> Capture "cnv" ConvId + :> "members" + :> ReqBody '[JSON] Invite + :> MultiVerb 'POST '[JSON] ConvUpdateResponses (UpdateResult Event) + ) + :<|> Named + "add-members-to-conversation" + ( Summary "Add qualified members to an existing conversation." + :> ZLocalUser + :> ZConn + :> "conversations" + :> Capture "cnv" ConvId + :> "members" + :> "v2" + :> ReqBody '[Servant.JSON] InviteQualified + :> MultiVerb 'POST '[Servant.JSON] ConvUpdateResponses (UpdateResult Event) + ) -- This endpoint can lead to the following events being sent: -- - MemberLeave event to members - removeMemberUnqualified :: - routes - :- Summary "Remove a member from a conversation (deprecated)" - :> ZLocalUser - :> ZConn - :> CanThrow ConvNotFound - :> CanThrow (InvalidOp "Invalid operation") - :> "conversations" - :> Capture' '[Description "Conversation ID"] "cnv" ConvId - :> "members" - :> Capture' '[Description "Target User ID"] "usr" UserId - :> RemoveFromConversationVerb, + :<|> Named + "remove-member-unqualified" + ( Summary "Remove a member from a conversation (deprecated)" + :> ZLocalUser + :> ZConn + :> CanThrow ConvNotFound + :> CanThrow (InvalidOp "Invalid operation") + :> "conversations" + :> Capture' '[Description "Conversation ID"] "cnv" ConvId + :> "members" + :> Capture' '[Description "Target User ID"] "usr" UserId + :> RemoveFromConversationVerb + ) -- This endpoint can lead to the following events being sent: -- - MemberLeave event to members - removeMember :: - routes - :- Summary "Remove a member from a conversation" - :> ZLocalUser - :> ZConn - :> CanThrow ConvNotFound - :> CanThrow (InvalidOp "Invalid operation") - :> "conversations" - :> QualifiedCapture' '[Description "Conversation ID"] "cnv" ConvId - :> "members" - :> QualifiedCapture' '[Description "Target User ID"] "usr" UserId - :> RemoveFromConversationVerb, + :<|> Named + "remove-member" + ( Summary "Remove a member from a conversation" + :> ZLocalUser + :> ZConn + :> CanThrow ConvNotFound + :> CanThrow (InvalidOp "Invalid operation") + :> "conversations" + :> QualifiedCapture' '[Description "Conversation ID"] "cnv" ConvId + :> "members" + :> QualifiedCapture' '[Description "Target User ID"] "usr" UserId + :> RemoveFromConversationVerb + ) -- This endpoint can lead to the following events being sent: -- - MemberStateUpdate event to members - updateOtherMemberUnqualified :: - routes - :- Summary "Update membership of the specified user (deprecated)" - :> Description "Use `PUT /conversations/:cnv_domain/:cnv/members/:usr_domain/:usr` instead" - :> ZLocalUser - :> ZConn - :> CanThrow ConvNotFound - :> CanThrow ConvMemberNotFound - :> CanThrow (InvalidOp "Invalid operation") - :> "conversations" - :> Capture' '[Description "Conversation ID"] "cnv" ConvId - :> "members" - :> Capture' '[Description "Target User ID"] "usr" UserId - :> ReqBody '[JSON] OtherMemberUpdate - :> MultiVerb - 'PUT - '[JSON] - '[RespondEmpty 200 "Membership updated"] - (), - updateOtherMember :: - routes - :- Summary "Update membership of the specified user" - :> Description "**Note**: at least one field has to be provided." - :> ZLocalUser - :> ZConn - :> CanThrow ConvNotFound - :> CanThrow ConvMemberNotFound - :> CanThrow (InvalidOp "Invalid operation") - :> "conversations" - :> QualifiedCapture' '[Description "Conversation ID"] "cnv" ConvId - :> "members" - :> QualifiedCapture' '[Description "Target User ID"] "usr" UserId - :> ReqBody '[JSON] OtherMemberUpdate - :> MultiVerb - 'PUT - '[JSON] - '[RespondEmpty 200 "Membership updated"] - (), + :<|> Named + "update-other-member-unqualified" + ( Summary "Update membership of the specified user (deprecated)" + :> Description "Use `PUT /conversations/:cnv_domain/:cnv/members/:usr_domain/:usr` instead" + :> ZLocalUser + :> ZConn + :> CanThrow ConvNotFound + :> CanThrow ConvMemberNotFound + :> CanThrow (InvalidOp "Invalid operation") + :> "conversations" + :> Capture' '[Description "Conversation ID"] "cnv" ConvId + :> "members" + :> Capture' '[Description "Target User ID"] "usr" UserId + :> ReqBody '[JSON] OtherMemberUpdate + :> MultiVerb + 'PUT + '[JSON] + '[RespondEmpty 200 "Membership updated"] + () + ) + :<|> Named + "update-other-member" + ( Summary "Update membership of the specified user" + :> Description "**Note**: at least one field has to be provided." + :> ZLocalUser + :> ZConn + :> CanThrow ConvNotFound + :> CanThrow ConvMemberNotFound + :> CanThrow (InvalidOp "Invalid operation") + :> "conversations" + :> QualifiedCapture' '[Description "Conversation ID"] "cnv" ConvId + :> "members" + :> QualifiedCapture' '[Description "Target User ID"] "usr" UserId + :> ReqBody '[JSON] OtherMemberUpdate + :> MultiVerb + 'PUT + '[JSON] + '[RespondEmpty 200 "Membership updated"] + () + ) -- This endpoint can lead to the following events being sent: -- - ConvRename event to members - updateConversationNameDeprecated :: - routes - :- Summary "Update conversation name (deprecated)" - :> Description "Use `/conversations/:domain/:conv/name` instead." - :> ZLocalUser - :> ZConn - :> "conversations" - :> Capture' '[Description "Conversation ID"] "cnv" ConvId - :> ReqBody '[JSON] ConversationRename - :> MultiVerb - 'PUT - '[JSON] - [ ConvNotFound, - Respond 200 "Conversation updated" Event - ] - (Maybe Event), - updateConversationNameUnqualified :: - routes - :- Summary "Update conversation name (deprecated)" - :> Description "Use `/conversations/:domain/:conv/name` instead." - :> ZLocalUser - :> ZConn - :> "conversations" - :> Capture' '[Description "Conversation ID"] "cnv" ConvId - :> "name" - :> ReqBody '[JSON] ConversationRename - :> MultiVerb - 'PUT - '[JSON] - [ ConvNotFound, - Respond 200 "Conversation updated" Event - ] - (Maybe Event), - updateConversationName :: - routes - :- Summary "Update conversation name" - :> ZLocalUser - :> ZConn - :> "conversations" - :> QualifiedCapture' '[Description "Conversation ID"] "cnv" ConvId - :> "name" - :> ReqBody '[JSON] ConversationRename - :> MultiVerb - 'PUT - '[JSON] - [ ConvNotFound, - Respond 200 "Conversation updated" Event - ] - (Maybe Event), + :<|> Named + "update-conversation-name-deprecated" + ( Summary "Update conversation name (deprecated)" + :> Description "Use `/conversations/:domain/:conv/name` instead." + :> ZLocalUser + :> ZConn + :> "conversations" + :> Capture' '[Description "Conversation ID"] "cnv" ConvId + :> ReqBody '[JSON] ConversationRename + :> MultiVerb + 'PUT + '[JSON] + [ ConvNotFound, + Respond 200 "Conversation updated" Event + ] + (Maybe Event) + ) + :<|> Named + "update-conversation-name-unqualified" + ( Summary "Update conversation name (deprecated)" + :> Description "Use `/conversations/:domain/:conv/name` instead." + :> ZLocalUser + :> ZConn + :> "conversations" + :> Capture' '[Description "Conversation ID"] "cnv" ConvId + :> "name" + :> ReqBody '[JSON] ConversationRename + :> MultiVerb + 'PUT + '[JSON] + [ ConvNotFound, + Respond 200 "Conversation updated" Event + ] + (Maybe Event) + ) + :<|> Named + "update-conversation-name" + ( Summary "Update conversation name" + :> ZLocalUser + :> ZConn + :> "conversations" + :> QualifiedCapture' '[Description "Conversation ID"] "cnv" ConvId + :> "name" + :> ReqBody '[JSON] ConversationRename + :> MultiVerb + 'PUT + '[JSON] + [ ConvNotFound, + Respond 200 "Conversation updated" Event + ] + (Maybe Event) + ) -- This endpoint can lead to the following events being sent: -- - ConvMessageTimerUpdate event to members - updateConversationMessageTimerUnqualified :: - routes - :- Summary "Update the message timer for a conversation (deprecated)" - :> Description "Use `/conversations/:domain/:cnv/message-timer` instead." - :> ZLocalUser - :> ZConn - :> CanThrow ConvAccessDenied - :> CanThrow ConvNotFound - :> CanThrow (InvalidOp "Invalid operation") - :> "conversations" - :> Capture' '[Description "Conversation ID"] "cnv" ConvId - :> "message-timer" - :> ReqBody '[JSON] ConversationMessageTimerUpdate - :> MultiVerb - 'PUT - '[JSON] - (UpdateResponses "Message timer unchanged" "Message timer updated" Event) - (UpdateResult Event), - updateConversationMessageTimer :: - routes - :- Summary "Update the message timer for a conversation" - :> ZLocalUser - :> ZConn - :> CanThrow ConvAccessDenied - :> CanThrow ConvNotFound - :> CanThrow (InvalidOp "Invalid operation") - :> "conversations" - :> QualifiedCapture' '[Description "Conversation ID"] "cnv" ConvId - :> "message-timer" - :> ReqBody '[JSON] ConversationMessageTimerUpdate - :> MultiVerb - 'PUT - '[JSON] - (UpdateResponses "Message timer unchanged" "Message timer updated" Event) - (UpdateResult Event), + :<|> Named + "update-conversation-message-timer-unqualified" + ( Summary "Update the message timer for a conversation (deprecated)" + :> Description "Use `/conversations/:domain/:cnv/message-timer` instead." + :> ZLocalUser + :> ZConn + :> CanThrow ConvAccessDenied + :> CanThrow ConvNotFound + :> CanThrow (InvalidOp "Invalid operation") + :> "conversations" + :> Capture' '[Description "Conversation ID"] "cnv" ConvId + :> "message-timer" + :> ReqBody '[JSON] ConversationMessageTimerUpdate + :> MultiVerb + 'PUT + '[JSON] + (UpdateResponses "Message timer unchanged" "Message timer updated" Event) + (UpdateResult Event) + ) + :<|> Named + "update-conversation-message-timer" + ( Summary "Update the message timer for a conversation" + :> ZLocalUser + :> ZConn + :> CanThrow ConvAccessDenied + :> CanThrow ConvNotFound + :> CanThrow (InvalidOp "Invalid operation") + :> "conversations" + :> QualifiedCapture' '[Description "Conversation ID"] "cnv" ConvId + :> "message-timer" + :> ReqBody '[JSON] ConversationMessageTimerUpdate + :> MultiVerb + 'PUT + '[JSON] + (UpdateResponses "Message timer unchanged" "Message timer updated" Event) + (UpdateResult Event) + ) -- This endpoint can lead to the following events being sent: -- - ConvReceiptModeUpdate event to members - updateConversationReceiptModeUnqualified :: - routes - :- Summary "Update receipt mode for a conversation (deprecated)" - :> Description "Use `PUT /conversations/:domain/:cnv/receipt-mode` instead." - :> ZLocalUser - :> ZConn - :> CanThrow ConvAccessDenied - :> CanThrow ConvNotFound - :> "conversations" - :> Capture' '[Description "Conversation ID"] "cnv" ConvId - :> "receipt-mode" - :> ReqBody '[JSON] ConversationReceiptModeUpdate - :> MultiVerb - 'PUT - '[JSON] - (UpdateResponses "Receipt mode unchanged" "Receipt mode updated" Event) - (UpdateResult Event), - updateConversationReceiptMode :: - routes - :- Summary "Update receipt mode for a conversation" - :> ZLocalUser - :> ZConn - :> CanThrow ConvAccessDenied - :> CanThrow ConvNotFound - :> "conversations" - :> QualifiedCapture' '[Description "Conversation ID"] "cnv" ConvId - :> "receipt-mode" - :> ReqBody '[JSON] ConversationReceiptModeUpdate - :> MultiVerb - 'PUT - '[JSON] - (UpdateResponses "Receipt mode unchanged" "Receipt mode updated" Event) - (UpdateResult Event), + :<|> Named + "update-conversation-receipt-mode-unqualified" + ( Summary "Update receipt mode for a conversation (deprecated)" + :> Description "Use `PUT /conversations/:domain/:cnv/receipt-mode` instead." + :> ZLocalUser + :> ZConn + :> CanThrow ConvAccessDenied + :> CanThrow ConvNotFound + :> "conversations" + :> Capture' '[Description "Conversation ID"] "cnv" ConvId + :> "receipt-mode" + :> ReqBody '[JSON] ConversationReceiptModeUpdate + :> MultiVerb + 'PUT + '[JSON] + (UpdateResponses "Receipt mode unchanged" "Receipt mode updated" Event) + (UpdateResult Event) + ) + :<|> Named + "update-conversation-receipt-mode" + ( Summary "Update receipt mode for a conversation" + :> ZLocalUser + :> ZConn + :> CanThrow ConvAccessDenied + :> CanThrow ConvNotFound + :> "conversations" + :> QualifiedCapture' '[Description "Conversation ID"] "cnv" ConvId + :> "receipt-mode" + :> ReqBody '[JSON] ConversationReceiptModeUpdate + :> MultiVerb + 'PUT + '[JSON] + (UpdateResponses "Receipt mode unchanged" "Receipt mode updated" Event) + (UpdateResult Event) + ) -- This endpoint can lead to the following events being sent: -- - MemberLeave event to members, if members get removed -- - ConvAccessUpdate event to members - updateConversationAccessUnqualified :: - routes - :- Summary "Update access modes for a conversation (deprecated)" - :> Description "Use PUT `/conversations/:domain/:cnv/access` instead." - :> ZLocalUser - :> ZConn - :> CanThrow ConvAccessDenied - :> CanThrow ConvNotFound - :> CanThrow (InvalidOp "Invalid operation") - :> "conversations" - :> Capture' '[Description "Conversation ID"] "cnv" ConvId - :> "access" - :> ReqBody '[JSON] ConversationAccessData - :> MultiVerb - 'PUT - '[JSON] - (UpdateResponses "Access unchanged" "Access updated" Event) - (UpdateResult Event), - updateConversationAccess :: - routes - :- Summary "Update access modes for a conversation" - :> ZLocalUser - :> ZConn - :> CanThrow ConvAccessDenied - :> CanThrow ConvNotFound - :> CanThrow (InvalidOp "Invalid operation") - :> "conversations" - :> QualifiedCapture' '[Description "Conversation ID"] "cnv" ConvId - :> "access" - :> ReqBody '[JSON] ConversationAccessData - :> MultiVerb - 'PUT - '[JSON] - (UpdateResponses "Access unchanged" "Access updated" Event) - (UpdateResult Event), - getConversationSelfUnqualified :: - routes - :- Summary "Get self membership properties (deprecated)" - :> ZLocalUser - :> "conversations" - :> Capture' '[Description "Conversation ID"] "cnv" ConvId - :> "self" - :> Get '[JSON] (Maybe Member), - updateConversationSelfUnqualified :: - routes - :- Summary "Update self membership properties (deprecated)" - :> Description "Use `/conversations/:domain/:conv/self` instead." - :> CanThrow ConvNotFound - :> ZLocalUser - :> ZConn - :> "conversations" - :> Capture' '[Description "Conversation ID"] "cnv" ConvId - :> "self" - :> ReqBody '[JSON] MemberUpdate - :> MultiVerb - 'PUT - '[JSON] - '[RespondEmpty 200 "Update successful"] - (), - updateConversationSelf :: - routes - :- Summary "Update self membership properties" - :> Description "**Note**: at least one field has to be provided." - :> CanThrow ConvNotFound - :> ZLocalUser - :> ZConn - :> "conversations" - :> QualifiedCapture' '[Description "Conversation ID"] "cnv" ConvId - :> "self" - :> ReqBody '[JSON] MemberUpdate - :> MultiVerb - 'PUT - '[JSON] - '[RespondEmpty 200 "Update successful"] - (), - -- Team Conversations + :<|> Named + "update-conversation-access-unqualified" + ( Summary "Update access modes for a conversation (deprecated)" + :> Description "Use PUT `/conversations/:domain/:cnv/access` instead." + :> ZLocalUser + :> ZConn + :> CanThrow ConvAccessDenied + :> CanThrow ConvNotFound + :> CanThrow (InvalidOp "Invalid operation") + :> "conversations" + :> Capture' '[Description "Conversation ID"] "cnv" ConvId + :> "access" + :> ReqBody '[JSON] ConversationAccessData + :> MultiVerb + 'PUT + '[JSON] + (UpdateResponses "Access unchanged" "Access updated" Event) + (UpdateResult Event) + ) + :<|> Named + "update-conversation-access" + ( Summary "Update access modes for a conversation" + :> ZLocalUser + :> ZConn + :> CanThrow ConvAccessDenied + :> CanThrow ConvNotFound + :> CanThrow (InvalidOp "Invalid operation") + :> "conversations" + :> QualifiedCapture' '[Description "Conversation ID"] "cnv" ConvId + :> "access" + :> ReqBody '[JSON] ConversationAccessData + :> MultiVerb + 'PUT + '[JSON] + (UpdateResponses "Access unchanged" "Access updated" Event) + (UpdateResult Event) + ) + :<|> Named + "get-conversation-self-unqualified" + ( Summary "Get self membership properties (deprecated)" + :> ZLocalUser + :> "conversations" + :> Capture' '[Description "Conversation ID"] "cnv" ConvId + :> "self" + :> Get '[JSON] (Maybe Member) + ) + :<|> Named + "update-conversation-self-unqualified" + ( Summary "Update self membership properties (deprecated)" + :> Description "Use `/conversations/:domain/:conv/self` instead." + :> CanThrow ConvNotFound + :> ZLocalUser + :> ZConn + :> "conversations" + :> Capture' '[Description "Conversation ID"] "cnv" ConvId + :> "self" + :> ReqBody '[JSON] MemberUpdate + :> MultiVerb + 'PUT + '[JSON] + '[RespondEmpty 200 "Update successful"] + () + ) + :<|> Named + "update-conversation-self" + ( Summary "Update self membership properties" + :> Description "**Note**: at least one field has to be provided." + :> CanThrow ConvNotFound + :> ZLocalUser + :> ZConn + :> "conversations" + :> QualifiedCapture' '[Description "Conversation ID"] "cnv" ConvId + :> "self" + :> ReqBody '[JSON] MemberUpdate + :> MultiVerb + 'PUT + '[JSON] + '[RespondEmpty 200 "Update successful"] + () + ) - getTeamConversationRoles :: - routes - :- Summary "Get existing roles available for the given team" +type TeamConversationAPI = + Named + "get-team-conversation-roles" + ( Summary "Get existing roles available for the given team" :> CanThrow NotATeamMember :> ZUser :> "teams" :> Capture "tid" TeamId :> "conversations" :> "roles" - :> Get '[Servant.JSON] ConversationRolesList, - getTeamConversations :: - routes - :- Summary "Get team conversations" - :> CanThrow OperationDenied - :> ZUser - :> "teams" - :> Capture "tid" TeamId - :> "conversations" - :> Get '[Servant.JSON] TeamConversationList, - getTeamConversation :: - routes - :- Summary "Get one team conversation" - :> CanThrow OperationDenied + :> Get '[Servant.JSON] ConversationRolesList + ) + :<|> Named + "get-team-conversations" + ( Summary "Get team conversations" + :> CanThrow OperationDenied + :> ZUser + :> "teams" + :> Capture "tid" TeamId + :> "conversations" + :> Get '[Servant.JSON] TeamConversationList + ) + :<|> Named + "get-team-conversation" + ( Summary "Get one team conversation" + :> CanThrow OperationDenied + :> ZUser + :> "teams" + :> Capture "tid" TeamId + :> "conversations" + :> Capture "cid" ConvId + :> Get '[Servant.JSON] TeamConversation + ) + :<|> Named + "delete-team-conversation" + ( Summary "Remove a team conversation" + :> CanThrow NotATeamMember + :> CanThrow ActionDenied + :> ZLocalUser + :> ZConn + :> "teams" + :> Capture "tid" TeamId + :> "conversations" + :> Capture "cid" ConvId + :> MultiVerb 'DELETE '[JSON] '[RespondEmpty 200 "Conversation deleted"] () + ) + +type TeamAPI = + Named + "create-non-binding-team" + ( Summary "Create a new non binding team" :> ZUser - :> "teams" - :> Capture "tid" TeamId - :> "conversations" - :> Capture "cid" ConvId - :> Get '[Servant.JSON] TeamConversation, - deleteTeamConversation :: - routes - :- Summary "Remove a team conversation" - :> CanThrow NotATeamMember - :> CanThrow ActionDenied - :> ZLocalUser :> ZConn + :> CanThrow NotConnected :> "teams" - :> Capture "tid" TeamId - :> "conversations" - :> Capture "cid" ConvId - :> MultiVerb 'DELETE '[JSON] '[RespondEmpty 200 "Conversation deleted"] (), - postOtrMessageUnqualified :: - routes - :- Summary "Post an encrypted message to a conversation (accepts JSON or Protobuf)" + :> ReqBody '[Servant.JSON] NonBindingNewTeam + :> MultiVerb + 'POST + '[JSON] + '[ WithHeaders + '[DescHeader "Location" "Team ID" TeamId] + TeamId + (RespondEmpty 201 "Team ID as `Location` header value") + ] + TeamId + ) + :<|> Named + "update-team" + ( Summary "Update team properties" + :> ZUser + :> ZConn + :> CanThrow NotATeamMember + :> CanThrow (OperationDeniedError 'SetTeamData) + :> "teams" + :> Capture "tid" TeamId + :> ReqBody '[JSON] TeamUpdateData + :> MultiVerb + 'PUT + '[JSON] + '[RespondEmpty 200 "Team updated"] + () + ) + :<|> Named + "get-teams" + ( Summary "Get teams (deprecated); use `GET /teams/:tid`" + :> ZUser + :> "teams" + :> Get '[JSON] TeamList + ) + +type MessagingAPI = + Named + "post-otr-message-unqualified" + ( Summary "Post an encrypted message to a conversation (accepts JSON or Protobuf)" :> Description PostOtrDescriptionUnqualified :> ZLocalUser :> ZConn @@ -588,180 +677,133 @@ data Api routes = Api 'POST '[Servant.JSON] (PostOtrResponses ClientMismatch) - (Either (MessageNotSent ClientMismatch) ClientMismatch), - postProteusMessage :: - routes - :- Summary "Post an encrypted message to a conversation (accepts only Protobuf)" - :> Description PostOtrDescription - :> ZLocalUser - :> ZConn - :> "conversations" - :> QualifiedCapture "cnv" ConvId - :> "proteus" - :> "messages" - :> ReqBody '[Proto] (RawProto QualifiedNewOtrMessage) - :> MultiVerb - 'POST - '[Servant.JSON] - (PostOtrResponses MessageSendingStatus) - (Either (MessageNotSent MessageSendingStatus) MessageSendingStatus), - -- team features - teamFeatureStatusSSOGet :: - routes - :- FeatureStatusGet 'TeamFeatureSSO, - teamFeatureStatusLegalHoldGet :: - routes - :- FeatureStatusGet 'TeamFeatureLegalHold, - teamFeatureStatusLegalHoldPut :: - routes - :- FeatureStatusPut 'TeamFeatureLegalHold, - teamFeatureStatusSearchVisibilityGet :: - routes - :- FeatureStatusGet 'TeamFeatureSearchVisibility, - teamFeatureStatusSearchVisibilityPut :: - routes - :- FeatureStatusPut 'TeamFeatureSearchVisibility, - teamFeatureStatusSearchVisibilityDeprecatedGet :: - routes - :- FeatureStatusDeprecatedGet 'WithoutLockStatus 'TeamFeatureSearchVisibility, - teamFeatureStatusSearchVisibilityDeprecatedPut :: - routes - :- FeatureStatusDeprecatedPut 'TeamFeatureSearchVisibility, - teamFeatureStatusValidateSAMLEmailsGet :: - routes - :- FeatureStatusGet 'TeamFeatureValidateSAMLEmails, - teamFeatureStatusValidateSAMLEmailsDeprecatedGet :: - routes - :- FeatureStatusDeprecatedGet 'WithoutLockStatus 'TeamFeatureValidateSAMLEmails, - teamFeatureStatusDigitalSignaturesGet :: - routes - :- FeatureStatusGet 'TeamFeatureDigitalSignatures, - teamFeatureStatusDigitalSignaturesDeprecatedGet :: - routes - :- FeatureStatusDeprecatedGet 'WithoutLockStatus 'TeamFeatureDigitalSignatures, - teamFeatureStatusAppLockGet :: - routes - :- FeatureStatusGet 'TeamFeatureAppLock, - teamFeatureStatusAppLockPut :: - routes - :- FeatureStatusPut 'TeamFeatureAppLock, - teamFeatureStatusFileSharingGet :: - routes - :- FeatureStatusGet 'TeamFeatureFileSharing, - teamFeatureStatusFileSharingPut :: - routes - :- FeatureStatusPut 'TeamFeatureFileSharing, - teamFeatureStatusClassifiedDomainsGet :: - routes - :- FeatureStatusGet 'TeamFeatureClassifiedDomains, - teamFeatureStatusConferenceCallingGet :: - routes - :- FeatureStatusGet 'TeamFeatureConferenceCalling, - teamFeatureStatusSelfDeletingMessagesGet :: - routes - :- FeatureStatusGet 'TeamFeatureSelfDeletingMessages, - teamFeatureStatusSelfDeletingMessagesPut :: - routes - :- FeatureStatusPut 'TeamFeatureSelfDeletingMessages, - featureStatusGuestLinksGet :: - routes - :- FeatureStatusGet 'TeamFeatureGuestLinks, - featureStatusGuestLinksPut :: - routes - :- FeatureStatusPut 'TeamFeatureGuestLinks, - featureAllFeatureConfigsGet :: - routes - :- AllFeatureConfigsGet, - featureConfigLegalHoldGet :: - routes - :- FeatureConfigGet 'WithoutLockStatus 'TeamFeatureLegalHold, - featureConfigSSOGet :: - routes - :- FeatureConfigGet 'WithoutLockStatus 'TeamFeatureSSO, - featureConfigSearchVisibilityGet :: - routes - :- FeatureConfigGet 'WithoutLockStatus 'TeamFeatureSearchVisibility, - featureConfigValidateSAMLEmailsGet :: - routes - :- FeatureConfigGet 'WithoutLockStatus 'TeamFeatureValidateSAMLEmails, - featureConfigDigitalSignaturesGet :: - routes - :- FeatureConfigGet 'WithoutLockStatus 'TeamFeatureDigitalSignatures, - featureConfigAppLockGet :: - routes - :- FeatureConfigGet 'WithoutLockStatus 'TeamFeatureAppLock, - featureConfigFileSharingGet :: - routes - :- FeatureConfigGet 'WithoutLockStatus 'TeamFeatureFileSharing, - featureConfigClassifiedDomainsGet :: - routes - :- FeatureConfigGet 'WithoutLockStatus 'TeamFeatureClassifiedDomains, - featureConfigConferenceCallingGet :: - routes - :- FeatureConfigGet 'WithLockStatus 'TeamFeatureConferenceCalling, - featureConfigSelfDeletingMessagesGet :: - routes - :- FeatureConfigGet 'WithLockStatus 'TeamFeatureSelfDeletingMessages, - featureConfigGuestLinksGet :: - routes - :- FeatureConfigGet 'WithLockStatus 'TeamFeatureGuestLinks - } - deriving (Generic) + (Either (MessageNotSent ClientMismatch) ClientMismatch) + ) + :<|> Named + "post-proteus-message" + ( Summary "Post an encrypted message to a conversation (accepts only Protobuf)" + :> Description PostOtrDescription + :> ZLocalUser + :> ZConn + :> "conversations" + :> QualifiedCapture "cnv" ConvId + :> "proteus" + :> "messages" + :> ReqBody '[Proto] (RawProto QualifiedNewOtrMessage) + :> MultiVerb + 'POST + '[Servant.JSON] + (PostOtrResponses MessageSendingStatus) + (Either (MessageNotSent MessageSendingStatus) MessageSendingStatus) + ) -type ServantAPI = ToServantApi Api +type FeatureAPI = + FeatureStatusGet 'TeamFeatureSSO + :<|> FeatureStatusGet 'TeamFeatureLegalHold + :<|> FeatureStatusPut 'TeamFeatureLegalHold + :<|> FeatureStatusGet 'TeamFeatureSearchVisibility + :<|> FeatureStatusPut 'TeamFeatureSearchVisibility + :<|> FeatureStatusDeprecatedGet 'WithoutLockStatus 'TeamFeatureSearchVisibility + :<|> FeatureStatusDeprecatedPut 'TeamFeatureSearchVisibility + :<|> FeatureStatusGet 'TeamFeatureValidateSAMLEmails + :<|> FeatureStatusDeprecatedGet 'WithoutLockStatus 'TeamFeatureValidateSAMLEmails + :<|> FeatureStatusGet 'TeamFeatureDigitalSignatures + :<|> FeatureStatusDeprecatedGet 'WithoutLockStatus 'TeamFeatureDigitalSignatures + :<|> FeatureStatusGet 'TeamFeatureAppLock + :<|> FeatureStatusPut 'TeamFeatureAppLock + :<|> FeatureStatusGet 'TeamFeatureFileSharing + :<|> FeatureStatusPut 'TeamFeatureFileSharing + :<|> FeatureStatusGet 'TeamFeatureClassifiedDomains + :<|> FeatureStatusGet 'TeamFeatureConferenceCalling + :<|> FeatureStatusGet 'TeamFeatureSelfDeletingMessages + :<|> FeatureStatusPut 'TeamFeatureSelfDeletingMessages + :<|> FeatureStatusGet 'TeamFeatureGuestLinks + :<|> FeatureStatusPut 'TeamFeatureGuestLinks + :<|> AllFeatureConfigsGet + :<|> FeatureConfigGet 'WithoutLockStatus 'TeamFeatureLegalHold + :<|> FeatureConfigGet 'WithoutLockStatus 'TeamFeatureSSO + :<|> FeatureConfigGet 'WithoutLockStatus 'TeamFeatureSearchVisibility + :<|> FeatureConfigGet 'WithoutLockStatus 'TeamFeatureValidateSAMLEmails + :<|> FeatureConfigGet 'WithoutLockStatus 'TeamFeatureDigitalSignatures + :<|> FeatureConfigGet 'WithoutLockStatus 'TeamFeatureAppLock + :<|> FeatureConfigGet 'WithoutLockStatus 'TeamFeatureFileSharing + :<|> FeatureConfigGet 'WithoutLockStatus 'TeamFeatureClassifiedDomains + :<|> FeatureConfigGet 'WithLockStatus 'TeamFeatureConferenceCalling + :<|> FeatureConfigGet 'WithLockStatus 'TeamFeatureSelfDeletingMessages + :<|> FeatureConfigGet 'WithLockStatus 'TeamFeatureGuestLinks type FeatureStatusGet featureName = - Summary (AppendSymbol "Get config for " (KnownTeamFeatureNameSymbol featureName)) - :> ZUser - :> "teams" - :> Capture "tid" TeamId - :> "features" - :> KnownTeamFeatureNameSymbol featureName - :> Get '[Servant.JSON] (TeamFeatureStatus 'WithLockStatus featureName) + Named + '("get", featureName) + ( Summary (AppendSymbol "Get config for " (KnownTeamFeatureNameSymbol featureName)) + :> ZUser + :> "teams" + :> Capture "tid" TeamId + :> "features" + :> KnownTeamFeatureNameSymbol featureName + :> Get '[Servant.JSON] (TeamFeatureStatus 'WithLockStatus featureName) + ) type FeatureStatusPut featureName = - Summary (AppendSymbol "Put config for " (KnownTeamFeatureNameSymbol featureName)) - :> ZUser - :> "teams" - :> Capture "tid" TeamId - :> "features" - :> KnownTeamFeatureNameSymbol featureName - :> ReqBody '[Servant.JSON] (TeamFeatureStatus 'WithoutLockStatus featureName) - :> Put '[Servant.JSON] (TeamFeatureStatus 'WithoutLockStatus featureName) + Named + '("put", featureName) + ( Summary (AppendSymbol "Put config for " (KnownTeamFeatureNameSymbol featureName)) + :> ZUser + :> "teams" + :> Capture "tid" TeamId + :> "features" + :> KnownTeamFeatureNameSymbol 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 ps featureName = - Summary (AppendSymbol "[deprecated] Get config for " (KnownTeamFeatureNameSymbol featureName)) - :> ZUser - :> "teams" - :> Capture "tid" TeamId - :> "features" - :> DeprecatedFeatureName featureName - :> Get '[Servant.JSON] (TeamFeatureStatus ps featureName) + Named + '("get-deprecated", featureName) + ( Summary + (AppendSymbol "[deprecated] Get config for " (KnownTeamFeatureNameSymbol featureName)) + :> ZUser + :> "teams" + :> Capture "tid" TeamId + :> "features" + :> DeprecatedFeatureName featureName + :> Get '[Servant.JSON] (TeamFeatureStatus ps featureName) + ) -- | A type for a PUT endpoint for a feature with a deprecated path type FeatureStatusDeprecatedPut featureName = - Summary (AppendSymbol "[deprecated] Get config for " (KnownTeamFeatureNameSymbol featureName)) - :> ZUser - :> "teams" - :> Capture "tid" TeamId - :> "features" - :> DeprecatedFeatureName featureName - :> ReqBody '[Servant.JSON] (TeamFeatureStatus 'WithoutLockStatus featureName) - :> Put '[Servant.JSON] (TeamFeatureStatus 'WithoutLockStatus featureName) + Named + '("put-deprecated", featureName) + ( Summary + (AppendSymbol "[deprecated] Get config for " (KnownTeamFeatureNameSymbol featureName)) + :> ZUser + :> "teams" + :> Capture "tid" TeamId + :> "features" + :> DeprecatedFeatureName featureName + :> ReqBody '[Servant.JSON] (TeamFeatureStatus 'WithoutLockStatus featureName) + :> Put '[Servant.JSON] (TeamFeatureStatus 'WithoutLockStatus featureName) + ) type FeatureConfigGet ps featureName = - Summary (AppendSymbol "Get feature config for feature " (KnownTeamFeatureNameSymbol featureName)) - :> ZUser - :> "feature-configs" - :> KnownTeamFeatureNameSymbol featureName - :> Get '[Servant.JSON] (TeamFeatureStatus ps featureName) + Named + '("get-config", featureName) + ( Summary (AppendSymbol "Get feature config for feature " (KnownTeamFeatureNameSymbol featureName)) + :> ZUser + :> "feature-configs" + :> KnownTeamFeatureNameSymbol featureName + :> Get '[Servant.JSON] (TeamFeatureStatus ps featureName) + ) type AllFeatureConfigsGet = - Summary "Get configurations of all features" - :> ZUser - :> "feature-configs" - :> Get '[Servant.JSON] AllFeatureConfigs + Named + "get-all-feature-configs" + ( Summary "Get configurations of all features" + :> ZUser + :> "feature-configs" + :> Get '[Servant.JSON] AllFeatureConfigs + ) type PostOtrDescriptionUnqualified = "This endpoint ensures that the list of clients is correct and only sends the message if the list is correct.\n\ diff --git a/libs/wire-api/src/Wire/API/Routes/WebSocket.hs b/libs/wire-api/src/Wire/API/Routes/WebSocket.hs new file mode 100644 index 00000000000..6a2e5c340ed --- /dev/null +++ b/libs/wire-api/src/Wire/API/Routes/WebSocket.hs @@ -0,0 +1,89 @@ +-- 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.Routes.WebSocket where + +import Control.Lens +import Control.Monad.Trans.Resource +import Data.HashMap.Strict.InsOrd +import Data.Metrics.Servant +import Data.Proxy +import Data.Swagger +import Imports +import Network.Wai.Handler.WebSockets +import Network.WebSockets +import Servant.Server hiding (respond) +import Servant.Server.Internal.Delayed +import Servant.Server.Internal.RouteResult +import Servant.Server.Internal.Router +import Servant.Swagger + +-- | A websocket that relates to a 'PendingConnection' +-- Copied and adapted from: +data WebSocketPending + +instance HasServer WebSocketPending ctx where + type ServerT WebSocketPending m = PendingConnection -> m () + + hoistServerWithContext _ _ nat svr = nat . svr + + route Proxy _ app = leafRouter $ \env request respond -> + runResourceT $ + runDelayed app env request >>= liftIO . go request respond + where + go request respond (Route app') = + websocketsOr defaultConnectionOptions (runApp app') (backupApp respond) request (respond . Route) + go _ respond (Fail e) = respond $ Fail e + go _ respond (FailFatal e) = respond $ FailFatal e + + runApp a c = void (runHandler $ a c) + + backupApp respond _ _ = + respond $ + FailFatal + ServerError + { errHTTPCode = 426, + errReasonPhrase = "Upgrade Required", + errBody = mempty, + errHeaders = mempty + } + +instance HasSwagger WebSocketPending where + toSwagger _ = + mempty + & paths + . at "/" + ?~ ( mempty + & get + ?~ ( mempty + & responses . responses .~ resps + & externalDocs + ?~ ( mempty + & description ?~ "RFC 6455" + & url .~ URL "https://datatracker.ietf.org/doc/html/rfc6455" + ) + ) + ) + where + resps :: InsOrdHashMap HttpStatusCode (Referenced Data.Swagger.Response) + resps = + mempty + & at 101 ?~ Inline (mempty & description .~ "Connection upgraded.") + & at 426 ?~ Inline (mempty & description .~ "Upgrade required.") + +instance RoutesToPaths WebSocketPending where + getRoutes = [] diff --git a/libs/wire-api/src/Wire/API/Team.hs b/libs/wire-api/src/Wire/API/Team.hs index b1307bea120..fda2311e6e1 100644 --- a/libs/wire-api/src/Wire/API/Team.hs +++ b/libs/wire-api/src/Wire/API/Team.hs @@ -46,7 +46,6 @@ module Wire.API.Team newTeamIcon, newTeamIconKey, newTeamMembers, - newTeamJson, -- * TeamUpdateData TeamUpdateData (..), @@ -71,12 +70,13 @@ module Wire.API.Team where import Control.Lens (makeLenses) -import Data.Aeson -import Data.Aeson.Types (Pair) +import Data.Aeson (FromJSON, ToJSON, Value (..)) +import Data.Aeson.Types (Parser) import Data.Id (TeamId, UserId) -import Data.Json.Util import Data.Misc (PlainTextPassword (..)) import Data.Range +import Data.Schema +import qualified Data.Swagger as S import qualified Data.Swagger.Build.Api as Doc import Imports import Test.QuickCheck.Gen (suchThat) @@ -96,9 +96,10 @@ data Team = Team } deriving stock (Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform Team) + deriving (ToJSON, FromJSON, S.ToSchema) via (Schema Team) newTeam :: TeamId -> UserId -> Text -> Text -> TeamBinding -> Team -newTeam tid uid nme ico bnd = Team tid uid nme ico Nothing bnd +newTeam tid uid nme ico = Team tid uid nme ico Nothing modelTeam :: Doc.Model modelTeam = Doc.defineModel "Team" $ do @@ -117,41 +118,28 @@ modelTeam = Doc.defineModel "Team" $ do Doc.property "binding" Doc.bool' $ Doc.description "user binding team" -instance ToJSON Team where - toJSON t = - object $ - "id" .= _teamId t - # "creator" .= _teamCreator t - # "name" .= _teamName t - # "icon" .= _teamIcon t - # "icon_key" .= _teamIconKey t - # "binding" .= _teamBinding t - # [] - -instance FromJSON Team where - parseJSON = withObject "team" $ \o -> do - Team - <$> o .: "id" - <*> o .: "creator" - <*> o .: "name" - <*> o .: "icon" - <*> o .:? "icon_key" - <*> o .:? "binding" .!= NonBinding +instance ToSchema Team where + schema = + object "Team" $ + Team + <$> _teamId .= field "id" schema + <*> _teamCreator .= field "creator" schema + <*> _teamName .= field "name" schema + <*> _teamIcon .= field "icon" schema + <*> _teamIconKey .= maybe_ (optField "icon_key" schema) + <*> _teamBinding .= (fromMaybe Binding <$> optField "binding" schema) data TeamBinding = Binding | NonBinding deriving stock (Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform TeamBinding) + deriving (ToJSON, FromJSON, S.ToSchema) via (Schema TeamBinding) -instance ToJSON TeamBinding where - toJSON Binding = Bool True - toJSON NonBinding = Bool False - -instance FromJSON TeamBinding where - parseJSON (Bool True) = pure Binding - parseJSON (Bool False) = pure NonBinding - parseJSON other = fail $ "Unknown binding type: " <> show other +instance ToSchema TeamBinding where + schema = + enum @Bool "TeamBinding" $ + mconcat [element True Binding, element False NonBinding] -------------------------------------------------------------------------------- -- TeamList @@ -162,6 +150,7 @@ data TeamList = TeamList } deriving stock (Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform TeamList) + deriving (ToJSON, FromJSON, S.ToSchema) via (Schema TeamList) newTeamList :: [Team] -> Bool -> TeamList newTeamList = TeamList @@ -174,24 +163,18 @@ modelTeamList = Doc.defineModel "TeamList" $ do Doc.property "has_more" Doc.bool' $ Doc.description "if more teams are available" -instance ToJSON TeamList where - toJSON t = - object $ - "teams" .= _teamListTeams t - # "has_more" .= _teamListHasMore t - # [] - -instance FromJSON TeamList where - parseJSON = withObject "teamlist" $ \o -> do - TeamList - <$> o .: "teams" - <*> o .: "has_more" +instance ToSchema TeamList where + schema = + object "TeamList" $ + TeamList <$> _teamListTeams .= field "teams" (array schema) + <*> _teamListHasMore .= field "has_more" schema -------------------------------------------------------------------------------- -- NewTeam newtype BindingNewTeam = BindingNewTeam (NewTeam ()) deriving stock (Eq, Show, Generic) + deriving (ToJSON, FromJSON, S.ToSchema) via (Schema BindingNewTeam) modelNewBindingTeam :: Doc.Model modelNewBindingTeam = Doc.defineModel "NewBindingTeam" $ do @@ -204,17 +187,13 @@ modelNewBindingTeam = Doc.defineModel "NewBindingTeam" $ do Doc.description "team icon asset key" Doc.optional -instance ToJSON BindingNewTeam where - toJSON (BindingNewTeam t) = object $ newTeamJson t - -newTeamJson :: NewTeam a -> [Pair] -newTeamJson (NewTeam n i ik _) = - "name" .= fromRange n - # "icon" .= fromRange i - # "icon_key" .= (fromRange <$> ik) - # [] +instance ToSchema BindingNewTeam where + schema = BindingNewTeam <$> unwrap .= newTeamSchema "BindingNewTeam" sch + where + unwrap (BindingNewTeam nt) = nt -deriving newtype instance FromJSON BindingNewTeam + sch :: ValueSchema SwaggerDoc () + sch = null_ -- FUTUREWORK: since new team members do not get serialized, we zero them here. -- it may be worth looking into how this can be solved in the types. @@ -227,6 +206,15 @@ instance Arbitrary BindingNewTeam where -- | FUTUREWORK: this is dead code! remove! newtype NonBindingNewTeam = NonBindingNewTeam (NewTeam (Range 1 127 [TeamMember])) deriving stock (Eq, Show, Generic) + deriving (FromJSON, ToJSON, S.ToSchema) via (Schema NonBindingNewTeam) + +instance ToSchema NonBindingNewTeam where + schema = NonBindingNewTeam <$> unwrap .= newTeamSchema "NonBindingNewTeam" sch + where + unwrap (NonBindingNewTeam nt) = nt + + sch :: ValueSchema SwaggerDoc (Range 1 127 [TeamMember]) + sch = fromRange .= rangedSchema (array schema) modelNewNonBindingTeam :: Doc.Model modelNewNonBindingTeam = Doc.defineModel "newNonBindingTeam" $ do @@ -242,14 +230,6 @@ modelNewNonBindingTeam = Doc.defineModel "newNonBindingTeam" $ do Doc.description "initial team member ids (between 1 and 127)" Doc.optional -instance ToJSON NonBindingNewTeam where - toJSON (NonBindingNewTeam t) = - object $ - "members" .= (fromRange <$> _newTeamMembers t) - # newTeamJson t - -deriving newtype instance FromJSON NonBindingNewTeam - data NewTeam a = NewTeam { _newTeamName :: Range 1 256 Text, _newTeamIcon :: Range 1 256 Text, @@ -262,17 +242,14 @@ data NewTeam a = NewTeam newNewTeam :: Range 1 256 Text -> Range 1 256 Text -> NewTeam a newNewTeam nme ico = NewTeam nme ico Nothing Nothing -instance (FromJSON a) => FromJSON (NewTeam a) where - parseJSON = withObject "new-team" $ \o -> do - name <- o .: "name" - icon <- o .: "icon" - key <- o .:? "icon_key" - mems <- o .:? "members" - either fail pure $ - NewTeam <$> checkedEitherMsg "name" name - <*> checkedEitherMsg "icon" icon - <*> maybe (pure Nothing) (fmap Just . checkedEitherMsg "icon_key") key - <*> pure mems +newTeamSchema :: HasSchemaRef d => Text -> ValueSchema d a -> ValueSchema NamedSwaggerDoc (NewTeam a) +newTeamSchema name sch = + object name $ + NewTeam + <$> _newTeamName .= field "name" schema + <*> _newTeamIcon .= field "icon" schema + <*> _newTeamIconKey .= maybe_ (optField "icon_key" schema) + <*> _newTeamMembers .= maybe_ (optField "members" sch) -------------------------------------------------------------------------------- -- TeamUpdateData @@ -283,6 +260,7 @@ data TeamUpdateData = TeamUpdateData _iconKeyUpdate :: Maybe (Range 1 256 Text) } deriving stock (Eq, Show, Generic) + deriving (ToJSON, FromJSON, S.ToSchema) via (Schema TeamUpdateData) instance Arbitrary TeamUpdateData where arbitrary = arb `suchThat` valid @@ -307,25 +285,21 @@ modelUpdateData = Doc.defineModel "TeamUpdateData" $ do newTeamUpdateData :: TeamUpdateData newTeamUpdateData = TeamUpdateData Nothing Nothing Nothing -instance ToJSON TeamUpdateData where - toJSON u = - object $ - "name" .= _nameUpdate u - # "icon" .= _iconUpdate u - # "icon_key" .= _iconKeyUpdate u - # [] - -instance FromJSON TeamUpdateData where - parseJSON = withObject "team update data" $ \o -> do - name <- o .:? "name" - icon <- o .:? "icon" - icon_key <- o .:? "icon_key" - when (isNothing name && isNothing icon && isNothing icon_key) $ - fail "TeamUpdateData: no update data specified" - either fail pure $ - TeamUpdateData <$> maybe (pure Nothing) (fmap Just . checkedEitherMsg "name") name - <*> maybe (pure Nothing) (fmap Just . checkedEitherMsg "icon") icon - <*> maybe (pure Nothing) (fmap Just . checkedEitherMsg "icon_key") icon_key +validateTeamUpdateData :: TeamUpdateData -> Parser TeamUpdateData +validateTeamUpdateData u = + when + (isNothing (_nameUpdate u) && isNothing (_iconUpdate u) && isNothing (_iconKeyUpdate u)) + (fail "TeamUpdateData: no update data specified") + $> u + +instance ToSchema TeamUpdateData where + schema = + (`withParser` validateTeamUpdateData) + . object "TeamUpdateData" + $ TeamUpdateData + <$> _nameUpdate .= maybe_ (optField "name" schema) + <*> _iconUpdate .= maybe_ (optField "icon" schema) + <*> _iconKeyUpdate .= maybe_ (optField "icon_key" schema) -------------------------------------------------------------------------------- -- TeamDeleteData @@ -335,6 +309,7 @@ newtype TeamDeleteData = TeamDeleteData } deriving stock (Eq, Show) deriving newtype (Arbitrary) + deriving (ToJSON, FromJSON, S.ToSchema) via (Schema TeamDeleteData) newTeamDeleteData :: Maybe PlainTextPassword -> TeamDeleteData newTeamDeleteData = TeamDeleteData @@ -346,15 +321,10 @@ modelTeamDelete = Doc.defineModel "teamDeleteData" $ do Doc.property "password" Doc.string' $ Doc.description "The account password to authorise the deletion." -instance FromJSON TeamDeleteData where - parseJSON = withObject "team-delete-data" $ \o -> - TeamDeleteData <$> o .: "password" - -instance ToJSON TeamDeleteData where - toJSON tdd = - object - [ "password" .= _tdAuthPassword tdd - ] +instance ToSchema TeamDeleteData where + schema = + object "TeamDeleteData" $ + TeamDeleteData <$> _tdAuthPassword .= optField "password" (maybeWithDefault Null schema) makeLenses ''Team makeLenses ''TeamList diff --git a/libs/wire-api/src/Wire/API/Team/Member.hs b/libs/wire-api/src/Wire/API/Team/Member.hs index 905bd2f9718..600978c6b12 100644 --- a/libs/wire-api/src/Wire/API/Team/Member.hs +++ b/libs/wire-api/src/Wire/API/Team/Member.hs @@ -21,12 +21,17 @@ module Wire.API.Team.Member ( -- * TeamMember - TeamMember (..), + TeamMember, + mkTeamMember, userId, permissions, invitation, legalHoldStatus, + ntmNewTeamMember, + + -- * TODO: remove after servantification teamMemberJson, + teamMemberListJson, -- * TeamMemberList TeamMemberList, @@ -38,12 +43,13 @@ module Wire.API.Team.Member NewListType (..), toNewListType, ListType (..), - teamMemberListJson, -- * NewTeamMember NewTeamMember, - newNewTeamMember, - ntmNewTeamMember, + mkNewTeamMember, + nUserId, + nPermissions, + nInvitation, -- * TeamMemberDeleteData TeamMemberDeleteData, @@ -58,35 +64,95 @@ module Wire.API.Team.Member ) where -import Control.Lens (makeLenses) -import Data.Aeson -import Data.Aeson.Types (Parser) -import qualified Data.HashMap.Strict as HM +import Control.Lens (Lens, Lens', makeLenses, (%~)) +import Data.Aeson (FromJSON (..), ToJSON (..), Value (..)) import Data.Id (UserId) import Data.Json.Util import Data.LegalHold (UserLegalHoldStatus (..), defUserLegalHoldStatus, typeUserLegalHoldStatus) import Data.Misc (PlainTextPassword (..)) import Data.Proxy -import Data.String.Conversions (cs) +import Data.Schema import qualified Data.Swagger.Build.Api as Doc -import Data.Swagger.Schema (ToSchema) -import Deriving.Swagger (CamelToSnake, ConstructorTagModifier, CustomSwagger, StripPrefix) +import qualified Data.Swagger.Schema as S import GHC.TypeLits import Imports -import Wire.API.Arbitrary (Arbitrary, GenericUniform (..), arbitrary, shrink) +import Wire.API.Arbitrary (Arbitrary, GenericUniform (..)) import Wire.API.Team.Permission (Permissions, modelPermissions) +data PermissionTag = Required | Optional + +type family PermissionType (tag :: PermissionTag) = (t :: *) | t -> tag where + PermissionType 'Required = Permissions + PermissionType 'Optional = Maybe Permissions + -------------------------------------------------------------------------------- -- TeamMember -data TeamMember = TeamMember - { _userId :: UserId, - _permissions :: Permissions, - _invitation :: Maybe (UserId, UTCTimeMillis), +type TeamMember = TeamMember' 'Required + +data TeamMember' (tag :: PermissionTag) = TeamMember + { _newTeamMember :: NewTeamMember' tag, _legalHoldStatus :: UserLegalHoldStatus } - deriving stock (Eq, Ord, Show, Generic) - deriving (Arbitrary) via (GenericUniform TeamMember) + deriving stock (Generic) + +ntmNewTeamMember :: NewTeamMember' tag -> TeamMember' tag +ntmNewTeamMember ntm = TeamMember ntm defUserLegalHoldStatus + +deriving instance Eq (PermissionType tag) => Eq (TeamMember' tag) + +deriving instance Ord (PermissionType tag) => Ord (TeamMember' tag) + +deriving instance Show (PermissionType tag) => Show (TeamMember' tag) + +deriving via (GenericUniform TeamMember) instance Arbitrary TeamMember + +deriving via (GenericUniform (TeamMember' 'Optional)) instance Arbitrary (TeamMember' 'Optional) + +deriving via + (Schema (TeamMember' tag)) + instance + (ToSchema (TeamMember' tag)) => + ToJSON (TeamMember' tag) + +deriving via + (Schema (TeamMember' tag)) + instance + (ToSchema (TeamMember' tag)) => + FromJSON (TeamMember' tag) + +deriving via + (Schema (TeamMember' tag)) + instance + (ToSchema (TeamMember' tag)) => + S.ToSchema (TeamMember' tag) + +mkTeamMember :: + UserId -> + PermissionType tag -> + Maybe (UserId, UTCTimeMillis) -> + UserLegalHoldStatus -> + TeamMember' tag +mkTeamMember uid perms inv = TeamMember (NewTeamMember uid perms inv) + +instance ToSchema TeamMember where + schema = + object "TeamMember" $ + TeamMember + <$> _newTeamMember .= newTeamMemberSchema + <*> _legalHoldStatus .= (fromMaybe defUserLegalHoldStatus <$> optField "legalhold_status" schema) + +instance ToSchema (TeamMember' 'Optional) where + schema = + object "TeamMember" $ + TeamMember + <$> _newTeamMember + .= ( NewTeamMember + <$> _nUserId .= field "user" schema + <*> _nPermissions .= maybe_ (optField "permissions" schema) + <*> _nInvitation .= invitedSchema' + ) + <*> _legalHoldStatus .= (fromMaybe defUserLegalHoldStatus <$> optField "legalhold_status" schema) modelTeamMember :: Doc.Model modelTeamMember = Doc.defineModel "TeamMember" $ do @@ -111,54 +177,46 @@ modelTeamMember = Doc.defineModel "TeamMember" $ do Doc.description "The state of Legal Hold compliance for the member" Doc.optional -instance ToJSON TeamMember where - toJSON = teamMemberJson (const True) - -instance FromJSON TeamMember where - parseJSON = parseTeamMember - --- | Show 'Permissions' conditionally. The condition takes the member that will receive the result --- into account. See 'canSeePermsOf'. --- --- FUTUREWORK: --- There must be a cleaner way to do this, with a separate type --- instead of logic in the JSON instance. -teamMemberJson :: (TeamMember -> Bool) -> TeamMember -> Value -teamMemberJson withPerms m = - object $ - ["user" .= _userId m] - <> ["permissions" .= _permissions m | withPerms m] - <> ["created_by" .= (fst <$> _invitation m)] - <> ["created_at" .= (snd <$> _invitation m)] - <> ["legalhold_status" .= _legalHoldStatus m] - -parseTeamMember :: Value -> Parser TeamMember -parseTeamMember = withObject "team-member" $ \o -> - TeamMember - <$> o .: "user" - <*> o .: "permissions" - <*> parseInvited o - -- Default to disabled if missing - <*> o .:? "legalhold_status" .!= defUserLegalHoldStatus - where - parseInvited :: Object -> Parser (Maybe (UserId, UTCTimeMillis)) - parseInvited o = do - invby <- o .:? "created_by" - invat <- o .:? "created_at" - case (invby, invat) of - (Just b, Just a) -> pure $ Just (b, a) - (Nothing, Nothing) -> pure $ Nothing - _ -> fail "created_by, created_at" +setPerm :: Bool -> Permissions -> Maybe Permissions +setPerm True = Just +setPerm False = const Nothing -------------------------------------------------------------------------------- -- TeamMemberList -data TeamMemberList = TeamMemberList - { _teamMembers :: [TeamMember], +type TeamMemberList = TeamMemberList' 'Required + +data TeamMemberList' (tag :: PermissionTag) = TeamMemberList + { _teamMembers :: [TeamMember' tag], _teamMemberListType :: ListType } - deriving stock (Eq, Show, Generic) - deriving (Arbitrary) via (GenericUniform TeamMemberList) + deriving stock (Generic) + +deriving instance Eq (PermissionType tag) => Eq (TeamMemberList' tag) + +deriving instance Show (PermissionType tag) => Show (TeamMemberList' tag) + +deriving via (GenericUniform (TeamMemberList' 'Optional)) instance Arbitrary (TeamMemberList' 'Optional) + +deriving via (GenericUniform TeamMemberList) instance Arbitrary TeamMemberList + +deriving via + (Schema (TeamMemberList' tag)) + instance + ToSchema (TeamMemberList' tag) => + FromJSON (TeamMemberList' tag) + +deriving via + (Schema (TeamMemberList' tag)) + instance + ToSchema (TeamMemberList' tag) => + ToJSON (TeamMemberList' tag) + +deriving via + (Schema (TeamMemberList' tag)) + instance + ToSchema (TeamMemberList' tag) => + S.ToSchema (TeamMemberList' tag) newTeamMemberList :: [TeamMember] -> ListType -> TeamMemberList newTeamMemberList = TeamMemberList @@ -171,20 +229,12 @@ modelTeamMemberList = Doc.defineModel "TeamMemberList" $ do Doc.property "hasMore" Doc.bool' $ Doc.description "true if 'members' doesn't contain all team members" -instance ToJSON TeamMemberList where - toJSON = teamMemberListJson (const True) - --- | Show a list of team members using 'teamMemberJson'. -teamMemberListJson :: (TeamMember -> Bool) -> TeamMemberList -> Value -teamMemberListJson withPerms l = - object - [ "members" .= map (teamMemberJson withPerms) (_teamMembers l), - "hasMore" .= _teamMemberListType l - ] - -instance FromJSON TeamMemberList where - parseJSON = withObject "team member list" $ \o -> - TeamMemberList <$> o .: "members" <*> o .: "hasMore" +instance ToSchema (TeamMember' tag) => ToSchema (TeamMemberList' tag) where + schema = + object "TeamMemberList" $ + TeamMemberList + <$> _teamMembers .= field "members" (array schema) + <*> _teamMemberListType .= field "hasMore" schema type HardTruncationLimit = (2000 :: Nat) @@ -197,18 +247,15 @@ data NewListType | NewListTruncated deriving stock (Eq, Ord, Show, Generic) deriving (Arbitrary) via (GenericUniform NewListType) - deriving (ToSchema) via (CustomSwagger '[ConstructorTagModifier (StripPrefix "New", CamelToSnake)] NewListType) - --- This replaces the previous `hasMore` but has no boolean blindness. At the API level --- though we do want this to remain true/false -instance ToJSON NewListType where - toJSON NewListComplete = String "list_complete" - toJSON NewListTruncated = String "list_truncated" + deriving (FromJSON, ToJSON, S.ToSchema) via (Schema NewListType) -instance FromJSON NewListType where - parseJSON (String "list_complete") = pure NewListComplete - parseJSON (String "list_truncated") = pure NewListTruncated - parseJSON bad = fail $ "NewListType: " <> cs (encode bad) +instance ToSchema NewListType where + schema = + enum @Text "NewListType" $ + mconcat + [ element "list_complete" NewListComplete, + element "list_truncated" NewListTruncated + ] toNewListType :: ListType -> NewListType toNewListType ListComplete = NewListComplete @@ -219,37 +266,83 @@ data ListType | ListTruncated deriving stock (Eq, Ord, Show, Generic) deriving (Arbitrary) via (GenericUniform ListType) + deriving (FromJSON, ToJSON, S.ToSchema) via (Schema ListType) -- This replaces the previous `hasMore` but has no boolean blindness. At the API level -- though we do want this to remain true/false -instance ToJSON ListType where - toJSON ListComplete = Bool False - toJSON ListTruncated = Bool True - -instance FromJSON ListType where - parseJSON (Bool False) = pure ListComplete - parseJSON (Bool True) = pure ListTruncated - parseJSON bad = fail $ "ListType: " <> cs (encode bad) +instance ToSchema ListType where + schema = + enum @Bool "ListType" $ + mconcat [element True ListTruncated, element False ListComplete] -------------------------------------------------------------------------------- -- NewTeamMember +type NewTeamMember = NewTeamMember' 'Required + +mkNewTeamMember :: UserId -> PermissionType 'Required -> Maybe (UserId, UTCTimeMillis) -> NewTeamMember +mkNewTeamMember = NewTeamMember + -- | Like 'TeamMember', but we can receive this from the clients. Clients are not allowed to --- set 'UserLegalHoldStatus', so both 'newNewTeamMember and {To,From}JSON make sure that is --- always the default. I decided to keep the 'TeamMember' inside (rather than making an --- entirely new type because (1) it's a smaller change and I'm in a hurry; (2) it encodes the --- identity relationship between the fields that *do* occur in both more explicit. -newtype NewTeamMember = NewTeamMember - { _ntmNewTeamMember :: TeamMember +-- set 'UserLegalHoldStatus'. +data NewTeamMember' (tag :: PermissionTag) = NewTeamMember + { _nUserId :: UserId, + _nPermissions :: PermissionType tag, + _nInvitation :: Maybe (UserId, UTCTimeMillis) } - deriving stock (Eq, Show) + deriving stock (Generic) + +deriving instance (Eq (PermissionType tag)) => Eq (NewTeamMember' tag) + +deriving instance (Ord (PermissionType tag)) => Ord (NewTeamMember' tag) + +deriving instance (Show (PermissionType tag)) => Show (NewTeamMember' tag) + +deriving via + (Schema (NewTeamMember' tag)) + instance + (ToSchema (NewTeamMember' tag)) => + ToJSON (NewTeamMember' tag) + +deriving via + (Schema (NewTeamMember' tag)) + instance + (ToSchema (NewTeamMember' tag)) => + FromJSON (NewTeamMember' tag) + +deriving via + (Schema (NewTeamMember' tag)) + instance + (ToSchema (NewTeamMember' tag)) => + S.ToSchema (NewTeamMember' tag) + +deriving via (GenericUniform NewTeamMember) instance Arbitrary NewTeamMember + +deriving via (GenericUniform (NewTeamMember' 'Optional)) instance Arbitrary (NewTeamMember' 'Optional) + +newTeamMemberSchema :: ObjectSchema SwaggerDoc NewTeamMember +newTeamMemberSchema = + NewTeamMember + <$> _nUserId .= field "user" schema + <*> _nPermissions .= field "permissions" schema + <*> _nInvitation .= invitedSchema' -instance Arbitrary NewTeamMember where - arbitrary = newNewTeamMember <$> arbitrary <*> arbitrary <*> arbitrary - shrink (NewTeamMember (TeamMember uid perms _mbinv _)) = [newNewTeamMember uid perms Nothing] +invitedSchema :: ObjectSchemaP SwaggerDoc (Maybe (UserId, UTCTimeMillis)) (Maybe UserId, Maybe UTCTimeMillis) +invitedSchema = + (,) <$> fmap fst .= optField "created_by" (maybeWithDefault Null schema) + <*> fmap snd .= optField "created_at" (maybeWithDefault Null schema) -newNewTeamMember :: UserId -> Permissions -> Maybe (UserId, UTCTimeMillis) -> NewTeamMember -newNewTeamMember uid perms mbinv = NewTeamMember $ TeamMember uid perms mbinv defUserLegalHoldStatus +invitedSchema' :: ObjectSchema SwaggerDoc (Maybe (UserId, UTCTimeMillis)) +invitedSchema' = withParser invitedSchema $ \(invby, invat) -> + case (invby, invat) of + (Just b, Just a) -> pure $ Just (b, a) + (Nothing, Nothing) -> pure Nothing + _ -> fail "created_by, created_at" + +instance ToSchema NewTeamMember where + schema = + object "NewTeamMember" $ + field "member" $ unnamed (object "Unnamed" newTeamMemberSchema) modelNewTeamMember :: Doc.Model modelNewTeamMember = Doc.defineModel "NewTeamMember" $ do @@ -257,22 +350,6 @@ modelNewTeamMember = Doc.defineModel "NewTeamMember" $ do Doc.property "member" (Doc.ref modelTeamMember) $ Doc.description "the team member to add (the legalhold_status field must be null or missing!)" -instance ToJSON NewTeamMember where - toJSON t = object ["member" .= mem] - where - mem = Object . HM.fromList . fltr . HM.toList $ o - o = case toJSON (_ntmNewTeamMember t) of - Object o_ -> o_ - _ -> error "impossible" - fltr = filter ((`elem` ["user", "permissions", "created_by", "created_at"]) . fst) - -instance FromJSON NewTeamMember where - parseJSON = withObject "add team member" $ \o -> do - mem <- o .: "member" - if (_legalHoldStatus mem == defUserLegalHoldStatus) - then pure $ NewTeamMember mem - else fail "legalhold_status field cannot be set in NewTeamMember" - -------------------------------------------------------------------------------- -- TeamMemberDeleteData @@ -281,6 +358,12 @@ newtype TeamMemberDeleteData = TeamMemberDeleteData } deriving stock (Eq, Show) deriving newtype (Arbitrary) + deriving (ToJSON, FromJSON, S.ToSchema) via (Schema TeamMemberDeleteData) + +instance ToSchema TeamMemberDeleteData where + schema = + object "TeamMemberDeleteData" $ + TeamMemberDeleteData <$> _tmdAuthPassword .= optField "password" (maybeWithDefault Null schema) newTeamMemberDeleteData :: Maybe PlainTextPassword -> TeamMemberDeleteData newTeamMemberDeleteData = TeamMemberDeleteData @@ -292,17 +375,30 @@ modelTeamMemberDelete = Doc.defineModel "teamDeleteData" $ do Doc.property "password" Doc.string' $ Doc.description "The account password to authorise the deletion." -instance FromJSON TeamMemberDeleteData where - parseJSON = withObject "team-member-delete-data" $ \o -> - TeamMemberDeleteData <$> (o .:? "password") +makeLenses ''TeamMember' +makeLenses ''TeamMemberList' +makeLenses ''NewTeamMember' +makeLenses ''TeamMemberDeleteData -instance ToJSON TeamMemberDeleteData where - toJSON tmd = - object - [ "password" .= _tmdAuthPassword tmd - ] +userId :: Lens' TeamMember UserId +userId = newTeamMember . nUserId -makeLenses ''TeamMember -makeLenses ''TeamMemberList -makeLenses ''NewTeamMember -makeLenses ''TeamMemberDeleteData +permissions :: Lens (TeamMember' tag1) (TeamMember' tag2) (PermissionType tag1) (PermissionType tag2) +permissions = newTeamMember . nPermissions + +invitation :: Lens' TeamMember (Maybe (UserId, UTCTimeMillis)) +invitation = newTeamMember . nInvitation + +-- JSON serialisation utilities (FUTUREWORK(leif): remove after servantification) + +teamMemberJson :: (TeamMember -> Bool) -> TeamMember -> Value +teamMemberJson withPerms = toJSON . setOptionalPerms withPerms + +setOptionalPerms :: (TeamMember -> Bool) -> TeamMember -> TeamMember' 'Optional +setOptionalPerms withPerms m = m & permissions %~ setPerm (withPerms m) + +-- | Show a list of team members using 'teamMemberJson'. +teamMemberListJson :: (TeamMember -> Bool) -> TeamMemberList -> Value +teamMemberListJson withPerms l = + toJSON $ + l {_teamMembers = map (setOptionalPerms withPerms) (_teamMembers l)} diff --git a/libs/wire-api/src/Wire/API/Team/Permission.hs b/libs/wire-api/src/Wire/API/Team/Permission.hs index 00ef0ed71c0..272d7281b26 100644 --- a/libs/wire-api/src/Wire/API/Team/Permission.hs +++ b/libs/wire-api/src/Wire/API/Team/Permission.hs @@ -44,10 +44,11 @@ where import qualified Cassandra as Cql import qualified Control.Error.Util as Err import Control.Lens (makeLenses, (^.)) -import Data.Aeson +import Data.Aeson (FromJSON (..), ToJSON (..)) import Data.Bits (testBit, (.|.)) -import Data.Json.Util +import Data.Schema import qualified Data.Set as Set +import qualified Data.Swagger as S import qualified Data.Swagger.Build.Api as Doc import Imports import Wire.API.Arbitrary (Arbitrary (arbitrary), GenericUniform (..)) @@ -60,6 +61,19 @@ data Permissions = Permissions _copy :: Set Perm } deriving stock (Eq, Ord, Show, Generic) + deriving (FromJSON, ToJSON, S.ToSchema) via (Schema Permissions) + +permissionsSchema :: ValueSchemaP NamedSwaggerDoc Permissions (Set Perm, Set Perm) +permissionsSchema = + object "Permissions" $ + (,) <$> (permsToInt . _self) .= field "self" (intToPerms <$> schema) + <*> (permsToInt . _copy) .= field "copy" (intToPerms <$> schema) + +instance ToSchema Permissions where + schema = withParser permissionsSchema $ \(s, d) -> + case newPermissions s d of + Nothing -> fail "invalid permissions" + Just ps -> pure ps modelPermissions :: Doc.Model modelPermissions = Doc.defineModel "Permissions" $ do @@ -72,21 +86,6 @@ modelPermissions = Doc.defineModel "Permissions" $ do Doc.property "copy" (Doc.int64 $ Doc.min 0 . Doc.max 0x7FFFFFFFFFFFFFFF) $ Doc.description "The permissions bitmask which this user can assign to others" -instance ToJSON Permissions where - toJSON p = - object $ - "self" .= permsToInt (_self p) - # "copy" .= permsToInt (_copy p) - # [] - -instance FromJSON Permissions where - parseJSON = withObject "permissions" $ \o -> do - s <- intToPerms <$> o .: "self" - d <- intToPerms <$> o .: "copy" - case newPermissions s d of - Nothing -> fail "invalid permissions" - Just ps -> pure ps - instance Arbitrary Permissions where arbitrary = maybe (error "instance Arbitrary Permissions") pure =<< do diff --git a/libs/wire-api/src/Wire/API/Team/Role.hs b/libs/wire-api/src/Wire/API/Team/Role.hs index 2a3ebca9df7..d9d9d74a216 100644 --- a/libs/wire-api/src/Wire/API/Team/Role.hs +++ b/libs/wire-api/src/Wire/API/Team/Role.hs @@ -29,9 +29,9 @@ where import qualified Cassandra as Cql import Data.Aeson import Data.Attoparsec.ByteString.Char8 (string) +import Data.ByteString.Builder (toLazyByteString) import Data.ByteString.Conversion (FromByteString (..), ToByteString (..)) import Data.ByteString.Conversion.From (runParser) -import Data.ByteString.Lazy.Builder (toLazyByteString) import Data.String.Conversions (cs) import qualified Data.Swagger.Model.Api as Doc import Imports diff --git a/libs/wire-api/src/Wire/API/User.hs b/libs/wire-api/src/Wire/API/User.hs index 30bbe2933e8..40780bd55fe 100644 --- a/libs/wire-api/src/Wire/API/User.hs +++ b/libs/wire-api/src/Wire/API/User.hs @@ -129,7 +129,7 @@ import qualified SAML2.WebSSO as SAML import qualified Test.QuickCheck as QC import Wire.API.Arbitrary (Arbitrary (arbitrary), GenericUniform (..)) import Wire.API.Provider.Service (ServiceRef, modelServiceRef) -import Wire.API.Team (BindingNewTeam (BindingNewTeam), modelNewBindingTeam, newTeamJson) +import Wire.API.Team (BindingNewTeam (BindingNewTeam), NewTeam (..), modelNewBindingTeam) import Wire.API.User.Activation (ActivationCode) import Wire.API.User.Auth (CookieLabel) import Wire.API.User.Identity @@ -234,12 +234,12 @@ instance ToSchema UserProfile where <*> profileAssets .= (field "assets" (array schema) <|> pure []) <*> profileAccentId .= field "accent_id" schema <*> ((\del -> if del then Just True else Nothing) . profileDeleted) - .= fmap (fromMaybe False) (opt (field "deleted" schema)) - <*> profileService .= opt (field "service" schema) - <*> profileHandle .= opt (field "handle" schema) - <*> profileExpire .= opt (field "expires_at" schema) - <*> profileTeam .= opt (field "team" schema) - <*> profileEmail .= opt (field "email" schema) + .= maybe_ (fromMaybe False <$> optField "deleted" schema) + <*> profileService .= maybe_ (optField "service" schema) + <*> profileHandle .= maybe_ (optField "handle" schema) + <*> profileExpire .= maybe_ (optField "expires_at" schema) + <*> profileTeam .= maybe_ (optField "team" schema) + <*> profileEmail .= maybe_ (optField "email" schema) <*> profileLegalholdStatus .= field "legalhold_status" schema modelUser :: Doc.Model @@ -802,6 +802,15 @@ instance ToJSON BindingNewTeamUser where A.object $ "currency" A..= c # newTeamJson t + where + -- FUTUREWORK(leif): this was originally defined in libs/wire-api/src/Wire/API/Team.hs and I moved it here + -- during the process of servantifying, it should go away when servantification is complete + newTeamJson :: NewTeam a -> [A.Pair] + newTeamJson (NewTeam n i ik _) = + "name" A..= fromRange n + # "icon" A..= fromRange i + # "icon_key" A..= (fromRange <$> ik) + # [] instance FromJSON BindingNewTeamUser where parseJSON j@(A.Object o) = do @@ -986,7 +995,7 @@ instance ToSchema DeleteUser where schema = object "DeleteUser" $ DeleteUser - <$> deleteUserPassword .= opt (field "password" schema) + <$> deleteUserPassword .= maybe_ (optField "password" schema) mkDeleteUser :: Maybe PlainTextPassword -> DeleteUser mkDeleteUser = DeleteUser diff --git a/libs/wire-api/src/Wire/API/User/Client.hs b/libs/wire-api/src/Wire/API/User/Client.hs index 6e601ecbb81..7437a6e74dd 100644 --- a/libs/wire-api/src/Wire/API/User/Client.hs +++ b/libs/wire-api/src/Wire/API/User/Client.hs @@ -74,7 +74,8 @@ module Wire.API.User.Client where import qualified Cassandra as Cql -import Control.Lens (view, (?~), (^.)) +import Control.Applicative +import Control.Lens (over, view, (?~), (^.)) import Data.Aeson (FromJSON (..), ToJSON (..)) import qualified Data.Aeson as A import Data.Bifunctor (second) @@ -180,12 +181,14 @@ newtype ClientCapabilityList = ClientCapabilityList {fromClientCapabilityList :: instance ToSchema ClientCapabilityList where schema = object "ClientCapabilityList" $ - ClientCapabilityList <$> fromClientCapabilityList .= capabilitiesFieldSchema + ClientCapabilityList <$> fromClientCapabilityList .= fmap runIdentity capabilitiesFieldSchema -capabilitiesFieldSchema :: ObjectSchema SwaggerDoc (Set ClientCapability) +capabilitiesFieldSchema :: + FieldFunctor SwaggerDoc f => + ObjectSchemaP SwaggerDoc (Set ClientCapability) (f (Set ClientCapability)) capabilitiesFieldSchema = Set.toList - .= fieldWithDocModifier "capabilities" mods (Set.fromList <$> array schema) + .= fieldWithDocModifierF "capabilities" mods (Set.fromList <$> array schema) where mods = description @@ -218,14 +221,22 @@ modelOtrClientMap = Doc.defineModel "OtrClientMap" $ do instance ToSchema a => ToSchema (UserClientMap a) where schema = userClientMapSchema schema +class WrapName doc where + wrapName :: doc -> (Text -> Text) -> SwaggerDoc -> doc + +instance WrapName SwaggerDoc where + wrapName _ _ = id + +instance WrapName NamedSwaggerDoc where + wrapName d f = fmap (Swagger.NamedSchema (Just (f (maybe "" ("_" <>) (getName d))))) + userClientMapSchema :: - ValueSchema NamedSwaggerDoc a -> - ValueSchema NamedSwaggerDoc (UserClientMap a) + (WrapName doc, HasSchemaRef doc) => + ValueSchema doc a -> + ValueSchema doc (UserClientMap a) userClientMapSchema sch = - named nm $ + over doc (wrapName (schemaDoc sch) ("UserClientMap" <>)) $ UserClientMap <$> userClientMap .= map_ (map_ sch) - where - nm = "UserClientMap" <> maybe "" (" " <>) (getName (schemaDoc sch)) newtype UserClientPrekeyMap = UserClientPrekeyMap {getUserClientPrekeyMap :: UserClientMap (Maybe Prekey)} @@ -240,8 +251,8 @@ instance ToSchema UserClientPrekeyMap where schema = UserClientPrekeyMap <$> getUserClientPrekeyMap .= addDoc sch where sch = - named "UserClientPrekeyMap" . unnamed $ - userClientMapSchema (optWithDefault A.Null schema) + named "UserClientPrekeyMap" $ + userClientMapSchema (nullable (unnamed schema)) addDoc = Swagger.schema . Swagger.example ?~ toJSON @@ -442,12 +453,12 @@ instance ToSchema Client where <$> clientId .= field "id" schema <*> clientType .= field "type" schema <*> clientTime .= field "time" schema - <*> clientClass .= opt (field "class" schema) - <*> clientLabel .= opt (field "label" schema) - <*> clientCookie .= opt (field "cookie" schema) - <*> clientLocation .= opt (field "location" schema) - <*> clientModel .= opt (field "model" schema) - <*> clientCapabilities .= (field "capabilities" schema <|> pure mempty) + <*> clientClass .= maybe_ (optField "class" schema) + <*> clientLabel .= maybe_ (optField "label" schema) + <*> clientCookie .= maybe_ (optField "cookie" schema) + <*> clientLocation .= maybe_ (optField "location" schema) + <*> clientModel .= maybe_ (optField "model" schema) + <*> clientCapabilities .= (fromMaybe mempty <$> optField "capabilities" schema) modelClient :: Doc.Model modelClient = Doc.defineModel "Client" $ do @@ -654,10 +665,10 @@ instance ToSchema NewClient where \When a temporary client already exists, it is replaced." ) schema - <*> newClientLabel .= opt (field "label" schema) + <*> newClientLabel .= maybe_ (optField "label" schema) <*> newClientClass - .= opt - ( fieldWithDocModifier + .= maybe_ + ( optFieldWithDocModifier "class" ( description ?~ "The device class this client belongs to. \ @@ -666,15 +677,15 @@ instance ToSchema NewClient where schema ) <*> newClientCookie - .= opt - ( fieldWithDocModifier + .= maybe_ + ( optFieldWithDocModifier "cookie" (description ?~ "The cookie label, i.e. the label used when logging in.") schema ) <*> newClientPassword - .= opt - ( fieldWithDocModifier + .= maybe_ + ( optFieldWithDocModifier "password" ( description ?~ "The password of the authenticated user for verification. \ @@ -682,8 +693,8 @@ instance ToSchema NewClient where ) schema ) - <*> newClientModel .= opt (field "model" schema) - <*> newClientCapabilities .= opt capabilitiesFieldSchema + <*> newClientModel .= maybe_ (optField "model" schema) + <*> newClientCapabilities .= maybe_ capabilitiesFieldSchema newClient :: ClientType -> LastPrekey -> NewClient newClient t k = @@ -717,30 +728,29 @@ instance ToSchema UpdateClient where schema = object "UpdateClient" $ UpdateClient - <$> (Just . updateClientPrekeys) + <$> updateClientPrekeys .= ( fromMaybe [] - <$> opt - ( fieldWithDocModifier - "prekeys" - (description ?~ "New prekeys for other clients to establish OTR sessions.") - (array schema) - ) + <$> ( optFieldWithDocModifier + "prekeys" + (description ?~ "New prekeys for other clients to establish OTR sessions.") + (array schema) + ) ) <*> updateClientLastKey - .= opt - ( fieldWithDocModifier + .= maybe_ + ( optFieldWithDocModifier "lastkey" (description ?~ "New last-resort prekey.") schema ) <*> updateClientLabel - .= opt - ( fieldWithDocModifier + .= maybe_ + ( optFieldWithDocModifier "label" (description ?~ "A new name for this client.") schema ) - <*> updateClientCapabilities .= opt capabilitiesFieldSchema + <*> updateClientCapabilities .= maybe_ capabilitiesFieldSchema modelUpdateClient :: Doc.Model modelUpdateClient = Doc.defineModel "UpdateClient" $ do @@ -781,12 +791,11 @@ instance ToSchema RmClient where <$> rmPassword .= optFieldWithDocModifier "password" - (Just A.Null) ( description ?~ "The password of the authenticated user for verification. \ \The password is not required for deleting temporary clients." ) - schema + (maybeWithDefault A.Null schema) modelDeleteClient :: Doc.Model modelDeleteClient = Doc.defineModel "DeleteClient" $ do diff --git a/libs/wire-api/src/Wire/API/User/Profile.hs b/libs/wire-api/src/Wire/API/User/Profile.hs index 7bea3c03def..0c4a7a389cb 100644 --- a/libs/wire-api/src/Wire/API/User/Profile.hs +++ b/libs/wire-api/src/Wire/API/User/Profile.hs @@ -126,7 +126,7 @@ instance ToSchema Asset where object "UserAsset" $ ImageAsset <$> assetKey .= field "key" schema - <*> assetSize .= opt (field "size" schema) + <*> assetSize .= maybe_ (optField "size" schema) <* const () .= field "type" typeSchema where typeSchema :: ValueSchema NamedSwaggerDoc () diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated.hs index 7eacbb74d24..cefc6936c64 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated.hs @@ -42,7 +42,6 @@ import qualified Test.Wire.API.Golden.Generated.BindingNewTeam_team import qualified Test.Wire.API.Golden.Generated.BotConvView_provider import qualified Test.Wire.API.Golden.Generated.BotUserView_provider import qualified Test.Wire.API.Golden.Generated.CheckHandles_user -import qualified Test.Wire.API.Golden.Generated.ChunkSize_user import qualified Test.Wire.API.Golden.Generated.ClientClass_user import qualified Test.Wire.API.Golden.Generated.ClientMismatch_user import qualified Test.Wire.API.Golden.Generated.ClientPrekey_user @@ -127,7 +126,6 @@ import qualified Test.Wire.API.Golden.Generated.NewService_provider import qualified Test.Wire.API.Golden.Generated.NewTeamMember_team import qualified Test.Wire.API.Golden.Generated.NewUserPublic_user import qualified Test.Wire.API.Golden.Generated.NewUser_user -import qualified Test.Wire.API.Golden.Generated.Offset_user import qualified Test.Wire.API.Golden.Generated.OtherMemberUpdate_user import qualified Test.Wire.API.Golden.Generated.OtherMember_user import qualified Test.Wire.API.Golden.Generated.OtrMessage_user @@ -166,8 +164,6 @@ import qualified Test.Wire.API.Golden.Generated.RemoveBotResponse_user import qualified Test.Wire.API.Golden.Generated.RemoveCookies_user import qualified Test.Wire.API.Golden.Generated.RemoveLegalHoldSettingsRequest_team import qualified Test.Wire.API.Golden.Generated.RequestNewLegalHoldClient_team -import qualified Test.Wire.API.Golden.Generated.ResumableAsset_user -import qualified Test.Wire.API.Golden.Generated.ResumableSettings_user import qualified Test.Wire.API.Golden.Generated.RichField_user import qualified Test.Wire.API.Golden.Generated.RichInfoAssocList_user import qualified Test.Wire.API.Golden.Generated.RichInfoMapAndList_user @@ -212,7 +208,6 @@ import qualified Test.Wire.API.Golden.Generated.TeamUpdateData_team import qualified Test.Wire.API.Golden.Generated.Team_team import qualified Test.Wire.API.Golden.Generated.TokenType_user import qualified Test.Wire.API.Golden.Generated.Token_user -import qualified Test.Wire.API.Golden.Generated.TotalSize_user import qualified Test.Wire.API.Golden.Generated.Transport_user import qualified Test.Wire.API.Golden.Generated.TurnHost_user import qualified Test.Wire.API.Golden.Generated.TurnURI_user @@ -293,30 +288,6 @@ tests = (Test.Wire.API.Golden.Generated.AssetKey_user.testObject_AssetKey_user_4, "testObject_AssetKey_user_4.json"), (Test.Wire.API.Golden.Generated.AssetKey_user.testObject_AssetKey_user_5, "testObject_AssetKey_user_5.json") ], - testGroup "Golden: ResumableSettings_user" $ - testObjects - [ (Test.Wire.API.Golden.Generated.ResumableSettings_user.testObject_ResumableSettings_user_1, "testObject_ResumableSettings_user_1.json"), - (Test.Wire.API.Golden.Generated.ResumableSettings_user.testObject_ResumableSettings_user_2, "testObject_ResumableSettings_user_2.json"), - (Test.Wire.API.Golden.Generated.ResumableSettings_user.testObject_ResumableSettings_user_4, "testObject_ResumableSettings_user_4.json"), - (Test.Wire.API.Golden.Generated.ResumableSettings_user.testObject_ResumableSettings_user_5, "testObject_ResumableSettings_user_5.json"), - (Test.Wire.API.Golden.Generated.ResumableSettings_user.testObject_ResumableSettings_user_17, "testObject_ResumableSettings_user_17.json") - ], - testGroup "Golden: TotalSize_user" $ - testObjects - [ (Test.Wire.API.Golden.Generated.TotalSize_user.testObject_TotalSize_user_1, "testObject_TotalSize_user_1.json") - ], - testGroup "Golden: ChunkSize_user" $ - testObjects - [ (Test.Wire.API.Golden.Generated.ChunkSize_user.testObject_ChunkSize_user_1, "testObject_ChunkSize_user_1.json") - ], - testGroup "Golden: Offset_user" $ - testObjects - [ (Test.Wire.API.Golden.Generated.Offset_user.testObject_Offset_user_1, "testObject_Offset_user_1.json") - ], - testGroup "Golden: ResumableAsset_user" $ - testObjects - [ (Test.Wire.API.Golden.Generated.ResumableAsset_user.testObject_ResumableAsset_user_1, "testObject_ResumableAsset_user_1.json") - ], testGroup "Golden: TurnHost_user" $ testObjects [ (Test.Wire.API.Golden.Generated.TurnHost_user.testObject_TurnHost_user_1, "testObject_TurnHost_user_1.json"), @@ -377,7 +348,8 @@ tests = (Test.Wire.API.Golden.Generated.RTCConfiguration_user.testObject_RTCConfiguration_user_3, "testObject_RTCConfiguration_user_3.json"), (Test.Wire.API.Golden.Generated.RTCConfiguration_user.testObject_RTCConfiguration_user_4, "testObject_RTCConfiguration_user_4.json"), (Test.Wire.API.Golden.Generated.RTCConfiguration_user.testObject_RTCConfiguration_user_5, "testObject_RTCConfiguration_user_5.json"), - (Test.Wire.API.Golden.Generated.RTCConfiguration_user.testObject_RTCConfiguration_user_6, "testObject_RTCConfiguration_user_6.json") + (Test.Wire.API.Golden.Generated.RTCConfiguration_user.testObject_RTCConfiguration_user_6, "testObject_RTCConfiguration_user_6.json"), + (Test.Wire.API.Golden.Generated.RTCConfiguration_user.testObject_RTCConfiguration_user_7, "testObject_RTCConfiguration_user_7.json") ], testGroup "Golden: SFTServer_user" $ testObjects diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Asset_asset.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Asset_asset.hs index 9e74080103a..98da5bf2c18 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Asset_asset.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Asset_asset.hs @@ -19,44 +19,31 @@ module Test.Wire.API.Golden.Generated.Asset_asset where import Control.Lens ((.~)) +import Data.Domain import Data.Id (Id (Id)) +import Data.Qualified import Data.Text.Ascii (AsciiChars (validate)) import qualified Data.UUID as UUID (fromString) import Imports (Functor (fmap), Maybe (Just, Nothing), fromJust, fromRight, read, undefined, (&)) import Wire.API.Asset - ( Asset, - AssetKey (AssetKeyV3), - AssetRetention - ( AssetEternal, - AssetEternalInfrequentAccess, - AssetExpiring, - AssetPersistent, - AssetVolatile - ), - AssetToken (AssetToken, assetTokenAscii), - assetExpires, - assetToken, - mkAsset, - ) testObject_Asset_asset_1 :: Asset testObject_Asset_asset_1 = - ( mkAsset (AssetKeyV3 (Id (fromJust (UUID.fromString "0000004b-0000-0017-0000-003e00000033"))) AssetExpiring) - & assetExpires .~ (fmap read (Just "1864-04-30 15:58:55.452 UTC")) - & assetToken .~ Just (AssetToken {assetTokenAscii = (fromRight undefined (validate ("Kun4JaxR6QuASXywDhzx")))}) - ) + mkAsset (Qualified (AssetKeyV3 (Id (fromJust (UUID.fromString "0000004b-0000-0017-0000-003e00000033"))) AssetExpiring) (Domain "example.com")) + & assetExpires .~ (fmap read (Just "1864-04-30 15:58:55.452 UTC")) + & assetToken .~ Just (AssetToken {assetTokenAscii = (fromRight undefined (validate ("Kun4JaxR6QuASXywDhzx")))}) testObject_Asset_asset_2 :: Asset testObject_Asset_asset_2 = ( mkAsset - (AssetKeyV3 (Id (fromJust (UUID.fromString "00000008-0000-006c-0000-001900000036"))) AssetEternalInfrequentAccess) + (Qualified (AssetKeyV3 (Id (fromJust (UUID.fromString "00000008-0000-006c-0000-001900000036"))) AssetEternalInfrequentAccess) (Domain "example.com")) & assetExpires .~ (fmap read (Just "1864-06-04 17:39:43.924 UTC")) & assetToken .~ Just (AssetToken {assetTokenAscii = (fromRight undefined (validate ("mPuul678vuJVZ_u9lQ==")))}) ) testObject_Asset_asset_3 :: Asset testObject_Asset_asset_3 = - ( mkAsset (AssetKeyV3 (Id (fromJust (UUID.fromString "00000055-0000-0071-0000-002e00000020"))) AssetEternal) + ( mkAsset (Qualified (AssetKeyV3 (Id (fromJust (UUID.fromString "00000055-0000-0071-0000-002e00000020"))) AssetEternal) (Domain "example.com")) & assetExpires .~ (fmap read (Just "1864-05-18 20:18:13.438 UTC")) & assetToken .~ Nothing ) @@ -64,49 +51,49 @@ testObject_Asset_asset_3 = testObject_Asset_asset_4 :: Asset testObject_Asset_asset_4 = ( mkAsset - (AssetKeyV3 (Id (fromJust (UUID.fromString "00000063-0000-0044-0000-003000000059"))) AssetEternalInfrequentAccess) + (Qualified (AssetKeyV3 (Id (fromJust (UUID.fromString "00000063-0000-0044-0000-003000000059"))) AssetEternalInfrequentAccess) (Domain "example.com")) & assetExpires .~ (fmap read (Nothing)) & assetToken .~ Just (AssetToken {assetTokenAscii = (fromRight undefined (validate ("IRKruiPSiANiX1fL")))}) ) testObject_Asset_asset_5 :: Asset testObject_Asset_asset_5 = - ( mkAsset (AssetKeyV3 (Id (fromJust (UUID.fromString "00000019-0000-005b-0000-001d00000056"))) AssetVolatile) + ( mkAsset (Qualified (AssetKeyV3 (Id (fromJust (UUID.fromString "00000019-0000-005b-0000-001d00000056"))) AssetVolatile) (Domain "example.com")) & assetExpires .~ (fmap read (Just "1864-05-11 14:38:25.874 UTC")) & assetToken .~ Just (AssetToken {assetTokenAscii = (fromRight undefined (validate ("BrbiaM1RxJlqjlqq7quuPSc=")))}) ) testObject_Asset_asset_6 :: Asset testObject_Asset_asset_6 = - ( mkAsset (AssetKeyV3 (Id (fromJust (UUID.fromString "0000000e-0000-0046-0000-00560000005e"))) AssetPersistent) + ( mkAsset (Qualified (AssetKeyV3 (Id (fromJust (UUID.fromString "0000000e-0000-0046-0000-00560000005e"))) AssetPersistent) (Domain "example.com")) & assetExpires .~ (fmap read (Just "1864-05-25 01:19:16.676 UTC")) & assetToken .~ Nothing ) testObject_Asset_asset_7 :: Asset testObject_Asset_asset_7 = - ( mkAsset (AssetKeyV3 (Id (fromJust (UUID.fromString "00000013-0000-002e-0000-003000000042"))) AssetEternal) + ( mkAsset (Qualified (AssetKeyV3 (Id (fromJust (UUID.fromString "00000013-0000-002e-0000-003000000042"))) AssetEternal) (Domain "example.com")) & assetExpires .~ (fmap read (Just "1864-04-14 08:45:43.05 UTC")) & assetToken .~ Just (AssetToken {assetTokenAscii = (fromRight undefined (validate ("_N9ERJGmbZtd6XlW_6O12bxuNe4=")))}) ) testObject_Asset_asset_8 :: Asset testObject_Asset_asset_8 = - ( mkAsset (AssetKeyV3 (Id (fromJust (UUID.fromString "00000073-0000-003e-0000-00120000000c"))) AssetEternal) + ( mkAsset (Qualified (AssetKeyV3 (Id (fromJust (UUID.fromString "00000073-0000-003e-0000-00120000000c"))) AssetEternal) (Domain "example.com")) & assetExpires .~ (fmap read (Nothing)) & assetToken .~ Nothing ) testObject_Asset_asset_9 :: Asset testObject_Asset_asset_9 = - ( mkAsset (AssetKeyV3 (Id (fromJust (UUID.fromString "00000006-0000-004b-0000-004f00000025"))) AssetPersistent) + ( mkAsset (Qualified (AssetKeyV3 (Id (fromJust (UUID.fromString "00000006-0000-004b-0000-004f00000025"))) AssetPersistent) (Domain "example.com")) & assetExpires .~ (fmap read (Just "1864-05-21 01:34:09.726 UTC")) & assetToken .~ Nothing ) testObject_Asset_asset_10 :: Asset testObject_Asset_asset_10 = - ( mkAsset (AssetKeyV3 (Id (fromJust (UUID.fromString "00000065-0000-0080-0000-003400000061"))) AssetEternal) + ( mkAsset (Qualified (AssetKeyV3 (Id (fromJust (UUID.fromString "00000065-0000-0080-0000-003400000061"))) AssetEternal) (Domain "example.com")) & assetExpires .~ (fmap read (Nothing)) & assetToken .~ Nothing ) @@ -114,14 +101,14 @@ testObject_Asset_asset_10 = testObject_Asset_asset_11 :: Asset testObject_Asset_asset_11 = ( mkAsset - (AssetKeyV3 (Id (fromJust (UUID.fromString "00000014-0000-0077-0000-001e00000076"))) AssetEternalInfrequentAccess) + (Qualified (AssetKeyV3 (Id (fromJust (UUID.fromString "00000014-0000-0077-0000-001e00000076"))) AssetEternalInfrequentAccess) (Domain "example.com")) & assetExpires .~ (fmap read (Just "1864-05-11 16:58:59.746 UTC")) & assetToken .~ Just (AssetToken {assetTokenAscii = (fromRight undefined (validate ("DnlRW9Q=")))}) ) testObject_Asset_asset_12 :: Asset testObject_Asset_asset_12 = - ( mkAsset (AssetKeyV3 (Id (fromJust (UUID.fromString "0000001d-0000-0076-0000-003800000021"))) AssetPersistent) + ( mkAsset (Qualified (AssetKeyV3 (Id (fromJust (UUID.fromString "0000001d-0000-0076-0000-003800000021"))) AssetPersistent) (Domain "example.com")) & assetExpires .~ (fmap read (Nothing)) & assetToken .~ Nothing ) @@ -129,7 +116,7 @@ testObject_Asset_asset_12 = testObject_Asset_asset_13 :: Asset testObject_Asset_asset_13 = ( mkAsset - (AssetKeyV3 (Id (fromJust (UUID.fromString "00000030-0000-0036-0000-003c0000000a"))) AssetEternalInfrequentAccess) + (Qualified (AssetKeyV3 (Id (fromJust (UUID.fromString "00000030-0000-0036-0000-003c0000000a"))) AssetEternalInfrequentAccess) (Domain "example.com")) & assetExpires .~ (fmap read (Just "1864-04-30 19:37:57.302 UTC")) & assetToken .~ Just (AssetToken {assetTokenAscii = (fromRight undefined (validate ("n7CJBcdOSKznRmOypWXsGfEE0g==")))}) ) @@ -137,42 +124,42 @@ testObject_Asset_asset_13 = testObject_Asset_asset_14 :: Asset testObject_Asset_asset_14 = ( mkAsset - (AssetKeyV3 (Id (fromJust (UUID.fromString "00000047-0000-0012-0000-005500000062"))) AssetEternalInfrequentAccess) + (Qualified (AssetKeyV3 (Id (fromJust (UUID.fromString "00000047-0000-0012-0000-005500000062"))) AssetEternalInfrequentAccess) (Domain "example.com")) & assetExpires .~ (fmap read (Just "1864-05-06 09:09:55.146 UTC")) & assetToken .~ Just (AssetToken {assetTokenAscii = (fromRight undefined (validate ("LYfUg4qlMjw=")))}) ) testObject_Asset_asset_15 :: Asset testObject_Asset_asset_15 = - ( mkAsset (AssetKeyV3 (Id (fromJust (UUID.fromString "00000030-0000-0074-0000-00660000004c"))) AssetPersistent) + ( mkAsset (Qualified (AssetKeyV3 (Id (fromJust (UUID.fromString "00000030-0000-0074-0000-00660000004c"))) AssetPersistent) (Domain "example.com")) & assetExpires .~ (fmap read (Nothing)) & assetToken .~ Nothing ) testObject_Asset_asset_16 :: Asset testObject_Asset_asset_16 = - ( mkAsset (AssetKeyV3 (Id (fromJust (UUID.fromString "00000048-0000-0051-0000-005d00000070"))) AssetVolatile) + ( mkAsset (Qualified (AssetKeyV3 (Id (fromJust (UUID.fromString "00000048-0000-0051-0000-005d00000070"))) AssetVolatile) (Domain "example.com")) & assetExpires .~ (fmap read (Just "1864-05-04 02:19:12.52 UTC")) & assetToken .~ Nothing ) testObject_Asset_asset_17 :: Asset testObject_Asset_asset_17 = - ( mkAsset (AssetKeyV3 (Id (fromJust (UUID.fromString "00000017-0000-000d-0000-00680000003e"))) AssetPersistent) + ( mkAsset (Qualified (AssetKeyV3 (Id (fromJust (UUID.fromString "00000017-0000-000d-0000-00680000003e"))) AssetPersistent) (Domain "example.com")) & assetExpires .~ (fmap read (Just "1864-04-09 17:00:39.763 UTC")) & assetToken .~ Nothing ) testObject_Asset_asset_18 :: Asset testObject_Asset_asset_18 = - ( mkAsset (AssetKeyV3 (Id (fromJust (UUID.fromString "0000003e-0000-0032-0000-004d00000070"))) AssetEternal) + ( mkAsset (Qualified (AssetKeyV3 (Id (fromJust (UUID.fromString "0000003e-0000-0032-0000-004d00000070"))) AssetEternal) (Domain "example.com")) & assetExpires .~ (fmap read (Just "1864-04-12 20:53:21.25 UTC")) & assetToken .~ Nothing ) testObject_Asset_asset_19 :: Asset testObject_Asset_asset_19 = - ( mkAsset (AssetKeyV3 (Id (fromJust (UUID.fromString "00000021-0000-0062-0000-002a0000006b"))) AssetVolatile) + ( mkAsset (Qualified (AssetKeyV3 (Id (fromJust (UUID.fromString "00000021-0000-0062-0000-002a0000006b"))) AssetVolatile) (Domain "example.com")) & assetExpires .~ (fmap read (Nothing)) & assetToken @@ -181,7 +168,7 @@ testObject_Asset_asset_19 = testObject_Asset_asset_20 :: Asset testObject_Asset_asset_20 = - ( mkAsset (AssetKeyV3 (Id (fromJust (UUID.fromString "00000053-0000-0072-0000-001700000047"))) AssetVolatile) + ( mkAsset (Qualified (AssetKeyV3 (Id (fromJust (UUID.fromString "00000053-0000-0072-0000-001700000047"))) AssetVolatile) (Domain "example.com")) & assetExpires .~ (fmap read (Just "1864-04-25 16:48:39.986 UTC")) & assetToken .~ Nothing ) diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewTeamMember_team.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewTeamMember_team.hs index ebbffc91d2f..4092949a185 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewTeamMember_team.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewTeamMember_team.hs @@ -23,7 +23,7 @@ import Data.Json.Util (readUTCTimeMillis) import qualified Data.UUID as UUID (fromString) import GHC.Exts (IsList (fromList)) import Imports (Maybe (Just, Nothing), fromJust) -import Wire.API.Team.Member (NewTeamMember, newNewTeamMember) +import Wire.API.Team.Member (NewTeamMember, mkNewTeamMember) import Wire.API.Team.Permission ( Perm ( AddTeamMember, @@ -45,7 +45,7 @@ import Wire.API.Team.Permission testObject_NewTeamMember_team_1 :: NewTeamMember testObject_NewTeamMember_team_1 = - ( newNewTeamMember + ( mkNewTeamMember (Id (fromJust (UUID.fromString "00000002-0000-0007-0000-000200000002"))) (Permissions {_self = fromList [], _copy = fromList []}) ( Just @@ -57,7 +57,7 @@ testObject_NewTeamMember_team_1 = testObject_NewTeamMember_team_2 :: NewTeamMember testObject_NewTeamMember_team_2 = - ( newNewTeamMember + ( mkNewTeamMember (Id (fromJust (UUID.fromString "00000004-0000-0000-0000-000200000003"))) ( Permissions { _self = @@ -81,7 +81,7 @@ testObject_NewTeamMember_team_2 = testObject_NewTeamMember_team_3 :: NewTeamMember testObject_NewTeamMember_team_3 = - ( newNewTeamMember + ( mkNewTeamMember (Id (fromJust (UUID.fromString "00000008-0000-0008-0000-000700000005"))) ( Permissions { _self = @@ -99,7 +99,7 @@ testObject_NewTeamMember_team_3 = testObject_NewTeamMember_team_4 :: NewTeamMember testObject_NewTeamMember_team_4 = - ( newNewTeamMember + ( mkNewTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000700000005"))) ( Permissions { _self = fromList [CreateConversation, AddTeamMember, SetTeamData], @@ -111,7 +111,7 @@ testObject_NewTeamMember_team_4 = testObject_NewTeamMember_team_5 :: NewTeamMember testObject_NewTeamMember_team_5 = - ( newNewTeamMember + ( mkNewTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000002"))) (Permissions {_self = fromList [AddTeamMember, SetBilling, GetTeamConversations], _copy = fromList [AddTeamMember]}) ( Just @@ -123,7 +123,7 @@ testObject_NewTeamMember_team_5 = testObject_NewTeamMember_team_6 :: NewTeamMember testObject_NewTeamMember_team_6 = - ( newNewTeamMember + ( mkNewTeamMember (Id (fromJust (UUID.fromString "00000002-0000-0006-0000-000400000003"))) ( Permissions { _self = @@ -141,7 +141,7 @@ testObject_NewTeamMember_team_6 = testObject_NewTeamMember_team_7 :: NewTeamMember testObject_NewTeamMember_team_7 = - ( newNewTeamMember + ( mkNewTeamMember (Id (fromJust (UUID.fromString "00000007-0000-0004-0000-000500000005"))) ( Permissions { _self = @@ -159,7 +159,7 @@ testObject_NewTeamMember_team_7 = testObject_NewTeamMember_team_8 :: NewTeamMember testObject_NewTeamMember_team_8 = - ( newNewTeamMember + ( mkNewTeamMember (Id (fromJust (UUID.fromString "00000008-0000-0003-0000-000200000003"))) ( Permissions { _self = fromList [DoNotUseDeprecatedModifyConvName], @@ -175,7 +175,7 @@ testObject_NewTeamMember_team_8 = testObject_NewTeamMember_team_9 :: NewTeamMember testObject_NewTeamMember_team_9 = - ( newNewTeamMember + ( mkNewTeamMember (Id (fromJust (UUID.fromString "00000001-0000-0008-0000-000300000004"))) (Permissions {_self = fromList [SetBilling], _copy = fromList []}) ( Just @@ -187,7 +187,7 @@ testObject_NewTeamMember_team_9 = testObject_NewTeamMember_team_10 :: NewTeamMember testObject_NewTeamMember_team_10 = - ( newNewTeamMember + ( mkNewTeamMember (Id (fromJust (UUID.fromString "00000008-0000-0003-0000-000600000003"))) (Permissions {_self = fromList [GetBilling], _copy = fromList []}) ( Just @@ -199,7 +199,7 @@ testObject_NewTeamMember_team_10 = testObject_NewTeamMember_team_11 :: NewTeamMember testObject_NewTeamMember_team_11 = - ( newNewTeamMember + ( mkNewTeamMember (Id (fromJust (UUID.fromString "00000006-0000-0005-0000-000000000002"))) ( Permissions { _self = fromList [CreateConversation, DoNotUseDeprecatedModifyConvName, SetTeamData], @@ -215,7 +215,7 @@ testObject_NewTeamMember_team_11 = testObject_NewTeamMember_team_12 :: NewTeamMember testObject_NewTeamMember_team_12 = - ( newNewTeamMember + ( mkNewTeamMember (Id (fromJust (UUID.fromString "00000001-0000-0004-0000-000000000007"))) (Permissions {_self = fromList [SetBilling, SetTeamData, GetTeamConversations], _copy = fromList []}) (Nothing) @@ -223,7 +223,7 @@ testObject_NewTeamMember_team_12 = testObject_NewTeamMember_team_13 :: NewTeamMember testObject_NewTeamMember_team_13 = - ( newNewTeamMember + ( mkNewTeamMember (Id (fromJust (UUID.fromString "00000002-0000-0004-0000-000600000001"))) ( Permissions { _self = fromList [AddTeamMember, DoNotUseDeprecatedAddRemoveConvMember, SetTeamData, GetTeamConversations], @@ -235,7 +235,7 @@ testObject_NewTeamMember_team_13 = testObject_NewTeamMember_team_14 :: NewTeamMember testObject_NewTeamMember_team_14 = - ( newNewTeamMember + ( mkNewTeamMember (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000500000004"))) ( Permissions { _self = @@ -253,7 +253,7 @@ testObject_NewTeamMember_team_14 = testObject_NewTeamMember_team_15 :: NewTeamMember testObject_NewTeamMember_team_15 = - ( newNewTeamMember + ( mkNewTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0008-0000-000800000007"))) ( Permissions { _self = fromList [RemoveTeamMember, GetMemberPermissions, DeleteTeam], @@ -269,7 +269,7 @@ testObject_NewTeamMember_team_15 = testObject_NewTeamMember_team_16 :: NewTeamMember testObject_NewTeamMember_team_16 = - ( newNewTeamMember + ( mkNewTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0006-0000-000300000005"))) ( Permissions { _self = fromList [CreateConversation, RemoveTeamMember, GetBilling, GetTeamConversations, DeleteTeam], @@ -281,7 +281,7 @@ testObject_NewTeamMember_team_16 = testObject_NewTeamMember_team_17 :: NewTeamMember testObject_NewTeamMember_team_17 = - ( newNewTeamMember + ( mkNewTeamMember (Id (fromJust (UUID.fromString "00000000-0000-0008-0000-000400000005"))) (Permissions {_self = fromList [], _copy = fromList []}) ( Just @@ -293,7 +293,7 @@ testObject_NewTeamMember_team_17 = testObject_NewTeamMember_team_18 :: NewTeamMember testObject_NewTeamMember_team_18 = - ( newNewTeamMember + ( mkNewTeamMember (Id (fromJust (UUID.fromString "00000006-0000-0003-0000-000000000001"))) (Permissions {_self = fromList [], _copy = fromList []}) ( Just @@ -305,7 +305,7 @@ testObject_NewTeamMember_team_18 = testObject_NewTeamMember_team_19 :: NewTeamMember testObject_NewTeamMember_team_19 = - ( newNewTeamMember + ( mkNewTeamMember (Id (fromJust (UUID.fromString "00000004-0000-0005-0000-000100000008"))) ( Permissions { _self = fromList [DoNotUseDeprecatedDeleteConversation, RemoveTeamMember, SetBilling, SetMemberPermissions], @@ -317,7 +317,7 @@ testObject_NewTeamMember_team_19 = testObject_NewTeamMember_team_20 :: NewTeamMember testObject_NewTeamMember_team_20 = - ( newNewTeamMember + ( mkNewTeamMember (Id (fromJust (UUID.fromString "00000008-0000-0000-0000-000000000004"))) ( Permissions { _self = diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/RTCConfiguration_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/RTCConfiguration_user.hs index cb52eaec7a7..9b75aa71b71 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/RTCConfiguration_user.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/RTCConfiguration_user.hs @@ -152,6 +152,7 @@ testObject_RTCConfiguration_user_1 = ) (Nothing) (2) + Nothing ) testObject_RTCConfiguration_user_2 :: RTCConfiguration @@ -334,6 +335,7 @@ testObject_RTCConfiguration_user_2 = ) ) (4) + Nothing ) testObject_RTCConfiguration_user_3 :: RTCConfiguration @@ -480,6 +482,7 @@ testObject_RTCConfiguration_user_3 = ) ) (9) + Nothing ) testObject_RTCConfiguration_user_4 :: RTCConfiguration @@ -685,6 +688,7 @@ testObject_RTCConfiguration_user_4 = ) ) (2) + Nothing ) testObject_RTCConfiguration_user_5 :: RTCConfiguration @@ -728,6 +732,7 @@ testObject_RTCConfiguration_user_5 = ) ) (2) + Nothing ) testObject_RTCConfiguration_user_6 :: RTCConfiguration @@ -750,4 +755,47 @@ testObject_RTCConfiguration_user_6 = ) Nothing (2) + Nothing + ) + +testObject_RTCConfiguration_user_7 :: RTCConfiguration +testObject_RTCConfiguration_user_7 = + ( rtcConfiguration + ( ( rtcIceServer + ( (turnURI (SchemeTurns) (TurnHostIp (IpAddr (read "248.187.155.126"))) (read "1") (Nothing)) + :| [ (turnURI (SchemeTurn) (TurnHostIp (IpAddr (read "166.155.90.230"))) (read "0") (Just TransportTCP)), + (turnURI (SchemeTurns) (TurnHostName "xn--mgbh0fb.xn--kgbechtv") (read "1") (Just TransportTCP)), + (turnURI (SchemeTurn) (TurnHostName "host.name") (read "1") (Just TransportTCP)) + ] + ) + ( ( turnUsername (secondsToNominalDiffTime (2.000000000000)) ("tj") & tuVersion .~ (0) & tuKeyindex .~ (0) + & tuT .~ ('\1011805') + ) + ) + ((fromRight undefined (validate ("")))) + ) + :| [] + ) + Nothing + (2) + ( Just + [ sftServer + ( coerce + URI + { uriScheme = Scheme {schemeBS = "https"}, + uriAuthority = + Just + ( Authority + { authorityUserInfo = Nothing, + authorityHost = Host {hostBS = "example.com"}, + authorityPort = Nothing + } + ), + uriPath = "", + uriQuery = Query {queryPairs = []}, + uriFragment = Nothing + } + ) + ] + ) ) diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ResumableAsset_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ResumableAsset_user.hs deleted file mode 100644 index 98798a95470..00000000000 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ResumableAsset_user.hs +++ /dev/null @@ -1,46 +0,0 @@ --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2021 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . -module Test.Wire.API.Golden.Generated.ResumableAsset_user where - -import Control.Lens ((.~), (?~)) -import Data.Id (Id (Id)) -import Data.Text.Ascii (AsciiChars (validate)) -import qualified Data.UUID as UUID (fromString) -import Imports (Functor (fmap), Maybe (Just), fromJust, fromRight, read, undefined, (&)) -import Wire.API.Asset - ( AssetKey (AssetKeyV3), - AssetRetention - ( AssetExpiring - ), - AssetToken (AssetToken, assetTokenAscii), - ChunkSize (ChunkSize, chunkSizeBytes), - ResumableAsset, - assetExpires, - assetToken, - mkAsset, - mkResumableAsset, - ) - -testObject_ResumableAsset_user_1 :: ResumableAsset -testObject_ResumableAsset_user_1 = - mkResumableAsset - ( mkAsset (AssetKeyV3 (Id (fromJust (UUID.fromString "00000010-0000-0008-0000-004300000006"))) AssetExpiring) - & assetExpires .~ fmap read (Just "1864-04-13 11:37:47.393 UTC") - & assetToken ?~ (AssetToken {assetTokenAscii = fromRight undefined (validate "5A==")}) - ) - (read "1864-04-09 06:01:25.576 UTC") - (ChunkSize {chunkSizeBytes = 17}) diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ResumableSettings_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ResumableSettings_user.hs deleted file mode 100644 index 3c82024710f..00000000000 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ResumableSettings_user.hs +++ /dev/null @@ -1,54 +0,0 @@ -{-# LANGUAGE OverloadedLists #-} - --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2021 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . -module Test.Wire.API.Golden.Generated.ResumableSettings_user where - -import Codec.MIME.Type (Type (..)) -import qualified Codec.MIME.Type as MIME (MIMEType (Image)) -import Imports (Bool (False, True)) -import Wire.API.Asset - ( AssetRetention - ( AssetEternal, - AssetEternalInfrequentAccess, - AssetExpiring, - AssetPersistent, - AssetVolatile - ), - ResumableSettings, - mkResumableSettings, - ) - -testObject_ResumableSettings_user_1 :: ResumableSettings -testObject_ResumableSettings_user_1 = - mkResumableSettings AssetExpiring False (Type {mimeType = MIME.Image "png", mimeParams = []}) - -testObject_ResumableSettings_user_2 :: ResumableSettings -testObject_ResumableSettings_user_2 = - mkResumableSettings AssetEternal True (Type {mimeType = MIME.Image "png", mimeParams = []}) - -testObject_ResumableSettings_user_4 :: ResumableSettings -testObject_ResumableSettings_user_4 = - mkResumableSettings AssetEternalInfrequentAccess True (Type {mimeType = MIME.Image "png", mimeParams = []}) - -testObject_ResumableSettings_user_5 :: ResumableSettings -testObject_ResumableSettings_user_5 = - mkResumableSettings AssetPersistent False (Type {mimeType = MIME.Image "png", mimeParams = []}) - -testObject_ResumableSettings_user_17 :: ResumableSettings -testObject_ResumableSettings_user_17 = - mkResumableSettings AssetVolatile True (Type {mimeType = MIME.Image "png", mimeParams = []}) diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TeamMemberList_team.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TeamMemberList_team.hs index 9cb5bc130eb..5b6a14c481b 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TeamMemberList_team.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TeamMemberList_team.hs @@ -32,14 +32,8 @@ import GHC.Exts (IsList (fromList)) import Imports (Maybe (Just, Nothing), fromJust) import Wire.API.Team.Member ( ListType (ListComplete, ListTruncated), - TeamMember - ( TeamMember, - _invitation, - _legalHoldStatus, - _permissions, - _userId - ), TeamMemberList, + mkTeamMember, newTeamMemberList, ) import Wire.API.Team.Permission @@ -56,95 +50,85 @@ import Wire.API.Team.Permission ) testObject_TeamMemberList_team_1 :: TeamMemberList -testObject_TeamMemberList_team_1 = (newTeamMemberList ([]) (ListComplete)) +testObject_TeamMemberList_team_1 = newTeamMemberList ([]) (ListComplete) testObject_TeamMemberList_team_2 :: TeamMemberList testObject_TeamMemberList_team_2 = - ( newTeamMemberList - ( [ TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000002-0000-0000-0000-000000000002"))), - _permissions = Permissions {_self = fromList [GetBilling, SetMemberPermissions], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000002"))), - (fromJust (readUTCTimeMillis "1864-05-10T10:05:44.332Z")) - ), - _legalHoldStatus = UserLegalHoldPending - } - ] - ) - (ListComplete) - ) + newTeamMemberList + [ mkTeamMember + (Id (fromJust (UUID.fromString "00000002-0000-0000-0000-000000000002"))) + (Permissions {_self = fromList [GetBilling, SetMemberPermissions], _copy = fromList []}) + ( Just + ( Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000002")), + fromJust (readUTCTimeMillis "1864-05-10T10:05:44.332Z") + ) + ) + UserLegalHoldPending + ] + ListComplete testObject_TeamMemberList_team_3 :: TeamMemberList testObject_TeamMemberList_team_3 = ( newTeamMemberList - ( [ TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000001"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000000"))), - (fromJust (readUTCTimeMillis "1864-05-09T06:07:36.175Z")) - ), - _legalHoldStatus = UserLegalHoldPending - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000001"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000"))), - (fromJust (readUTCTimeMillis "1864-05-09T14:28:10.448Z")) - ), - _legalHoldStatus = UserLegalHoldPending - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000000"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000001"))), - (fromJust (readUTCTimeMillis "1864-05-09T16:05:37.642Z")) - ), - _legalHoldStatus = UserLegalHoldDisabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000001"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = Nothing, - _legalHoldStatus = UserLegalHoldPending - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000000"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000001"))), - (fromJust (readUTCTimeMillis "1864-05-09T13:06:20.504Z")) - ), - _legalHoldStatus = UserLegalHoldPending - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000001"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000001"))), - (fromJust (readUTCTimeMillis "1864-05-09T16:37:10.774Z")) - ), - _legalHoldStatus = UserLegalHoldDisabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000000"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000"))), - (fromJust (readUTCTimeMillis "1864-05-09T04:36:55.388Z")) - ), - _legalHoldStatus = UserLegalHoldPending - } + ( [ mkTeamMember + (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000001"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000000"))), + (fromJust (readUTCTimeMillis "1864-05-09T06:07:36.175Z")) + ) + ) + UserLegalHoldPending, + mkTeamMember + (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000001"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000"))), + (fromJust (readUTCTimeMillis "1864-05-09T14:28:10.448Z")) + ) + ) + UserLegalHoldPending, + mkTeamMember + (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000000"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000001"))), + (fromJust (readUTCTimeMillis "1864-05-09T16:05:37.642Z")) + ) + ) + UserLegalHoldDisabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000001"))) + (Permissions {_self = fromList [], _copy = fromList []}) + (Nothing) + UserLegalHoldPending, + mkTeamMember + (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000000"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000001"))), + (fromJust (readUTCTimeMillis "1864-05-09T13:06:20.504Z")) + ) + ) + UserLegalHoldPending, + mkTeamMember + (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000001"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000001"))), + (fromJust (readUTCTimeMillis "1864-05-09T16:37:10.774Z")) + ) + ) + UserLegalHoldDisabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000000"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000"))), + (fromJust (readUTCTimeMillis "1864-05-09T04:36:55.388Z")) + ) + ) + UserLegalHoldPending ] ) (ListComplete) @@ -153,26 +137,24 @@ testObject_TeamMemberList_team_3 = testObject_TeamMemberList_team_4 :: TeamMemberList testObject_TeamMemberList_team_4 = ( newTeamMemberList - ( [ TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000000"))), - _permissions = Permissions {_self = fromList [GetTeamConversations], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000"))), - (fromJust (readUTCTimeMillis "1864-05-08T16:05:11.696Z")) - ), - _legalHoldStatus = UserLegalHoldEnabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000000"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000001"))), - (fromJust (readUTCTimeMillis "1864-05-08T07:09:26.753Z")) - ), - _legalHoldStatus = UserLegalHoldDisabled - } + ( [ mkTeamMember + (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000000"))) + (Permissions {_self = fromList [GetTeamConversations], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000"))), + (fromJust (readUTCTimeMillis "1864-05-08T16:05:11.696Z")) + ) + ) + UserLegalHoldEnabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000000"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000001"))), + (fromJust (readUTCTimeMillis "1864-05-08T07:09:26.753Z")) + ) + ) + UserLegalHoldDisabled ] ) (ListTruncated) @@ -181,46 +163,42 @@ testObject_TeamMemberList_team_4 = testObject_TeamMemberList_team_5 :: TeamMemberList testObject_TeamMemberList_team_5 = ( newTeamMemberList - ( [ TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000000"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000001"))), - (fromJust (readUTCTimeMillis "1864-05-09T23:10:04.963Z")) - ), - _legalHoldStatus = UserLegalHoldPending - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000001"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000"))), - (fromJust (readUTCTimeMillis "1864-05-09T15:40:17.119Z")) - ), - _legalHoldStatus = UserLegalHoldEnabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000001"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000000"))), - (fromJust (readUTCTimeMillis "1864-05-09T00:40:38.004Z")) - ), - _legalHoldStatus = UserLegalHoldEnabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000001"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000001"))), - (fromJust (readUTCTimeMillis "1864-05-09T07:30:49.028Z")) - ), - _legalHoldStatus = UserLegalHoldEnabled - } + ( [ mkTeamMember + (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000000"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000001"))), + (fromJust (readUTCTimeMillis "1864-05-09T23:10:04.963Z")) + ) + ) + UserLegalHoldPending, + mkTeamMember + (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000001"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000"))), + (fromJust (readUTCTimeMillis "1864-05-09T15:40:17.119Z")) + ) + ) + UserLegalHoldEnabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000001"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000000"))), + (fromJust (readUTCTimeMillis "1864-05-09T00:40:38.004Z")) + ) + ) + UserLegalHoldEnabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000001"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000001"))), + (fromJust (readUTCTimeMillis "1864-05-09T07:30:49.028Z")) + ) + ) + UserLegalHoldEnabled ] ) (ListComplete) @@ -229,106 +207,96 @@ testObject_TeamMemberList_team_5 = testObject_TeamMemberList_team_6 :: TeamMemberList testObject_TeamMemberList_team_6 = ( newTeamMemberList - ( [ TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000000"))), - (fromJust (readUTCTimeMillis "1864-05-09T17:07:48.156Z")) - ), - _legalHoldStatus = UserLegalHoldDisabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000000"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000001"))), - (fromJust (readUTCTimeMillis "1864-05-09T00:04:10.559Z")) - ), - _legalHoldStatus = UserLegalHoldPending - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000001"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000001"))), - (fromJust (readUTCTimeMillis "1864-05-09T10:39:19.860Z")) - ), - _legalHoldStatus = UserLegalHoldDisabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000001"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000001"))), - (fromJust (readUTCTimeMillis "1864-05-09T13:40:56.648Z")) - ), - _legalHoldStatus = UserLegalHoldDisabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000000"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000000"))), - (fromJust (readUTCTimeMillis "1864-05-09T12:13:40.273Z")) - ), - _legalHoldStatus = UserLegalHoldEnabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000001"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000001"))), - (fromJust (readUTCTimeMillis "1864-05-09T13:28:04.561Z")) - ), - _legalHoldStatus = UserLegalHoldDisabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000000"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000"))), - (fromJust (readUTCTimeMillis "1864-05-09T02:59:55.584Z")) - ), - _legalHoldStatus = UserLegalHoldEnabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000000"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000000"))), - (fromJust (readUTCTimeMillis "1864-05-09T22:57:33.947Z")) - ), - _legalHoldStatus = UserLegalHoldPending - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000000"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000001"))), - (fromJust (readUTCTimeMillis "1864-05-09T01:02:39.691Z")) - ), - _legalHoldStatus = UserLegalHoldEnabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000001"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000001"))), - (fromJust (readUTCTimeMillis "1864-05-09T13:39:38.488Z")) - ), - _legalHoldStatus = UserLegalHoldEnabled - } + ( [ mkTeamMember + (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000000"))), + (fromJust (readUTCTimeMillis "1864-05-09T17:07:48.156Z")) + ) + ) + UserLegalHoldDisabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000000"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000001"))), + (fromJust (readUTCTimeMillis "1864-05-09T00:04:10.559Z")) + ) + ) + UserLegalHoldPending, + mkTeamMember + (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000001"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000001"))), + (fromJust (readUTCTimeMillis "1864-05-09T10:39:19.860Z")) + ) + ) + UserLegalHoldDisabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000001"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000001"))), + (fromJust (readUTCTimeMillis "1864-05-09T13:40:56.648Z")) + ) + ) + UserLegalHoldDisabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000000"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000000"))), + (fromJust (readUTCTimeMillis "1864-05-09T12:13:40.273Z")) + ) + ) + UserLegalHoldEnabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000001"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000001"))), + (fromJust (readUTCTimeMillis "1864-05-09T13:28:04.561Z")) + ) + ) + UserLegalHoldDisabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000000"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000"))), + (fromJust (readUTCTimeMillis "1864-05-09T02:59:55.584Z")) + ) + ) + UserLegalHoldEnabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000000"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000000"))), + (fromJust (readUTCTimeMillis "1864-05-09T22:57:33.947Z")) + ) + ) + UserLegalHoldPending, + mkTeamMember + (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000000"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000001"))), + (fromJust (readUTCTimeMillis "1864-05-09T01:02:39.691Z")) + ) + ) + UserLegalHoldEnabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000001"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000001"))), + (fromJust (readUTCTimeMillis "1864-05-09T13:39:38.488Z")) + ) + ) + UserLegalHoldEnabled ] ) (ListComplete) @@ -337,28 +305,25 @@ testObject_TeamMemberList_team_6 = testObject_TeamMemberList_team_7 :: TeamMemberList testObject_TeamMemberList_team_7 = ( newTeamMemberList - ( [ TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000000"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = Nothing, - _legalHoldStatus = UserLegalHoldPending - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000001"))), - _permissions = Permissions {_self = fromList [SetTeamData], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000000"))), - (fromJust (readUTCTimeMillis "1864-05-10T03:11:36.961Z")) - ), - _legalHoldStatus = UserLegalHoldEnabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000001"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = Nothing, - _legalHoldStatus = UserLegalHoldEnabled - } + ( [ mkTeamMember + (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000000"))) + (Permissions {_self = fromList [], _copy = fromList []}) + (Nothing) + UserLegalHoldPending, + mkTeamMember + (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000001"))) + (Permissions {_self = fromList [SetTeamData], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000000"))), + (fromJust (readUTCTimeMillis "1864-05-10T03:11:36.961Z")) + ) + ) + UserLegalHoldEnabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000001"))) + (Permissions {_self = fromList [], _copy = fromList []}) + (Nothing) + UserLegalHoldEnabled ] ) (ListTruncated) @@ -367,108 +332,97 @@ testObject_TeamMemberList_team_7 = testObject_TeamMemberList_team_8 :: TeamMemberList testObject_TeamMemberList_team_8 = ( newTeamMemberList - ( [ TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000000"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000000"))), - (fromJust (readUTCTimeMillis "1864-05-09T07:35:03.629Z")) - ), - _legalHoldStatus = UserLegalHoldPending - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000001"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000000"))), - (fromJust (readUTCTimeMillis "1864-05-09T00:48:38.818Z")) - ), - _legalHoldStatus = UserLegalHoldDisabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000001"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000000"))), - (fromJust (readUTCTimeMillis "1864-05-09T06:12:10.151Z")) - ), - _legalHoldStatus = UserLegalHoldEnabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000000"))), - (fromJust (readUTCTimeMillis "1864-05-09T03:45:53.520Z")) - ), - _legalHoldStatus = UserLegalHoldEnabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000000"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000001"))), - (fromJust (readUTCTimeMillis "1864-05-09T17:14:59.798Z")) - ), - _legalHoldStatus = UserLegalHoldDisabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000000"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000001"))), - (fromJust (readUTCTimeMillis "1864-05-09T17:51:55.340Z")) - ), - _legalHoldStatus = UserLegalHoldPending - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000001"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000001"))), - (fromJust (readUTCTimeMillis "1864-05-09T01:38:35.880Z")) - ), - _legalHoldStatus = UserLegalHoldDisabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000000"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000001"))), - (fromJust (readUTCTimeMillis "1864-05-09T18:06:10.660Z")) - ), - _legalHoldStatus = UserLegalHoldPending - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000001"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000000"))), - (fromJust (readUTCTimeMillis "1864-05-09T07:30:46.880Z")) - ), - _legalHoldStatus = UserLegalHoldPending - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000000"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = Nothing, - _legalHoldStatus = UserLegalHoldDisabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000001"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = Nothing, - _legalHoldStatus = UserLegalHoldPending - } + ( [ mkTeamMember + (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000000"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000000"))), + (fromJust (readUTCTimeMillis "1864-05-09T07:35:03.629Z")) + ) + ) + UserLegalHoldPending, + mkTeamMember + (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000001"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000000"))), + (fromJust (readUTCTimeMillis "1864-05-09T00:48:38.818Z")) + ) + ) + UserLegalHoldDisabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000001"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000000"))), + (fromJust (readUTCTimeMillis "1864-05-09T06:12:10.151Z")) + ) + ) + UserLegalHoldEnabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000000"))), + (fromJust (readUTCTimeMillis "1864-05-09T03:45:53.520Z")) + ) + ) + UserLegalHoldEnabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000000"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000001"))), + (fromJust (readUTCTimeMillis "1864-05-09T17:14:59.798Z")) + ) + ) + UserLegalHoldDisabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000000"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000001"))), + (fromJust (readUTCTimeMillis "1864-05-09T17:51:55.340Z")) + ) + ) + UserLegalHoldPending, + mkTeamMember + (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000001"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000001"))), + (fromJust (readUTCTimeMillis "1864-05-09T01:38:35.880Z")) + ) + ) + UserLegalHoldDisabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000000"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000001"))), + (fromJust (readUTCTimeMillis "1864-05-09T18:06:10.660Z")) + ) + ) + UserLegalHoldPending, + mkTeamMember + (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000001"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000000"))), + (fromJust (readUTCTimeMillis "1864-05-09T07:30:46.880Z")) + ) + ) + UserLegalHoldPending, + mkTeamMember + (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000000"))) + (Permissions {_self = fromList [], _copy = fromList []}) + (Nothing) + UserLegalHoldDisabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000001"))) + (Permissions {_self = fromList [], _copy = fromList []}) + (Nothing) + UserLegalHoldPending ] ) (ListTruncated) @@ -477,26 +431,24 @@ testObject_TeamMemberList_team_8 = testObject_TeamMemberList_team_9 :: TeamMemberList testObject_TeamMemberList_team_9 = ( newTeamMemberList - ( [ TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000001"))), - _permissions = Permissions {_self = fromList [AddTeamMember], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000001"))), - (fromJust (readUTCTimeMillis "1864-05-08T22:16:59.050Z")) - ), - _legalHoldStatus = UserLegalHoldEnabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000001"))), - _permissions = Permissions {_self = fromList [CreateConversation], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000001"))), - (fromJust (readUTCTimeMillis "1864-05-08T21:43:37.550Z")) - ), - _legalHoldStatus = UserLegalHoldEnabled - } + ( [ mkTeamMember + (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000001"))) + (Permissions {_self = fromList [AddTeamMember], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000001"))), + (fromJust (readUTCTimeMillis "1864-05-08T22:16:59.050Z")) + ) + ) + UserLegalHoldEnabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000001"))) + (Permissions {_self = fromList [CreateConversation], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000001"))), + (fromJust (readUTCTimeMillis "1864-05-08T21:43:37.550Z")) + ) + ) + UserLegalHoldEnabled ] ) (ListTruncated) @@ -505,214 +457,192 @@ testObject_TeamMemberList_team_9 = testObject_TeamMemberList_team_10 :: TeamMemberList testObject_TeamMemberList_team_10 = ( newTeamMemberList - ( [ TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000000"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000001"))), - (fromJust (readUTCTimeMillis "1864-05-09T04:44:28.366Z")) - ), - _legalHoldStatus = UserLegalHoldEnabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000001"))), - (fromJust (readUTCTimeMillis "1864-05-09T06:22:04.036Z")) - ), - _legalHoldStatus = UserLegalHoldEnabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000001"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000001"))), - (fromJust (readUTCTimeMillis "1864-05-09T12:10:11.701Z")) - ), - _legalHoldStatus = UserLegalHoldEnabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000001"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000000"))), - (fromJust (readUTCTimeMillis "1864-05-09T21:54:05.305Z")) - ), - _legalHoldStatus = UserLegalHoldEnabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000001"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000000"))), - (fromJust (readUTCTimeMillis "1864-05-09T00:26:06.221Z")) - ), - _legalHoldStatus = UserLegalHoldPending - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000001"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = Nothing, - _legalHoldStatus = UserLegalHoldPending - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000001"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000000"))), - (fromJust (readUTCTimeMillis "1864-05-09T20:12:04.856Z")) - ), - _legalHoldStatus = UserLegalHoldDisabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000000"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000000"))), - (fromJust (readUTCTimeMillis "1864-05-09T23:35:44.986Z")) - ), - _legalHoldStatus = UserLegalHoldDisabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000001"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000001"))), - (fromJust (readUTCTimeMillis "1864-05-09T07:36:17.730Z")) - ), - _legalHoldStatus = UserLegalHoldPending - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000001"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000000"))), - (fromJust (readUTCTimeMillis "1864-05-09T19:36:57.529Z")) - ), - _legalHoldStatus = UserLegalHoldPending - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000001"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = Nothing, - _legalHoldStatus = UserLegalHoldDisabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000000"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000001"))), - (fromJust (readUTCTimeMillis "1864-05-09T19:45:56.914Z")) - ), - _legalHoldStatus = UserLegalHoldPending - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000000"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000000"))), - (fromJust (readUTCTimeMillis "1864-05-09T13:42:17.107Z")) - ), - _legalHoldStatus = UserLegalHoldEnabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000000"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000001"))), - (fromJust (readUTCTimeMillis "1864-05-09T03:42:46.106Z")) - ), - _legalHoldStatus = UserLegalHoldEnabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000000"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000"))), - (fromJust (readUTCTimeMillis "1864-05-09T09:41:44.679Z")) - ), - _legalHoldStatus = UserLegalHoldEnabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000001"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000000"))), - (fromJust (readUTCTimeMillis "1864-05-09T09:26:44.717Z")) - ), - _legalHoldStatus = UserLegalHoldPending - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000000"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000001"))), - (fromJust (readUTCTimeMillis "1864-05-09T00:40:00.056Z")) - ), - _legalHoldStatus = UserLegalHoldDisabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000000"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = Nothing, - _legalHoldStatus = UserLegalHoldEnabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000000"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000"))), - (fromJust (readUTCTimeMillis "1864-05-09T07:47:20.635Z")) - ), - _legalHoldStatus = UserLegalHoldPending - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000000"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000000"))), - (fromJust (readUTCTimeMillis "1864-05-09T15:58:21.895Z")) - ), - _legalHoldStatus = UserLegalHoldEnabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000001"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000001"))), - (fromJust (readUTCTimeMillis "1864-05-09T19:25:51.873Z")) - ), - _legalHoldStatus = UserLegalHoldEnabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000001"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000001"))), - (fromJust (readUTCTimeMillis "1864-05-09T03:19:55.569Z")) - ), - _legalHoldStatus = UserLegalHoldPending - } + ( [ mkTeamMember + (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000000"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000001"))), + (fromJust (readUTCTimeMillis "1864-05-09T04:44:28.366Z")) + ) + ) + UserLegalHoldEnabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000001"))), + (fromJust (readUTCTimeMillis "1864-05-09T06:22:04.036Z")) + ) + ) + UserLegalHoldEnabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000001"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000001"))), + (fromJust (readUTCTimeMillis "1864-05-09T12:10:11.701Z")) + ) + ) + UserLegalHoldEnabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000001"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000000"))), + (fromJust (readUTCTimeMillis "1864-05-09T21:54:05.305Z")) + ) + ) + UserLegalHoldEnabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000001"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000000"))), + (fromJust (readUTCTimeMillis "1864-05-09T00:26:06.221Z")) + ) + ) + UserLegalHoldPending, + mkTeamMember + (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000001"))) + (Permissions {_self = fromList [], _copy = fromList []}) + (Nothing) + UserLegalHoldPending, + mkTeamMember + (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000001"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000000"))), + (fromJust (readUTCTimeMillis "1864-05-09T20:12:04.856Z")) + ) + ) + UserLegalHoldDisabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000000"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000000"))), + (fromJust (readUTCTimeMillis "1864-05-09T23:35:44.986Z")) + ) + ) + UserLegalHoldDisabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000001"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000001"))), + (fromJust (readUTCTimeMillis "1864-05-09T07:36:17.730Z")) + ) + ) + UserLegalHoldPending, + mkTeamMember + (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000001"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000000"))), + (fromJust (readUTCTimeMillis "1864-05-09T19:36:57.529Z")) + ) + ) + UserLegalHoldPending, + mkTeamMember + (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000001"))) + (Permissions {_self = fromList [], _copy = fromList []}) + (Nothing) + UserLegalHoldDisabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000000"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000001"))), + (fromJust (readUTCTimeMillis "1864-05-09T19:45:56.914Z")) + ) + ) + UserLegalHoldPending, + mkTeamMember + (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000000"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000000"))), + (fromJust (readUTCTimeMillis "1864-05-09T13:42:17.107Z")) + ) + ) + UserLegalHoldEnabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000000"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000001"))), + (fromJust (readUTCTimeMillis "1864-05-09T03:42:46.106Z")) + ) + ) + UserLegalHoldEnabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000000"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000"))), + (fromJust (readUTCTimeMillis "1864-05-09T09:41:44.679Z")) + ) + ) + UserLegalHoldEnabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000001"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000000"))), + (fromJust (readUTCTimeMillis "1864-05-09T09:26:44.717Z")) + ) + ) + UserLegalHoldPending, + mkTeamMember + (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000000"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000001"))), + (fromJust (readUTCTimeMillis "1864-05-09T00:40:00.056Z")) + ) + ) + UserLegalHoldDisabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000000"))) + (Permissions {_self = fromList [], _copy = fromList []}) + (Nothing) + UserLegalHoldEnabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000000"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000"))), + (fromJust (readUTCTimeMillis "1864-05-09T07:47:20.635Z")) + ) + ) + UserLegalHoldPending, + mkTeamMember + (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000000"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000000"))), + (fromJust (readUTCTimeMillis "1864-05-09T15:58:21.895Z")) + ) + ) + UserLegalHoldEnabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000001"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000001"))), + (fromJust (readUTCTimeMillis "1864-05-09T19:25:51.873Z")) + ) + ) + UserLegalHoldEnabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000001"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000001"))), + (fromJust (readUTCTimeMillis "1864-05-09T03:19:55.569Z")) + ) + ) + UserLegalHoldPending ] ) (ListComplete) @@ -721,120 +651,107 @@ testObject_TeamMemberList_team_10 = testObject_TeamMemberList_team_11 :: TeamMemberList testObject_TeamMemberList_team_11 = ( newTeamMemberList - ( [ TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000000"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000000"))), - (fromJust (readUTCTimeMillis "1864-05-09T06:08:50.626Z")) - ), - _legalHoldStatus = UserLegalHoldEnabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000001"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = Nothing, - _legalHoldStatus = UserLegalHoldPending - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000000"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000001"))), - (fromJust (readUTCTimeMillis "1864-05-09T08:23:53.653Z")) - ), - _legalHoldStatus = UserLegalHoldEnabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000000"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = Nothing, - _legalHoldStatus = UserLegalHoldPending - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000001"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000000"))), - (fromJust (readUTCTimeMillis "1864-05-09T16:28:42.815Z")) - ), - _legalHoldStatus = UserLegalHoldPending - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000001"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = Nothing, - _legalHoldStatus = UserLegalHoldPending - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000001"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = Nothing, - _legalHoldStatus = UserLegalHoldDisabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000001"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000000"))), - (fromJust (readUTCTimeMillis "1864-05-09T11:47:57.498Z")) - ), - _legalHoldStatus = UserLegalHoldEnabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000000"))), - (fromJust (readUTCTimeMillis "1864-05-09T17:22:07.538Z")) - ), - _legalHoldStatus = UserLegalHoldPending - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000001"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000001"))), - (fromJust (readUTCTimeMillis "1864-05-09T19:14:48.836Z")) - ), - _legalHoldStatus = UserLegalHoldPending - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000001"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000000"))), - (fromJust (readUTCTimeMillis "1864-05-09T14:53:49.059Z")) - ), - _legalHoldStatus = UserLegalHoldEnabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000000"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000001"))), - (fromJust (readUTCTimeMillis "1864-05-09T10:44:04.209Z")) - ), - _legalHoldStatus = UserLegalHoldDisabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000001"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000000"))), - (fromJust (readUTCTimeMillis "1864-05-09T23:34:24.831Z")) - ), - _legalHoldStatus = UserLegalHoldPending - } + ( [ mkTeamMember + (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000000"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000000"))), + (fromJust (readUTCTimeMillis "1864-05-09T06:08:50.626Z")) + ) + ) + UserLegalHoldEnabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000001"))) + (Permissions {_self = fromList [], _copy = fromList []}) + (Nothing) + UserLegalHoldPending, + mkTeamMember + (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000000"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000001"))), + (fromJust (readUTCTimeMillis "1864-05-09T08:23:53.653Z")) + ) + ) + UserLegalHoldEnabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000000"))) + (Permissions {_self = fromList [], _copy = fromList []}) + (Nothing) + UserLegalHoldPending, + mkTeamMember + (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000001"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000000"))), + (fromJust (readUTCTimeMillis "1864-05-09T16:28:42.815Z")) + ) + ) + UserLegalHoldPending, + mkTeamMember + (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000001"))) + (Permissions {_self = fromList [], _copy = fromList []}) + (Nothing) + UserLegalHoldPending, + mkTeamMember + (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000001"))) + (Permissions {_self = fromList [], _copy = fromList []}) + (Nothing) + UserLegalHoldDisabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000001"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000000"))), + (fromJust (readUTCTimeMillis "1864-05-09T11:47:57.498Z")) + ) + ) + UserLegalHoldEnabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000000"))), + (fromJust (readUTCTimeMillis "1864-05-09T17:22:07.538Z")) + ) + ) + UserLegalHoldPending, + mkTeamMember + (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000001"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000001"))), + (fromJust (readUTCTimeMillis "1864-05-09T19:14:48.836Z")) + ) + ) + UserLegalHoldPending, + mkTeamMember + (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000001"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000000"))), + (fromJust (readUTCTimeMillis "1864-05-09T14:53:49.059Z")) + ) + ) + UserLegalHoldEnabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000000"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000001"))), + (fromJust (readUTCTimeMillis "1864-05-09T10:44:04.209Z")) + ) + ) + UserLegalHoldDisabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000001"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000000"))), + (fromJust (readUTCTimeMillis "1864-05-09T23:34:24.831Z")) + ) + ) + UserLegalHoldPending ] ) (ListTruncated) @@ -843,38 +760,34 @@ testObject_TeamMemberList_team_11 = testObject_TeamMemberList_team_12 :: TeamMemberList testObject_TeamMemberList_team_12 = ( newTeamMemberList - ( [ TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000001"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = Nothing, - _legalHoldStatus = UserLegalHoldEnabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000001"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000001"))), - (fromJust (readUTCTimeMillis "1864-05-09T15:59:09.462Z")) - ), - _legalHoldStatus = UserLegalHoldPending - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000001"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = Nothing, - _legalHoldStatus = UserLegalHoldEnabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000001"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000001"))), - (fromJust (readUTCTimeMillis "1864-05-09T00:27:17.631Z")) - ), - _legalHoldStatus = UserLegalHoldEnabled - } + ( [ mkTeamMember + (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000001"))) + (Permissions {_self = fromList [], _copy = fromList []}) + (Nothing) + UserLegalHoldEnabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000001"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000001"))), + (fromJust (readUTCTimeMillis "1864-05-09T15:59:09.462Z")) + ) + ) + UserLegalHoldPending, + mkTeamMember + (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000001"))) + (Permissions {_self = fromList [], _copy = fromList []}) + (Nothing) + UserLegalHoldEnabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000001"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000001"))), + (fromJust (readUTCTimeMillis "1864-05-09T00:27:17.631Z")) + ) + ) + UserLegalHoldEnabled ] ) (ListTruncated) @@ -883,32 +796,29 @@ testObject_TeamMemberList_team_12 = testObject_TeamMemberList_team_13 :: TeamMemberList testObject_TeamMemberList_team_13 = ( newTeamMemberList - ( [ TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = Nothing, - _legalHoldStatus = UserLegalHoldDisabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000000"))), - _permissions = Permissions {_self = fromList [GetMemberPermissions], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000001"))), - (fromJust (readUTCTimeMillis "1864-05-10T04:37:19.686Z")) - ), - _legalHoldStatus = UserLegalHoldEnabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000000"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000000"))), - (fromJust (readUTCTimeMillis "1864-05-09T13:22:20.368Z")) - ), - _legalHoldStatus = UserLegalHoldEnabled - } + ( [ mkTeamMember + (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000"))) + (Permissions {_self = fromList [], _copy = fromList []}) + (Nothing) + UserLegalHoldDisabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000000"))) + (Permissions {_self = fromList [GetMemberPermissions], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000001"))), + (fromJust (readUTCTimeMillis "1864-05-10T04:37:19.686Z")) + ) + ) + UserLegalHoldEnabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000000"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000000"))), + (fromJust (readUTCTimeMillis "1864-05-09T13:22:20.368Z")) + ) + ) + UserLegalHoldEnabled ] ) (ListTruncated) @@ -917,136 +827,121 @@ testObject_TeamMemberList_team_13 = testObject_TeamMemberList_team_14 :: TeamMemberList testObject_TeamMemberList_team_14 = ( newTeamMemberList - ( [ TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000001"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = Nothing, - _legalHoldStatus = UserLegalHoldDisabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000000"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000001"))), - (fromJust (readUTCTimeMillis "1864-05-09T07:01:56.077Z")) - ), - _legalHoldStatus = UserLegalHoldEnabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000001"))), - (fromJust (readUTCTimeMillis "1864-05-09T09:34:46.900Z")) - ), - _legalHoldStatus = UserLegalHoldEnabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000000"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000000"))), - (fromJust (readUTCTimeMillis "1864-05-09T10:40:24.034Z")) - ), - _legalHoldStatus = UserLegalHoldEnabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000001"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000"))), - (fromJust (readUTCTimeMillis "1864-05-09T10:17:53.056Z")) - ), - _legalHoldStatus = UserLegalHoldEnabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000001"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000001"))), - (fromJust (readUTCTimeMillis "1864-05-09T18:37:38.894Z")) - ), - _legalHoldStatus = UserLegalHoldDisabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000000"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = Nothing, - _legalHoldStatus = UserLegalHoldDisabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000001"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000001"))), - (fromJust (readUTCTimeMillis "1864-05-09T06:25:10.534Z")) - ), - _legalHoldStatus = UserLegalHoldEnabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000001"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000000"))), - (fromJust (readUTCTimeMillis "1864-05-09T02:42:16.433Z")) - ), - _legalHoldStatus = UserLegalHoldDisabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000001"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000001"))), - (fromJust (readUTCTimeMillis "1864-05-09T07:25:18.248Z")) - ), - _legalHoldStatus = UserLegalHoldEnabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000001"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = Nothing, - _legalHoldStatus = UserLegalHoldPending - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000001"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000001"))), - (fromJust (readUTCTimeMillis "1864-05-09T15:31:36.237Z")) - ), - _legalHoldStatus = UserLegalHoldPending - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000001"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000001"))), - (fromJust (readUTCTimeMillis "1864-05-09T15:23:38.616Z")) - ), - _legalHoldStatus = UserLegalHoldDisabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000001"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = Nothing, - _legalHoldStatus = UserLegalHoldPending - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000000"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = Nothing, - _legalHoldStatus = UserLegalHoldEnabled - } + ( [ mkTeamMember + (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000001"))) + (Permissions {_self = fromList [], _copy = fromList []}) + (Nothing) + UserLegalHoldDisabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000000"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000001"))), + (fromJust (readUTCTimeMillis "1864-05-09T07:01:56.077Z")) + ) + ) + UserLegalHoldEnabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000001"))), + (fromJust (readUTCTimeMillis "1864-05-09T09:34:46.900Z")) + ) + ) + UserLegalHoldEnabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000000"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000000"))), + (fromJust (readUTCTimeMillis "1864-05-09T10:40:24.034Z")) + ) + ) + UserLegalHoldEnabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000001"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000"))), + (fromJust (readUTCTimeMillis "1864-05-09T10:17:53.056Z")) + ) + ) + UserLegalHoldEnabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000001"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000001"))), + (fromJust (readUTCTimeMillis "1864-05-09T18:37:38.894Z")) + ) + ) + UserLegalHoldDisabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000000"))) + (Permissions {_self = fromList [], _copy = fromList []}) + (Nothing) + UserLegalHoldDisabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000001"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000001"))), + (fromJust (readUTCTimeMillis "1864-05-09T06:25:10.534Z")) + ) + ) + UserLegalHoldEnabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000001"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000000"))), + (fromJust (readUTCTimeMillis "1864-05-09T02:42:16.433Z")) + ) + ) + UserLegalHoldDisabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000001"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000001"))), + (fromJust (readUTCTimeMillis "1864-05-09T07:25:18.248Z")) + ) + ) + UserLegalHoldEnabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000001"))) + (Permissions {_self = fromList [], _copy = fromList []}) + (Nothing) + UserLegalHoldPending, + mkTeamMember + (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000001"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000001"))), + (fromJust (readUTCTimeMillis "1864-05-09T15:31:36.237Z")) + ) + ) + UserLegalHoldPending, + mkTeamMember + (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000001"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000001"))), + (fromJust (readUTCTimeMillis "1864-05-09T15:23:38.616Z")) + ) + ) + UserLegalHoldDisabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000001"))) + (Permissions {_self = fromList [], _copy = fromList []}) + (Nothing) + UserLegalHoldPending, + mkTeamMember + (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000000"))) + (Permissions {_self = fromList [], _copy = fromList []}) + (Nothing) + UserLegalHoldEnabled ] ) (ListTruncated) @@ -1055,44 +950,39 @@ testObject_TeamMemberList_team_14 = testObject_TeamMemberList_team_15 :: TeamMemberList testObject_TeamMemberList_team_15 = ( newTeamMemberList - ( [ TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000001"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000001"))), - (fromJust (readUTCTimeMillis "1864-05-09T20:33:17.912Z")) - ), - _legalHoldStatus = UserLegalHoldDisabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000001"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000001"))), - (fromJust (readUTCTimeMillis "1864-05-09T09:03:59.579Z")) - ), - _legalHoldStatus = UserLegalHoldEnabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000001"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = Nothing, - _legalHoldStatus = UserLegalHoldPending - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000001"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = Nothing, - _legalHoldStatus = UserLegalHoldEnabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000001"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = Nothing, - _legalHoldStatus = UserLegalHoldDisabled - } + ( [ mkTeamMember + (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000001"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000001"))), + (fromJust (readUTCTimeMillis "1864-05-09T20:33:17.912Z")) + ) + ) + UserLegalHoldDisabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000001"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000001"))), + (fromJust (readUTCTimeMillis "1864-05-09T09:03:59.579Z")) + ) + ) + UserLegalHoldEnabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000001"))) + (Permissions {_self = fromList [], _copy = fromList []}) + (Nothing) + UserLegalHoldPending, + mkTeamMember + (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000001"))) + (Permissions {_self = fromList [], _copy = fromList []}) + (Nothing) + UserLegalHoldEnabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000001"))) + (Permissions {_self = fromList [], _copy = fromList []}) + (Nothing) + UserLegalHoldDisabled ] ) (ListTruncated) @@ -1104,52 +994,47 @@ testObject_TeamMemberList_team_16 = (newTeamMemberList ([]) (ListComplete)) testObject_TeamMemberList_team_17 :: TeamMemberList testObject_TeamMemberList_team_17 = ( newTeamMemberList - ( [ TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000"))), - (fromJust (readUTCTimeMillis "1864-05-09T10:04:36.715Z")) - ), - _legalHoldStatus = UserLegalHoldDisabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000000"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = Nothing, - _legalHoldStatus = UserLegalHoldDisabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000001"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000001"))), - (fromJust (readUTCTimeMillis "1864-05-09T03:02:37.641Z")) - ), - _legalHoldStatus = UserLegalHoldEnabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000001"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000000"))), - (fromJust (readUTCTimeMillis "1864-05-09T23:21:44.944Z")) - ), - _legalHoldStatus = UserLegalHoldDisabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000001"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000000"))), - (fromJust (readUTCTimeMillis "1864-05-09T08:47:48.774Z")) - ), - _legalHoldStatus = UserLegalHoldDisabled - } + ( [ mkTeamMember + (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000"))), + (fromJust (readUTCTimeMillis "1864-05-09T10:04:36.715Z")) + ) + ) + UserLegalHoldDisabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000000"))) + (Permissions {_self = fromList [], _copy = fromList []}) + (Nothing) + UserLegalHoldDisabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000001"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000001"))), + (fromJust (readUTCTimeMillis "1864-05-09T03:02:37.641Z")) + ) + ) + UserLegalHoldEnabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000001"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000000"))), + (fromJust (readUTCTimeMillis "1864-05-09T23:21:44.944Z")) + ) + ) + UserLegalHoldDisabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000001"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000000"))), + (fromJust (readUTCTimeMillis "1864-05-09T08:47:48.774Z")) + ) + ) + UserLegalHoldDisabled ] ) (ListTruncated) @@ -1158,56 +1043,51 @@ testObject_TeamMemberList_team_17 = testObject_TeamMemberList_team_18 :: TeamMemberList testObject_TeamMemberList_team_18 = ( newTeamMemberList - ( [ TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000000"))), - (fromJust (readUTCTimeMillis "1864-05-09T17:44:12.611Z")) - ), - _legalHoldStatus = UserLegalHoldEnabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000001"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000000"))), - (fromJust (readUTCTimeMillis "1864-05-09T05:14:06.040Z")) - ), - _legalHoldStatus = UserLegalHoldEnabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000001"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000001"))), - (fromJust (readUTCTimeMillis "1864-05-09T05:24:40.864Z")) - ), - _legalHoldStatus = UserLegalHoldPending - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000000"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000"))), - (fromJust (readUTCTimeMillis "1864-05-09T20:09:48.156Z")) - ), - _legalHoldStatus = UserLegalHoldEnabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000000"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000000"))), - (fromJust (readUTCTimeMillis "1864-05-09T20:09:31.059Z")) - ), - _legalHoldStatus = UserLegalHoldPending - } + ( [ mkTeamMember + (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000000"))), + (fromJust (readUTCTimeMillis "1864-05-09T17:44:12.611Z")) + ) + ) + UserLegalHoldEnabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000001"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000000"))), + (fromJust (readUTCTimeMillis "1864-05-09T05:14:06.040Z")) + ) + ) + UserLegalHoldEnabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000001"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000001"))), + (fromJust (readUTCTimeMillis "1864-05-09T05:24:40.864Z")) + ) + ) + UserLegalHoldPending, + mkTeamMember + (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000000"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000"))), + (fromJust (readUTCTimeMillis "1864-05-09T20:09:48.156Z")) + ) + ) + UserLegalHoldEnabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000000"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000000"))), + (fromJust (readUTCTimeMillis "1864-05-09T20:09:31.059Z")) + ) + ) + UserLegalHoldPending ] ) (ListTruncated) @@ -1216,20 +1096,19 @@ testObject_TeamMemberList_team_18 = testObject_TeamMemberList_team_19 :: TeamMemberList testObject_TeamMemberList_team_19 = ( newTeamMemberList - ( [ TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000000-0000-0002-0000-000200000000"))), - _permissions = - Permissions - { _self = fromList [CreateConversation, SetTeamData, SetMemberPermissions], - _copy = fromList [] - }, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000000-0000-0002-0000-000200000002"))), - (fromJust (readUTCTimeMillis "1864-05-09T19:12:15.962Z")) - ), - _legalHoldStatus = UserLegalHoldDisabled - } + ( [ mkTeamMember + (Id (fromJust (UUID.fromString "00000000-0000-0002-0000-000200000000"))) + ( Permissions + { _self = fromList [CreateConversation, SetTeamData, SetMemberPermissions], + _copy = fromList [] + } + ) + ( Just + ( (Id (fromJust (UUID.fromString "00000000-0000-0002-0000-000200000002"))), + (fromJust (readUTCTimeMillis "1864-05-09T19:12:15.962Z")) + ) + ) + UserLegalHoldDisabled ] ) (ListTruncated) @@ -1238,22 +1117,20 @@ testObject_TeamMemberList_team_19 = testObject_TeamMemberList_team_20 :: TeamMemberList testObject_TeamMemberList_team_20 = ( newTeamMemberList - ( [ TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000001"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = Nothing, - _legalHoldStatus = UserLegalHoldEnabled - }, - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000000"))), - _permissions = Permissions {_self = fromList [], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000"))), - (fromJust (readUTCTimeMillis "1864-05-08T15:41:51.601Z")) - ), - _legalHoldStatus = UserLegalHoldPending - } + ( [ mkTeamMember + (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000001"))) + (Permissions {_self = fromList [], _copy = fromList []}) + (Nothing) + UserLegalHoldEnabled, + mkTeamMember + (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000000"))) + (Permissions {_self = fromList [], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000"))), + (fromJust (readUTCTimeMillis "1864-05-08T15:41:51.601Z")) + ) + ) + UserLegalHoldPending ] ) (ListComplete) diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TeamMember_team.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TeamMember_team.hs index 432dba47f5a..395af66b78f 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TeamMember_team.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TeamMember_team.hs @@ -30,7 +30,7 @@ import Data.LegalHold import qualified Data.UUID as UUID (fromString) import GHC.Exts (IsList (fromList)) import Imports (Maybe (Just, Nothing), fromJust) -import Wire.API.Team.Member (TeamMember (..)) +import Wire.API.Team.Member (TeamMember, mkTeamMember) import Wire.API.Team.Permission ( Perm ( AddTeamMember, @@ -52,340 +52,316 @@ import Wire.API.Team.Permission testObject_TeamMember_team_1 :: TeamMember testObject_TeamMember_team_1 = - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000007-0000-0005-0000-000500000002"))), - _permissions = - Permissions - { _self = fromList [GetBilling, GetMemberPermissions, SetMemberPermissions, DeleteTeam], - _copy = fromList [GetBilling] - }, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000001-0000-0003-0000-000300000004"))), - (fromJust (readUTCTimeMillis "1864-05-12T22:05:34.634Z")) - ), - _legalHoldStatus = UserLegalHoldPending - } + mkTeamMember + (Id (fromJust (UUID.fromString "00000007-0000-0005-0000-000500000002"))) + ( Permissions + { _self = fromList [GetBilling, GetMemberPermissions, SetMemberPermissions, DeleteTeam], + _copy = fromList [GetBilling] + } + ) + ( Just + ( (Id (fromJust (UUID.fromString "00000001-0000-0003-0000-000300000004"))), + (fromJust (readUTCTimeMillis "1864-05-12T22:05:34.634Z")) + ) + ) + UserLegalHoldPending testObject_TeamMember_team_2 :: TeamMember testObject_TeamMember_team_2 = - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000003-0000-0000-0000-000500000005"))), - _permissions = - Permissions {_self = fromList [DoNotUseDeprecatedModifyConvName, SetMemberPermissions], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000004"))), - (fromJust (readUTCTimeMillis "1864-05-03T14:56:52.508Z")) - ), - _legalHoldStatus = UserLegalHoldDisabled - } + mkTeamMember + (Id (fromJust (UUID.fromString "00000003-0000-0000-0000-000500000005"))) + (Permissions {_self = fromList [DoNotUseDeprecatedModifyConvName, SetMemberPermissions], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000004"))), + (fromJust (readUTCTimeMillis "1864-05-03T14:56:52.508Z")) + ) + ) + (UserLegalHoldDisabled) testObject_TeamMember_team_3 :: TeamMember testObject_TeamMember_team_3 = - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000005-0000-0003-0000-000400000003"))), - _permissions = - Permissions - { _self = - fromList - [DoNotUseDeprecatedDeleteConversation, AddTeamMember, DoNotUseDeprecatedAddRemoveConvMember, GetBilling], - _copy = fromList [GetBilling] - }, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000000-0000-0005-0000-000200000007"))), - (fromJust (readUTCTimeMillis "1864-05-06T14:02:04.371Z")) - ), - _legalHoldStatus = UserLegalHoldPending - } + mkTeamMember + (Id (fromJust (UUID.fromString "00000005-0000-0003-0000-000400000003"))) + ( Permissions + { _self = + fromList + [DoNotUseDeprecatedDeleteConversation, AddTeamMember, DoNotUseDeprecatedAddRemoveConvMember, GetBilling], + _copy = fromList [GetBilling] + } + ) + ( Just + ( (Id (fromJust (UUID.fromString "00000000-0000-0005-0000-000200000007"))), + (fromJust (readUTCTimeMillis "1864-05-06T14:02:04.371Z")) + ) + ) + (UserLegalHoldPending) testObject_TeamMember_team_4 :: TeamMember testObject_TeamMember_team_4 = - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000008-0000-0005-0000-000100000006"))), - _permissions = - Permissions - { _self = fromList [DoNotUseDeprecatedModifyConvName, SetMemberPermissions], - _copy = fromList [SetMemberPermissions] - }, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000006-0000-0002-0000-000500000001"))), - (fromJust (readUTCTimeMillis "1864-05-12T15:36:56.285Z")) - ), - _legalHoldStatus = UserLegalHoldEnabled - } + mkTeamMember + (Id (fromJust (UUID.fromString "00000008-0000-0005-0000-000100000006"))) + ( Permissions + { _self = fromList [DoNotUseDeprecatedModifyConvName, SetMemberPermissions], + _copy = fromList [SetMemberPermissions] + } + ) + ( Just + ( (Id (fromJust (UUID.fromString "00000006-0000-0002-0000-000500000001"))), + (fromJust (readUTCTimeMillis "1864-05-12T15:36:56.285Z")) + ) + ) + (UserLegalHoldEnabled) testObject_TeamMember_team_5 :: TeamMember testObject_TeamMember_team_5 = - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000007-0000-0000-0000-000200000001"))), - _permissions = - Permissions - { _self = fromList [DoNotUseDeprecatedDeleteConversation, GetBilling, SetBilling, GetMemberPermissions], - _copy = fromList [DoNotUseDeprecatedDeleteConversation, GetMemberPermissions] - }, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000004-0000-0002-0000-000300000007"))), - (fromJust (readUTCTimeMillis "1864-05-07T21:02:57.104Z")) - ), - _legalHoldStatus = UserLegalHoldPending - } + mkTeamMember + (Id (fromJust (UUID.fromString "00000007-0000-0000-0000-000200000001"))) + ( Permissions + { _self = fromList [DoNotUseDeprecatedDeleteConversation, GetBilling, SetBilling, GetMemberPermissions], + _copy = fromList [DoNotUseDeprecatedDeleteConversation, GetMemberPermissions] + } + ) + ( Just + ( (Id (fromJust (UUID.fromString "00000004-0000-0002-0000-000300000007"))), + (fromJust (readUTCTimeMillis "1864-05-07T21:02:57.104Z")) + ) + ) + (UserLegalHoldPending) testObject_TeamMember_team_6 :: TeamMember testObject_TeamMember_team_6 = - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000006-0000-0007-0000-000800000005"))), - _permissions = - Permissions - { _self = - fromList - [CreateConversation, AddTeamMember, DoNotUseDeprecatedAddRemoveConvMember, SetBilling, SetTeamData], - _copy = fromList [] - }, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000005-0000-0007-0000-000800000000"))), - (fromJust (readUTCTimeMillis "1864-05-09T03:11:26.909Z")) - ), - _legalHoldStatus = UserLegalHoldEnabled - } + mkTeamMember + (Id (fromJust (UUID.fromString "00000006-0000-0007-0000-000800000005"))) + ( Permissions + { _self = + fromList + [CreateConversation, AddTeamMember, DoNotUseDeprecatedAddRemoveConvMember, SetBilling, SetTeamData], + _copy = fromList [] + } + ) + ( Just + ( (Id (fromJust (UUID.fromString "00000005-0000-0007-0000-000800000000"))), + (fromJust (readUTCTimeMillis "1864-05-09T03:11:26.909Z")) + ) + ) + (UserLegalHoldEnabled) testObject_TeamMember_team_7 :: TeamMember testObject_TeamMember_team_7 = - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000007-0000-0000-0000-000200000001"))), - _permissions = - Permissions - { _self = - fromList - [ DoNotUseDeprecatedDeleteConversation, - DoNotUseDeprecatedAddRemoveConvMember, - SetBilling, - SetMemberPermissions, - GetTeamConversations - ], - _copy = fromList [] - }, - _invitation = Nothing, - _legalHoldStatus = UserLegalHoldPending - } + mkTeamMember + (Id (fromJust (UUID.fromString "00000007-0000-0000-0000-000200000001"))) + ( Permissions + { _self = + fromList + [ DoNotUseDeprecatedDeleteConversation, + DoNotUseDeprecatedAddRemoveConvMember, + SetBilling, + SetMemberPermissions, + GetTeamConversations + ], + _copy = fromList [] + } + ) + (Nothing) + (UserLegalHoldPending) testObject_TeamMember_team_8 :: TeamMember testObject_TeamMember_team_8 = - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000005-0000-0007-0000-000300000000"))), - _permissions = - Permissions - { _self = - fromList - [ DoNotUseDeprecatedAddRemoveConvMember, - DoNotUseDeprecatedModifyConvName, - SetTeamData, - SetMemberPermissions, - DeleteTeam - ], - _copy = fromList [] - }, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000007-0000-0003-0000-000400000003"))), - (fromJust (readUTCTimeMillis "1864-05-05T18:40:11.956Z")) - ), - _legalHoldStatus = UserLegalHoldDisabled - } + mkTeamMember + (Id (fromJust (UUID.fromString "00000005-0000-0007-0000-000300000000"))) + ( Permissions + { _self = + fromList + [ DoNotUseDeprecatedAddRemoveConvMember, + DoNotUseDeprecatedModifyConvName, + SetTeamData, + SetMemberPermissions, + DeleteTeam + ], + _copy = fromList [] + } + ) + ( Just + ( (Id (fromJust (UUID.fromString "00000007-0000-0003-0000-000400000003"))), + (fromJust (readUTCTimeMillis "1864-05-05T18:40:11.956Z")) + ) + ) + (UserLegalHoldDisabled) testObject_TeamMember_team_9 :: TeamMember testObject_TeamMember_team_9 = - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000008-0000-0006-0000-000300000003"))), - _permissions = - Permissions - { _self = fromList [AddTeamMember, DoNotUseDeprecatedModifyConvName], - _copy = fromList [DoNotUseDeprecatedModifyConvName] - }, - _invitation = Nothing, - _legalHoldStatus = UserLegalHoldPending - } + mkTeamMember + (Id (fromJust (UUID.fromString "00000008-0000-0006-0000-000300000003"))) + ( Permissions + { _self = fromList [AddTeamMember, DoNotUseDeprecatedModifyConvName], + _copy = fromList [DoNotUseDeprecatedModifyConvName] + } + ) + (Nothing) + (UserLegalHoldPending) testObject_TeamMember_team_10 :: TeamMember testObject_TeamMember_team_10 = - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000002-0000-0000-0000-000100000006"))), - _permissions = - Permissions {_self = fromList [DoNotUseDeprecatedDeleteConversation, AddTeamMember], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000008-0000-0005-0000-000000000002"))), - (fromJust (readUTCTimeMillis "1864-05-03T19:02:13.669Z")) - ), - _legalHoldStatus = UserLegalHoldDisabled - } + mkTeamMember + (Id (fromJust (UUID.fromString "00000002-0000-0000-0000-000100000006"))) + (Permissions {_self = fromList [DoNotUseDeprecatedDeleteConversation, AddTeamMember], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000008-0000-0005-0000-000000000002"))), + (fromJust (readUTCTimeMillis "1864-05-03T19:02:13.669Z")) + ) + ) + (UserLegalHoldDisabled) testObject_TeamMember_team_11 :: TeamMember testObject_TeamMember_team_11 = - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000004-0000-0001-0000-000400000007"))), - _permissions = - Permissions - { _self = - fromList [CreateConversation, DoNotUseDeprecatedDeleteConversation, SetTeamData, SetMemberPermissions], - _copy = fromList [] - }, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000003-0000-0001-0000-000100000005"))), - (fromJust (readUTCTimeMillis "1864-05-04T18:20:29.420Z")) - ), - _legalHoldStatus = UserLegalHoldEnabled - } + mkTeamMember + (Id (fromJust (UUID.fromString "00000004-0000-0001-0000-000400000007"))) + ( Permissions + { _self = + fromList [CreateConversation, DoNotUseDeprecatedDeleteConversation, SetTeamData, SetMemberPermissions], + _copy = fromList [] + } + ) + ( Just + ( (Id (fromJust (UUID.fromString "00000003-0000-0001-0000-000100000005"))), + (fromJust (readUTCTimeMillis "1864-05-04T18:20:29.420Z")) + ) + ) + (UserLegalHoldEnabled) testObject_TeamMember_team_12 :: TeamMember testObject_TeamMember_team_12 = - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000002-0000-0006-0000-000200000005"))), - _permissions = Permissions {_self = fromList [GetTeamConversations], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000005-0000-0001-0000-000300000003"))), - (fromJust (readUTCTimeMillis "1864-05-10T22:34:18.259Z")) - ), - _legalHoldStatus = UserLegalHoldPending - } + mkTeamMember + (Id (fromJust (UUID.fromString "00000002-0000-0006-0000-000200000005"))) + (Permissions {_self = fromList [GetTeamConversations], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000005-0000-0001-0000-000300000003"))), + (fromJust (readUTCTimeMillis "1864-05-10T22:34:18.259Z")) + ) + ) + (UserLegalHoldPending) testObject_TeamMember_team_13 :: TeamMember testObject_TeamMember_team_13 = - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000006-0000-0001-0000-000800000006"))), - _permissions = - Permissions {_self = fromList [CreateConversation, GetMemberPermissions], _copy = fromList [CreateConversation]}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000000-0000-0003-0000-000400000007"))), - (fromJust (readUTCTimeMillis "1864-05-06T08:18:27.514Z")) - ), - _legalHoldStatus = UserLegalHoldDisabled - } + mkTeamMember + (Id (fromJust (UUID.fromString "00000006-0000-0001-0000-000800000006"))) + (Permissions {_self = fromList [CreateConversation, GetMemberPermissions], _copy = fromList [CreateConversation]}) + ( Just + ( (Id (fromJust (UUID.fromString "00000000-0000-0003-0000-000400000007"))), + (fromJust (readUTCTimeMillis "1864-05-06T08:18:27.514Z")) + ) + ) + (UserLegalHoldDisabled) testObject_TeamMember_team_14 :: TeamMember testObject_TeamMember_team_14 = - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000004-0000-0000-0000-000300000007"))), - _permissions = - Permissions - { _self = fromList [DoNotUseDeprecatedDeleteConversation, AddTeamMember, GetBilling, GetMemberPermissions], - _copy = fromList [GetBilling, GetMemberPermissions] - }, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000008-0000-0000-0000-000200000002"))), - (fromJust (readUTCTimeMillis "1864-05-12T15:53:41.144Z")) - ), - _legalHoldStatus = UserLegalHoldDisabled - } + mkTeamMember + (Id (fromJust (UUID.fromString "00000004-0000-0000-0000-000300000007"))) + ( Permissions + { _self = fromList [DoNotUseDeprecatedDeleteConversation, AddTeamMember, GetBilling, GetMemberPermissions], + _copy = fromList [GetBilling, GetMemberPermissions] + } + ) + ( Just + ( (Id (fromJust (UUID.fromString "00000008-0000-0000-0000-000200000002"))), + (fromJust (readUTCTimeMillis "1864-05-12T15:53:41.144Z")) + ) + ) + (UserLegalHoldDisabled) testObject_TeamMember_team_15 :: TeamMember testObject_TeamMember_team_15 = - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000005-0000-0006-0000-000800000006"))), - _permissions = Permissions {_self = fromList [DeleteTeam], _copy = fromList [DeleteTeam]}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000008-0000-0000-0000-000500000003"))), - (fromJust (readUTCTimeMillis "1864-05-04T06:15:13.870Z")) - ), - _legalHoldStatus = UserLegalHoldEnabled - } + mkTeamMember + (Id (fromJust (UUID.fromString "00000005-0000-0006-0000-000800000006"))) + (Permissions {_self = fromList [DeleteTeam], _copy = fromList [DeleteTeam]}) + ( Just + ( (Id (fromJust (UUID.fromString "00000008-0000-0000-0000-000500000003"))), + (fromJust (readUTCTimeMillis "1864-05-04T06:15:13.870Z")) + ) + ) + (UserLegalHoldEnabled) testObject_TeamMember_team_16 :: TeamMember testObject_TeamMember_team_16 = - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000000-0000-0008-0000-000200000008"))), - _permissions = - Permissions {_self = fromList [DoNotUseDeprecatedDeleteConversation, GetTeamConversations], _copy = fromList []}, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000006-0000-0000-0000-000400000002"))), - (fromJust (readUTCTimeMillis "1864-05-10T04:27:37.101Z")) - ), - _legalHoldStatus = UserLegalHoldPending - } + mkTeamMember + (Id (fromJust (UUID.fromString "00000000-0000-0008-0000-000200000008"))) + (Permissions {_self = fromList [DoNotUseDeprecatedDeleteConversation, GetTeamConversations], _copy = fromList []}) + ( Just + ( (Id (fromJust (UUID.fromString "00000006-0000-0000-0000-000400000002"))), + (fromJust (readUTCTimeMillis "1864-05-10T04:27:37.101Z")) + ) + ) + (UserLegalHoldPending) testObject_TeamMember_team_17 :: TeamMember testObject_TeamMember_team_17 = - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000006-0000-0006-0000-000500000007"))), - _permissions = - Permissions - { _self = - fromList - [ DoNotUseDeprecatedAddRemoveConvMember, - DoNotUseDeprecatedModifyConvName, - GetBilling, - SetTeamData, - GetTeamConversations - ], - _copy = fromList [DoNotUseDeprecatedAddRemoveConvMember] - }, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000006-0000-0003-0000-000700000004"))), - (fromJust (readUTCTimeMillis "1864-05-07T23:22:37.991Z")) - ), - _legalHoldStatus = UserLegalHoldDisabled - } + mkTeamMember + (Id (fromJust (UUID.fromString "00000006-0000-0006-0000-000500000007"))) + ( Permissions + { _self = + fromList + [ DoNotUseDeprecatedAddRemoveConvMember, + DoNotUseDeprecatedModifyConvName, + GetBilling, + SetTeamData, + GetTeamConversations + ], + _copy = fromList [DoNotUseDeprecatedAddRemoveConvMember] + } + ) + ( Just + ( (Id (fromJust (UUID.fromString "00000006-0000-0003-0000-000700000004"))), + (fromJust (readUTCTimeMillis "1864-05-07T23:22:37.991Z")) + ) + ) + (UserLegalHoldDisabled) testObject_TeamMember_team_18 :: TeamMember testObject_TeamMember_team_18 = - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000005-0000-0005-0000-000200000008"))), - _permissions = - Permissions - { _self = - fromList [RemoveTeamMember, DoNotUseDeprecatedModifyConvName, GetMemberPermissions, SetMemberPermissions], - _copy = fromList [SetMemberPermissions] - }, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000007-0000-0008-0000-000500000006"))), - (fromJust (readUTCTimeMillis "1864-05-15T14:48:55.847Z")) - ), - _legalHoldStatus = UserLegalHoldPending - } + mkTeamMember + (Id (fromJust (UUID.fromString "00000005-0000-0005-0000-000200000008"))) + ( Permissions + { _self = + fromList [RemoveTeamMember, DoNotUseDeprecatedModifyConvName, GetMemberPermissions, SetMemberPermissions], + _copy = fromList [SetMemberPermissions] + } + ) + ( Just + ( (Id (fromJust (UUID.fromString "00000007-0000-0008-0000-000500000006"))), + (fromJust (readUTCTimeMillis "1864-05-15T14:48:55.847Z")) + ) + ) + (UserLegalHoldPending) testObject_TeamMember_team_19 :: TeamMember testObject_TeamMember_team_19 = - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000003-0000-0002-0000-000200000008"))), - _permissions = - Permissions - { _self = - fromList [AddTeamMember, DoNotUseDeprecatedModifyConvName, GetBilling, SetBilling, SetMemberPermissions], - _copy = fromList [SetMemberPermissions] - }, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000006-0000-0001-0000-000200000008"))), - (fromJust (readUTCTimeMillis "1864-05-12T01:37:35.003Z")) - ), - _legalHoldStatus = UserLegalHoldPending - } + mkTeamMember + (Id (fromJust (UUID.fromString "00000003-0000-0002-0000-000200000008"))) + ( Permissions + { _self = + fromList [AddTeamMember, DoNotUseDeprecatedModifyConvName, GetBilling, SetBilling, SetMemberPermissions], + _copy = fromList [SetMemberPermissions] + } + ) + ( Just + ( (Id (fromJust (UUID.fromString "00000006-0000-0001-0000-000200000008"))), + (fromJust (readUTCTimeMillis "1864-05-12T01:37:35.003Z")) + ) + ) + (UserLegalHoldPending) testObject_TeamMember_team_20 :: TeamMember testObject_TeamMember_team_20 = - TeamMember - { _userId = (Id (fromJust (UUID.fromString "00000005-0000-0007-0000-000100000005"))), - _permissions = - Permissions - { _self = fromList [CreateConversation, AddTeamMember, DoNotUseDeprecatedModifyConvName, GetBilling], - _copy = fromList [] - }, - _invitation = - Just - ( (Id (fromJust (UUID.fromString "00000005-0000-0001-0000-000800000007"))), - (fromJust (readUTCTimeMillis "1864-05-04T22:12:50.096Z")) - ), - _legalHoldStatus = UserLegalHoldEnabled - } + mkTeamMember + (Id (fromJust (UUID.fromString "00000005-0000-0007-0000-000100000005"))) + ( Permissions + { _self = fromList [CreateConversation, AddTeamMember, DoNotUseDeprecatedModifyConvName, GetBilling], + _copy = fromList [] + } + ) + ( Just + ( (Id (fromJust (UUID.fromString "00000005-0000-0001-0000-000800000007"))), + (fromJust (readUTCTimeMillis "1864-05-04T22:12:50.096Z")) + ) + ) + (UserLegalHoldEnabled) 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 e4daf3da24b..5416af10400 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 @@ -19,11 +19,10 @@ module Test.Wire.API.Golden.Generator where import Data.Id import Imports -import System.IO (Handle, hPutStr, hPutStrLn, openFile) +import System.IO (Handle, hPutStr, hPutStrLn) import Test.Tasty.QuickCheck (Arbitrary (..), generate) import Type.Reflection (typeRep) import qualified Wire.API.Asset as Asset -import qualified Wire.API.Asset.V3.Resumable as Asset.Resumable import qualified Wire.API.Call.Config as Call.Config import qualified Wire.API.Connection as Connection import qualified Wire.API.Conversation as Conversation @@ -136,11 +135,6 @@ generateTestModule = do generateBindingModule @Asset.AssetRetention "user" ref generateBindingModule @Asset.AssetSettings "user" ref generateBindingModule @Asset.AssetKey "user" ref - generateBindingModule @Asset.Resumable.ResumableSettings "user" ref - generateBindingModule @Asset.Resumable.TotalSize "user" ref - generateBindingModule @Asset.Resumable.ChunkSize "user" ref - generateBindingModule @Asset.Resumable.Offset "user" ref - generateBindingModule @Asset.Resumable.ResumableAsset "user" ref generateBindingModule @Call.Config.TurnHost "user" ref generateBindingModule @Call.Config.Scheme "user" ref generateBindingModule @Call.Config.Transport "user" ref diff --git a/libs/wire-api/test/golden/testObject_Asset_asset_1.json b/libs/wire-api/test/golden/testObject_Asset_asset_1.json index 9bef9870da2..d4f078bbfb5 100644 --- a/libs/wire-api/test/golden/testObject_Asset_asset_1.json +++ b/libs/wire-api/test/golden/testObject_Asset_asset_1.json @@ -1,4 +1,5 @@ { + "domain": "example.com", "expires": "1864-04-30T15:58:55.452Z", "key": "3-5-0000004b-0000-0017-0000-003e00000033", "token": "Kun4JaxR6QuASXywDhzx" diff --git a/libs/wire-api/test/golden/testObject_Asset_asset_10.json b/libs/wire-api/test/golden/testObject_Asset_asset_10.json index 1d25e3b58cd..c495e0a86cb 100644 --- a/libs/wire-api/test/golden/testObject_Asset_asset_10.json +++ b/libs/wire-api/test/golden/testObject_Asset_asset_10.json @@ -1,3 +1,4 @@ { + "domain": "example.com", "key": "3-1-00000065-0000-0080-0000-003400000061" } diff --git a/libs/wire-api/test/golden/testObject_Asset_asset_11.json b/libs/wire-api/test/golden/testObject_Asset_asset_11.json index d6e74f8e6ee..2b6ee63fdd3 100644 --- a/libs/wire-api/test/golden/testObject_Asset_asset_11.json +++ b/libs/wire-api/test/golden/testObject_Asset_asset_11.json @@ -1,4 +1,5 @@ { + "domain": "example.com", "expires": "1864-05-11T16:58:59.746Z", "key": "3-4-00000014-0000-0077-0000-001e00000076", "token": "DnlRW9Q=" diff --git a/libs/wire-api/test/golden/testObject_Asset_asset_12.json b/libs/wire-api/test/golden/testObject_Asset_asset_12.json index eda1a4fdd6d..85bd8fd2660 100644 --- a/libs/wire-api/test/golden/testObject_Asset_asset_12.json +++ b/libs/wire-api/test/golden/testObject_Asset_asset_12.json @@ -1,3 +1,4 @@ { + "domain": "example.com", "key": "3-2-0000001d-0000-0076-0000-003800000021" } diff --git a/libs/wire-api/test/golden/testObject_Asset_asset_13.json b/libs/wire-api/test/golden/testObject_Asset_asset_13.json index 8e07a56197e..2ac23c24eb5 100644 --- a/libs/wire-api/test/golden/testObject_Asset_asset_13.json +++ b/libs/wire-api/test/golden/testObject_Asset_asset_13.json @@ -1,4 +1,5 @@ { + "domain": "example.com", "expires": "1864-04-30T19:37:57.302Z", "key": "3-4-00000030-0000-0036-0000-003c0000000a", "token": "n7CJBcdOSKznRmOypWXsGfEE0g==" diff --git a/libs/wire-api/test/golden/testObject_Asset_asset_14.json b/libs/wire-api/test/golden/testObject_Asset_asset_14.json index 442e5562469..a70a668bc8b 100644 --- a/libs/wire-api/test/golden/testObject_Asset_asset_14.json +++ b/libs/wire-api/test/golden/testObject_Asset_asset_14.json @@ -1,4 +1,5 @@ { + "domain": "example.com", "expires": "1864-05-06T09:09:55.146Z", "key": "3-4-00000047-0000-0012-0000-005500000062", "token": "LYfUg4qlMjw=" diff --git a/libs/wire-api/test/golden/testObject_Asset_asset_15.json b/libs/wire-api/test/golden/testObject_Asset_asset_15.json index f49cd13e46a..770067088cd 100644 --- a/libs/wire-api/test/golden/testObject_Asset_asset_15.json +++ b/libs/wire-api/test/golden/testObject_Asset_asset_15.json @@ -1,3 +1,4 @@ { + "domain": "example.com", "key": "3-2-00000030-0000-0074-0000-00660000004c" } diff --git a/libs/wire-api/test/golden/testObject_Asset_asset_16.json b/libs/wire-api/test/golden/testObject_Asset_asset_16.json index 69e6e5f1816..bf6597141cf 100644 --- a/libs/wire-api/test/golden/testObject_Asset_asset_16.json +++ b/libs/wire-api/test/golden/testObject_Asset_asset_16.json @@ -1,4 +1,5 @@ { + "domain": "example.com", "expires": "1864-05-04T02:19:12.520Z", "key": "3-3-00000048-0000-0051-0000-005d00000070" } diff --git a/libs/wire-api/test/golden/testObject_Asset_asset_17.json b/libs/wire-api/test/golden/testObject_Asset_asset_17.json index ccb77a2d1c5..5a4e7a4811f 100644 --- a/libs/wire-api/test/golden/testObject_Asset_asset_17.json +++ b/libs/wire-api/test/golden/testObject_Asset_asset_17.json @@ -1,4 +1,5 @@ { + "domain": "example.com", "expires": "1864-04-09T17:00:39.763Z", "key": "3-2-00000017-0000-000d-0000-00680000003e" } diff --git a/libs/wire-api/test/golden/testObject_Asset_asset_18.json b/libs/wire-api/test/golden/testObject_Asset_asset_18.json index 516f95363ff..8f02aeae56c 100644 --- a/libs/wire-api/test/golden/testObject_Asset_asset_18.json +++ b/libs/wire-api/test/golden/testObject_Asset_asset_18.json @@ -1,4 +1,5 @@ { + "domain": "example.com", "expires": "1864-04-12T20:53:21.250Z", "key": "3-1-0000003e-0000-0032-0000-004d00000070" } diff --git a/libs/wire-api/test/golden/testObject_Asset_asset_19.json b/libs/wire-api/test/golden/testObject_Asset_asset_19.json index 4b62e85e30c..c8ea25d227f 100644 --- a/libs/wire-api/test/golden/testObject_Asset_asset_19.json +++ b/libs/wire-api/test/golden/testObject_Asset_asset_19.json @@ -1,4 +1,5 @@ { + "domain": "example.com", "key": "3-3-00000021-0000-0062-0000-002a0000006b", "token": "4wm3D03aqvZ_0oKFtwXCYnSTC7m_z1E=" } diff --git a/libs/wire-api/test/golden/testObject_Asset_asset_2.json b/libs/wire-api/test/golden/testObject_Asset_asset_2.json index 3a8d556bd57..a4e0765c06c 100644 --- a/libs/wire-api/test/golden/testObject_Asset_asset_2.json +++ b/libs/wire-api/test/golden/testObject_Asset_asset_2.json @@ -1,4 +1,5 @@ { + "domain": "example.com", "expires": "1864-06-04T17:39:43.924Z", "key": "3-4-00000008-0000-006c-0000-001900000036", "token": "mPuul678vuJVZ_u9lQ==" diff --git a/libs/wire-api/test/golden/testObject_Asset_asset_20.json b/libs/wire-api/test/golden/testObject_Asset_asset_20.json index ee08bfe6d13..3cd958cedc2 100644 --- a/libs/wire-api/test/golden/testObject_Asset_asset_20.json +++ b/libs/wire-api/test/golden/testObject_Asset_asset_20.json @@ -1,4 +1,5 @@ { + "domain": "example.com", "expires": "1864-04-25T16:48:39.986Z", "key": "3-3-00000053-0000-0072-0000-001700000047" } diff --git a/libs/wire-api/test/golden/testObject_Asset_asset_3.json b/libs/wire-api/test/golden/testObject_Asset_asset_3.json index eb3537825f3..13b90b2b057 100644 --- a/libs/wire-api/test/golden/testObject_Asset_asset_3.json +++ b/libs/wire-api/test/golden/testObject_Asset_asset_3.json @@ -1,4 +1,5 @@ { + "domain": "example.com", "expires": "1864-05-18T20:18:13.438Z", "key": "3-1-00000055-0000-0071-0000-002e00000020" } diff --git a/libs/wire-api/test/golden/testObject_Asset_asset_4.json b/libs/wire-api/test/golden/testObject_Asset_asset_4.json index d43de9f1101..fc65d82c3c0 100644 --- a/libs/wire-api/test/golden/testObject_Asset_asset_4.json +++ b/libs/wire-api/test/golden/testObject_Asset_asset_4.json @@ -1,4 +1,5 @@ { + "domain": "example.com", "key": "3-4-00000063-0000-0044-0000-003000000059", "token": "IRKruiPSiANiX1fL" } diff --git a/libs/wire-api/test/golden/testObject_Asset_asset_5.json b/libs/wire-api/test/golden/testObject_Asset_asset_5.json index 0bd2857635e..37a8a6a8dc7 100644 --- a/libs/wire-api/test/golden/testObject_Asset_asset_5.json +++ b/libs/wire-api/test/golden/testObject_Asset_asset_5.json @@ -1,4 +1,5 @@ { + "domain": "example.com", "expires": "1864-05-11T14:38:25.874Z", "key": "3-3-00000019-0000-005b-0000-001d00000056", "token": "BrbiaM1RxJlqjlqq7quuPSc=" diff --git a/libs/wire-api/test/golden/testObject_Asset_asset_6.json b/libs/wire-api/test/golden/testObject_Asset_asset_6.json index 8d9571f2dc1..506b8af9ecc 100644 --- a/libs/wire-api/test/golden/testObject_Asset_asset_6.json +++ b/libs/wire-api/test/golden/testObject_Asset_asset_6.json @@ -1,4 +1,5 @@ { + "domain": "example.com", "expires": "1864-05-25T01:19:16.676Z", "key": "3-2-0000000e-0000-0046-0000-00560000005e" } diff --git a/libs/wire-api/test/golden/testObject_Asset_asset_7.json b/libs/wire-api/test/golden/testObject_Asset_asset_7.json index b97f270a807..5d9fd890b0b 100644 --- a/libs/wire-api/test/golden/testObject_Asset_asset_7.json +++ b/libs/wire-api/test/golden/testObject_Asset_asset_7.json @@ -1,4 +1,5 @@ { + "domain": "example.com", "expires": "1864-04-14T08:45:43.050Z", "key": "3-1-00000013-0000-002e-0000-003000000042", "token": "_N9ERJGmbZtd6XlW_6O12bxuNe4=" diff --git a/libs/wire-api/test/golden/testObject_Asset_asset_8.json b/libs/wire-api/test/golden/testObject_Asset_asset_8.json index 434d93f714c..e23c34c5439 100644 --- a/libs/wire-api/test/golden/testObject_Asset_asset_8.json +++ b/libs/wire-api/test/golden/testObject_Asset_asset_8.json @@ -1,3 +1,4 @@ { + "domain": "example.com", "key": "3-1-00000073-0000-003e-0000-00120000000c" } diff --git a/libs/wire-api/test/golden/testObject_Asset_asset_9.json b/libs/wire-api/test/golden/testObject_Asset_asset_9.json index 5e7097dcd98..5c33c2d979f 100644 --- a/libs/wire-api/test/golden/testObject_Asset_asset_9.json +++ b/libs/wire-api/test/golden/testObject_Asset_asset_9.json @@ -1,4 +1,5 @@ { + "domain": "example.com", "expires": "1864-05-21T01:34:09.726Z", "key": "3-2-00000006-0000-004b-0000-004f00000025" } diff --git a/libs/wire-api/test/golden/testObject_ChunkSize_user_1.json b/libs/wire-api/test/golden/testObject_ChunkSize_user_1.json deleted file mode 100644 index 98d9bcb75a6..00000000000 --- a/libs/wire-api/test/golden/testObject_ChunkSize_user_1.json +++ /dev/null @@ -1 +0,0 @@ -17 diff --git a/libs/wire-api/test/golden/testObject_Offset_user_1.json b/libs/wire-api/test/golden/testObject_Offset_user_1.json deleted file mode 100644 index d00491fd7e5..00000000000 --- a/libs/wire-api/test/golden/testObject_Offset_user_1.json +++ /dev/null @@ -1 +0,0 @@ -1 diff --git a/libs/wire-api/test/golden/testObject_RTCConfiguration_user_7.json b/libs/wire-api/test/golden/testObject_RTCConfiguration_user_7.json new file mode 100644 index 00000000000..8e9fa8b7808 --- /dev/null +++ b/libs/wire-api/test/golden/testObject_RTCConfiguration_user_7.json @@ -0,0 +1,22 @@ +{ + "ice_servers": [ + { + "credential": "", + "urls": [ + "turns:248.187.155.126:1", + "turn:166.155.90.230:0?transport=tcp", + "turns:xn--mgbh0fb.xn--kgbechtv:1?transport=tcp", + "turn:host.name:1?transport=tcp" + ], + "username": "d=2.v=0.k=0.t=󷁝.r=tj" + } + ], + "sft_servers_all": [ + { + "urls": [ + "https://example.com" + ] + } + ], + "ttl": 2 +} diff --git a/libs/wire-api/test/golden/testObject_ResumableAsset_user_1.json b/libs/wire-api/test/golden/testObject_ResumableAsset_user_1.json deleted file mode 100644 index b31ce6ad354..00000000000 --- a/libs/wire-api/test/golden/testObject_ResumableAsset_user_1.json +++ /dev/null @@ -1,9 +0,0 @@ -{ - "asset": { - "expires": "1864-04-13T11:37:47.393Z", - "key": "3-5-00000010-0000-0008-0000-004300000006", - "token": "5A==" - }, - "chunk_size": 17, - "expires": "1864-04-09T06:01:25.576Z" -} diff --git a/libs/wire-api/test/golden/testObject_ResumableSettings_user_1.json b/libs/wire-api/test/golden/testObject_ResumableSettings_user_1.json deleted file mode 100644 index 6fe2dd17d1f..00000000000 --- a/libs/wire-api/test/golden/testObject_ResumableSettings_user_1.json +++ /dev/null @@ -1,5 +0,0 @@ -{ - "public": false, - "retention": "expiring", - "type": "image/png" -} diff --git a/libs/wire-api/test/golden/testObject_ResumableSettings_user_17.json b/libs/wire-api/test/golden/testObject_ResumableSettings_user_17.json deleted file mode 100644 index 462ed70e3eb..00000000000 --- a/libs/wire-api/test/golden/testObject_ResumableSettings_user_17.json +++ /dev/null @@ -1,5 +0,0 @@ -{ - "public": true, - "retention": "volatile", - "type": "image/png" -} diff --git a/libs/wire-api/test/golden/testObject_ResumableSettings_user_2.json b/libs/wire-api/test/golden/testObject_ResumableSettings_user_2.json deleted file mode 100644 index 8223d85e2dd..00000000000 --- a/libs/wire-api/test/golden/testObject_ResumableSettings_user_2.json +++ /dev/null @@ -1,5 +0,0 @@ -{ - "public": true, - "retention": "eternal", - "type": "image/png" -} diff --git a/libs/wire-api/test/golden/testObject_ResumableSettings_user_4.json b/libs/wire-api/test/golden/testObject_ResumableSettings_user_4.json deleted file mode 100644 index 7b059d3d67e..00000000000 --- a/libs/wire-api/test/golden/testObject_ResumableSettings_user_4.json +++ /dev/null @@ -1,5 +0,0 @@ -{ - "public": true, - "retention": "eternal-infrequent_access", - "type": "image/png" -} diff --git a/libs/wire-api/test/golden/testObject_ResumableSettings_user_5.json b/libs/wire-api/test/golden/testObject_ResumableSettings_user_5.json deleted file mode 100644 index 13648db881b..00000000000 --- a/libs/wire-api/test/golden/testObject_ResumableSettings_user_5.json +++ /dev/null @@ -1,5 +0,0 @@ -{ - "public": false, - "retention": "persistent", - "type": "image/png" -} diff --git a/libs/wire-api/test/golden/testObject_TotalSize_user_1.json b/libs/wire-api/test/golden/testObject_TotalSize_user_1.json deleted file mode 100644 index ec635144f60..00000000000 --- a/libs/wire-api/test/golden/testObject_TotalSize_user_1.json +++ /dev/null @@ -1 +0,0 @@ -9 diff --git a/libs/wire-api/test/golden/testObject_UserIdentity_user_16.json b/libs/wire-api/test/golden/testObject_UserIdentity_user_16.json deleted file mode 100644 index 156ade504d6..00000000000 --- a/libs/wire-api/test/golden/testObject_UserIdentity_user_16.json +++ /dev/null @@ -1,8 +0,0 @@ -{ - "email": "%x\u0013􀔑\u0004.@G빯t.6", - "phone": "+298116118047", - "sso_id": { - "subject": "me@example.com", - "tenant": "http://example.com" - } -} diff --git a/libs/wire-api/test/golden/testObject_UserIdentity_user_5.json b/libs/wire-api/test/golden/testObject_UserIdentity_user_5.json deleted file mode 100644 index 902e47fbe87..00000000000 --- a/libs/wire-api/test/golden/testObject_UserIdentity_user_5.json +++ /dev/null @@ -1,8 +0,0 @@ -{ - "email": null, - "phone": "+49198172826", - "sso_id": { - "subject": "me@example.com", - "tenant": "http://example.com" - } -} diff --git a/libs/wire-api/test/golden/testObject_UserIdentity_user_8.json b/libs/wire-api/test/golden/testObject_UserIdentity_user_8.json deleted file mode 100644 index f9a46004b6f..00000000000 --- a/libs/wire-api/test/golden/testObject_UserIdentity_user_8.json +++ /dev/null @@ -1,8 +0,0 @@ -{ - "email": null, - "phone": "+149548802116267", - "sso_id": { - "subject": "me@example.com", - "tenant": "http://example.com" - } -} diff --git a/libs/wire-api/test/golden/testObject_UserSSOId_user_1.json b/libs/wire-api/test/golden/testObject_UserSSOId_user_1.json deleted file mode 100644 index 520bcfc7dad..00000000000 --- a/libs/wire-api/test/golden/testObject_UserSSOId_user_1.json +++ /dev/null @@ -1,4 +0,0 @@ -{ - "subject": "𝢱􁱝S\u0006\\\u0017\\", - "tenant": "#ph􀽌" -} diff --git a/libs/wire-api/test/golden/testObject_UserSSOId_user_10.json b/libs/wire-api/test/golden/testObject_UserSSOId_user_10.json deleted file mode 100644 index 269300657d1..00000000000 --- a/libs/wire-api/test/golden/testObject_UserSSOId_user_10.json +++ /dev/null @@ -1,4 +0,0 @@ -{ - "subject": "􀞢^}Y7A\u0014󰐺\u001bF", - "tenant": "oo\"u/]5" -} diff --git a/libs/wire-api/test/golden/testObject_UserSSOId_user_11.json b/libs/wire-api/test/golden/testObject_UserSSOId_user_11.json deleted file mode 100644 index 46b703e246b..00000000000 --- a/libs/wire-api/test/golden/testObject_UserSSOId_user_11.json +++ /dev/null @@ -1,3 +0,0 @@ -{ - "scim_external_id": "U㞠\u00129[𮥂z􆔇ⵍ􎹘#~􀐽D\u0003[􏈫u𦷊h똶㕠2 c4􄯇\u000e" -} diff --git a/libs/wire-api/test/golden/testObject_UserSSOId_user_12.json b/libs/wire-api/test/golden/testObject_UserSSOId_user_12.json deleted file mode 100644 index db68edf1a29..00000000000 --- a/libs/wire-api/test/golden/testObject_UserSSOId_user_12.json +++ /dev/null @@ -1,4 +0,0 @@ -{ - "subject": "􏺁\u001bg𑄉", - "tenant": "\na," -} diff --git a/libs/wire-api/test/golden/testObject_UserSSOId_user_14.json b/libs/wire-api/test/golden/testObject_UserSSOId_user_14.json deleted file mode 100644 index 4d74fb56c90..00000000000 --- a/libs/wire-api/test/golden/testObject_UserSSOId_user_14.json +++ /dev/null @@ -1,4 +0,0 @@ -{ - "subject": "g\ta\u001d󳹝[a\u0013𢝝oA", - "tenant": "g􉙇)By𡑗h.\u000c\u00179@" -} diff --git a/libs/wire-api/test/golden/testObject_UserSSOId_user_15.json b/libs/wire-api/test/golden/testObject_UserSSOId_user_15.json deleted file mode 100644 index 69528cc5164..00000000000 --- a/libs/wire-api/test/golden/testObject_UserSSOId_user_15.json +++ /dev/null @@ -1,3 +0,0 @@ -{ - "scim_external_id": "a9qᩤ󶴏nM]vM\u0012t풣_'\u0010t1MJb{󼥁\u001dZC\u0006" -} diff --git a/libs/wire-api/test/golden/testObject_UserSSOId_user_16.json b/libs/wire-api/test/golden/testObject_UserSSOId_user_16.json deleted file mode 100644 index 9b9641de712..00000000000 --- a/libs/wire-api/test/golden/testObject_UserSSOId_user_16.json +++ /dev/null @@ -1,3 +0,0 @@ -{ - "scim_external_id": "Ltepz\u0006\u001c\u001c\u0000􇀶󽍉}𡃭N뫴7GJ" -} diff --git a/libs/wire-api/test/golden/testObject_UserSSOId_user_17.json b/libs/wire-api/test/golden/testObject_UserSSOId_user_17.json deleted file mode 100644 index 830c5048c44..00000000000 --- a/libs/wire-api/test/golden/testObject_UserSSOId_user_17.json +++ /dev/null @@ -1,3 +0,0 @@ -{ - "scim_external_id": "qj𤂎.^" -} diff --git a/libs/wire-api/test/golden/testObject_UserSSOId_user_18.json b/libs/wire-api/test/golden/testObject_UserSSOId_user_18.json deleted file mode 100644 index 764dfe765c5..00000000000 --- a/libs/wire-api/test/golden/testObject_UserSSOId_user_18.json +++ /dev/null @@ -1,3 +0,0 @@ -{ - "scim_external_id": "𒍧" -} diff --git a/libs/wire-api/test/golden/testObject_UserSSOId_user_19.json b/libs/wire-api/test/golden/testObject_UserSSOId_user_19.json deleted file mode 100644 index f1874f30cf6..00000000000 --- a/libs/wire-api/test/golden/testObject_UserSSOId_user_19.json +++ /dev/null @@ -1,3 +0,0 @@ -{ - "scim_external_id": "!𛉋mᅛ\u0018\u001dA\u0010󿃯𤧇x[h\n~􋁝" -} diff --git a/libs/wire-api/test/golden/testObject_UserSSOId_user_20.json b/libs/wire-api/test/golden/testObject_UserSSOId_user_20.json deleted file mode 100644 index 6476075a9dd..00000000000 --- a/libs/wire-api/test/golden/testObject_UserSSOId_user_20.json +++ /dev/null @@ -1,4 +0,0 @@ -{ - "subject": "\u0002b\u000e􇆽\u001b\u001d3,􅲈𠩀8𑿋", - "tenant": "X#\u0004 " -} diff --git a/libs/wire-api/test/golden/testObject_UserSSOId_user_3.json b/libs/wire-api/test/golden/testObject_UserSSOId_user_3.json deleted file mode 100644 index 1db46e5e7f4..00000000000 --- a/libs/wire-api/test/golden/testObject_UserSSOId_user_3.json +++ /dev/null @@ -1,4 +0,0 @@ -{ - "subject": "𨊌4X\u0019", - "tenant": "i\\\u0004\r𘑍\u0015󲛚줴Vi" -} diff --git a/libs/wire-api/test/golden/testObject_UserSSOId_user_4.json b/libs/wire-api/test/golden/testObject_UserSSOId_user_4.json deleted file mode 100644 index eb3dcf271d5..00000000000 --- a/libs/wire-api/test/golden/testObject_UserSSOId_user_4.json +++ /dev/null @@ -1,4 +0,0 @@ -{ - "subject": "􉹡0\u001b𬴯=2.14 , aeson >=0.6 , attoparsec >=0.10 - , base >=4 && <5 + , base ==4.* , base64-bytestring >=1.0 , binary , bytestring >=0.9 @@ -114,6 +154,7 @@ library , cassava >=0.5 , cereal , comonad + , conduit , containers >=0.5 , cookie , cryptonite @@ -154,6 +195,7 @@ library , servant , servant-client , servant-client-core + , servant-conduit , servant-multipart , servant-server , servant-swagger @@ -171,6 +213,8 @@ library , uuid >=1.3 , vector >=0.12 , wai + , wai-websockets + , websockets , wire-message-proto-lens , x509 default-language: Haskell2010 @@ -204,7 +248,6 @@ test-suite wire-api-golden-tests Test.Wire.API.Golden.Generated.BotConvView_provider Test.Wire.API.Golden.Generated.BotUserView_provider Test.Wire.API.Golden.Generated.CheckHandles_user - Test.Wire.API.Golden.Generated.ChunkSize_user Test.Wire.API.Golden.Generated.Client_user Test.Wire.API.Golden.Generated.ClientClass_user Test.Wire.API.Golden.Generated.ClientMismatch_user @@ -289,7 +332,6 @@ test-suite wire-api-golden-tests Test.Wire.API.Golden.Generated.NewTeamMember_team Test.Wire.API.Golden.Generated.NewUser_user Test.Wire.API.Golden.Generated.NewUserPublic_user - Test.Wire.API.Golden.Generated.Offset_user Test.Wire.API.Golden.Generated.OtherMember_user Test.Wire.API.Golden.Generated.OtherMemberUpdate_user Test.Wire.API.Golden.Generated.OtrMessage_user @@ -327,8 +369,6 @@ test-suite wire-api-golden-tests Test.Wire.API.Golden.Generated.RemoveCookies_user Test.Wire.API.Golden.Generated.RemoveLegalHoldSettingsRequest_team Test.Wire.API.Golden.Generated.RequestNewLegalHoldClient_team - Test.Wire.API.Golden.Generated.ResumableAsset_user - Test.Wire.API.Golden.Generated.ResumableSettings_user Test.Wire.API.Golden.Generated.RichField_user Test.Wire.API.Golden.Generated.RichInfo_user Test.Wire.API.Golden.Generated.RichInfoAssocList_user @@ -375,7 +415,6 @@ test-suite wire-api-golden-tests Test.Wire.API.Golden.Generated.TeamUpdateData_team Test.Wire.API.Golden.Generated.Token_user Test.Wire.API.Golden.Generated.TokenType_user - Test.Wire.API.Golden.Generated.TotalSize_user Test.Wire.API.Golden.Generated.Transport_user Test.Wire.API.Golden.Generated.TurnHost_user Test.Wire.API.Golden.Generated.TurnURI_user @@ -423,7 +462,46 @@ test-suite wire-api-golden-tests Paths_wire_api hs-source-dirs: test/golden - 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 + 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-depends: QuickCheck @@ -486,7 +564,46 @@ test-suite wire-api-tests Paths_wire_api hs-source-dirs: test/unit - 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 + 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-depends: QuickCheck diff --git a/libs/zauth/test/ZAuth.hs b/libs/zauth/test/ZAuth.hs index 43e27cac49f..65dbd8b4c83 100644 --- a/libs/zauth/test/ZAuth.hs +++ b/libs/zauth/test/ZAuth.hs @@ -93,6 +93,10 @@ testNotExpired p = do x <- liftIO $ runValidate p $ check t liftIO $ assertBool "testNotExpired: validation failed" (isRight x) +-- The testExpired test conforms to the following testing standards: +-- @SF.Channel @TSFI.RESTfulAPI @S2 @S3 +-- +-- Using an expired access token should fail testExpired :: V.Env -> Create () testExpired p = do u <- liftIO nextRandom @@ -101,6 +105,8 @@ testExpired p = do x <- liftIO $ runValidate p $ check t liftIO $ Left Expired @=? x +-- @END + testSignAndVerify :: V.Env -> Create () testSignAndVerify p = do u <- liftIO nextRandom diff --git a/libs/zauth/zauth.cabal b/libs/zauth/zauth.cabal index 0118d7a4615..921a1584f66 100644 --- a/libs/zauth/zauth.cabal +++ b/libs/zauth/zauth.cabal @@ -1,10 +1,10 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack -- --- hash: 0d38dff701f563388d036116d5f2757ae74b04eab0b7fe2f3d5bfd8ef2800628 +-- hash: 645c91889ea532ce07463edf54a10559d3f581091b53c20903607d9800f6fa3f name: zauth version: 0.10.3 @@ -30,7 +30,46 @@ library Paths_zauth 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 + 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 -funbox-strict-fields build-depends: attoparsec >=0.11 @@ -56,7 +95,46 @@ executable zauth Paths_zauth hs-source-dirs: main - 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 + 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 build-depends: base @@ -81,7 +159,46 @@ test-suite zauth-unit Paths_zauth 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 + 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 build-depends: base diff --git a/nix/overlays/wire-server.nix b/nix/overlays/wire-server.nix index 602b42059fa..9ba8ca872fb 100644 --- a/nix/overlays/wire-server.nix +++ b/nix/overlays/wire-server.nix @@ -13,7 +13,7 @@ self: super: { rev = "4067ad96b125942545dbdec8c1a89f1e1b65d013"; sha256 = "1i9dlhw0xk1viglyhail9fb36v1awrypps8jmhrkz8k1bhx98ci3"; }; - cargoSha256 = "0zs8ibv7rinrrzp9naxd7yak7kn1gp3pjb3g8i4wf7xw2hkkq81z"; + cargoSha256 = "sha256-Afr3ShCXDCwTQNdeCZbA5/aosRt+KFpGfT1mrob6cog="; patchLibs = super.lib.optionalString super.stdenv.isDarwin '' install_name_tool -id $out/lib/libcryptobox.dylib $out/lib/libcryptobox.dylib @@ -37,7 +37,7 @@ self: super: { src = self.nix-gitignore.gitignoreSourcePure [ ../../.gitignore ] ../../libs/libzauth; sourceRoot = "libzauth/libzauth-c"; - cargoSha256 = "10ijvi3rnnqpy589hhhp8s4p7xfpsbb1c3mzqnf65ra96q4nd6bf"; # self.lib.fakeSha256; + cargoSha256 = "sha256-umwOVCFHtszu64aIc8eqMPGCS7vt1nYQFAQh2XuV+v4="; # self.lib.fakeSha256; patchLibs = super.lib.optionalString super.stdenv.isDarwin '' install_name_tool -id $out/lib/libzauth.dylib $out/lib/libzauth.dylib diff --git a/nix/sources.json b/nix/sources.json index c3675c36b54..987e681846e 100644 --- a/nix/sources.json +++ b/nix/sources.json @@ -5,10 +5,10 @@ "homepage": "https://github.com/nmattia/niv", "owner": "nmattia", "repo": "niv", - "rev": "18b7314c13a6d0e82113a15c14e7a5f54286327d", - "sha256": "0b2xb99nn7ddysvgzncwa4vglv0j6c0l4bgxz9hl4i3gmrlq3r59", + "rev": "5830a4dd348d77e39a0f3c4c762ff2663b602d4c", + "sha256": "1d3lsrqvci4qz2hwjrcnd8h5vfkg8aypq3sjd4g3izbc8frwz5sm", "type": "tarball", - "url": "https://github.com/nmattia/niv/archive/18b7314c13a6d0e82113a15c14e7a5f54286327d.tar.gz", + "url": "https://github.com/nmattia/niv/archive/5830a4dd348d77e39a0f3c4c762ff2663b602d4c.tar.gz", "url_template": "https://github.com///archive/.tar.gz" }, "nixpkgs": { @@ -17,10 +17,10 @@ "homepage": "https://github.com/NixOS/nixpkgs", "owner": "NixOS", "repo": "nixpkgs", - "rev": "8e1891d5b8d0b898db8890ddab73141f0cd3c2bc", - "sha256": "0a767mn0nfp4qnklsvs6bnc0vng4nc3ch566nmrz18ypk67z4zz0", + "rev": "cc61d6cca06aaa46ccde79a92cd94dbb27c634a7", + "sha256": "0qi05m6vk9zqqs9573w2rhwm5k7jga70sjzq370npcipayrifw99", "type": "tarball", - "url": "https://github.com/NixOS/nixpkgs/archive/8e1891d5b8d0b898db8890ddab73141f0cd3c2bc.tar.gz", + "url": "https://github.com/NixOS/nixpkgs/archive/cc61d6cca06aaa46ccde79a92cd94dbb27c634a7.tar.gz", "url_template": "https://github.com///archive/.tar.gz" } } diff --git a/nix/sources.nix b/nix/sources.nix index 8a725cb4e7f..1938409dddb 100644 --- a/nix/sources.nix +++ b/nix/sources.nix @@ -6,52 +6,63 @@ let # The fetchers. fetch_ fetches specs of type . # - fetch_file = pkgs: spec: - if spec.builtin or true then - builtins_fetchurl { inherit (spec) url sha256; } - else - pkgs.fetchurl { inherit (spec) url sha256; }; - - fetch_tarball = pkgs: spec: - if spec.builtin or true then - builtins_fetchTarball { inherit (spec) url sha256; } - else - pkgs.fetchzip { inherit (spec) url sha256; }; + fetch_file = pkgs: name: spec: + let + name' = sanitizeName name + "-src"; + in + if spec.builtin or true then + builtins_fetchurl { inherit (spec) url sha256; name = name'; } + else + pkgs.fetchurl { inherit (spec) url sha256; name = name'; }; - fetch_git = spec: - builtins.fetchGit { url = spec.repo; inherit (spec) rev ref; }; + fetch_tarball = pkgs: name: spec: + let + name' = sanitizeName name + "-src"; + in + if spec.builtin or true then + builtins_fetchTarball { name = name'; inherit (spec) url sha256; } + else + pkgs.fetchzip { name = name'; inherit (spec) url sha256; }; - fetch_builtin-tarball = spec: - builtins.trace - '' - WARNING: - The niv type "builtin-tarball" will soon be deprecated. You should - instead use `builtin = true`. + fetch_git = name: spec: + let + ref = + if spec ? ref then spec.ref else + if spec ? branch then "refs/heads/${spec.branch}" else + if spec ? tag then "refs/tags/${spec.tag}" else + abort "In git source '${name}': Please specify `ref`, `tag` or `branch`!"; + in + builtins.fetchGit { url = spec.repo; inherit (spec) rev; inherit ref; }; - $ niv modify -a type=tarball -a builtin=true - '' - builtins_fetchTarball { inherit (spec) url sha256; }; + fetch_local = spec: spec.path; - fetch_builtin-url = spec: - builtins.trace - '' - WARNING: - The niv type "builtin-url" will soon be deprecated. You should - instead use `builtin = true`. + fetch_builtin-tarball = name: throw + ''[${name}] The niv type "builtin-tarball" is deprecated. You should instead use `builtin = true`. + $ niv modify ${name} -a type=tarball -a builtin=true''; - $ niv modify -a type=file -a builtin=true - '' - (builtins_fetchurl { inherit (spec) url sha256; }); + fetch_builtin-url = name: throw + ''[${name}] The niv type "builtin-url" will soon be deprecated. You should instead use `builtin = true`. + $ niv modify ${name} -a type=file -a builtin=true''; # # Various helpers # + # https://github.com/NixOS/nixpkgs/pull/83241/files#diff-c6f540a4f3bfa4b0e8b6bafd4cd54e8bR695 + sanitizeName = name: + ( + concatMapStrings (s: if builtins.isList s then "-" else s) + ( + builtins.split "[^[:alnum:]+._?=-]+" + ((x: builtins.elemAt (builtins.match "\\.*(.*)" x) 0) name) + ) + ); + # The set of packages used when specs are fetched using non-builtins. - mkPkgs = sources: + mkPkgs = sources: system: let sourcesNixpkgs = - import (builtins_fetchTarball { inherit (sources.nixpkgs) url sha256; }) {}; + import (builtins_fetchTarball { inherit (sources.nixpkgs) url sha256; }) { inherit system; }; hasNixpkgsPath = builtins.any (x: x.prefix == "nixpkgs") builtins.nixPath; hasThisAsNixpkgsPath = == ./.; in @@ -71,14 +82,27 @@ let if ! builtins.hasAttr "type" spec then abort "ERROR: niv spec ${name} does not have a 'type' attribute" - else if spec.type == "file" then fetch_file pkgs spec - else if spec.type == "tarball" then fetch_tarball pkgs spec - else if spec.type == "git" then fetch_git spec - else if spec.type == "builtin-tarball" then fetch_builtin-tarball spec - else if spec.type == "builtin-url" then fetch_builtin-url spec + else if spec.type == "file" then fetch_file pkgs name spec + else if spec.type == "tarball" then fetch_tarball pkgs name spec + else if spec.type == "git" then fetch_git name spec + else if spec.type == "local" then fetch_local spec + else if spec.type == "builtin-tarball" then fetch_builtin-tarball name + else if spec.type == "builtin-url" then fetch_builtin-url name else abort "ERROR: niv spec ${name} has unknown type ${builtins.toJSON spec.type}"; + # If the environment variable NIV_OVERRIDE_${name} is set, then use + # the path directly as opposed to the fetched source. + replace = name: drv: + let + saneName = stringAsChars (c: if isNull (builtins.match "[a-zA-Z0-9]" c) then "_" else c) name; + ersatz = builtins.getEnv "NIV_OVERRIDE_${saneName}"; + in + if ersatz == "" then drv else + # this turns the string into an actual Nix path (for both absolute and + # relative paths) + if builtins.substring 0 1 ersatz == "/" then /. + ersatz else /. + builtins.getEnv "PWD" + "/${ersatz}"; + # Ports of functions for older nix versions # a Nix version of mapAttrs if the built-in doesn't exist @@ -87,23 +111,37 @@ let listToAttrs (map (attr: { name = attr; value = f attr set.${attr}; }) (attrNames set)) ); + # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/lists.nix#L295 + range = first: last: if first > last then [] else builtins.genList (n: first + n) (last - first + 1); + + # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L257 + stringToCharacters = s: map (p: builtins.substring p 1 s) (range 0 (builtins.stringLength s - 1)); + + # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L269 + stringAsChars = f: s: concatStrings (map f (stringToCharacters s)); + concatMapStrings = f: list: concatStrings (map f list); + concatStrings = builtins.concatStringsSep ""; + + # https://github.com/NixOS/nixpkgs/blob/8a9f58a375c401b96da862d969f66429def1d118/lib/attrsets.nix#L331 + optionalAttrs = cond: as: if cond then as else {}; + # fetchTarball version that is compatible between all the versions of Nix - builtins_fetchTarball = { url, sha256 }@attrs: + builtins_fetchTarball = { url, name ? null, sha256 }@attrs: let inherit (builtins) lessThan nixVersion fetchTarball; in if lessThan nixVersion "1.12" then - fetchTarball { inherit url; } + fetchTarball ({ inherit url; } // (optionalAttrs (!isNull name) { inherit name; })) else fetchTarball attrs; # fetchurl version that is compatible between all the versions of Nix - builtins_fetchurl = { url, sha256 }@attrs: + builtins_fetchurl = { url, name ? null, sha256 }@attrs: let inherit (builtins) lessThan nixVersion fetchurl; in if lessThan nixVersion "1.12" then - fetchurl { inherit url; } + fetchurl ({ inherit url; } // (optionalAttrs (!isNull name) { inherit name; })) else fetchurl attrs; @@ -115,14 +153,15 @@ let then abort "The values in sources.json should not have an 'outPath' attribute" else - spec // { outPath = fetch config.pkgs name spec; } + spec // { outPath = replace name (fetch config.pkgs name spec); } ) config.sources; # The "config" used by the fetchers mkConfig = - { sourcesFile ? ./sources.json - , sources ? builtins.fromJSON (builtins.readFile sourcesFile) - , pkgs ? mkPkgs sources + { sourcesFile ? if builtins.pathExists ./sources.json then ./sources.json else null + , sources ? if isNull sourcesFile then {} else builtins.fromJSON (builtins.readFile sourcesFile) + , system ? builtins.currentSystem + , pkgs ? mkPkgs sources system }: rec { # The sources, i.e. the attribute set of spec name to spec inherit sources; @@ -130,5 +169,6 @@ let # The "pkgs" (evaluated nixpkgs) to use for e.g. non-builtin fetchers inherit pkgs; }; + in mkSources (mkConfig {}) // { __functor = _: settings: mkSources (mkConfig settings); } diff --git a/services/brig/Makefile b/services/brig/Makefile index c8acd908845..2f09ec70321 100644 --- a/services/brig/Makefile +++ b/services/brig/Makefile @@ -147,7 +147,7 @@ index-reset: install docker: $(foreach executable,$(EXECUTABLES),\ docker build -t $(DOCKER_USER)/$(executable):$(DOCKER_TAG) \ - -f ../../build/alpine/Dockerfile.executable \ + -f ../../build/ubuntu/Dockerfile.executable \ --build-arg executable=$(executable) \ ../.. && \ docker tag $(DOCKER_USER)/$(executable):$(DOCKER_TAG) $(DOCKER_USER)/$(executable):latest && \ diff --git a/services/brig/Setup.hs b/services/brig/Setup.hs index b7f084b8ca1..ce0b496ab7c 100644 --- a/services/brig/Setup.hs +++ b/services/brig/Setup.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2021 Wire Swiss GmbH @@ -15,10 +18,15 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . +import Control.Exception +import Control.Monad import Data.Char import Data.Foldable import qualified Data.Map as Map import Data.Maybe +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.IO as Text import Distribution.Simple import Distribution.Simple.BuildPaths import Distribution.Simple.LocalBuildInfo @@ -49,17 +57,25 @@ generateDocs base src = do let name = moduleName src dest = base (moduleName src <> ".hs") createDirectoryIfMissing True base - putStrLn ("Generating " <> dest <> " ...") let out = - unlines - [ "module Brig.Docs." <> name <> " where", + Text.unlines + [ "module Brig.Docs." <> Text.pack name <> " where", "", "import Imports", "", "contents :: Text", - "contents = " ++ show contents + "contents = " <> Text.pack (show contents) ] - writeFile dest out + writeFileIfChanged dest out + +writeFileIfChanged :: FilePath -> Text -> IO () +writeFileIfChanged fp c' = do + changed <- handle @IOException (const (pure True)) $ do + c <- Text.readFile fp + pure $ c /= c' + when changed $ do + putStrLn ("Generating " <> fp <> " ...") + Text.writeFile fp c' moduleName :: String -> String moduleName = go . dropExtension diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal index 94a4b541681..005df78d29a 100644 --- a/services/brig/brig.cabal +++ b/services/brig/brig.cabal @@ -1,10 +1,8 @@ cabal-version: 2.0 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack --- --- hash: 513c0f5104342fb14b0246f7c44733a84ec36fae97633fc55cb209e0e0bcd087 name: brig version: 2.0 @@ -26,6 +24,7 @@ custom-setup , containers , directory , filepath + , text library exposed-modules: @@ -64,6 +63,7 @@ library Brig.Data.User Brig.Data.UserKey Brig.Data.UserPendingActivation + Brig.Effects.SFT Brig.Email Brig.Federation.Client Brig.Index.Eval @@ -126,7 +126,46 @@ library 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 + 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 -funbox-strict-fields build-depends: HaskellNet >=0.3 @@ -207,10 +246,12 @@ library , safe >=0.3 , safe-exceptions >=0.1 , saml2-web-sso + , schema-profunctor , scientific >=0.3.4 , scrypt >=0.5 , servant , servant-client + , servant-client-core , servant-server , servant-swagger , servant-swagger-ui @@ -253,7 +294,46 @@ executable brig main-is: src/Main.hs other-modules: Paths_brig - 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 + 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 -funbox-strict-fields -threaded -with-rtsopts=-N1 -with-rtsopts=-T -rtsopts build-depends: HsOpenSSL @@ -268,7 +348,46 @@ executable brig-index main-is: index/src/Main.hs other-modules: Paths_brig - 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 + 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 -funbox-strict-fields -threaded -with-rtsopts=-N build-depends: base @@ -313,7 +432,46 @@ executable brig-integration Paths_brig hs-source-dirs: test/integration - 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 + 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 -funbox-strict-fields build-depends: HsOpenSSL @@ -346,6 +504,7 @@ executable brig-integration , http-api-data , http-client , http-client-tls >=0.2 + , http-media , http-types , imports , lens >=3.9 @@ -458,7 +617,46 @@ executable brig-schema Paths_brig hs-source-dirs: schema/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 + 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 -funbox-strict-fields build-depends: base @@ -483,7 +681,46 @@ test-suite brig-tests Paths_brig hs-source-dirs: test/unit - 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 + 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 -funbox-strict-fields -threaded -with-rtsopts=-N build-depends: aeson @@ -496,10 +733,12 @@ test-suite brig-tests , dns-util , http-types , imports + , lens , polysemy , polysemy-wire-zoo , retry , servant-client-core + , string-conversions , tasty , tasty-hunit , tasty-quickcheck diff --git a/services/brig/brig.integration.yaml b/services/brig/brig.integration.yaml index b5ca314dfb9..fa2d13ffe14 100644 --- a/services/brig/brig.integration.yaml +++ b/services/brig/brig.integration.yaml @@ -152,7 +152,8 @@ optSettings: setSuspendInactiveUsers: # if this is omitted: never suspend inactive users. suspendTimeout: 10 setRichInfoLimit: 5000 # should be in sync with Spar - setDefaultLocale: en + setDefaultTemplateLocale: en + setDefaultUserLocale: en setMaxTeamSize: 32 setMaxConvSize: 16 setEmailVisibility: visible_to_self diff --git a/services/brig/docs/swagger.md b/services/brig/docs/swagger.md index 63ec978afb9..59e6c1c3b8f 100644 --- a/services/brig/docs/swagger.md +++ b/services/brig/docs/swagger.md @@ -54,7 +54,7 @@ An error in this category likely indicates an issue with the configuration of fe - **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. + - **Federator discovery failed** (status: 400, 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 diff --git a/services/brig/package.yaml b/services/brig/package.yaml index 05329979f73..56bce3568b8 100644 --- a/services/brig/package.yaml +++ b/services/brig/package.yaml @@ -17,6 +17,7 @@ custom-setup: - containers - directory - filepath + - text extra-source-files: - docs/* library: @@ -102,10 +103,12 @@ library: - safe >=0.3 - safe-exceptions >=0.1 - saml2-web-sso + - schema-profunctor - scientific >=0.3.4 - scrypt >=0.5 - servant - servant-client + - servant-client-core - servant-server - servant-swagger - servant-swagger-ui @@ -160,10 +163,12 @@ tests: - dns-util - http-types - imports + - lens - polysemy - polysemy-wire-zoo - retry - servant-client-core + - string-conversions - tasty - tasty-hunit - tasty-quickcheck @@ -222,6 +227,7 @@ executables: - http-api-data - http-client - http-client-tls >=0.2 + - http-media - http-types - imports - lens >=3.9 diff --git a/services/brig/src/Brig/API/Federation.hs b/services/brig/src/Brig/API/Federation.hs index 12bec5d32f2..84c482c7b75 100644 --- a/services/brig/src/Brig/API/Federation.hs +++ b/services/brig/src/Brig/API/Federation.hs @@ -43,14 +43,12 @@ import Imports import Network.Wai.Utilities.Error ((!>>)) import Servant (ServerT) import Servant.API -import Servant.API.Generic (ToServantApi) -import Servant.Server.Generic (genericServerT) import UnliftIO.Async (pooledForConcurrentlyN_) -import Wire.API.Federation.API.Brig hiding (BrigApi (..)) -import qualified Wire.API.Federation.API.Brig as F +import Wire.API.Federation.API.Brig import Wire.API.Federation.API.Common import Wire.API.Message (UserClients) import Wire.API.Routes.Internal.Brig.Connection +import Wire.API.Routes.Named import Wire.API.Team.LegalHold (LegalholdProtectee (LegalholdPlusFederationNotImplemented)) import Wire.API.User (UserProfile) import Wire.API.User.Client (PubClient, UserClientPrekeyMap) @@ -58,22 +56,19 @@ import Wire.API.User.Client.Prekey (ClientPrekey) import Wire.API.User.Search import Wire.API.UserMap (UserMap) -type FederationAPI = "federation" :> ToServantApi F.BrigApi +type FederationAPI = "federation" :> BrigApi federationSitemap :: ServerT FederationAPI Handler federationSitemap = - genericServerT $ - F.BrigApi - { F.getUserByHandle = getUserByHandle, - F.getUsersByIds = getUsersByIds, - F.claimPrekey = claimPrekey, - F.claimPrekeyBundle = claimPrekeyBundle, - F.claimMultiPrekeyBundle = claimMultiPrekeyBundle, - F.searchUsers = searchUsers, - F.getUserClients = getUserClients, - F.sendConnectionAction = sendConnectionAction, - F.onUserDeleted = onUserDeleted - } + Named @"get-user-by-handle" getUserByHandle + :<|> Named @"get-users-by-ids" getUsersByIds + :<|> Named @"claim-prekey" claimPrekey + :<|> Named @"claim-prekey-bundle" claimPrekeyBundle + :<|> Named @"claim-multi-prekey-bundle" claimMultiPrekeyBundle + :<|> Named @"search-users" searchUsers + :<|> Named @"get-user-clients" getUserClients + :<|> Named @"send-connection-action" sendConnectionAction + :<|> Named @"on-user-deleted-connections" onUserDeleted sendConnectionAction :: Domain -> NewConnectionRequest -> Handler NewConnectionResponse sendConnectionAction originDomain NewConnectionRequest {..} = do @@ -87,8 +82,8 @@ sendConnectionAction originDomain NewConnectionRequest {..} = do pure $ NewConnectionResponseOk maction else pure NewConnectionResponseUserNotActivated -getUserByHandle :: Handle -> Handler (Maybe UserProfile) -getUserByHandle handle = lift $ do +getUserByHandle :: Domain -> Handle -> Handler (Maybe UserProfile) +getUserByHandle _ handle = lift $ do maybeOwnerId <- API.lookupHandle handle case maybeOwnerId of Nothing -> @@ -96,34 +91,34 @@ getUserByHandle handle = lift $ do Just ownerId -> listToMaybe <$> API.lookupLocalProfiles Nothing [ownerId] -getUsersByIds :: [UserId] -> Handler [UserProfile] -getUsersByIds uids = +getUsersByIds :: Domain -> [UserId] -> Handler [UserProfile] +getUsersByIds _ uids = lift (API.lookupLocalProfiles Nothing uids) -claimPrekey :: (UserId, ClientId) -> Handler (Maybe ClientPrekey) -claimPrekey (user, client) = do +claimPrekey :: Domain -> (UserId, ClientId) -> Handler (Maybe ClientPrekey) +claimPrekey _ (user, client) = do API.claimLocalPrekey LegalholdPlusFederationNotImplemented user client !>> clientError -claimPrekeyBundle :: UserId -> Handler PrekeyBundle -claimPrekeyBundle user = +claimPrekeyBundle :: Domain -> UserId -> Handler PrekeyBundle +claimPrekeyBundle _ user = API.claimLocalPrekeyBundle LegalholdPlusFederationNotImplemented user !>> clientError -claimMultiPrekeyBundle :: UserClients -> Handler UserClientPrekeyMap -claimMultiPrekeyBundle uc = API.claimLocalMultiPrekeyBundles LegalholdPlusFederationNotImplemented uc !>> clientError +claimMultiPrekeyBundle :: Domain -> UserClients -> Handler UserClientPrekeyMap +claimMultiPrekeyBundle _ uc = API.claimLocalMultiPrekeyBundles LegalholdPlusFederationNotImplemented uc !>> clientError -- | Searching for federated users on a remote backend should -- only search by exact handle search, not in elasticsearch. -- (This decision may change in the future) -searchUsers :: SearchRequest -> Handler [Contact] -searchUsers (SearchRequest searchTerm) = do +searchUsers :: Domain -> SearchRequest -> Handler [Contact] +searchUsers _ (SearchRequest searchTerm) = do let maybeHandle = parseHandle searchTerm maybeOwnerId <- maybe (pure Nothing) (lift . API.lookupHandle) maybeHandle case maybeOwnerId of Nothing -> pure [] Just foundUser -> lift $ contactFromProfile <$$> API.lookupLocalProfiles Nothing [foundUser] -getUserClients :: GetUserClients -> Handler (UserMap (Set PubClient)) -getUserClients (GetUserClients uids) = API.lookupLocalPubClientsBulk uids !>> clientError +getUserClients :: Domain -> GetUserClients -> Handler (UserMap (Set PubClient)) +getUserClients _ (GetUserClients uids) = API.lookupLocalPubClientsBulk uids !>> clientError onUserDeleted :: Domain -> UserDeletedConnectionsNotification -> Handler EmptyResponse onUserDeleted origDomain udcn = lift $ do diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index 081c96f8009..0c8fb15456c 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -104,6 +104,8 @@ import qualified Wire.API.Properties as Public import qualified Wire.API.Routes.MultiTablePaging as Public import Wire.API.Routes.Public.Brig (Api (updateConnectionUnqualified)) import qualified Wire.API.Routes.Public.Brig as BrigAPI +import qualified Wire.API.Routes.Public.Cannon as CannonAPI +import qualified Wire.API.Routes.Public.Cargohold as CargoholdAPI import qualified Wire.API.Routes.Public.Galley as GalleyAPI import qualified Wire.API.Routes.Public.LegalHold as LegalHoldAPI import qualified Wire.API.Routes.Public.Spar as SparAPI @@ -131,7 +133,13 @@ type ServantAPI = BrigAPI.ServantAPI swaggerDocsAPI :: Servant.Server SwaggerDocsAPI swaggerDocsAPI = swaggerSchemaUIServer $ - (BrigAPI.swagger <> GalleyAPI.swaggerDoc <> LegalHoldAPI.swaggerDoc <> SparAPI.swaggerDoc) + ( BrigAPI.swagger + <> GalleyAPI.swaggerDoc + <> LegalHoldAPI.swaggerDoc + <> SparAPI.swaggerDoc + <> CargoholdAPI.swaggerDoc + <> CannonAPI.swaggerDoc + ) & S.info . S.title .~ "Wire-Server API" & S.info . S.description ?~ Brig.Docs.Swagger.contents <> mempty & S.security %~ nub @@ -993,8 +1001,8 @@ sendActivationCodeH req = -- docs/reference/user/registration.md {#RefRegistration} sendActivationCode :: Public.SendActivationCode -> Handler () sendActivationCode Public.SendActivationCode {..} = do + either customerExtensionCheckBlockedDomains (const $ pure ()) saUserKey checkWhitelist saUserKey - either customerExtensionCheckBlockedDomains (\_ -> pure ()) saUserKey API.sendActivationCode saUserKey saLocale saCall !>> sendActCodeError -- | If the user presents an email address from a blocked domain, throw an error. diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index f1bdc2f0b87..b70bc93f5d9 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -1062,7 +1062,7 @@ deleteAccount account@(accountUser -> user) = do revokeAllCookies uid where mkTombstone = do - defLoc <- setDefaultLocale <$> view settings + defLoc <- setDefaultUserLocale <$> view settings return $ account { accountStatus = Deleted, diff --git a/services/brig/src/Brig/AWS.hs b/services/brig/src/Brig/AWS.hs index 15205905c07..0e0e4aec5a3 100644 --- a/services/brig/src/Brig/AWS.hs +++ b/services/brig/src/Brig/AWS.hs @@ -97,14 +97,10 @@ newtype Amazon a = Amazon MonadCatch, MonadMask, MonadReader Env, - MonadResource + MonadResource, + MonadUnliftIO ) -instance MonadUnliftIO Amazon where - askUnliftIO = Amazon . ReaderT $ \r -> - withUnliftIO $ \u -> - return (UnliftIO (unliftIO u . flip runReaderT r . unAmazon)) - instance MonadLogger Amazon where log l m = view logger >>= \g -> Logger.log g l m diff --git a/services/brig/src/Brig/Calling.hs b/services/brig/src/Brig/Calling.hs index 73e981873a5..acd77634009 100644 --- a/services/brig/src/Brig/Calling.hs +++ b/services/brig/src/Brig/Calling.hs @@ -18,9 +18,10 @@ -- with this program. If not, see . module Brig.Calling - ( getRandomSFTServers, + ( getRandomElements, mkSFTDomain, SFTServers, -- See NOTE SFTServers + unSFTServers, mkSFTServers, SFTEnv (..), Discovery (..), @@ -68,7 +69,7 @@ import Wire.Network.DNS.SRV -- And limited since client currently try contacting all servers returned -- (and we don't want them to open 100 parallel connections unnecessarily) -- Therefore, we hide the constructor from the module export. -newtype SFTServers = SFTServers (NonEmpty SrvEntry) +newtype SFTServers = SFTServers {unSFTServers :: NonEmpty SrvEntry} deriving (Eq, Show) mkSFTServers :: NonEmpty SrvEntry -> SFTServers @@ -85,10 +86,14 @@ type MaximumSFTServers = 100 -- Currently (Sept 2020) the client initiating an SFT call will try all -- servers in this list. Limit this list to a smaller subset in case many -- SFT servers are advertised in a given environment. -getRandomSFTServers :: MonadRandom m => Range 1 MaximumSFTServers Int -> SFTServers -> m (NonEmpty SrvEntry) -getRandomSFTServers limit (SFTServers list) = subsetSft limit <$> randomize list - -subsetSft :: Range 1 100 Int -> NonEmpty a -> NonEmpty a +getRandomElements :: + MonadRandom f => + Range 1 MaximumSFTServers Int -> + NonEmpty a -> + f (NonEmpty a) +getRandomElements limit list = subsetSft limit <$> randomize list + +subsetSft :: Range 1 MaximumSFTServers Int -> NonEmpty a -> NonEmpty a subsetSft l entries = do let entry1 = NonEmpty.head entries let entryTail = take (fromRange l - 1) (NonEmpty.tail entries) diff --git a/services/brig/src/Brig/Calling/API.hs b/services/brig/src/Brig/Calling/API.hs index e2654a488bc..b4ba4619956 100644 --- a/services/brig/src/Brig/Calling/API.hs +++ b/services/brig/src/Brig/Calling/API.hs @@ -19,6 +19,10 @@ module Brig.Calling.API ( routesPublic, + + -- * Exposed for testing purposes + newConfig, + CallsConfigVersion (..), ) where @@ -27,9 +31,10 @@ import Brig.App import Brig.Calling import qualified Brig.Calling as Calling import Brig.Calling.Internal +import Brig.Effects.SFT import qualified Brig.Options as Opt import Control.Lens -import Data.ByteString.Conversion (toByteString') +import Data.ByteString.Conversion import Data.ByteString.Lens import Data.Id import Data.List.NonEmpty (NonEmpty (..)) @@ -48,7 +53,10 @@ import Network.Wai.Routing hiding (toList) import Network.Wai.Utilities hiding (code, message) import Network.Wai.Utilities.Swagger (document) import OpenSSL.EVP.Digest (Digest, hmacBS) +import Polysemy +import Polysemy.TinyLog import qualified System.Random.MWC as MWC +import Wire.API.Call.Config (SFTServer) import qualified Wire.API.Call.Config as Public import Wire.Network.DNS.SRV (srvTarget) @@ -91,10 +99,16 @@ getCallsConfigV2H (_ ::: uid ::: connid ::: limit) = -- | ('UserId', 'ConnId' are required as args here to make sure this is an authenticated end-point.) getCallsConfigV2 :: UserId -> ConnId -> Maybe (Range 1 10 Int) -> Handler Public.RTCConfiguration getCallsConfigV2 _ _ limit = do - env <- liftIO =<< readIORef <$> view turnEnvV2 + env <- liftIO . readIORef =<< view turnEnvV2 staticUrl <- view $ settings . Opt.sftStaticUrl sftEnv' <- view sftEnv - newConfig env staticUrl sftEnv' limit + logger <- view applog + manager <- view httpManager + liftIO + . runM @IO + . runTinyLog logger + . interpretSFT manager + $ newConfig env staticUrl sftEnv' limit CallsConfigV2 getCallsConfigH :: JSON ::: UserId ::: ConnId -> Handler Response getCallsConfigH (_ ::: uid ::: connid) = @@ -102,8 +116,15 @@ getCallsConfigH (_ ::: uid ::: connid) = getCallsConfig :: UserId -> ConnId -> Handler Public.RTCConfiguration getCallsConfig _ _ = do - env <- liftIO =<< readIORef <$> view turnEnv - dropTransport <$> newConfig env Nothing Nothing Nothing + env <- liftIO . readIORef =<< view turnEnv + logger <- view applog + manager <- view httpManager + fmap dropTransport + . liftIO + . runM @IO + . runTinyLog logger + . interpretSFT manager + $ newConfig env Nothing Nothing Nothing CallsConfigDeprecated where -- In order to avoid being backwards incompatible, remove the `transport` query param from the URIs dropTransport :: Public.RTCConfiguration -> Public.RTCConfiguration @@ -112,8 +133,24 @@ getCallsConfig _ _ = do (Public.rtcConfIceServers . traverse . Public.iceURLs . traverse . Public.turiTransport) Nothing -newConfig :: MonadIO m => Calling.Env -> Maybe HttpsUrl -> Maybe SFTEnv -> Maybe (Range 1 10 Int) -> m Public.RTCConfiguration -newConfig env sftStaticUrl mSftEnv limit = do +data CallsConfigVersion + = CallsConfigDeprecated + | CallsConfigV2 + +-- | FUTUREWORK: It is not reflected in the function type the part of the +-- business logic that says that the SFT static URL parameter cannot be set at +-- the same time as the SFT environment parameter. See how to allow either none +-- to be set or only one of them (perhaps Data.These combined with error +-- handling). +newConfig :: + Members [Embed IO, SFT] r => + Calling.Env -> + Maybe HttpsUrl -> + Maybe SFTEnv -> + Maybe (Range 1 10 Int) -> + CallsConfigVersion -> + Sem r Public.RTCConfiguration +newConfig env sftStaticUrl mSftEnv limit version = do let (sha, secret, tTTL, cTTL, prng) = (env ^. turnSHA512, env ^. turnSecret, env ^. turnTokenTTL, env ^. turnConfigTTL, env ^. turnPrng) -- randomize list of servers (before limiting the list, to ensure not always the same servers are chosen if limit is set) randomizedUris <- liftIO $ randomize (List1.toNonEmpty $ env ^. turnServers) @@ -124,17 +161,27 @@ newConfig env sftStaticUrl mSftEnv limit = do finalUris <- liftIO $ randomize limitedUris srvs <- for finalUris $ \uri -> do u <- liftIO $ genUsername tTTL prng - pure $ Public.rtcIceServer (uri :| []) u (computeCred sha secret u) + pure $ Public.rtcIceServer (pure uri) u (computeCred sha secret u) - let staticSft = (\url -> Public.sftServer url :| []) <$> sftStaticUrl - sftEntries <- case mSftEnv of - Nothing -> pure Nothing - Just actualSftEnv -> do - sftSrvEntries <- fmap discoveryToMaybe . readIORef . sftServers $ actualSftEnv + let staticSft = pure . Public.sftServer <$> sftStaticUrl + allSrvEntries <- + fmap join $ + for mSftEnv $ + (unSFTServers <$$>) . fmap discoveryToMaybe . readIORef . sftServers + srvEntries <- fmap join $ + for mSftEnv $ \actualSftEnv -> liftIO $ do let subsetLength = Calling.sftListLength actualSftEnv - liftIO $ mapM (getRandomSFTServers subsetLength) sftSrvEntries + mapM (getRandomElements subsetLength) allSrvEntries + + mSftServersAll :: Maybe [SFTServer] <- case version of + CallsConfigDeprecated -> pure Nothing + CallsConfigV2 -> + Just <$> case sftStaticUrl of + Nothing -> pure $ sftServerFromSrvTarget . srvTarget <$> maybe [] toList allSrvEntries + Just url -> fromRight [] . unSFTGetResponse <$> sftGetAllServers url - pure $ Public.rtcConfiguration srvs (staticSft <|> sftServerFromSrvTarget . srvTarget <$$> sftEntries) cTTL + let mSftServers = staticSft <|> sftServerFromSrvTarget . srvTarget <$$> srvEntries + pure $ Public.rtcConfiguration srvs mSftServers cTTL mSftServersAll where limitedList :: NonEmpty Public.TurnURI -> Range 1 10 Int -> NonEmpty Public.TurnURI limitedList uris lim = diff --git a/services/brig/src/Brig/Data/Client.hs b/services/brig/src/Brig/Data/Client.hs index b6a322f8877..491479b2c89 100644 --- a/services/brig/src/Brig/Data/Client.hs +++ b/services/brig/src/Brig/Data/Client.hs @@ -56,7 +56,7 @@ import Control.Error import qualified Control.Exception.Lens as EL import Control.Lens import Control.Monad.Catch -import Control.Monad.Random (Random (randomRIO)) +import Control.Monad.Random (randomRIO) import Control.Retry import qualified Data.ByteString.Base64 as B64 import Data.ByteString.Conversion (toByteString, toByteString') diff --git a/services/brig/src/Brig/Data/User.hs b/services/brig/src/Brig/Data/User.hs index 1d501b0f489..56d8698266a 100644 --- a/services/brig/src/Brig/Data/User.hs +++ b/services/brig/src/Brig/Data/User.hs @@ -118,7 +118,7 @@ data ReAuthError -- there, it was claimed properly. newAccount :: NewUser -> Maybe InvitationId -> Maybe TeamId -> Maybe Handle -> AppIO (UserAccount, Maybe Password) newAccount u inv tid mbHandle = do - defLoc <- setDefaultLocale <$> view settings + defLoc <- setDefaultUserLocale <$> view settings domain <- viewFederationDomain uid <- Id <$> do @@ -132,7 +132,7 @@ newAccount u inv tid mbHandle = do -- Ephemeral users' expiry time is in expires_in (default sessionTokenTimeout) seconds e <- view zauthEnv let ZAuth.SessionTokenTimeout defTTL = e ^. ZAuth.settings . ZAuth.sessionTokenTimeout - ttl = fromMaybe defTTL (fromRange <$> newUserExpiresIn u) + ttl = maybe defTTL fromRange (newUserExpiresIn u) now <- liftIO =<< view currentTime return . Just . toUTCTimeMillis $ addUTCTime (fromIntegral ttl) now _ -> return Nothing @@ -154,7 +154,7 @@ newAccount u inv tid mbHandle = do newAccountInviteViaScim :: UserId -> TeamId -> Maybe Locale -> Name -> Email -> AppIO UserAccount newAccountInviteViaScim uid tid locale name email = do - defLoc <- setDefaultLocale <$> view settings + defLoc <- setDefaultUserLocale <$> view settings domain <- viewFederationDomain return (UserAccount (user domain (fromMaybe defLoc locale)) PendingInvitation) where @@ -370,7 +370,7 @@ deactivateUser u = lookupLocale :: UserId -> AppIO (Maybe Locale) lookupLocale u = do - defLoc <- setDefaultLocale <$> view settings + defLoc <- setDefaultUserLocale <$> view settings fmap (toLocale defLoc) <$> retry x1 (query1 localeSelect (params LocalQuorum (Identity u))) lookupName :: UserId -> AppIO (Maybe Name) @@ -417,7 +417,7 @@ lookupAuth u = fmap f <$> retry x1 (query1 authSelect (params LocalQuorum (Ident -- Skips nonexistent users. /Does not/ skip users who have been deleted. lookupUsers :: HavePendingInvitations -> [UserId] -> AppIO [User] lookupUsers hpi usrs = do - loc <- setDefaultLocale <$> view settings + loc <- setDefaultUserLocale <$> view settings domain <- viewFederationDomain toUsers domain loc hpi <$> retry x1 (query usersSelect (params LocalQuorum (Identity usrs))) @@ -426,7 +426,7 @@ lookupAccount u = listToMaybe <$> lookupAccounts [u] lookupAccounts :: [UserId] -> AppIO [UserAccount] lookupAccounts usrs = do - loc <- setDefaultLocale <$> view settings + loc <- setDefaultUserLocale <$> view settings domain <- viewFederationDomain fmap (toUserAccount domain loc) <$> retry x1 (query accountsSelect (params LocalQuorum (Identity usrs))) diff --git a/services/brig/src/Brig/Effects/SFT.hs b/services/brig/src/Brig/Effects/SFT.hs new file mode 100644 index 00000000000..0abae5ab210 --- /dev/null +++ b/services/brig/src/Brig/Effects/SFT.hs @@ -0,0 +1,93 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Brig.Effects.SFT + ( SFTError (..), + SFTGetResponse (..), + SFT (..), + sftGetAllServers, + interpretSFT, + interpretSFTInMemory, + ) +where + +import qualified Data.Aeson as Aeson +import Data.ByteString.Conversion +import qualified Data.Map as Map +import Data.Misc +import Data.Schema +import Data.String.Conversions (cs) +import Imports hiding (intercalate) +import Network.HTTP.Client +import Polysemy +import Polysemy.Internal +import Polysemy.TinyLog +import qualified System.Logger as Log +import URI.ByteString (uriPath) +import Wire.API.Call.Config + +newtype SFTError = SFTError {unSFTError :: String} + deriving (Eq, Show) + +newtype SFTGetResponse = SFTGetResponse + {unSFTGetResponse :: Either SFTError [SFTServer]} + deriving newtype (Eq) + +data SFT m a where + SFTGetAllServers :: HttpsUrl -> SFT m SFTGetResponse + +sftGetAllServers :: Member SFT r => HttpsUrl -> Sem r SFTGetResponse +sftGetAllServers = send . SFTGetAllServers + +interpretSFT :: Members [Embed IO, TinyLog] r => Manager -> Sem (SFT ': r) a -> Sem r a +interpretSFT httpManager = interpret $ \(SFTGetAllServers url) -> do + let urlWithPath = ensureHttpsUrl $ (httpsUrl url) {uriPath = "/sft_servers_all.json"} + req = parseRequest_ . cs . toByteString' $ urlWithPath + responseURLsRaw <- liftIO (responseBody <$> httpLbs req httpManager) + let eList = Aeson.eitherDecode @AllURLs responseURLsRaw + res = bimap SFTError (fmap sftServer . unAllURLs) eList + void $ case res of + Left e -> + err $ + Log.field "sft_err" (show e) . Log.msg ("Error for URL: " <> toByteString' urlWithPath) + Right servers -> + info $ + Log.field "IPv4s" (show servers) . Log.msg ("Fetched the following server URLs" :: ByteString) + pure . SFTGetResponse $ res + +newtype AllURLs = AllURLs {unAllURLs :: [HttpsUrl]} + deriving (Aeson.FromJSON) via Schema AllURLs + +instance ToSchema AllURLs where + schema = + object "AllURLs" $ + AllURLs + <$> unAllURLs .= field "sft_servers_all" (array schema) + +interpretSFTInMemory :: + Member TinyLog r => + Map HttpsUrl SFTGetResponse -> + Sem (SFT ': r) a -> + Sem r a +interpretSFTInMemory m = interpret $ \(SFTGetAllServers url) -> + case Map.lookup url m of + Nothing -> do + let msg = "No value in the lookup map" + err $ Log.field "url" (show url) . Log.msg (cs msg :: ByteString) + pure . SFTGetResponse . Left . SFTError $ msg + Just ss -> pure ss diff --git a/services/brig/src/Brig/Federation/Client.hs b/services/brig/src/Brig/Federation/Client.hs index cc38a065a82..57451d169c7 100644 --- a/services/brig/src/Brig/Federation/Client.hs +++ b/services/brig/src/Brig/Federation/Client.hs @@ -32,10 +32,14 @@ import Control.Monad.Trans.Except (ExceptT (..), throwE) import Data.Domain import Data.Handle import Data.Id (ClientId, UserId) +import Data.Proxy import Data.Qualified import Data.Range (Range) import qualified Data.Text as T +import GHC.TypeLits import Imports +import Servant.Client hiding (client) +import Servant.Client.Core import qualified System.Logger.Class as Log import Wire.API.Federation.API import Wire.API.Federation.API.Brig as FederatedBrig @@ -48,29 +52,25 @@ import Wire.API.UserMap (UserMap) type FederationAppIO = ExceptT FederationError AppIO --- FUTUREWORK: Maybe find a way to tranform 'clientRoutes' into a client which --- only uses 'FederationAppIO' monad, then boilerplate in this module can all be --- deleted. getUserHandleInfo :: Remote Handle -> FederationAppIO (Maybe UserProfile) getUserHandleInfo (qUntagged -> Qualified handle domain) = do Log.info $ Log.msg $ T.pack "Brig-federation: handle lookup call on remote backend" - executeFederated domain $ getUserByHandle clientRoutes handle + executeFederated @"get-user-by-handle" domain handle getUsersByIds :: Domain -> [UserId] -> FederationAppIO [UserProfile] getUsersByIds domain uids = do Log.info $ Log.msg ("Brig-federation: get users by ids on remote backends" :: ByteString) - executeFederated domain $ FederatedBrig.getUsersByIds clientRoutes uids + executeFederated @"get-users-by-ids" domain uids --- FUTUREWORK(federation): Abstract out all the rpc boilerplate and error handling claimPrekey :: Qualified UserId -> ClientId -> FederationAppIO (Maybe ClientPrekey) claimPrekey (Qualified user domain) client = do Log.info $ Log.msg @Text "Brig-federation: claiming remote prekey" - executeFederated domain $ FederatedBrig.claimPrekey clientRoutes (user, client) + executeFederated @"claim-prekey" domain (user, client) claimPrekeyBundle :: Qualified UserId -> FederationAppIO PrekeyBundle claimPrekeyBundle (Qualified user domain) = do Log.info $ Log.msg @Text "Brig-federation: claiming remote prekey bundle" - executeFederated domain $ FederatedBrig.claimPrekeyBundle clientRoutes user + executeFederated @"claim-prekey-bundle" domain user claimMultiPrekeyBundle :: Domain -> @@ -78,17 +78,17 @@ claimMultiPrekeyBundle :: FederationAppIO UserClientPrekeyMap claimMultiPrekeyBundle domain uc = do Log.info $ Log.msg @Text "Brig-federation: claiming remote multi-user prekey bundle" - executeFederated domain $ FederatedBrig.claimMultiPrekeyBundle clientRoutes uc + executeFederated @"claim-multi-prekey-bundle" domain uc searchUsers :: Domain -> SearchRequest -> FederationAppIO [Public.Contact] searchUsers domain searchTerm = do Log.warn $ Log.msg $ T.pack "Brig-federation: search call on remote backend" - executeFederated domain $ FederatedBrig.searchUsers clientRoutes searchTerm + executeFederated @"search-users" domain searchTerm getUserClients :: Domain -> GetUserClients -> FederationAppIO (UserMap (Set PubClient)) getUserClients domain guc = do Log.info $ Log.msg @Text "Brig-federation: get users' clients from remote backend" - executeFederated domain $ FederatedBrig.getUserClients clientRoutes guc + executeFederated @"get-user-clients" domain guc sendConnectionAction :: Local UserId -> @@ -98,7 +98,7 @@ sendConnectionAction :: sendConnectionAction self (qUntagged -> other) action = do let req = NewConnectionRequest (tUnqualified self) (qUnqualified other) action Log.info $ Log.msg @Text "Brig-federation: sending connection action to remote backend" - executeFederated (qDomain other) $ FederatedBrig.sendConnectionAction clientRoutes req + executeFederated @"send-connection-action" (qDomain other) req notifyUserDeleted :: Local UserId -> @@ -106,13 +106,12 @@ notifyUserDeleted :: FederationAppIO () notifyUserDeleted self remotes = do let remoteConnections = tUnqualified remotes - let fedRPC = - FederatedBrig.onUserDeleted clientRoutes $ - UserDeletedConnectionsNotification (tUnqualified self) remoteConnections - void $ executeFederated (tDomain remotes) fedRPC + void $ + executeFederated @"on-user-deleted-connections" (tDomain remotes) $ + UserDeletedConnectionsNotification (tUnqualified self) remoteConnections -executeFederated :: Domain -> FederatorClient 'Brig a -> FederationAppIO a -executeFederated targetDomain action = do +runBrigFederatorClient :: Domain -> FederatorClient 'Brig a -> FederationAppIO a +runBrigFederatorClient targetDomain action = do ownDomain <- viewFederationDomain endpoint <- view federator >>= maybe (throwE FederationNotConfigured) pure let env = @@ -123,3 +122,15 @@ executeFederated targetDomain action = do } liftIO (runFederatorClient env action) >>= either (throwE . FederationCallFailure) pure + +executeFederated :: + forall (name :: Symbol) api. + ( HasFedEndpoint 'Brig api name, + HasClient ClientM api, + HasClient (FederatorClient 'Brig) api + ) => + Domain -> + Client FederationAppIO api +executeFederated domain = + hoistClient (Proxy @api) (runBrigFederatorClient domain) $ + clientIn (Proxy @api) (Proxy @(FederatorClient 'Brig)) diff --git a/services/brig/src/Brig/IO/Intra.hs b/services/brig/src/Brig/IO/Intra.hs index 55fbb8f54bd..a7ed7bc5068 100644 --- a/services/brig/src/Brig/IO/Intra.hs +++ b/services/brig/src/Brig/IO/Intra.hs @@ -122,6 +122,7 @@ import Wire.API.Federation.Error import Wire.API.Message (UserClients) import Wire.API.Team.Feature (IncludeLockStatus (..), TeamFeatureName (..), TeamFeatureStatus) import Wire.API.Team.LegalHold (LegalholdProtectee) +import qualified Wire.API.Team.Member as Member ----------------------------------------------------------------------------- -- Event Handlers @@ -853,7 +854,7 @@ addTeamMember u tid (minvmeta, role) = do _ -> False where prm = Team.rolePermissions role - bdy = Team.newNewTeamMember u prm minvmeta + bdy = Member.mkNewTeamMember u prm minvmeta req = paths ["i", "teams", toByteString' tid, "members"] . header "Content-Type" "application/json" diff --git a/services/brig/src/Brig/Options.hs b/services/brig/src/Brig/Options.hs index ad631e49325..8487c2c4767 100644 --- a/services/brig/src/Brig/Options.hs +++ b/services/brig/src/Brig/Options.hs @@ -26,13 +26,15 @@ import Brig.Types import Brig.User.Auth.Cookie.Limit import Brig.Whitelist (Whitelist (..)) import qualified Brig.ZAuth as ZAuth +import Control.Applicative import qualified Control.Lens as Lens -import Data.Aeson (withText) +import Data.Aeson (defaultOptions, fieldLabelModifier, genericParseJSON, withText) import qualified Data.Aeson as Aeson import Data.Aeson.Types (typeMismatch) import qualified Data.Char as Char import Data.Domain (Domain (..)) import Data.Id +import Data.LanguageCodes (ISO639_1 (EN)) import Data.Misc (HttpsUrl) import Data.Range import Data.Scientific (toBoundedInteger) @@ -439,9 +441,12 @@ data Settings = Settings -- field names and values), should be in sync -- with Spar setRichInfoLimit :: !Int, - -- | Default locale to use - -- (e.g. when selecting templates) - setDefaultLocale :: !Locale, + -- | Default locale to use when selecting templates + -- use `setDefaultTemplateLocale` as the getter function which always provides a default value + setDefaultTemplateLocaleInternal :: !(Maybe Locale), + -- | Default locale to use for users + -- use `setDefaultUserLocale` as the getter function which always provides a default value + setDefaultUserLocaleInternal :: !(Maybe Locale), -- | Max. # of members in a team. -- NOTE: This must be in sync with galley setMaxTeamSize :: !Word32, @@ -474,7 +479,7 @@ data Settings = Settings -- setFederationAllowedDomains: -- - wire.com -- - example.com - setFederationDomain :: !(Domain), + setFederationDomain :: !Domain, -- | The amount of time in milliseconds to wait after reading from an SQS queue -- returns no message, before asking for messages from SQS again. -- defaults to 'defSqsThrottleMillis'. @@ -499,6 +504,18 @@ data Settings = Settings } deriving (Show, Generic) +defaultTemplateLocale :: Locale +defaultTemplateLocale = Locale (Language EN) Nothing + +defaultUserLocale :: Locale +defaultUserLocale = defaultTemplateLocale + +setDefaultUserLocale :: Settings -> Locale +setDefaultUserLocale = fromMaybe defaultUserLocale . setDefaultUserLocaleInternal + +setDefaultTemplateLocale :: Settings -> Locale +setDefaultTemplateLocale = fromMaybe defaultTemplateLocale . setDefaultTemplateLocaleInternal + -- | The analog to `GT.FeatureFlags`. This type tracks only the things that we need to -- express our current cloud business logic. -- @@ -664,7 +681,16 @@ instance FromJSON Timeout where maybe defaultV fromIntegral bounded parseJSON v = typeMismatch "activationTimeout" v -instance FromJSON Settings +instance FromJSON Settings where + parseJSON = genericParseJSON customOptions + where + customOptions = + defaultOptions + { fieldLabelModifier = \case + "setDefaultUserLocaleInternal" -> "setDefaultUserLocale" + "setDefaultTemplateLocaleInternal" -> "setDefaultTemplateLocale" + other -> other + } instance FromJSON Opts diff --git a/services/brig/src/Brig/Provider/API.hs b/services/brig/src/Brig/Provider/API.hs index 8cebe4a4f6b..3e705990009 100644 --- a/services/brig/src/Brig/Provider/API.hs +++ b/services/brig/src/Brig/Provider/API.hs @@ -846,7 +846,7 @@ addBot zuid zcon cid add = do let botReq = Ext.NewBotRequest bid bcl busr bcnv btk bloc rs <- RPC.createBot scon botReq !>> StdError . serviceError -- Insert the bot user and client - locale <- setDefaultLocale <$> view settings + locale <- Opt.setDefaultUserLocale <$> view settings let name = fromMaybe (serviceProfileName svp) (Ext.rsNewBotName rs) let assets = fromMaybe (serviceProfileAssets svp) (Ext.rsNewBotAssets rs) let colour = fromMaybe defaultAccentId (Ext.rsNewBotColour rs) @@ -858,7 +858,7 @@ addBot zuid zcon cid add = do { newClientPrekeys = Ext.rsNewBotPrekeys rs } lift $ User.insertAccount (UserAccount usr Active) (Just (cid, cnvTeam cnv)) Nothing True - maxPermClients <- fromMaybe Opt.defUserMaxPermClients <$> Opt.setUserMaxPermClients <$> view settings + maxPermClients <- fromMaybe Opt.defUserMaxPermClients . Opt.setUserMaxPermClients <$> view settings (clt, _, _) <- do _ <- do -- if we want to protect bots against lh, 'addClient' cannot just send lh capability diff --git a/services/brig/src/Brig/Provider/Template.hs b/services/brig/src/Brig/Provider/Template.hs index 579a0149e6d..b2c7828b7df 100644 --- a/services/brig/src/Brig/Provider/Template.hs +++ b/services/brig/src/Brig/Provider/Template.hs @@ -137,7 +137,7 @@ loadProviderTemplates o = readLocalesDir defLocale (templateDir gOptions) "provi maybeUrl = fromByteString $ encodeUtf8 $ homeUrl pOptions gOptions = general $ emailSMS o pOptions = provider $ emailSMS o - defLocale = setDefaultLocale (optSettings o) + defLocale = setDefaultTemplateLocale (optSettings o) readTemplate = readTemplateWithDefault (templateDir gOptions) defLocale "provider" readText = readTextWithDefault (templateDir gOptions) defLocale "provider" -- URL templates diff --git a/services/brig/src/Brig/Run.hs b/services/brig/src/Brig/Run.hs index 46179f9e372..f4402dce559 100644 --- a/services/brig/src/Brig/Run.hs +++ b/services/brig/src/Brig/Run.hs @@ -44,7 +44,7 @@ import qualified Control.Concurrent.Async as Async import Control.Exception.Safe (catchAny) import Control.Lens (view, (.~), (^.)) import Control.Monad.Catch (MonadCatch, finally) -import Control.Monad.Random (Random (randomRIO)) +import Control.Monad.Random (randomRIO) import qualified Data.Aeson as Aeson import Data.Default (Default (def)) import Data.Id (RequestId (..)) diff --git a/services/brig/src/Brig/SMTP.hs b/services/brig/src/Brig/SMTP.hs index 59818297d81..f176be2ddac 100644 --- a/services/brig/src/Brig/SMTP.hs +++ b/services/brig/src/Brig/SMTP.hs @@ -84,4 +84,4 @@ initSMTP lg host port credentials connType = do Logger.log lg Logger.Debug (msg $ val "Closing connection to: " +++ host) sendMail :: MonadIO m => SMTP -> Mail -> m () -sendMail s m = liftIO $ withResource (s ^. pool) $ SMTP.sendMimeMail2 m +sendMail s m = liftIO $ withResource (s ^. pool) $ SMTP.sendMail m diff --git a/services/brig/src/Brig/Team/Template.hs b/services/brig/src/Brig/Team/Template.hs index 35946a1404b..1599d810a03 100644 --- a/services/brig/src/Brig/Team/Template.hs +++ b/services/brig/src/Brig/Team/Template.hs @@ -95,6 +95,6 @@ loadTeamTemplates o = readLocalesDir defLocale (templateDir gOptions) "team" $ \ gOptions = general (emailSMS o) tOptions = team (emailSMS o) tUrl = template $ tInvitationUrl tOptions - defLocale = setDefaultLocale (optSettings o) + defLocale = setDefaultTemplateLocale (optSettings o) readTemplate = readTemplateWithDefault (templateDir gOptions) defLocale "team" readText = readTextWithDefault (templateDir gOptions) defLocale "team" diff --git a/services/brig/src/Brig/User/Template.hs b/services/brig/src/Brig/User/Template.hs index 60d1b5cab1c..9d44a2ad782 100644 --- a/services/brig/src/Brig/User/Template.hs +++ b/services/brig/src/Brig/User/Template.hs @@ -228,7 +228,7 @@ loadUserTemplates o = readLocalesDir defLocale templateDir "user" $ \fp -> teamActivationUrl = template $ Opt.tActivationUrl tOptions passwordResetUrl = template $ Opt.passwordResetUrl uOptions deletionUserUrl = template $ Opt.deletionUrl uOptions - defLocale = Opt.setDefaultLocale (Opt.optSettings o) + defLocale = Opt.setDefaultTemplateLocale (Opt.optSettings o) templateDir = Opt.templateDir gOptions readTemplate = readTemplateWithDefault templateDir defLocale "user" readText = readTextWithDefault templateDir defLocale "user" diff --git a/services/brig/test/integration/API/Calling.hs b/services/brig/test/integration/API/Calling.hs index be0185af2d0..758c1befc62 100644 --- a/services/brig/test/integration/API/Calling.hs +++ b/services/brig/test/integration/API/Calling.hs @@ -32,7 +32,7 @@ import Data.Id import qualified Data.List.NonEmpty as NonEmpty import Data.List1 (List1) import qualified Data.List1 as List1 -import Data.Misc (Port, mkHttpsUrl) +import Data.Misc (Port (..), mkHttpsUrl) import qualified Data.Set as Set import Imports import System.FilePath (()) @@ -54,9 +54,9 @@ tests m b opts turn turnV2 = do test m "multiple servers /calls/config - 200" . withTurnFile turn $ testCallsConfigMultiple b, test m "multiple servers /calls/config/v2 - 200" . withTurnFile turnV2 $ testCallsConfigMultipleV2 b ], - testGroup "sft" $ - [ test m "SFT servers /calls/config/v2 - 200" $ testSFT b opts, - test m "SFT servers static URI - 200" $ testSFTStatic b opts + testGroup + "sft" + [ test m "SFT servers /calls/config/v2 - 200" $ testSFT b opts ] ] @@ -87,23 +87,11 @@ testCallsConfigMultiple b turnUpdater = do let _expected = List1.singleton (toTurnURILegacy "127.0.0.1" 3478) modifyAndAssert b uid getTurnConfigurationV1 turnUpdater "turn:127.0.0.1:3478" _expected -testSFTStatic :: Brig -> Opts.Opts -> Http () -testSFTStatic b opts = do - uid <- userId <$> randomUser b - let Right server1 = mkHttpsUrl =<< first show (parseURI laxURIParserOptions "https://sft01.integration-tests.zinfra.io:443") - withSettingsOverrides (opts & Opts.optionSettings . Opts.sftStaticUrl ?~ server1) $ do - cfg1 <- retryWhileN 10 (isNothing . view rtcConfSftServers) (getTurnConfigurationV2 uid b) - liftIO $ - assertEqual - "when SFT static URL is enabled, sft_servers should return just one static entry." - (Set.fromList [sftServer server1]) - (Set.fromList $ maybe [] NonEmpty.toList $ cfg1 ^. rtcConfSftServers) - testSFT :: Brig -> Opts.Opts -> Http () testSFT b opts = do uid <- userId <$> randomUser b cfg <- getTurnConfigurationV2 uid b - liftIO $ + liftIO $ do assertEqual "when SFT discovery is not enabled, sft_servers shouldn't be returned" Nothing diff --git a/services/brig/test/integration/API/Federation.hs b/services/brig/test/integration/API/Federation.hs index a8f44b11136..616ac1c61ec 100644 --- a/services/brig/test/integration/API/Federation.hs +++ b/services/brig/test/integration/API/Federation.hs @@ -45,12 +45,13 @@ import Test.Tasty.HUnit (assertEqual, assertFailure) import Util import Wire.API.Federation.API.Brig (GetUserClients (..), SearchRequest (SearchRequest), UserDeletedConnectionsNotification (..)) import qualified Wire.API.Federation.API.Brig as FedBrig +import Wire.API.Federation.Component import Wire.API.Message (UserClients (..)) import Wire.API.User.Client (mkUserClientPrekeyMap) import Wire.API.UserMap (UserMap (UserMap)) -- Note: POST /federation/send-connection-action is implicitly tested in API.User.Connection -tests :: Manager -> Opt.Opts -> Brig -> Cannon -> FedBrigClient -> IO TestTree +tests :: Manager -> Opt.Opts -> Brig -> Cannon -> FedClient 'Brig -> IO TestTree tests m opts brig cannon fedBrigClient = return $ testGroup @@ -71,7 +72,7 @@ tests m opts brig cannon fedBrigClient = test m "POST /federation/on-user-deleted-connections : 200" (testRemoteUserGetsDeleted opts brig cannon fedBrigClient) ] -testSearchSuccess :: Brig -> FedBrigClient -> Http () +testSearchSuccess :: Brig -> FedClient 'Brig -> Http () testSearchSuccess brig fedBrigClient = do (handle, user) <- createUserWithHandle brig let quid = userQualifiedId user @@ -87,26 +88,32 @@ testSearchSuccess brig fedBrigClient = do put (brig . path "/self" . contentJson . zUser (userId identityThief) . zConn "c" . body update) !!! const 200 === statusCode refreshIndex brig - searchResult <- FedBrig.searchUsers (fedBrigClient (Domain "example.com")) (SearchRequest (fromHandle handle)) + searchResult <- + runFedClient @"search-users" fedBrigClient (Domain "example.com") $ + SearchRequest (fromHandle handle) liftIO $ do let contacts = contactQualifiedId <$> searchResult assertEqual "should return only the first user id but not the identityThief" [quid] contacts -testSearchNotFound :: FedBrigClient -> Http () +testSearchNotFound :: FedClient 'Brig -> Http () testSearchNotFound fedBrigClient = do - searchResult <- FedBrig.searchUsers (fedBrigClient (Domain "example.com")) $ SearchRequest "this-handle-should-not-exist" + searchResult <- + runFedClient @"search-users" fedBrigClient (Domain "example.com") $ + SearchRequest "this-handle-should-not-exist" liftIO $ assertEqual "should return empty array of users" [] searchResult -testSearchNotFoundEmpty :: FedBrigClient -> Http () +testSearchNotFoundEmpty :: FedClient 'Brig -> Http () testSearchNotFoundEmpty fedBrigClient = do - searchResult <- FedBrig.searchUsers (fedBrigClient (Domain "example.com")) $ SearchRequest "" + searchResult <- + runFedClient @"search-users" fedBrigClient (Domain "example.com") $ + SearchRequest "" liftIO $ assertEqual "should return empty array of users" [] searchResult -testGetUserByHandleSuccess :: Brig -> FedBrigClient -> Http () +testGetUserByHandleSuccess :: Brig -> FedClient 'Brig -> Http () testGetUserByHandleSuccess brig fedBrigClient = do (handle, user) <- createUserWithHandle brig let quid = userQualifiedId user - maybeProfile <- FedBrig.getUserByHandle (fedBrigClient (Domain "example.com")) handle + maybeProfile <- runFedClient @"get-user-by-handle" fedBrigClient (Domain "example.com") handle liftIO $ do case maybeProfile of Nothing -> assertFailure "Expected to find profile, found Nothing" @@ -114,13 +121,15 @@ testGetUserByHandleSuccess brig fedBrigClient = do assertEqual "should return correct user Id" quid (profileQualifiedId profile) assertEqual "should not have email address" Nothing (profileEmail profile) -testGetUserByHandleNotFound :: FedBrigClient -> Http () +testGetUserByHandleNotFound :: FedClient 'Brig -> Http () testGetUserByHandleNotFound fedBrigClient = do hdl <- randomHandle - maybeProfile <- FedBrig.getUserByHandle (fedBrigClient (Domain "example.com")) (Handle hdl) + maybeProfile <- + runFedClient @"get-user-by-handle" fedBrigClient (Domain "example.com") $ + Handle hdl liftIO $ assertEqual "should not return any UserProfile" Nothing maybeProfile -testGetUsersByIdsSuccess :: Brig -> FedBrigClient -> Http () +testGetUsersByIdsSuccess :: Brig -> FedClient 'Brig -> Http () testGetUsersByIdsSuccess brig fedBrigClient = do user1 <- randomUser brig user2 <- randomUser brig @@ -128,53 +137,55 @@ testGetUsersByIdsSuccess brig fedBrigClient = do quid1 = userQualifiedId user1 uid2 = userId user2 quid2 = userQualifiedId user2 - profiles <- FedBrig.getUsersByIds (fedBrigClient (Domain "example.com")) [uid1, uid2] + profiles <- runFedClient @"get-users-by-ids" fedBrigClient (Domain "example.com") [uid1, uid2] liftIO $ do assertEqual "should return correct user Id" (Set.fromList [quid1, quid2]) (Set.fromList $ profileQualifiedId <$> profiles) assertEqual "should not have email address" [Nothing, Nothing] (map profileEmail profiles) -testGetUsersByIdsPartial :: Brig -> FedBrigClient -> Http () +testGetUsersByIdsPartial :: Brig -> FedClient 'Brig -> Http () testGetUsersByIdsPartial brig fedBrigClient = do presentUser <- randomUser brig absentUserId :: UserId <- Id <$> lift UUIDv4.nextRandom - profiles <- FedBrig.getUsersByIds (fedBrigClient (Domain "example.com")) [userId presentUser, absentUserId] + profiles <- + runFedClient @"get-users-by-ids" fedBrigClient (Domain "example.com") $ + [userId presentUser, absentUserId] liftIO $ assertEqual "should return the present user and skip the absent ones" [userQualifiedId presentUser] (profileQualifiedId <$> profiles) -testGetUsersByIdsNoneFound :: FedBrigClient -> Http () +testGetUsersByIdsNoneFound :: FedClient 'Brig -> Http () testGetUsersByIdsNoneFound fedBrigClient = do absentUserId1 :: UserId <- Id <$> lift UUIDv4.nextRandom absentUserId2 :: UserId <- Id <$> lift UUIDv4.nextRandom - profiles <- FedBrig.getUsersByIds (fedBrigClient (Domain "example.com")) [absentUserId1, absentUserId2] + profiles <- runFedClient @"get-users-by-ids" fedBrigClient (Domain "example.com") [absentUserId1, absentUserId2] liftIO $ assertEqual "should return empty list" [] profiles -testClaimPrekeySuccess :: Brig -> FedBrigClient -> Http () +testClaimPrekeySuccess :: Brig -> FedClient 'Brig -> Http () testClaimPrekeySuccess brig fedBrigClient = do user <- randomUser brig let uid = userId user let new = defNewClient PermanentClientType [head somePrekeys] (head someLastPrekeys) c <- responseJsonError =<< addClient brig uid new - mkey <- FedBrig.claimPrekey (fedBrigClient (Domain "example.com")) (uid, clientId c) + mkey <- runFedClient @"claim-prekey" fedBrigClient (Domain "example.com") (uid, clientId c) liftIO $ assertEqual "should return prekey 1" (Just (PrekeyId 1)) (fmap (prekeyId . prekeyData) mkey) -testClaimPrekeyBundleSuccess :: Brig -> FedBrigClient -> Http () +testClaimPrekeyBundleSuccess :: Brig -> FedClient 'Brig -> Http () testClaimPrekeyBundleSuccess brig fedBrigClient = do let prekeys = take 5 (zip somePrekeys someLastPrekeys) (quid, clients) <- generateClientPrekeys brig prekeys let sortClients = sortBy (compare `on` prekeyClient) - bundle <- FedBrig.claimPrekeyBundle (fedBrigClient (Domain "example.com")) (qUnqualified quid) + bundle <- runFedClient @"claim-prekey-bundle" fedBrigClient (Domain "example.com") (qUnqualified quid) liftIO $ assertEqual "bundle should contain the clients" (sortClients clients) (sortClients . prekeyClients $ bundle) -testClaimMultiPrekeyBundleSuccess :: Brig -> FedBrigClient -> Http () +testClaimMultiPrekeyBundleSuccess :: Brig -> FedClient 'Brig -> Http () testClaimMultiPrekeyBundleSuccess brig fedBrigClient = do let prekeys = zip somePrekeys someLastPrekeys (prekeys1, prekeys') = splitAt 5 prekeys @@ -185,7 +196,7 @@ testClaimMultiPrekeyBundleSuccess brig fedBrigClient = do c2 <- first qUnqualified <$> generateClientPrekeys brig prekeys2 let uc = UserClients (Map.fromList [mkClients <$> c1, mkClients <$> c2]) ucm = mkUserClientPrekeyMap (Map.fromList [mkClientMap <$> c1, mkClientMap <$> c2]) - ucmResponse <- FedBrig.claimMultiPrekeyBundle (fedBrigClient (Domain "example.com")) uc + ucmResponse <- runFedClient @"claim-multi-prekey-bundle" fedBrigClient (Domain "example.com") uc liftIO $ assertEqual "should return the UserClientMap" @@ -199,28 +210,28 @@ addTestClients brig uid idxs = client :: Client <- responseJsonError =<< addClient brig uid (defNewClient PermanentClientType [pk] lk) pure client -testGetUserClients :: Brig -> FedBrigClient -> Http () +testGetUserClients :: Brig -> FedClient 'Brig -> Http () testGetUserClients brig fedBrigClient = do uid1 <- userId <$> randomUser brig clients :: [Client] <- addTestClients brig uid1 [0, 1, 2] - UserMap userClients <- FedBrig.getUserClients (fedBrigClient (Domain "example.com")) (GetUserClients [uid1]) + UserMap userClients <- runFedClient @"get-user-clients" fedBrigClient (Domain "example.com") (GetUserClients [uid1]) liftIO $ assertEqual "client set for user should match" (Just (Set.fromList (fmap clientId clients))) (fmap (Set.map pubClientId) . Map.lookup uid1 $ userClients) -testGetUserClientsNotFound :: FedBrigClient -> Http () +testGetUserClientsNotFound :: FedClient 'Brig -> Http () testGetUserClientsNotFound fedBrigClient = do absentUserId <- randomId - UserMap userClients <- FedBrig.getUserClients (fedBrigClient (Domain "example.com")) (GetUserClients [absentUserId]) + UserMap userClients <- runFedClient @"get-user-clients" fedBrigClient (Domain "example.com") (GetUserClients [absentUserId]) liftIO $ assertEqual "client set for user should match" (Just (Set.fromList [])) (fmap (Set.map pubClientId) . Map.lookup absentUserId $ userClients) -testRemoteUserGetsDeleted :: Opt.Opts -> Brig -> Cannon -> FedBrigClient -> Http () +testRemoteUserGetsDeleted :: Opt.Opts -> Brig -> Cannon -> FedClient 'Brig -> Http () testRemoteUserGetsDeleted opts brig cannon fedBrigClient = do connectedUser <- userId <$> randomUser brig pendingUser <- userId <$> randomUser brig @@ -236,9 +247,8 @@ testRemoteUserGetsDeleted opts brig cannon fedBrigClient = do let localUsers = [connectedUser, pendingUser, blockedUser, unconnectedUser] void . WS.bracketRN cannon localUsers $ \[cc, pc, bc, uc] -> do _ <- - FedBrig.onUserDeleted - (fedBrigClient (qDomain remoteUser)) - (UserDeletedConnectionsNotification (qUnqualified remoteUser) (unsafeRange localUsers)) + runFedClient @"on-user-deleted-connections" fedBrigClient (qDomain remoteUser) $ + UserDeletedConnectionsNotification (qUnqualified remoteUser) (unsafeRange localUsers) WS.assertMatchN_ (5 # Second) [cc] $ matchDeleteUserNotification remoteUser WS.assertNoEvent (1 # Second) [pc, bc, uc] diff --git a/services/brig/test/integration/API/Team/Util.hs b/services/brig/test/integration/API/Team/Util.hs index aa44fc75895..36811ec25d3 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.Team.Member as Member import qualified Wire.API.User as Public -- | FUTUREWORK: Remove 'createPopulatedBindingTeam', 'createPopulatedBindingTeamWithNames', @@ -204,7 +205,7 @@ updatePermissions from tid (to, perm) galley = !!! const 200 === statusCode where - changeMember = Team.newNewTeamMember to perm Nothing + changeMember = Member.mkNewTeamMember to perm Nothing createTeamConv :: HasCallStack => Galley -> TeamId -> UserId -> [UserId] -> Maybe Milliseconds -> Http ConvId createTeamConv g tid u us mtimer = do diff --git a/services/brig/test/integration/API/User.hs b/services/brig/test/integration/API/User.hs index 8d3a357312d..ed1863c4a59 100644 --- a/services/brig/test/integration/API/User.hs +++ b/services/brig/test/integration/API/User.hs @@ -40,8 +40,21 @@ import Imports import Test.Tasty hiding (Timeout) import Util import Util.Options.Common +import Wire.API.Federation.Component -tests :: Opt.Opts -> FedBrigClient -> FedGalleyClient -> Manager -> Brig -> Cannon -> CargoHold -> Galley -> Nginz -> AWS.Env -> DB.ClientState -> IO TestTree +tests :: + Opt.Opts -> + FedClient 'Brig -> + FedClient 'Galley -> + Manager -> + Brig -> + Cannon -> + CargoHold -> + Galley -> + Nginz -> + AWS.Env -> + DB.ClientState -> + IO TestTree tests conf fbc fgc p b c ch g n aws db = do let cl = ConnectionLimit $ Opt.setUserMaxConnections (Opt.optSettings conf) let at = Opt.setActivationTimeout (Opt.optSettings conf) diff --git a/services/brig/test/integration/API/User/Account.hs b/services/brig/test/integration/API/User/Account.hs index f723e318aa0..118e31f8ecf 100644 --- a/services/brig/test/integration/API/User/Account.hs +++ b/services/brig/test/integration/API/User/Account.hs @@ -34,7 +34,6 @@ import Brig.Types import Brig.Types.Intra import Brig.Types.User.Auth hiding (user) import qualified Brig.Types.User.Auth as Auth -import qualified CargoHold.Types.V3 as CHV3 import Control.Arrow ((&&&)) import Control.Exception (throw) import Control.Lens (ix, preview, (^.), (^?)) @@ -79,6 +78,7 @@ import UnliftIO (mapConcurrently_) import Util as Util import Util.AWS as Util import Web.Cookie (parseSetCookie) +import qualified Wire.API.Asset as Asset import Wire.API.Federation.API.Brig (UserDeletedConnectionsNotification (..)) import qualified Wire.API.Federation.API.Brig as FedBrig import Wire.API.Federation.API.Common (EmptyResponse (EmptyResponse)) @@ -90,9 +90,12 @@ tests _ at opts p b c ch g aws = testGroup "account" [ test' aws p "post /register - 201 (with preverified)" $ testCreateUserWithPreverified opts b aws, + test' aws p "post /register - 400 (with preverified)" $ testCreateUserWithInvalidVerificationCode b, test' aws p "post /register - 201" $ testCreateUser b g, test' aws p "post /register - 201 + no email" $ testCreateUserNoEmailNoPassword b, test' aws p "post /register - 201 anonymous" $ testCreateUserAnon b g, + test' aws p "post /register - 400 empty name" $ testCreateUserEmptyName b, + test' aws p "post /register - 400 name too long" $ testCreateUserLongName b, test' aws p "post /register - 201 anonymous expiry" $ testCreateUserAnonExpiry b, test' aws p "post /register - 201 pending" $ testCreateUserPending opts b, test' aws p "post /register - 201 existing activation" $ testCreateAccountPendingActivationKey opts b, @@ -148,6 +151,34 @@ tests _ at opts p b c ch g aws = ] ] +-- The testCreateUserWithInvalidVerificationCode test conforms to the following testing standards: +-- @SF.Provisioning @TSFI.RESTfulAPI @S2 +-- +-- Registering with an invalid verification code and valid account details should fail. +testCreateUserWithInvalidVerificationCode :: Brig -> Http () +testCreateUserWithInvalidVerificationCode brig = do + -- Attempt to register (pre verified) user with phone + p <- randomPhone + code <- randomActivationCode -- incorrect but syntactically valid activation code + let Object regPhone = + object + [ "name" .= Name "Alice", + "phone" .= fromPhone p, + "phone_code" .= code + ] + postUserRegister' regPhone brig !!! const 404 === statusCode + -- Attempt to register (pre verified) user with email + e <- randomEmail + let Object regEmail = + object + [ "name" .= Name "Alice", + "email" .= fromEmail e, + "email_code" .= code + ] + postUserRegister' regEmail brig !!! const 404 === statusCode + +-- @END + testUpdateUserEmailByTeamOwner :: Brig -> Http () testUpdateUserEmailByTeamOwner brig = do (_, teamOwner, emailOwner : otherTeamMember : _) <- createPopulatedBindingTeamWithNamesAndHandles brig 2 @@ -263,6 +294,37 @@ testCreateUser brig galley = do b <- responseBody r b ^? key "conversations" . nth 0 . key "type" >>= maybeFromJSON +-- The testCreateUserEmptyName test conforms to the following testing standards: +-- @SF.Provisioning @TSFI.RESTfulAPI @S2 +-- +-- An empty name is not allowed on registration +testCreateUserEmptyName :: Brig -> Http () +testCreateUserEmptyName brig = do + let p = + RequestBodyLBS . encode $ + object + ["name" .= ("" :: Text)] + post (brig . path "/register" . contentJson . body p) + !!! const 400 === statusCode + +-- @END + +-- The testCreateUserLongName test conforms to the following testing standards: +-- @SF.Provisioning @TSFI.RESTfulAPI @S2 +-- +-- a name with > 128 characters is not allowed. +testCreateUserLongName :: Brig -> Http () +testCreateUserLongName brig = do + let nameTooLong = cs $ concat $ replicate 129 "a" + let p = + RequestBodyLBS . encode $ + object + ["name" .= (nameTooLong :: Text)] + post (brig . path "/register" . contentJson . body p) + !!! const 400 === statusCode + +-- @END + testCreateUserAnon :: Brig -> Galley -> Http () testCreateUserAnon brig galley = do let p = @@ -348,7 +410,10 @@ testCreateUserNoEmailNoPassword brig = do getPhoneLoginCode brig p initiateEmailUpdateLogin brig e (SmsLogin p code Nothing) uid !!! (const 202 === statusCode) --- | email address must not be taken on @/register@. +-- The testCreateUserConflict test conforms to the following testing standards: +-- @SF.Provisioning @TSFI.RESTfulAPI @S2 +-- +-- email address must not be taken on @/register@. testCreateUserConflict :: Opt.Opts -> Brig -> Http () testCreateUserConflict (Opt.setRestrictUserCreation . Opt.optSettings -> Just True) _ = pure () testCreateUserConflict _ brig = do @@ -378,6 +443,12 @@ testCreateUserConflict _ brig = do const 409 === statusCode const (Just "key-exists") === fmap Error.label . responseJsonMaybe +-- @END + +-- The testCreateUserInvalidEmailOrPhone test conforms to the following testing standards: +-- @SF.Provisioning @TSFI.RESTfulAPI @S2 +-- +-- Test to make sure a new user cannot be created with an invalid email address or invalid phone number. testCreateUserInvalidEmailOrPhone :: Opt.Opts -> Brig -> Http () testCreateUserInvalidEmailOrPhone (Opt.setRestrictUserCreation . Opt.optSettings -> Just True) _ = pure () testCreateUserInvalidEmailOrPhone _ brig = do @@ -405,6 +476,8 @@ testCreateUserInvalidEmailOrPhone _ brig = do post (brig . path "/register" . contentJson . body reqPhone) !!! const 400 === statusCode +-- @END + testCreateUserBlacklist :: Opt.Opts -> Brig -> AWS.Env -> Http () testCreateUserBlacklist (Opt.setRestrictUserCreation . Opt.optSettings -> Just True) _ _ = pure () testCreateUserBlacklist _ brig aws = @@ -1246,10 +1319,15 @@ testDeleteInternal brig cannon aws = do testDeleteWithProfilePic :: Brig -> CargoHold -> Http () testDeleteWithProfilePic brig cargohold = do uid <- userId <$> createAnonUser "anon" brig - ast <- uploadAsset cargohold uid "this is my profile pic" + ast <- responseJsonError =<< uploadAsset cargohold uid Asset.defAssetSettings "this is my profile pic" -- Ensure that the asset is there - downloadAsset cargohold uid (toByteString' (ast ^. CHV3.assetKey)) !!! const 200 === statusCode - let newAssets = Just [ImageAsset (T.decodeLatin1 $ toByteString' (ast ^. CHV3.assetKey)) (Just AssetComplete)] + downloadAsset cargohold uid (ast ^. Asset.assetKey) !!! const 200 === statusCode + let newAssets = + Just + [ ImageAsset + (T.decodeLatin1 $ toByteString' (qUnqualified (ast ^. Asset.assetKey))) + (Just AssetComplete) + ] userUpdate = UserUpdate Nothing Nothing newAssets Nothing update = RequestBodyLBS . encode $ userUpdate -- Update profile with the uploaded asset @@ -1257,7 +1335,7 @@ testDeleteWithProfilePic brig cargohold = do !!! const 200 === statusCode deleteUser uid Nothing brig !!! const 200 === statusCode -- Check that the asset gets deleted - downloadAsset cargohold uid (toByteString' (ast ^. CHV3.assetKey)) !!! const 404 === statusCode + downloadAsset cargohold uid (ast ^. Asset.assetKey) !!! const 404 === statusCode testDeleteWithRemotes :: Opt.Opts -> Brig -> Http () testDeleteWithRemotes opts brig = do diff --git a/services/brig/test/integration/API/User/Auth.hs b/services/brig/test/integration/API/User/Auth.hs index 37e803e54bd..f4ee97ea3f5 100644 --- a/services/brig/test/integration/API/User/Auth.hs +++ b/services/brig/test/integration/API/User/Auth.hs @@ -361,6 +361,10 @@ testSendLoginCode brig = do let _timeout = fromLoginCodeTimeout <$> responseJsonMaybe rsp2 liftIO $ assertEqual "timeout" (Just (Code.Timeout 600)) _timeout +-- The testLoginFailure test conforms to the following testing standards: +-- @SF.Provisioning @TSFI.RESTfulAPI @S2 +-- +-- Test that trying to log in with a wrong password or non-existent email fails. testLoginFailure :: Brig -> Http () testLoginFailure brig = do Just email <- userEmail <$> randomUser brig @@ -373,6 +377,8 @@ testLoginFailure brig = do login brig (PasswordLogin (LoginByEmail badmail) defPassword Nothing) PersistentCookie !!! const 403 === statusCode +-- @END + testThrottleLogins :: Opts.Opts -> Brig -> Http () testThrottleLogins conf b = do -- Get the maximum amount of times we are allowed to login before @@ -395,6 +401,16 @@ testThrottleLogins conf b = do threadDelay (1000000 * (n + 1)) login b (defEmailLogin e) SessionCookie !!! const 200 === statusCode +-- The testLimitRetries test conforms to the following testing standards: +-- @SF.Channel @TSFI.RESTfulAPI @S2 +-- +-- The following test tests the login retries. It checks that a user can make +-- only a prespecified number of attempts to log in with an invalid password, +-- after which the user is unable to try again for a configured amount of time. +-- After the configured amount of time has passed, the test asserts the user can +-- successfully log in again. Furthermore, the test asserts that another +-- unrelated user can successfully log-in in parallel to the failed attempts of +-- the aforementioned user. testLimitRetries :: HasCallStack => Opts.Opts -> Brig -> Http () testLimitRetries conf brig = do let Just opts = Opts.setLimitFailedLogins . Opts.optSettings $ conf @@ -441,6 +457,8 @@ testLimitRetries conf brig = do liftIO $ threadDelay (1000000 * 2) login brig (defEmailLogin email) SessionCookie !!! const 200 === statusCode +-- @END + ------------------------------------------------------------------------------- -- LegalHold Login @@ -566,6 +584,10 @@ testNoUserSsoLogin brig = do ------------------------------------------------------------------------------- -- Token Refresh +-- The testInvalidCookie test conforms to the following testing standards: +-- @SF.Provisioning @TSFI.RESTfulAPI @S2 +-- +-- Test that invalid and expired tokens do not work. testInvalidCookie :: forall u. ZAuth.UserTokenLike u => ZAuth.Env -> Brig -> Http () testInvalidCookie z b = do -- Syntactically invalid @@ -581,6 +603,8 @@ testInvalidCookie z b = do const 403 === statusCode const (Just "expired") =~= responseBody +-- @END + testInvalidToken :: Brig -> Http () testInvalidToken b = do -- Syntactically invalid @@ -898,6 +922,14 @@ testRemoveCookiesByLabelAndId b = do let lbl = cookieLabel c4 listCookies b (userId u) >>= liftIO . ([lbl] @=?) . map cookieLabel +-- The testTooManyCookies test conforms to the following testing standards: +-- @SF.Provisioning @TSFI.RESTfulAPI @S2 +-- +-- The test asserts that there is an upper limit for the number of user cookies +-- per cookie type. It does that by concurrently attempting to create more +-- persistent and session cookies than the configured maximum. +-- Creation of new cookies beyond the limit causes deletion of the +-- oldest cookies. testTooManyCookies :: Opts.Opts -> Brig -> Http () testTooManyCookies config b = do u <- randomUser b @@ -941,6 +973,8 @@ testTooManyCookies config b = do ) xxx -> error ("Unexpected status code when logging in: " ++ show xxx) +-- @END + testLogout :: Brig -> Http () testLogout b = do Just email <- userEmail <$> randomUser b diff --git a/services/brig/test/integration/API/User/Client.hs b/services/brig/test/integration/API/User/Client.hs index f086ebbdafd..0a2e1315695 100644 --- a/services/brig/test/integration/API/User/Client.hs +++ b/services/brig/test/integration/API/User/Client.hs @@ -89,6 +89,7 @@ tests _cl _at opts p b c g = test p "delete /clients/:client - 200 (pwd)" $ testRemoveClient True b c, test p "delete /clients/:client - 200 (no pwd)" $ testRemoveClient False b c, test p "delete /clients/:client - 400 (short pwd)" $ testRemoveClientShortPwd b, + test p "delete /clients/:client - 403 (incorrect pwd)" $ testRemoveClientIncorrectPwd b, test p "put /clients/:client - 200" $ testUpdateClient opts b, test p "get /clients/:client - 404" $ testMissingClient b, test p "post /clients - 200 multiple temporary" $ testAddMultipleTemporary b g, @@ -416,6 +417,13 @@ testMultiUserGetPrekeysQualified brig opts = do const 200 === statusCode const (Right $ expectedUserClientMap) === responseJsonEither +-- The testTooManyClients test conforms to the following testing standards: +-- @SF.Provisioning @TSFI.RESTfulAPI @S2 +-- +-- The test validates the upper bound on the number of permanent clients per +-- user. It does so by trying to create one permanent client more than allowed. +-- The expected outcome is that all the clients up to the limit are successfully +-- created, but the one over the limit is not (error `404 too-many-clients`). testTooManyClients :: Opt.Opts -> Brig -> Http () testTooManyClients opts brig = do uid <- userId <$> randomUser brig @@ -436,6 +444,14 @@ testTooManyClients opts brig = do const (Just "too-many-clients") === fmap Error.label . responseJsonMaybe const (Just "application/json;charset=utf-8") === getHeader "Content-Type" +-- @END + +-- The testRemoveClient test conforms to the following testing standards: +-- @SF.Provisioning @TSFI.RESTfulAPI @S2 +-- +-- This test validates creating and deleting a client. A client is created and +-- consequently deleted. Deleting a second time yields response 404 not found. +-- Prekeys and cookies are not there anymore once the client is deleted. testRemoveClient :: Bool -> Brig -> Cannon -> Http () testRemoveClient hasPwd brig cannon = do u <- randomUser' hasPwd brig @@ -475,6 +491,14 @@ testRemoveClient hasPwd brig cannon = do newClientCookie = Just defCookieLabel } +-- @END + +-- The testRemoveClientShortPwd test conforms to the following testing standards: +-- @SF.Provisioning @TSFI.RESTfulAPI @S2 +-- +-- The test checks if a client can be deleted by providing a too short password. +-- This is done by using a single-character password, whereas the minimum is 6 +-- characters. The client deletion attempt fails as expected. testRemoveClientShortPwd :: Brig -> Http () testRemoveClientShortPwd brig = do u <- randomUser brig @@ -501,6 +525,42 @@ testRemoveClientShortPwd brig = do newClientCookie = Just defCookieLabel } +-- @END + +-- The testRemoveClientIncorrectPwd test conforms to the following testing standards: +-- @SF.Provisioning @TSFI.RESTfulAPI @S2 +-- +-- The test checks if a client can be deleted by providing a syntax-valid, but +-- incorrect password. The client deletion attempt fails with a 403 error +-- response. +testRemoveClientIncorrectPwd :: Brig -> Http () +testRemoveClientIncorrectPwd brig = do + u <- randomUser brig + let uid = userId u + let Just email = userEmail u + -- Permanent client with attached cookie + login brig (defEmailLogin email) PersistentCookie + !!! const 200 === statusCode + numCookies <- countCookies brig uid defCookieLabel + liftIO $ Just 1 @=? numCookies + c <- responseJsonError =<< addClient brig uid (client PermanentClientType (someLastPrekeys !! 10)) + resp <- + deleteClient brig uid (clientId c) (Just "abcdef") + Brig -> Http () testUpdateClient opts brig = do uid <- userId <$> randomUser brig @@ -661,7 +721,14 @@ testMissingClient brig = do const ["text/plain;charset=utf-8"] === map snd . filter ((== "Content-Type") . fst) . responseHeaders +-- The testAddMultipleTemporary test conforms to the following testing standards: +-- @SF.Provisioning @TSFI.RESTfulAPI @S2 -- Legacy (galley) +-- +-- Add temporary client, check that all services (both galley and +-- brig) have registered it. Add second temporary client, check +-- again. (NB: temp clients replace each other, there can always be +-- at most one per account.) testAddMultipleTemporary :: Brig -> Galley -> Http () testAddMultipleTemporary brig galley = do uid <- userId <$> randomUser brig @@ -701,6 +768,8 @@ testAddMultipleTemporary brig galley = do . zUser u return $ Vec.length <$> (preview _Array =<< responseJsonMaybe @Value r) +-- @END + testPreKeyRace :: Brig -> Http () testPreKeyRace brig = do uid <- userId <$> randomUser brig diff --git a/services/brig/test/integration/API/User/Connection.hs b/services/brig/test/integration/API/User/Connection.hs index 199d41228d7..8ab59976bd7 100644 --- a/services/brig/test/integration/API/User/Connection.hs +++ b/services/brig/test/integration/API/User/Connection.hs @@ -44,13 +44,24 @@ import Test.Tasty hiding (Timeout) import Test.Tasty.HUnit import Util import Wire.API.Connection -import qualified Wire.API.Federation.API.Brig as F +import Wire.API.Federation.API.Brig import Wire.API.Federation.API.Galley (GetConversationsRequest (..), GetConversationsResponse (gcresConvs), RemoteConvMembers (rcmOthers), RemoteConversation (rcnvMembers)) -import qualified Wire.API.Federation.API.Galley as F +import Wire.API.Federation.Component import Wire.API.Routes.Internal.Brig.Connection import Wire.API.Routes.MultiTablePaging -tests :: ConnectionLimit -> Opt.Timeout -> Opt.Opts -> Manager -> Brig -> Cannon -> Galley -> FedBrigClient -> FedGalleyClient -> DB.ClientState -> TestTree +tests :: + ConnectionLimit -> + Opt.Timeout -> + Opt.Opts -> + Manager -> + Brig -> + Cannon -> + Galley -> + FedClient 'Brig -> + FedClient 'Galley -> + DB.ClientState -> + TestTree tests cl _at opts p b _c g fedBrigClient fedGalleyClient db = testGroup "connection" @@ -713,23 +724,25 @@ testConnectFederationNotAvailable brig = do postConnectionQualified brig uid1 quid2 !!! const 422 === statusCode -testConnectOK :: Brig -> Galley -> FedBrigClient -> Http () +testConnectOK :: Brig -> Galley -> FedClient 'Brig -> Http () testConnectOK brig galley fedBrigClient = do let convIsLocal = True (uid1, quid2, convId) <- localAndRemoteUserWithConvId brig convIsLocal - receiveConnectionAction brig fedBrigClient uid1 quid2 F.RemoteConnect Nothing Pending + receiveConnectionAction brig fedBrigClient uid1 quid2 RemoteConnect Nothing Pending -- The conversation exists uid1 is not a participant however getConversationQualified galley uid1 convId !!! statusCode === const 403 -testConnectWithAnon :: Brig -> FedBrigClient -> Http () +testConnectWithAnon :: Brig -> FedClient 'Brig -> Http () testConnectWithAnon brig fedBrigClient = do fromUser <- randomId toUser <- userId <$> createAnonUser "anon1234" brig - res <- F.sendConnectionAction (fedBrigClient (Domain "far-away.example.com")) (F.NewConnectionRequest fromUser toUser F.RemoteConnect) + res <- + runFedClient @"send-connection-action" fedBrigClient (Domain "far-away.example.com") $ + NewConnectionRequest fromUser toUser RemoteConnect liftIO $ - assertEqual "The response should specify that the user is not activated" F.NewConnectionResponseUserNotActivated res + assertEqual "The response should specify that the user is not activated" NewConnectionResponseUserNotActivated res testConnectFromAnon :: Brig -> Http () testConnectFromAnon brig = do @@ -737,7 +750,7 @@ testConnectFromAnon brig = do remoteUser <- fakeRemoteUser postConnectionQualified brig anonUser remoteUser !!! const 403 === statusCode -testConnectMutualLocalActionThenRemoteAction :: Opt.Opts -> Brig -> Galley -> FedBrigClient -> Http () +testConnectMutualLocalActionThenRemoteAction :: Opt.Opts -> Brig -> Galley -> FedClient 'Brig -> Http () testConnectMutualLocalActionThenRemoteAction opts brig galley fedBrigClient = do let convIsLocal = True (uid1, quid2, convId) <- localAndRemoteUserWithConvId brig convIsLocal @@ -756,7 +769,7 @@ testConnectMutualLocalActionThenRemoteAction opts brig galley fedBrigClient = do -- The response should have 'RemoteConnect' as action, because we cannot be -- sure if the remote was previously in Ignored state or not - receiveConnectionAction brig fedBrigClient uid1 quid2 F.RemoteConnect (Just F.RemoteConnect) Accepted + receiveConnectionAction brig fedBrigClient uid1 quid2 RemoteConnect (Just RemoteConnect) Accepted do res <- @@ -766,14 +779,14 @@ testConnectMutualLocalActionThenRemoteAction opts brig galley fedBrigClient = do liftIO $ (fmap omQualifiedId . cmOthers . cnvMembers) conv @?= [quid2] -testConnectMutualRemoteActionThenLocalAction :: Opt.Opts -> Brig -> FedBrigClient -> FedGalleyClient -> Http () +testConnectMutualRemoteActionThenLocalAction :: Opt.Opts -> Brig -> FedClient 'Brig -> FedClient 'Galley -> Http () testConnectMutualRemoteActionThenLocalAction opts brig fedBrigClient fedGalleyClient = do let convIsLocal = True (uid1, quid2, convId) <- localAndRemoteUserWithConvId brig convIsLocal -- First create a connection request from remote to local user, as this test -- aims to test the behaviour of sending a mutual request to remote - receiveConnectionAction brig fedBrigClient uid1 quid2 F.RemoteConnect Nothing Pending + receiveConnectionAction brig fedBrigClient uid1 quid2 RemoteConnect Nothing Pending let request = GetConversationsRequest @@ -781,58 +794,58 @@ testConnectMutualRemoteActionThenLocalAction opts brig fedBrigClient fedGalleyCl gcrConvIds = [qUnqualified convId] } - res <- F.getConversations (fedGalleyClient (qDomain quid2)) request + res <- runFedClient @"get-conversations" fedGalleyClient (qDomain quid2) request liftIO $ fmap (fmap omQualifiedId . rcmOthers . rcnvMembers) (gcresConvs res) @?= [[]] -- The mock response has 'RemoteConnect' as action, because the remote backend -- cannot be sure if the local backend was previously in Ignored state or not - sendConnectionAction brig opts uid1 quid2 (Just F.RemoteConnect) Accepted + sendConnectionAction brig opts uid1 quid2 (Just RemoteConnect) Accepted -testConnectFromPending :: Brig -> FedBrigClient -> Http () +testConnectFromPending :: Brig -> FedClient 'Brig -> Http () testConnectFromPending brig fedBrigClient = do (uid1, quid2) <- localAndRemoteUser brig - receiveConnectionAction brig fedBrigClient uid1 quid2 F.RemoteConnect Nothing Pending - receiveConnectionAction brig fedBrigClient uid1 quid2 F.RemoteConnect Nothing Pending - receiveConnectionAction brig fedBrigClient uid1 quid2 F.RemoteRescind Nothing Cancelled + receiveConnectionAction brig fedBrigClient uid1 quid2 RemoteConnect Nothing Pending + receiveConnectionAction brig fedBrigClient uid1 quid2 RemoteConnect Nothing Pending + receiveConnectionAction brig fedBrigClient uid1 quid2 RemoteRescind Nothing Cancelled -testConnectFromIgnored :: Opt.Opts -> Brig -> FedBrigClient -> Http () +testConnectFromIgnored :: Opt.Opts -> Brig -> FedClient 'Brig -> Http () testConnectFromIgnored opts brig fedBrigClient = do (uid1, quid2) <- localAndRemoteUser brig -- set up an initial 'Ignored' state - receiveConnectionAction brig fedBrigClient uid1 quid2 F.RemoteConnect Nothing Pending + receiveConnectionAction brig fedBrigClient uid1 quid2 RemoteConnect Nothing Pending putConnectionQualified brig uid1 quid2 Ignored !!! statusCode === const 200 assertConnectionQualified brig uid1 quid2 Ignored -- if the remote side sends a new connection request, we go back to 'Pending' - receiveConnectionAction brig fedBrigClient uid1 quid2 F.RemoteConnect Nothing Pending + receiveConnectionAction brig fedBrigClient uid1 quid2 RemoteConnect Nothing Pending -- if we accept, and the remote side still wants to connect, we transition to 'Accepted' - sendConnectionAction brig opts uid1 quid2 (Just F.RemoteConnect) Accepted + sendConnectionAction brig opts uid1 quid2 (Just RemoteConnect) Accepted -testSentFromIgnored :: Opt.Opts -> Brig -> FedBrigClient -> Http () +testSentFromIgnored :: Opt.Opts -> Brig -> FedClient 'Brig -> Http () testSentFromIgnored opts brig fedBrigClient = do (uid1, quid2) <- localAndRemoteUser brig -- set up an initial 'Ignored' state - receiveConnectionAction brig fedBrigClient uid1 quid2 F.RemoteConnect Nothing Pending + receiveConnectionAction brig fedBrigClient uid1 quid2 RemoteConnect Nothing Pending putConnectionQualified brig uid1 quid2 Ignored !!! statusCode === const 200 assertConnectionQualified brig uid1 quid2 Ignored -- if the remote side rescinds, we stay in 'Ignored' - receiveConnectionAction brig fedBrigClient uid1 quid2 F.RemoteRescind Nothing Ignored + receiveConnectionAction brig fedBrigClient uid1 quid2 RemoteRescind Nothing Ignored -- if we accept, and the remote does not want to connect anymore, we transition to 'Sent' sendConnectionAction brig opts uid1 quid2 Nothing Sent -testConnectFromBlocked :: Opt.Opts -> Brig -> Galley -> FedBrigClient -> Http () +testConnectFromBlocked :: Opt.Opts -> Brig -> Galley -> FedClient 'Brig -> Http () testConnectFromBlocked opts brig galley fedBrigClient = do let convIsLocal = True (uid1, quid2, convId) <- localAndRemoteUserWithConvId brig convIsLocal -- set up an initial 'Blocked' state - receiveConnectionAction brig fedBrigClient uid1 quid2 F.RemoteConnect Nothing Pending + receiveConnectionAction brig fedBrigClient uid1 quid2 RemoteConnect Nothing Pending putConnectionQualified brig uid1 quid2 Blocked !!! statusCode === const 200 assertConnectionQualified brig uid1 quid2 Blocked @@ -840,11 +853,11 @@ testConnectFromBlocked opts brig galley fedBrigClient = do !!! statusCode === const 403 -- if the remote side sends a new connection request, we ignore it - receiveConnectionAction brig fedBrigClient uid1 quid2 F.RemoteConnect Nothing Blocked + receiveConnectionAction brig fedBrigClient uid1 quid2 RemoteConnect Nothing Blocked -- if we accept (or send a connection request), and the remote side still -- wants to connect, we transition to 'Accepted' - sendConnectionAction brig opts uid1 quid2 (Just F.RemoteConnect) Accepted + sendConnectionAction brig opts uid1 quid2 (Just RemoteConnect) Accepted do res <- @@ -854,17 +867,17 @@ testConnectFromBlocked opts brig galley fedBrigClient = do liftIO $ (fmap omQualifiedId . cmOthers . cnvMembers) conv @?= [quid2] -testSentFromBlocked :: Opt.Opts -> Brig -> FedBrigClient -> Http () +testSentFromBlocked :: Opt.Opts -> Brig -> FedClient 'Brig -> Http () testSentFromBlocked opts brig fedBrigClient = do (uid1, quid2) <- localAndRemoteUser brig -- set up an initial 'Blocked' state - receiveConnectionAction brig fedBrigClient uid1 quid2 F.RemoteConnect Nothing Pending + receiveConnectionAction brig fedBrigClient uid1 quid2 RemoteConnect Nothing Pending putConnectionQualified brig uid1 quid2 Blocked !!! statusCode === const 200 assertConnectionQualified brig uid1 quid2 Blocked -- if the remote side rescinds, we stay in 'Blocked' - receiveConnectionAction brig fedBrigClient uid1 quid2 F.RemoteRescind Nothing Blocked + receiveConnectionAction brig fedBrigClient uid1 quid2 RemoteRescind Nothing Blocked -- if we accept, and the remote does not want to connect anymore, we transition to 'Sent' sendConnectionAction brig opts uid1 quid2 Nothing Sent @@ -876,7 +889,7 @@ testCancel opts brig = do sendConnectionAction brig opts uid1 quid2 Nothing Sent sendConnectionUpdateAction brig opts uid1 quid2 Nothing Cancelled -testConnectionLimits :: Opt.Opts -> Brig -> FedBrigClient -> Http () +testConnectionLimits :: Opt.Opts -> Brig -> FedClient 'Brig -> Http () testConnectionLimits opts brig fedBrigClient = do let connectionLimit = Opt.setUserMaxConnections (Opt.optSettings opts) (uid1, quid2) <- localAndRemoteUser brig @@ -886,38 +899,38 @@ testConnectionLimits opts brig fedBrigClient = do (quid6Sent : _) <- replicateM (fromIntegral connectionLimit - 1) (newConn uid1) -- accepting another one should be allowed - receiveConnectionAction brig fedBrigClient uid1 quid2 F.RemoteConnect Nothing Pending - sendConnectionAction brig opts uid1 quid2 (Just F.RemoteConnect) Accepted + receiveConnectionAction brig fedBrigClient uid1 quid2 RemoteConnect Nothing Pending + sendConnectionAction brig opts uid1 quid2 (Just RemoteConnect) Accepted -- get an incoming connection requests beyond the limit, This connection -- cannot be accepted. This is also the behaviour without federation, if the -- user wants to accept this one, they have to either sacrifice another -- connection or ask the backend operator to increase the limit. - receiveConnectionAction brig fedBrigClient uid1 quid3 F.RemoteConnect Nothing Pending + receiveConnectionAction brig fedBrigClient uid1 quid3 RemoteConnect Nothing Pending -- accepting the second one hits the limit (and relation stays Pending): - sendConnectionActionExpectLimit uid1 quid3 (Just F.RemoteConnect) + sendConnectionActionExpectLimit uid1 quid3 (Just RemoteConnect) assertConnectionQualified brig uid1 quid3 Pending -- When a remote accepts, it is allowed, this does not break the limit as a -- Sent becomes an Accepted. assertConnectionQualified brig uid1 quid6Sent Sent - receiveConnectionAction brig fedBrigClient uid1 quid6Sent F.RemoteConnect (Just F.RemoteConnect) Accepted + receiveConnectionAction brig fedBrigClient uid1 quid6Sent RemoteConnect (Just RemoteConnect) Accepted -- attempting to send an own new connection request also hits the limit - sendConnectionActionExpectLimit uid1 quid4 (Just F.RemoteConnect) + sendConnectionActionExpectLimit uid1 quid4 (Just RemoteConnect) getConnectionQualified brig uid1 quid4 !!! const 404 === statusCode -- (re-)sending an already accepted connection does not affect the limit - sendConnectionAction brig opts uid1 quid2 (Just F.RemoteConnect) Accepted + sendConnectionAction brig opts uid1 quid2 (Just RemoteConnect) Accepted -- blocked connections do not count towards the limit putConnectionQualified brig uid1 quid2 Blocked !!! statusCode === const 200 assertConnectionQualified brig uid1 quid2 Blocked -- after blocking quid2, we can now accept another connection request - receiveConnectionAction brig fedBrigClient uid1 quid5 F.RemoteConnect Nothing Pending - sendConnectionAction brig opts uid1 quid5 (Just F.RemoteConnect) Accepted + receiveConnectionAction brig fedBrigClient uid1 quid5 RemoteConnect Nothing Pending + sendConnectionAction brig opts uid1 quid5 (Just RemoteConnect) Accepted where newConn :: UserId -> Http (Qualified UserId) newConn from = do @@ -925,13 +938,13 @@ testConnectionLimits opts brig fedBrigClient = do sendConnectionAction brig opts from to Nothing Sent pure to - sendConnectionActionExpectLimit :: HasCallStack => UserId -> Qualified UserId -> Maybe F.RemoteConnectionAction -> Http () + sendConnectionActionExpectLimit :: HasCallStack => UserId -> Qualified UserId -> Maybe RemoteConnectionAction -> Http () sendConnectionActionExpectLimit uid1 quid2 _reaction = do postConnectionQualified brig uid1 quid2 !!! do const 403 === statusCode const (Just "connection-limit") === fmap Error.label . responseJsonMaybe -testInternalGetConnStatusesAll :: Brig -> Opt.Opts -> FedBrigClient -> Http () +testInternalGetConnStatusesAll :: Brig -> Opt.Opts -> FedClient 'Brig -> Http () testInternalGetConnStatusesAll brig opts fedBrigClient = do quids <- replicateM 2 $ userQualifiedId <$> randomUser brig let uids = qUnqualified <$> quids @@ -951,11 +964,11 @@ testInternalGetConnStatusesAll brig opts fedBrigClient = do -- Create 5 remote connections with remote1, accept 1 for_ remoteDomain1Users $ \qOther -> sendConnectionAction brig opts uid qOther Nothing Sent - receiveConnectionAction brig fedBrigClient uid remoteDomain1User1 F.RemoteConnect (Just F.RemoteConnect) Accepted + receiveConnectionAction brig fedBrigClient uid remoteDomain1User1 RemoteConnect (Just RemoteConnect) Accepted -- Create 5 remote connections with remote2, accept 1 for_ remoteDomain2Users $ \qOther -> sendConnectionAction brig opts uid qOther Nothing Sent - receiveConnectionAction brig fedBrigClient uid remoteDomain2User1 F.RemoteConnect (Just F.RemoteConnect) Accepted + receiveConnectionAction brig fedBrigClient uid remoteDomain2User1 RemoteConnect (Just RemoteConnect) Accepted allStatuses :: [ConnectionStatusV2] <- responseJsonError =<< getConnStatusInternal brig (ConnectionsStatusRequestV2 uids Nothing Nothing) diff --git a/services/brig/test/integration/API/User/Handles.hs b/services/brig/test/integration/API/User/Handles.hs index 356e70e5bd0..5ea8fce5b74 100644 --- a/services/brig/test/integration/API/User/Handles.hs +++ b/services/brig/test/integration/API/User/Handles.hs @@ -66,6 +66,15 @@ tests _cl _at conf p b c g = test p "GET /users/by-handle// : no federation" $ testGetUserByQualifiedHandleNoFederation conf b ] +-- The next line contains a mapping from the testHandleUpdate test to the following test standards: +-- @SF.Provisioning @TSFI.RESTfulAPI @S2 +-- +-- The test validates various updates to the user's handle. First, it attempts +-- to set invalid handles. This fails. Then it successfully sets a valid handle. +-- The user can retry setting the valid handle. The next scenario is for another +-- user to attempt to reuse an already used handle, which fails. Finally, +-- several scenarios of searching users by handle are explored, where users +-- appear by handle. A user can also free a handle and then reclaim it again. testHandleUpdate :: Brig -> Cannon -> Http () testHandleUpdate brig cannon = do user <- randomUser brig @@ -129,6 +138,8 @@ testHandleUpdate brig cannon = do put (brig . path "/self/handle" . contentJson . zUser uid2 . zConn "c" . body update) !!! const 200 === statusCode +-- @END + testHandleRace :: Brig -> Http () testHandleRace brig = do us <- replicateM 10 (userId <$> randomUser brig) diff --git a/services/brig/test/integration/API/User/Util.hs b/services/brig/test/integration/API/User/Util.hs index 6e8087c4961..e626214cd22 100644 --- a/services/brig/test/integration/API/User/Util.hs +++ b/services/brig/test/integration/API/User/Util.hs @@ -27,7 +27,6 @@ import Brig.Types import Brig.Types.Team.LegalHold (LegalHoldClientRequest (..)) import Brig.Types.User.Auth hiding (user) import qualified Brig.ZAuth -import qualified CargoHold.Types.V3 as CHV3 import qualified Codec.MIME.Type as MIME import Control.Lens (preview, (^?)) import Control.Monad.Catch (MonadCatch) @@ -53,6 +52,7 @@ import Imports import qualified Test.Tasty.Cannon as WS import Test.Tasty.HUnit import Util +import Wire.API.Asset import qualified Wire.API.Event.Conversation as Conv import qualified Wire.API.Federation.API.Brig as F import Wire.API.Federation.Component @@ -336,7 +336,7 @@ assertConnectionQualified brig u1 qu2 rel = receiveConnectionAction :: HasCallStack => Brig -> - FedBrigClient -> + FedClient 'Brig -> UserId -> Qualified UserId -> F.RemoteConnectionAction -> @@ -345,7 +345,7 @@ receiveConnectionAction :: Http () receiveConnectionAction brig fedBrigClient uid1 quid2 action expectedReaction expectedRel = do res <- - F.sendConnectionAction (fedBrigClient (qDomain quid2)) $ + runFedClient @"send-connection-action" fedBrigClient (qDomain quid2) $ F.NewConnectionRequest (qUnqualified quid2) uid1 action liftIO $ do res @?= F.NewConnectionResponseOk expectedReaction @@ -407,30 +407,33 @@ uploadAsset :: (MonadCatch m, MonadIO m, MonadHttp m, HasCallStack) => CargoHold -> UserId -> + AssetSettings -> ByteString -> - m CHV3.Asset -uploadAsset c usr dat = do - let sts = CHV3.defAssetSettings - ct = MIME.Type (MIME.Application "text") [] - mpb = CHV3.buildMultipartBody sts ct (LB.fromStrict dat) - rsp <- - post - ( c - . path "/assets/v3" - . zUser usr - . zConn "conn" - . content "multipart/mixed" - . lbytes (toLazyByteString mpb) - ) - UserId -> ByteString -> (MonadIO m, MonadHttp m) => m (Response (Maybe LB.ByteString)) +downloadAsset :: + (MonadIO m, MonadHttp m) => + CargoHold -> + UserId -> + Qualified AssetKey -> + m (Response (Maybe LB.ByteString)) downloadAsset c usr ast = get ( c - . paths ["/assets/v3", ast] + . paths ["/assets/v4", toByteString' (qDomain ast), toByteString' (qUnqualified ast)] . zUser usr . zConn "conn" ) diff --git a/services/brig/test/integration/Federation/End2end.hs b/services/brig/test/integration/Federation/End2end.hs index 9affa5d1d3d..f430d6bca09 100644 --- a/services/brig/test/integration/Federation/End2end.hs +++ b/services/brig/test/integration/Federation/End2end.hs @@ -23,9 +23,9 @@ import Bilge import Bilge.Assert ((!!!), ( Brig -> Galley -> + CargoHold -> Cannon -> Endpoint -> Brig -> Galley -> + CargoHold -> IO TestTree -spec _brigOpts mg brig galley cannon _federator brigTwo galleyTwo = +spec _brigOpts mg brig galley cargohold cannon _federator brigTwo galleyTwo cargoholdTwo = pure $ testGroup "federation-end2end-user" @@ -99,7 +102,8 @@ spec _brigOpts mg brig galley cannon _federator brigTwo galleyTwo = test mg "include remote users to new conversation" $ testRemoteUsersInNewConv brig galley brigTwo galleyTwo, test mg "send a message to a remote user" $ testSendMessage brig brigTwo galleyTwo cannon, test mg "send a message in a remote conversation" $ testSendMessageToRemoteConv brig brigTwo galley galleyTwo cannon, - test mg "delete user connected to remotes and in conversation with remotes" $ testDeleteUser brig brigTwo galley galleyTwo cannon + test mg "delete user connected to remotes and in conversation with remotes" $ testDeleteUser brig brigTwo galley galleyTwo cannon, + test mg "download remote asset" $ testRemoteAsset brig brigTwo cargohold cargoholdTwo ] -- | Path covered by this test: @@ -619,3 +623,17 @@ testDeleteUser brig1 brig2 galley1 galley2 cannon1 = do WS.assertMatch_ (5 # Second) wsAlice $ matchDeleteUserNotification bobDel WS.assertMatch_ (5 # Second) wsAlice $ matchConvLeaveNotification conv1 bobDel [bobDel] WS.assertMatch_ (5 # Second) wsAlice $ matchConvLeaveNotification conv2 bobDel [bobDel] + +testRemoteAsset :: Brig -> Brig -> CargoHold -> CargoHold -> Http () +testRemoteAsset brig1 brig2 ch1 ch2 = do + alice <- userQualifiedId <$> randomUser brig1 + bob <- userQualifiedId <$> randomUser brig2 + + let sts = defAssetSettings & setAssetPublic .~ True + ast <- responseJsonError =<< uploadAsset ch2 (qUnqualified bob) sts "hello world" + let qkey = view assetKey ast + + downloadAsset ch1 (qUnqualified alice) qkey + !!! do + const 200 === statusCode + const (Just "hello world") === responseBody diff --git a/services/brig/test/integration/Federation/Util.hs b/services/brig/test/integration/Federation/Util.hs index e3cb6378b7d..227cf207e99 100644 --- a/services/brig/test/integration/Federation/Util.hs +++ b/services/brig/test/integration/Federation/Util.hs @@ -50,6 +50,7 @@ import GHC.IO.Exception (IOException (ioe_errno)) import qualified Galley.Types.Teams.SearchVisibility as Team import Imports import qualified Network.HTTP.Client as HTTP +import Network.HTTP.Media import Network.Socket import Network.Wai.Handler.Warp (Port) import Network.Wai.Test (Session) @@ -73,7 +74,7 @@ withTempMockFederator :: Opt.Opts -> LByteString -> Session a -> IO (a, [Mock.Fe withTempMockFederator opts resp action = Mock.withTempMockFederator [("Content-Type", "application/json")] - (const (pure resp)) + (const (pure ("application" // "json", resp))) $ \mockPort -> do let opts' = opts diff --git a/services/brig/test/integration/Main.hs b/services/brig/test/integration/Main.hs index b3784d8d114..29881f8efec 100644 --- a/services/brig/test/integration/Main.hs +++ b/services/brig/test/integration/Main.hs @@ -38,42 +38,31 @@ import qualified Brig.Options as Opts import Cassandra.Util (defInitCassandra) import Control.Lens import Data.Aeson -import Data.ByteString.Conversion -import Data.Domain import Data.Metrics.Test (pathsConsistencyCheck) import Data.Metrics.WaiRoute (treeToPaths) -import qualified Data.Text as Text import Data.Text.Encoding (encodeUtf8) import Data.Yaml (decodeFileEither) import qualified Federation.End2end import Imports hiding (local) import qualified Index.Create -import qualified Network.HTTP.Client as HTTP import Network.HTTP.Client.TLS (tlsManagerSettings) import Network.Wai.Utilities.Server (compile) import OpenSSL (withOpenSSL) import Options.Applicative hiding (action) -import Servant.API.Generic (GenericServant, ToServant, ToServantApi) -import qualified Servant.Client as Servant -import Servant.Client.Core -import qualified Servant.Client.Core.Request as Client -import Servant.Client.Generic (AsClientT) -import qualified Servant.Client.Generic as Servant import System.Environment (withArgs) import qualified System.Environment.Blank as Blank import qualified System.Logger as Logger import Test.Tasty import Test.Tasty.HUnit -import Util (FedBrigClient, FedGalleyClient) +import Util import Util.Options import Util.Test -import qualified Wire.API.Federation.API.Brig as F -import qualified Wire.API.Federation.API.Galley as F -import Wire.API.Federation.Domain +import Wire.API.Federation.API data BackendConf = BackendConf { remoteBrig :: Endpoint, remoteGalley :: Endpoint, + remoteCargohold :: Endpoint, remoteFederatorInternal :: Endpoint, remoteFederatorExternal :: Endpoint } @@ -84,6 +73,7 @@ instance FromJSON BackendConf where BackendConf <$> o .: "brig" <*> o .: "galley" + <*> o .: "cargohold" <*> o .: "federatorInternal" <*> o .: "federatorExternal" @@ -118,6 +108,7 @@ runTests iConf brigOpts otherArgs = do f = federatorInternal iConf brigTwo = mkRequest $ remoteBrig (backendTwo iConf) galleyTwo = mkRequest $ remoteGalley (backendTwo iConf) + ch2 = mkRequest $ remoteCargohold (backendTwo iConf) let turnFile = Opts.servers . Opts.turn $ brigOpts turnFileV2 = (Opts.serversV2 . Opts.turn) brigOpts @@ -129,8 +120,8 @@ runTests iConf brigOpts otherArgs = do lg <- Logger.new Logger.defSettings -- TODO: use mkLogger'? db <- defInitCassandra casKey casHost casPort lg mg <- newManager tlsManagerSettings - let fedBrigClient = mkFedBrigClient mg (brig iConf) - let fedGalleyClient = mkFedGalleyClient mg (galley iConf) + let fedBrigClient = FedClient @'Brig mg (brig iConf) + let fedGalleyClient = FedClient @'Galley mg (galley iConf) emailAWSOpts <- parseEmailAWSOpts awsEnv <- AWS.mkEnv lg awsOpts emailAWSOpts mg userApi <- User.tests brigOpts fedBrigClient fedGalleyClient mg b c ch g n awsEnv db @@ -143,7 +134,7 @@ runTests iConf brigOpts otherArgs = do createIndex <- Index.Create.spec brigOpts browseTeam <- TeamUserSearch.tests brigOpts mg g b userPendingActivation <- UserPendingActivation.tests brigOpts mg db b g s - federationEnd2End <- Federation.End2end.spec brigOpts mg b g c f brigTwo galleyTwo + federationEnd2End <- Federation.End2end.spec brigOpts mg b g ch c f brigTwo galleyTwo ch2 federationEndpoints <- API.Federation.tests mg brigOpts b c fedBrigClient includeFederationTests <- (== Just "1") <$> Blank.getEnv "INTEGRATION_FEDERATION_TESTS" internalApi <- API.Internal.tests brigOpts mg db b (brig iConf) gd g @@ -223,40 +214,3 @@ parseConfigPaths = do <> showDefault <> value defaultBrigPath ) - -mkFedBrigClient :: Manager -> Endpoint -> FedBrigClient -mkFedBrigClient = mkFedBrigClientGen @F.BrigApi - -mkFedGalleyClient :: Manager -> Endpoint -> FedGalleyClient -mkFedGalleyClient = mkFedBrigClientGen @F.GalleyApi - -mkFedBrigClientGen :: - forall routes. - ( HasClient Servant.ClientM (ToServantApi routes), - GenericServant routes (AsClientT (HttpT IO)), - Servant.Client (HttpT IO) (ToServantApi routes) ~ ToServant routes (AsClientT (HttpT IO)) - ) => - Manager -> - Endpoint -> - Domain -> - routes (AsClientT (HttpT IO)) -mkFedBrigClientGen mgr endpoint originDomain = Servant.genericClientHoist servantClientMToHttp - where - servantClientMToHttp :: Servant.ClientM a -> Http a - servantClientMToHttp action = liftIO $ do - let brigHost = Text.unpack $ endpoint ^. epHost - brigPort = fromInteger . toInteger $ endpoint ^. epPort - baseUrl = Servant.BaseUrl Servant.Http brigHost brigPort "/federation" - clientEnv = Servant.ClientEnv mgr baseUrl Nothing makeClientRequest - eitherRes <- Servant.runClientM action clientEnv - case eitherRes of - Right res -> pure res - Left err -> assertFailure $ "Servant client failed with: " <> show err - - makeClientRequest :: BaseUrl -> Client.Request -> HTTP.Request - makeClientRequest burl req = - let req' = Servant.defaultMakeClientRequest burl req - in req' - { HTTP.requestHeaders = - HTTP.requestHeaders req' <> [(originDomainHeaderName, toByteString' originDomain)] - } diff --git a/services/brig/test/integration/Util.hs b/services/brig/test/integration/Util.hs index 2b9879c7d91..86be8f98269 100644 --- a/services/brig/test/integration/Util.hs +++ b/services/brig/test/integration/Util.hs @@ -31,7 +31,7 @@ import qualified Brig.Options as Opt import qualified Brig.Options as Opts import qualified Brig.Run as Run import Brig.Types.Activation -import Brig.Types.Client +import Brig.Types.Client hiding (Client) import Brig.Types.Connection import Brig.Types.Intra import Brig.Types.User @@ -60,36 +60,43 @@ import Data.Misc (PlainTextPassword (..)) import Data.Proxy import Data.Qualified import Data.Range +import qualified Data.Text as T import qualified Data.Text as Text import qualified Data.Text.Ascii as Ascii import Data.Text.Encoding (encodeUtf8) import qualified Data.UUID as UUID import qualified Data.UUID.V4 as UUID import qualified Federator.MockServer as Mock +import GHC.TypeLits import Galley.Types.Conversations.One2One (one2OneConvId) import qualified Galley.Types.Teams as Team import Gundeck.Types.Notification import Imports +import qualified Network.HTTP.Client as HTTP +import Network.HTTP.Media.MediaType import Network.HTTP.Types (Method) import Network.Wai (Application) import qualified Network.Wai as Wai import qualified Network.Wai.Handler.Warp as Warp import Network.Wai.Test (Session) import qualified Network.Wai.Test as WaiTest -import Servant.Client.Generic (AsClientT) +import OpenSSL.BN (randIntegerZeroToNMinusOne) +import qualified Servant.Client as Servant +import qualified Servant.Client.Core as Servant import System.Random (randomIO, randomRIO) import qualified System.Timeout as System import Test.Tasty (TestName, TestTree) import Test.Tasty.Cannon import qualified Test.Tasty.Cannon as WS import Test.Tasty.HUnit +import Text.Printf (printf) import qualified UnliftIO.Async as Async import Util.AWS -import Util.Options (Endpoint (Endpoint)) +import Util.Options import Wire.API.Conversation import Wire.API.Conversation.Role (roleNameWireAdmin) -import qualified Wire.API.Federation.API.Brig as F -import qualified Wire.API.Federation.API.Galley as F +import Wire.API.Federation.API +import Wire.API.Federation.Domain import Wire.API.Routes.MultiTablePaging type Brig = Request -> Request @@ -106,9 +113,38 @@ type Nginz = Request -> Request type Spar = Request -> Request -type FedBrigClient = Domain -> F.BrigApi (AsClientT (HttpT IO)) +data FedClient (comp :: Component) = FedClient HTTP.Manager Endpoint -type FedGalleyClient = Domain -> F.GalleyApi (AsClientT (HttpT IO)) +runFedClient :: + forall (name :: Symbol) comp api. + ( HasFedEndpoint comp api name, + Servant.HasClient Servant.ClientM api + ) => + FedClient comp -> + Domain -> + Servant.Client Http api +runFedClient (FedClient mgr endpoint) domain = + Servant.hoistClient (Proxy @api) (servantClientMToHttp domain) $ + Servant.clientIn (Proxy @api) (Proxy @Servant.ClientM) + where + servantClientMToHttp :: Domain -> Servant.ClientM a -> Http a + servantClientMToHttp originDomain action = liftIO $ do + let brigHost = Text.unpack $ endpoint ^. epHost + brigPort = fromInteger . toInteger $ endpoint ^. epPort + baseUrl = Servant.BaseUrl Servant.Http brigHost brigPort "/federation" + clientEnv = Servant.ClientEnv mgr baseUrl Nothing (makeClientRequest originDomain) + eitherRes <- Servant.runClientM action clientEnv + case eitherRes of + Right res -> pure res + Left err -> assertFailure $ "Servant client failed with: " <> show err + + makeClientRequest :: Domain -> Servant.BaseUrl -> Servant.Request -> HTTP.Request + makeClientRequest originDomain burl req = + let req' = Servant.defaultMakeClientRequest burl req + in req' + { HTTP.requestHeaders = + HTTP.requestHeaders req' <> [(originDomainHeaderName, toByteString' originDomain)] + } instance ToJSON SESBounceType where toJSON BounceUndetermined = String "Undetermined" @@ -740,6 +776,12 @@ randomPhone = liftIO $ do let phone = parsePhone . Text.pack $ "+0" ++ concat nrs return $ fromMaybe (error "Invalid random phone#") phone +randomActivationCode :: (HasCallStack, MonadIO m) => m ActivationCode +randomActivationCode = + liftIO $ + ActivationCode . Ascii.unsafeFromText . T.pack . printf "%06d" + <$> randIntegerZeroToNMinusOne 1000000 + updatePhone :: HasCallStack => Brig -> UserId -> Phone -> Http () updatePhone brig uid phn = do -- update phone @@ -1045,13 +1087,16 @@ withMockedFederatorAndGalley :: withMockedFederatorAndGalley opts _domain fedResp galleyHandler action = do result <- assertRight <=< runExceptT $ withTempMockedService initState galleyHandler $ \galleyMockState -> - Mock.withTempMockFederator [("Content-Type", "application/json")] fedResp $ \fedMockPort -> do - let opts' = - opts - { Opt.galley = Endpoint "127.0.0.1" (fromIntegral (serverPort galleyMockState)), - Opt.federatorInternal = Just (Endpoint "127.0.0.1" (fromIntegral fedMockPort)) - } - withSettingsOverrides opts' action + Mock.withTempMockFederator + [("Content-Type", "application/json")] + ((\r -> pure ("application" // "json", r)) <=< fedResp) + $ \fedMockPort -> do + let opts' = + opts + { Opt.galley = Endpoint "127.0.0.1" (fromIntegral (serverPort galleyMockState)), + Opt.federatorInternal = Just (Endpoint "127.0.0.1" (fromIntegral fedMockPort)) + } + withSettingsOverrides opts' action pure (combineResults result) where combineResults :: ((a, [Mock.FederatedRequest]), [ReceivedRequest]) -> (a, [Mock.FederatedRequest], [ReceivedRequest]) diff --git a/services/brig/test/unit/Test/Brig/Calling.hs b/services/brig/test/unit/Test/Brig/Calling.hs index 8fab0a2731f..305ec4ec7ad 100644 --- a/services/brig/test/unit/Test/Brig/Calling.hs +++ b/services/brig/test/unit/Test/Brig/Calling.hs @@ -1,4 +1,5 @@ {-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -- This file is part of the Wire Server implementation. -- @@ -20,12 +21,20 @@ module Test.Brig.Calling where import Brig.Calling +import Brig.Calling.API (CallsConfigVersion (..), newConfig) +import Brig.Calling.Internal (sftServerFromSrvTarget) +import Brig.Effects.SFT import Brig.Options +import Control.Lens ((^.)) import Control.Retry +import Data.Bifunctor import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Map as Map +import Data.Misc import Data.Range import qualified Data.Set as Set +import Data.String.Conversions import Imports import Network.DNS import Polysemy @@ -33,24 +42,27 @@ import Polysemy.TinyLog import qualified System.Logger as Log import Test.Tasty import Test.Tasty.HUnit +import Test.Tasty.QuickCheck (Arbitrary (..), generate) +import URI.ByteString import qualified UnliftIO.Async as Async +import Wire.API.Call.Config import Wire.Network.DNS.Effect import Wire.Network.DNS.SRV data FakeDNSEnv = FakeDNSEnv - { fakeLookupFn :: Domain -> SrvResponse, - fakeLookupCalls :: IORef [Domain] + { fakeLookupSrv :: Domain -> SrvResponse, + fakeLookupSrvCalls :: IORef [Domain] } newFakeDNSEnv :: (Domain -> SrvResponse) -> IO FakeDNSEnv -newFakeDNSEnv lookupFn = - FakeDNSEnv lookupFn <$> newIORef [] +newFakeDNSEnv lookupSrvFn = + FakeDNSEnv lookupSrvFn <$> newIORef [] runFakeDNSLookup :: Member (Embed IO) r => FakeDNSEnv -> Sem (DNSLookup ': r) a -> Sem r a -runFakeDNSLookup FakeDNSEnv {..} = interpret $ \case - LookupSRV domain -> do - modifyIORef' fakeLookupCalls (++ [domain]) - pure $ fakeLookupFn domain +runFakeDNSLookup FakeDNSEnv {..} = interpret $ + \(LookupSRV domain) -> do + modifyIORef' fakeLookupSrvCalls (++ [domain]) + pure $ fakeLookupSrv domain newtype LogRecorder = LogRecorder {recordedLogs :: IORef [(Log.Level, LByteString)]} @@ -67,7 +79,8 @@ ignoreLogs = interpret $ \(Polylog _ _) -> pure () {-# ANN tests ("HLint: ignore" :: String) #-} tests :: TestTree tests = - testGroup "Calling" $ + testGroup + "Calling" [ testGroup "mkSFTDomain" $ [ testCase "when service name is provided" $ assertEqual @@ -91,10 +104,17 @@ tests = testCase "when service is not available" testSFTDiscoverWhenNotAvailable, testCase "when dns lookup fails" testSFTDiscoverWhenDNSFails ], - testGroup "getRandomSFTServers" $ + testGroup "Get Random SFT Servers" $ [ testCase "more servers in SRV than limit" testSFTManyServers, testCase "fewer servers in SRV than limit" testSFTFewerServers -- the randomization part is not (yet?) tested here. + ], + testGroup + "SFT static URL" + [ testCase "deprecated endpoint" testSFTStaticDeprecatedEndpoint, + testCase "v2 endpoint, no SFT static URL" testSFTStaticV2NoStaticUrl, + testCase "v2 endpoint, SFT static URL without /sft_servers_all.json" testSFTStaticV2StaticUrlError, + testCase "v2 endpoint, SFT static URL with /sft_servers_all.json" testSFTStaticV2StaticUrlList ] ] @@ -105,10 +125,10 @@ testDiscoveryLoopWhenSuccessful = do entry3 = SrvEntry 0 0 (SrvTarget "sft3.foo.example.com." 443) returnedEntries = entry1 :| [entry2, entry3] fakeDNSEnv <- newFakeDNSEnv (\_ -> SrvAvailable returnedEntries) - sftEnv <- mkSFTEnv (SFTOptions "foo.example.com" Nothing (Just 0.001) Nothing) + sftEnv <- mkSFTEnv $ SFTOptions "foo.example.com" Nothing (Just 0.001) Nothing discoveryLoop <- Async.async $ runM . ignoreLogs . runFakeDNSLookup fakeDNSEnv $ sftDiscoveryLoop sftEnv - void $ retryEvery10MicrosWhileN 2000 (== 0) (length <$> readIORef (fakeLookupCalls fakeDNSEnv)) + void $ retryEvery10MicrosWhileN 2000 (== 0) (length <$> readIORef (fakeLookupSrvCalls fakeDNSEnv)) -- We don't want to stop the loop before it has written to the sftServers IORef void $ retryEvery10MicrosWhileN 2000 (== NotDiscoveredYet) (readIORef (sftServers sftEnv)) Async.cancel discoveryLoop @@ -119,13 +139,13 @@ testDiscoveryLoopWhenSuccessful = do testDiscoveryLoopWhenUnsuccessful :: IO () testDiscoveryLoopWhenUnsuccessful = do - fakeDNSEnv <- newFakeDNSEnv (\_ -> SrvNotAvailable) - sftEnv <- mkSFTEnv (SFTOptions "foo.example.com" Nothing (Just 0.001) Nothing) + fakeDNSEnv <- newFakeDNSEnv (const SrvNotAvailable) + sftEnv <- mkSFTEnv $ SFTOptions "foo.example.com" Nothing (Just 0.001) Nothing discoveryLoop <- Async.async $ runM . ignoreLogs . runFakeDNSLookup fakeDNSEnv $ sftDiscoveryLoop sftEnv -- We wait for at least two lookups to be sure that the lookup loop looped at -- least once - void $ retryEvery10MicrosWhileN 2000 (<= 1) (length <$> readIORef (fakeLookupCalls fakeDNSEnv)) + void $ retryEvery10MicrosWhileN 2000 (<= 1) (length <$> readIORef (fakeLookupSrvCalls fakeDNSEnv)) Async.cancel discoveryLoop actualServers <- readIORef (sftServers sftEnv) @@ -138,11 +158,11 @@ testDiscoveryLoopWhenUnsuccessfulAfterSuccess = do -- In the following lines we re-use the 'sftEnv' from a successful lookup to -- replicate what will happen when a dns lookup fails after success - failingFakeDNSEnv <- newFakeDNSEnv (\_ -> SrvNotAvailable) + failingFakeDNSEnv <- newFakeDNSEnv (const SrvNotAvailable) discoveryLoop <- Async.async $ runM . ignoreLogs . runFakeDNSLookup failingFakeDNSEnv $ sftDiscoveryLoop sftEnv -- We wait for at least two lookups to be sure that the lookup loop looped at -- least once - void $ retryEvery10MicrosWhileN 2000 (<= 1) (length <$> readIORef (fakeLookupCalls failingFakeDNSEnv)) + void $ retryEvery10MicrosWhileN 2000 (<= 1) (length <$> readIORef (fakeLookupSrvCalls failingFakeDNSEnv)) Async.cancel discoveryLoop actualServers <- readIORef (sftServers sftEnv) @@ -156,11 +176,11 @@ testDiscoveryLoopWhenURLsChange = do -- replicate what will happen when a dns lookup returns new URLs let entry1 = SrvEntry 0 0 (SrvTarget "sft4.foo.example.com." 443) entry2 = SrvEntry 0 0 (SrvTarget "sft5.foo.example.com." 443) - newEntries = (entry1 :| [entry2]) + newEntries = entry1 :| [entry2] - fakeDNSEnv <- newFakeDNSEnv (\_ -> SrvAvailable newEntries) + fakeDNSEnv <- newFakeDNSEnv (const $ SrvAvailable newEntries) discoveryLoop <- Async.async $ runM . ignoreLogs . runFakeDNSLookup fakeDNSEnv $ sftDiscoveryLoop sftEnv - void $ retryEvery10MicrosWhileN 2000 (== 0) (length <$> readIORef (fakeLookupCalls fakeDNSEnv)) + void $ retryEvery10MicrosWhileN 2000 (== 0) (length <$> readIORef (fakeLookupSrvCalls fakeDNSEnv)) -- We don't want to stop the loop before it has written to the sftServers IORef void $ retryEvery10MicrosWhileN 2000 (== Discovered (mkSFTServers newEntries)) (readIORef (sftServers sftEnv)) Async.cancel discoveryLoop @@ -173,7 +193,7 @@ testSFTDiscoverWhenAvailable = do logRecorder <- newLogRecorder let entry1 = SrvEntry 0 0 (SrvTarget "sft7.foo.example.com." 443) entry2 = SrvEntry 0 0 (SrvTarget "sft8.foo.example.com." 8843) - returnedEntries = (entry1 :| [entry2]) + returnedEntries = entry1 :| [entry2] fakeDNSEnv <- newFakeDNSEnv (\_ -> SrvAvailable returnedEntries) assertEqual "discovered servers should be returned" (Just returnedEntries) @@ -186,7 +206,7 @@ testSFTDiscoverWhenAvailable = do testSFTDiscoverWhenNotAvailable :: IO () testSFTDiscoverWhenNotAvailable = do logRecorder <- newLogRecorder - fakeDNSEnv <- newFakeDNSEnv (\_ -> SrvNotAvailable) + fakeDNSEnv <- newFakeDNSEnv (const SrvNotAvailable) assertEqual "discovered servers should be returned" Nothing =<< ( runM . recordLogs logRecorder . runFakeDNSLookup fakeDNSEnv $ @@ -198,9 +218,9 @@ testSFTDiscoverWhenNotAvailable = do testSFTDiscoverWhenDNSFails :: IO () testSFTDiscoverWhenDNSFails = do logRecorder <- newLogRecorder - fakeDNSEnv <- newFakeDNSEnv (\_ -> SrvResponseError IllegalDomain) + fakeDNSEnv <- newFakeDNSEnv (const $ SrvResponseError IllegalDomain) - assertEqual "discovered servers should be returned" Nothing + assertEqual "no servers should be returned" Nothing =<< ( runM . recordLogs logRecorder . runFakeDNSLookup fakeDNSEnv $ discoverSFTServers "_sft._tcp.foo.example.com" ) @@ -218,7 +238,7 @@ testSFTManyServers = do entry7 = SrvEntry 0 0 (SrvTarget "sft7.foo.example.com." 443) entries = entry1 :| [entry2, entry3, entry4, entry5, entry6, entry7] sftServers = mkSFTServers entries - someServers <- getRandomSFTServers (unsafeRange 3) sftServers + someServers <- getRandomElements (unsafeRange 3) . unSFTServers $ sftServers assertEqual "should return only 3 servers" 3 (length someServers) testSFTFewerServers :: IO () @@ -230,7 +250,7 @@ testSFTFewerServers = do entries = entry1 :| [entry2, entry3, entry4] sftServers = mkSFTServers entries - allServers <- getRandomSFTServers (unsafeRange 10) sftServers + allServers <- getRandomElements (unsafeRange 10) . unSFTServers $ sftServers assertEqual "should return all of them" (Set.fromList $ NonEmpty.toList allServers) (Set.fromList $ NonEmpty.toList entries) retryEvery10MicrosWhileN :: (MonadIO m) => Int -> (a -> Bool) -> m a -> m a @@ -239,3 +259,89 @@ retryEvery10MicrosWhileN n f m = (constantDelay 10 <> limitRetries n) (const (return . f)) (const m) + +-- | Creates a calling environment and an https URL to be used in unit-testing +-- the logic of call configuration endpoints +sftStaticEnv :: IO (Env, HttpsUrl) +sftStaticEnv = do + turnUri <- generate arbitrary + let tokenTtl = 10 -- seconds + configTtl = 10 -- seconds + secret = "secret word" + env <- newEnv undefined (pure turnUri) tokenTtl configTtl secret + let Right staticUrl = + mkHttpsUrl + =<< first + show + (parseURI laxURIParserOptions "https://sft01.integration-tests.zinfra.io:443") + pure (env, staticUrl) + +-- The deprecated endpoint `GET /calls/config` without an SFT static URL +testSFTStaticDeprecatedEndpoint :: IO () +testSFTStaticDeprecatedEndpoint = do + env <- fst <$> sftStaticEnv + cfg <- + runM @IO + . discardLogs + . interpretSFTInMemory mempty + $ newConfig env Nothing Nothing Nothing CallsConfigDeprecated + assertEqual + "when SFT static URL is disabled, sft_servers should be empty." + Set.empty + (Set.fromList $ maybe [] NonEmpty.toList $ cfg ^. rtcConfSftServers) + +-- The v2 endpoint `GET /calls/config/v2` without an SFT static URL +testSFTStaticV2NoStaticUrl :: IO () +testSFTStaticV2NoStaticUrl = do + env <- fst <$> sftStaticEnv + let entry1 = SrvEntry 0 0 (SrvTarget "sft1.foo.example.com." 443) + entry2 = SrvEntry 0 0 (SrvTarget "sft2.foo.example.com." 443) + entry3 = SrvEntry 0 0 (SrvTarget "sft3.foo.example.com." 443) + servers = entry1 :| [entry2, entry3] + sftEnv <- + SFTEnv + <$> newIORef (Discovered . mkSFTServers $ servers) + <*> pure "foo.example.com" + <*> pure 5 + <*> pure (unsafeRange 1) + cfg <- + runM @IO + . discardLogs + . interpretSFTInMemory mempty + $ newConfig env Nothing (Just sftEnv) (Just . unsafeRange $ 2) CallsConfigV2 + assertEqual + "when SFT static URL is disabled, sft_servers_all should be from SFT environment" + (Just . fmap (sftServerFromSrvTarget . srvTarget) . toList $ servers) + (cfg ^. rtcConfSftServersAll) + +-- The v2 endpoint `GET /calls/config/v2` with an SFT static URL that gives an error +testSFTStaticV2StaticUrlError :: IO () +testSFTStaticV2StaticUrlError = do + (env, staticUrl) <- sftStaticEnv + cfg <- + runM @IO + . discardLogs + . interpretSFTInMemory mempty -- an empty lookup map, meaning there was + -- an error + $ newConfig env (Just staticUrl) Nothing (Just . unsafeRange $ 2) CallsConfigV2 + assertEqual + "when SFT static URL is enabled, but returns error, sft_servers_all should be empty" + (Just []) + (cfg ^. rtcConfSftServersAll) + +-- The v2 endpoint `GET /calls/config/v2` with an SFT static URL's /sft_servers_all.json +testSFTStaticV2StaticUrlList :: IO () +testSFTStaticV2StaticUrlList = do + (env, staticUrl) <- sftStaticEnv + -- 10 servers compared to the limit of 3 below that should be disregarded + -- for sft_servers_all + servers <- generate $ replicateM 10 arbitrary + cfg <- + runM @IO + . discardLogs + . interpretSFTInMemory (Map.singleton staticUrl (SFTGetResponse . Right $ servers)) + $ newConfig env (Just staticUrl) Nothing (Just . unsafeRange $ 3) CallsConfigV2 + assertEqual + "when SFT static URL is enabled, sft_servers_all should be from /sft_servers_all.json" + (Just servers) + (cfg ^. rtcConfSftServersAll) diff --git a/services/cannon/Makefile b/services/cannon/Makefile index 42372fe7d7f..965ec95d0c8 100644 --- a/services/cannon/Makefile +++ b/services/cannon/Makefile @@ -58,7 +58,7 @@ $(DEB): docker: $(foreach executable,$(EXECUTABLES),\ docker build -t $(DOCKER_USER)/$(executable):$(DOCKER_TAG) \ - -f ../../build/alpine/Dockerfile.executable \ + -f ../../build/ubuntu/Dockerfile.executable \ --build-arg executable=$(executable) \ ../.. && \ docker tag $(DOCKER_USER)/$(executable):$(DOCKER_TAG) $(DOCKER_USER)/$(executable):latest && \ diff --git a/services/cannon/test/Bench.hs b/services/cannon/bench/Bench.hs similarity index 100% rename from services/cannon/test/Bench.hs rename to services/cannon/bench/Bench.hs diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Offset_user.hs b/services/cannon/bench/Main.hs similarity index 81% rename from libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Offset_user.hs rename to services/cannon/bench/Main.hs index b6aa293045a..d019b98000f 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Offset_user.hs +++ b/services/cannon/bench/Main.hs @@ -14,9 +14,11 @@ -- -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Test.Wire.API.Golden.Generated.Offset_user where -import Wire.API.Asset (Offset (..)) +module Main where -testObject_Offset_user_1 :: Offset -testObject_Offset_user_1 = Offset {offsetBytes = 1} +import Bench +import Imports + +main :: IO () +main = benchmark diff --git a/services/cannon/cannon.cabal b/services/cannon/cannon.cabal index 56f3ef1f40f..c8571bd1fa2 100644 --- a/services/cannon/cannon.cabal +++ b/services/cannon/cannon.cabal @@ -1,10 +1,8 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack --- --- hash: 6c53d0a25079c3947f669ee6cf4a32b3e9a9472db9050997e478fc8fdb7b3858 name: cannon version: 0.31.0 @@ -25,7 +23,6 @@ flag static library exposed-modules: - Cannon.API Cannon.API.Internal Cannon.API.Public Cannon.App @@ -39,7 +36,46 @@ library Paths_cannon 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 + 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 build-depends: aeson >=0.11 @@ -63,6 +99,8 @@ library , mwc-random >=0.13 , retry >=0.7 , safe-exceptions + , servant + , servant-server , strict >=0.3.2 , swagger >=0.2 , text >=1.1 @@ -78,13 +116,53 @@ library , wai-websockets >=3.0 , warp >=3.0 , websockets >=0.11.2 + , wire-api default-language: Haskell2010 executable cannon main-is: src/Main.hs other-modules: Paths_cannon - 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 + 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 -rtsopts -with-rtsopts=-N -with-rtsopts=-T -with-rtsopts=-M1g -with-rtsopts=-ki4k build-depends: base @@ -100,12 +178,118 @@ test-suite cannon-tests type: exitcode-stdio-1.0 main-is: Main.hs other-modules: - Bench Test.Cannon.Dict Paths_cannon 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 + 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-depends: + QuickCheck >=2.7 + , async + , base + , bytestring + , cannon + , criterion >=1.0 + , extended + , imports + , metrics-wai + , random >=1.0 + , tasty >=0.8 + , tasty-hunit >=0.8 + , tasty-quickcheck >=0.8 + , types-common + , uuid + , wai-utilities + default-language: Haskell2010 + +benchmark cannon-bench + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + Bench + Paths_cannon + hs-source-dirs: + bench + 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-depends: QuickCheck >=2.7 diff --git a/services/cannon/package.yaml b/services/cannon/package.yaml index 91148258420..c784a2bc4bd 100644 --- a/services/cannon/package.yaml +++ b/services/cannon/package.yaml @@ -34,6 +34,8 @@ library: - mwc-random >=0.13 - retry >=0.7 - safe-exceptions + - servant + - servant-server - strict >=0.3.2 - swagger >=0.2 - text >=1.1 @@ -49,6 +51,7 @@ library: - wai-websockets >=3.0 - warp >=3.0 - websockets >=0.11.2 + - wire-api executables: cannon: main: src/Main.hs @@ -88,6 +91,28 @@ tests: - types-common - uuid - wai-utilities +benchmarks: + cannon-bench: + main: Main.hs + source-dirs: bench + ghc-options: + - -threaded + - -with-rtsopts=-N + dependencies: + - async + - base + - bytestring + - cannon + - criterion >=1.0 + - metrics-wai + - QuickCheck >=2.7 + - random >=1.0 + - tasty >=0.8 + - tasty-hunit >=0.8 + - tasty-quickcheck >=0.8 + - types-common + - uuid + - wai-utilities flags: static: description: Enable static linking diff --git a/services/cannon/src/Cannon/API/Public.hs b/services/cannon/src/Cannon/API/Public.hs index 8480c5932f9..8d4859ffca7 100644 --- a/services/cannon/src/Cannon/API/Public.hs +++ b/services/cannon/src/Cannon/API/Public.hs @@ -16,62 +16,27 @@ -- with this program. If not, see . module Cannon.API.Public - ( sitemap, - apiDocs, + ( API, + publicAPIServer, ) where -import Cannon.App +import Cannon.App (wsapp) import Cannon.Types import Cannon.WS -import Data.Id (ClientId, ConnId, UserId) -import Data.Swagger.Build.Api hiding (Response) -import Imports -import Network.HTTP.Types -import Network.Wai -import Network.Wai.Handler.WebSockets -import Network.Wai.Predicate -import Network.Wai.Routing -import Network.Wai.Utilities -import Network.Wai.Utilities.Swagger -import qualified Network.WebSockets as Ws +import Control.Monad.IO.Class +import Data.Id +import GHC.Base +import Network.WebSockets.Connection +import Servant +import Wire.API.Routes.Public.Cannon -sitemap :: Routes ApiBuilder Cannon () -sitemap = do - get "/await" (continue awaitH) $ - header "Z-User" - .&. header "Z-Connection" - .&. opt (query "client") - .&. request - document "GET" "await" $ do - summary "Establish websocket connection" - parameter Header "Upgrade" (string $ enum ["websocket"]) end - parameter Header "Connection" (string $ enum ["upgrade"]) end - parameter Header "Sec-WebSocket-Key" bytes' $ - description "16-bytes base64 encoded nonce" - parameter Header "Sec-WebSocket-Version" (int32 $ enum [13]) end - parameter Query "client" string' $ do - optional - description "Client ID" - response 426 "Upgrade required" end +type API = ServantAPI :<|> Raw -apiDocs :: Routes ApiBuilder Cannon () -apiDocs = do - get "/await/api-docs" (continue docsH) $ - accept "application" "json" - .&. query "base_url" +publicAPIServer :: ServerT ServantAPI Cannon +publicAPIServer = streamData -docsH :: Media "application" "json" ::: Text -> Cannon Response -docsH (_ ::: url) = do - let doc = mkSwaggerApi url [] sitemap - return $ json doc - -awaitH :: UserId ::: ConnId ::: Maybe ClientId ::: Request -> Cannon Response -awaitH (u ::: a ::: c ::: r) = do +streamData :: UserId -> ConnId -> Maybe ClientId -> PendingConnection -> Cannon () +streamData userId connId clientId con = do e <- wsenv - case websocketsApp wsoptions (wsapp (mkKey u a) c e) r of - Nothing -> return $ errorRs status426 "request-error" "websocket upgrade required" - Just rs -> return rs -- ensure all middlewares ignore RawResponse - see Note [Raw Response] - where - status426 = mkStatus 426 "Upgrade Required" - wsoptions = Ws.defaultConnectionOptions + liftIO $ wsapp (mkKey userId connId) clientId e con diff --git a/services/cannon/src/Cannon/Run.hs b/services/cannon/src/Cannon/Run.hs index 007c18748d7..17296d01b9a 100644 --- a/services/cannon/src/Cannon/Run.hs +++ b/services/cannon/src/Cannon/Run.hs @@ -21,11 +21,12 @@ module Cannon.Run where import Bilge (ManagerSettings (..), defaultManagerSettings, newManager) -import Cannon.API (sitemap) +import Cannon.API.Internal +import Cannon.API.Public import Cannon.App (maxPingInterval) import qualified Cannon.Dict as D import Cannon.Options -import Cannon.Types (Cannon, applog, clients, mkEnv, monitor, runCannon, runCannon') +import Cannon.Types (Cannon, applog, clients, mkEnv, monitor, runCannon, runCannon', runCannonToServant) import Cannon.WS hiding (env) import qualified Control.Concurrent.Async as Async import Control.Exception.Safe (catchAny) @@ -33,7 +34,8 @@ import Control.Lens ((^.)) import Control.Monad.Catch (MonadCatch, finally) import Data.Metrics.Middleware (gaugeSet, path) import qualified Data.Metrics.Middleware as Middleware -import Data.Metrics.Middleware.Prometheus (waiPrometheusMiddleware) +import Data.Metrics.Servant +import Data.Proxy import Data.Text (pack, strip) import Data.Text.Encoding (encodeUtf8) import Imports hiding (head) @@ -41,10 +43,12 @@ import qualified Network.Wai as Wai import Network.Wai.Handler.Warp hiding (run) import qualified Network.Wai.Middleware.Gzip as Gzip import Network.Wai.Utilities.Server +import Servant import qualified System.IO.Strict as Strict import qualified System.Logger.Class as LC import qualified System.Logger.Extended as L import System.Random.MWC (createSystemRandom) +import Wire.API.Routes.Public.Cannon run :: Opts -> IO () run o = do @@ -63,14 +67,17 @@ run o = do refreshMetricsThread <- Async.async $ runCannon' e refreshMetrics s <- newSettings $ Server (o ^. cannon . host) (o ^. cannon . port) (applog e) m (Just idleTimeout) let rtree = compile sitemap - app r k = runCannon e (route rtree r k) r + internalApp r k = runCannon e (Network.Wai.Utilities.Server.route rtree r k) r middleware :: Wai.Middleware middleware = - waiPrometheusMiddleware sitemap + servantPlusWAIPrometheusMiddleware sitemap (Proxy @ServantAPI) . Gzip.gzip Gzip.def . catchErrors g [Right m] - start = middleware app - runSettings s start `finally` do + app :: Application + app = middleware (serve (Proxy @API) server) + server :: Servant.Server API + server = hoistServer (Proxy @ServantAPI) (runCannonToServant e) publicAPIServer :<|> Tagged internalApp + runSettings s app `finally` do Async.cancel refreshMetricsThread L.close (applog e) where diff --git a/services/cannon/src/Cannon/Types.hs b/services/cannon/src/Cannon/Types.hs index b70f40a358c..4aa6fba4b54 100644 --- a/services/cannon/src/Cannon/Types.hs +++ b/services/cannon/src/Cannon/Types.hs @@ -34,6 +34,7 @@ module Cannon.Types clients, monitor, wsenv, + runCannonToServant, ) where @@ -51,6 +52,7 @@ import Data.Metrics.Middleware import Data.Text.Encoding import Imports import Network.Wai +import qualified Servant import qualified System.Logger as Logger import System.Logger.Class hiding (info) import System.Random.MWC (GenIO) @@ -138,3 +140,8 @@ wsenv = Cannon $ do logger :: Cannon Logger logger = Cannon $ asks applog + +-- | Natural transformation from 'Cannon' to 'Handler' monad. +-- Used to call 'Cannon' from servant. +runCannonToServant :: Cannon.Types.Env -> Cannon x -> Servant.Handler x +runCannonToServant env c = liftIO $ runCannon' env c diff --git a/services/cannon/test/Main.hs b/services/cannon/test/Main.hs index eb09db312c9..d6738f66c68 100644 --- a/services/cannon/test/Main.hs +++ b/services/cannon/test/Main.hs @@ -17,8 +17,7 @@ module Main where -import qualified Bench as B -import qualified Cannon.API +import qualified Cannon.API.Internal import Data.Metrics.Test (pathsConsistencyCheck) import Data.Metrics.WaiRoute (treeToPaths) import Imports @@ -28,8 +27,7 @@ import Test.Tasty import Test.Tasty.HUnit main :: IO () -main = do - B.benchmark +main = defaultMain $ testGroup "Tests" @@ -37,6 +35,6 @@ main = do assertEqual "inconcistent sitemap" mempty - (pathsConsistencyCheck . treeToPaths . compile $ Cannon.API.sitemap), + (pathsConsistencyCheck . treeToPaths . compile $ Cannon.API.Internal.sitemap), D.tests ] diff --git a/services/cargohold/Makefile b/services/cargohold/Makefile index 5e7bbf94cde..5a5c25265a7 100644 --- a/services/cargohold/Makefile +++ b/services/cargohold/Makefile @@ -103,7 +103,7 @@ integration-%: fast docker: $(foreach executable,$(EXECUTABLES),\ docker build -t $(DOCKER_USER)/$(executable):$(DOCKER_TAG) \ - -f ../../build/alpine/Dockerfile.executable \ + -f ../../build/ubuntu/Dockerfile.executable \ --build-arg executable=$(executable) \ ../.. && \ docker tag $(DOCKER_USER)/$(executable):$(DOCKER_TAG) $(DOCKER_USER)/$(executable):latest && \ diff --git a/services/cargohold/cargohold.cabal b/services/cargohold/cargohold.cabal index dd689436f55..7aad0bc98a8 100644 --- a/services/cargohold/cargohold.cabal +++ b/services/cargohold/cargohold.cabal @@ -1,10 +1,8 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack --- --- hash: 43240dbac626b3b23a6c7631367cc8c708e417b55fa7b007b4a58885878f8911 name: cargohold version: 1.5.0 @@ -25,28 +23,66 @@ flag static library exposed-modules: - CargoHold.API CargoHold.API.Error CargoHold.API.Federation CargoHold.API.Legacy CargoHold.API.Public + CargoHold.API.Util CargoHold.API.V3 - CargoHold.API.V3.Resumable CargoHold.App CargoHold.AWS CargoHold.CloudFront + CargoHold.Federation CargoHold.Metrics CargoHold.Options CargoHold.Run CargoHold.S3 - CargoHold.TUS CargoHold.Util Main other-modules: Paths_cargohold 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 + 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 build-depends: HsOpenSSL >=0.11 @@ -57,7 +93,7 @@ library , amazonka-s3 >=1.3.7 , attoparsec >=0.12 , auto-update >=0.1.4 - , base >=4 && <5 + , base ==4.* , base64-bytestring >=1.0 , bilge >=0.21 , bytestring >=0.10 @@ -76,6 +112,7 @@ library , http-client-openssl >=0.2 , http-types >=0.8 , imports + , kan-extensions , lens >=4.1 , metrics-wai >=0.4 , mime >=0.4 @@ -94,10 +131,7 @@ library , uri-bytestring >=0.2 , uuid >=1.3.5 , wai >=3.0 - , wai-conduit >=3.0 - , wai-extra >=3.0 - , wai-predicates >=0.8 - , wai-routing >=0.12 + , wai-extra , wai-utilities >=0.16.1 , wire-api , wire-api-federation @@ -108,7 +142,46 @@ executable cargohold main-is: src/Main.hs other-modules: Paths_cargohold - 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 + 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 -rtsopts -with-rtsopts=-T build-depends: HsOpenSSL >=0.11 @@ -127,6 +200,7 @@ executable cargohold , http-client >=0.4 , http-types >=0.8 , imports + , kan-extensions , mime >=0.4 , safe >=0.3 , text >=1.1 @@ -139,13 +213,55 @@ executable cargohold executable cargohold-integration main-is: Main.hs other-modules: + API + API.Federation + API.Util API.V3 Metrics TestSetup Paths_cargohold hs-source-dirs: test/integration - 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 + 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 build-depends: HsOpenSSL >=0.11 @@ -157,20 +273,28 @@ executable cargohold-integration , bytestring-conversion >=0.2 , cargohold , cargohold-types + , conduit , containers >=0.5 + , cryptonite , data-default >=0.5 , errors >=1.4 , exceptions >=0.6 , extended + , federator , http-client >=0.4 , http-client-tls >=0.2 + , http-media , http-types >=0.8 , imports + , kan-extensions , lens >=3.8 - , metrics-wai , mime >=0.4 + , mmorph + , mtl , optparse-applicative , safe >=0.3 + , servant-client + , servant-client-core , tagged >=0.8 , tasty >=1.0 , tasty-hunit >=0.9 @@ -178,6 +302,9 @@ executable cargohold-integration , time >=1.5 , types-common >=0.7 , uuid >=1.3 + , wai , wai-utilities >=0.12 + , wire-api + , wire-api-federation , yaml >=0.8 default-language: Haskell2010 diff --git a/services/cargohold/cargohold.integration.yaml b/services/cargohold/cargohold.integration.yaml index 5254cf9368d..d43b06f0197 100644 --- a/services/cargohold/cargohold.integration.yaml +++ b/services/cargohold/cargohold.integration.yaml @@ -2,6 +2,10 @@ cargohold: host: 0.0.0.0 port: 8084 +federator: + host: 127.0.0.1 + port: 8097 + aws: s3Bucket: dummy-bucket # <-- insert-bucket-name-here s3Endpoint: http://localhost:4570 # https://s3-eu-west-1.amazonaws.com:443 @@ -18,6 +22,7 @@ aws: settings: maxTotalBytes: 27262976 downloadLinkTTL: 300 # Seconds + federationDomain: example.com logLevel: Info logNetStrings: false diff --git a/services/cargohold/package.yaml b/services/cargohold/package.yaml index c73d7934df3..9bc22fa1204 100644 --- a/services/cargohold/package.yaml +++ b/services/cargohold/package.yaml @@ -23,6 +23,7 @@ dependencies: - HsOpenSSL >=0.11 - http-client >=0.4 - http-types >=0.8 +- kan-extensions - mime >=0.4 - safe >=0.3 - text >=1.1 @@ -59,10 +60,7 @@ library: - uri-bytestring >=0.2 - uuid >=1.3.5 - wai >=3.0 - - wai-conduit >=3.0 - - wai-extra >=3.0 - - wai-predicates >=0.8 - - wai-routing >=0.12 + - wai-extra - wai-utilities >=0.16.1 - wire-api - wire-api-federation @@ -74,17 +72,27 @@ executables: - base ==4.* - cargohold - cargohold-types + - conduit + - cryptonite + - federator - http-client-tls >=0.2 + - http-media - lens >=3.8 - - metrics-wai + - mmorph + - mtl - optparse-applicative + - servant-client-core + - servant-client - tagged >=0.8 - tasty >=1.0 - tasty-hunit >=0.9 - time >=1.5 - types-common >=0.7 - uuid >=1.3 + - wai - wai-utilities >=0.12 + - wire-api + - wire-api-federation cargohold: main: src/Main.hs ghc-options: diff --git a/services/cargohold/src/CargoHold/API.hs b/services/cargohold/src/CargoHold/API.hs deleted file mode 100644 index ce5bb5fc32e..00000000000 --- a/services/cargohold/src/CargoHold/API.hs +++ /dev/null @@ -1,40 +0,0 @@ --- 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 CargoHold.API - ( sitemap, - ) -where - -import qualified CargoHold.API.Public as Public -import CargoHold.App (Handler) -import Data.Predicate (true) -import qualified Data.Swagger.Build.Api as Doc -import Imports hiding (head) -import Network.Wai.Routing (Routes, continue, get, head) -import Network.Wai.Utilities (empty) - -sitemap :: Routes Doc.ApiBuilder Handler () -sitemap = do - Public.sitemap - Public.apiDocs - routesInternal - -routesInternal :: Routes a Handler () -routesInternal = do - get "/i/status" (continue $ const $ return empty) true - head "/i/status" (continue $ const $ return empty) true diff --git a/services/cargohold/src/CargoHold/API/Error.hs b/services/cargohold/src/CargoHold/API/Error.hs index d8be728e837..12d469439bf 100644 --- a/services/cargohold/src/CargoHold/API/Error.hs +++ b/services/cargohold/src/CargoHold/API/Error.hs @@ -17,24 +17,47 @@ module CargoHold.API.Error where -import CargoHold.Types.V3.Resumable (Offset, TotalSize) -import Data.Text.Lazy.Builder -import Data.Text.Lazy.Builder.Int +import Data.Proxy +import qualified Data.Text.Lazy as LT +import GHC.TypeLits import Imports import Network.HTTP.Types.Status import Network.Wai.Utilities.Error +import Servant.API.Status +import Wire.API.ErrorDescription + +errorDescriptionToWai :: + forall (code :: Nat) (lbl :: Symbol) (desc :: Symbol). + (KnownStatus code, KnownSymbol lbl) => + ErrorDescription code lbl desc -> + Error +errorDescriptionToWai (ErrorDescription msg) = + mkError + (statusVal (Proxy @code)) + (LT.pack (symbolVal (Proxy @lbl))) + (LT.fromStrict msg) + +errorDescriptionTypeToWai :: + forall e (code :: Nat) (lbl :: Symbol) (desc :: Symbol). + ( KnownStatus code, + KnownSymbol lbl, + KnownSymbol desc, + e ~ ErrorDescription code lbl desc + ) => + Error +errorDescriptionTypeToWai = errorDescriptionToWai (mkErrorDescription :: e) assetTooLarge :: Error -assetTooLarge = mkError status413 "client-error" "Asset too large." +assetTooLarge = errorDescriptionTypeToWai @AssetTooLarge unauthorised :: Error -unauthorised = mkError status403 "unauthorised" "Unauthorised operation." +unauthorised = errorDescriptionTypeToWai @Unauthorised invalidLength :: Error -invalidLength = mkError status400 "invalid-length" "Invalid content length." +invalidLength = errorDescriptionTypeToWai @InvalidLength assetNotFound :: Error -assetNotFound = mkError status404 "not-found" "Asset not found." +assetNotFound = errorDescriptionTypeToWai @AssetNotFound invalidMD5 :: Error invalidMD5 = mkError status400 "client-error" "Invalid MD5." @@ -48,18 +71,6 @@ requestTimeout = \but none was sent over an extended period of time. Idle connections \ \will be closed." -invalidOffset :: Offset -> Offset -> Error -invalidOffset expected given = - mkError status409 "invalid-offset" $ - toLazyText $ - "Invalid offset: " - <> "expected: " - <> decimal expected - <> ", " - <> "given: " - <> decimal given - <> "." - uploadTooSmall :: Error uploadTooSmall = mkError @@ -76,18 +87,6 @@ uploadTooLarge = "The current chunk size + offset \ \is larger than the full upload size." -uploadIncomplete :: TotalSize -> TotalSize -> Error -uploadIncomplete expected actual = - mkError status403 "client-error" $ - toLazyText $ - "The upload is incomplete: " - <> "expected size: " - <> decimal expected - <> ", " - <> "current size: " - <> decimal actual - <> "." - clientError :: LText -> Error clientError = mkError status400 "client-error" diff --git a/services/cargohold/src/CargoHold/API/Federation.hs b/services/cargohold/src/CargoHold/API/Federation.hs index e0ff94dc598..8a0efb0bb65 100644 --- a/services/cargohold/src/CargoHold/API/Federation.hs +++ b/services/cargohold/src/CargoHold/API/Federation.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE RecordWildCards #-} + -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2021 Wire Swiss GmbH @@ -21,24 +23,37 @@ module CargoHold.API.Federation ) where +import CargoHold.API.Error +import CargoHold.API.V3 import CargoHold.App +import qualified CargoHold.S3 as S3 import Control.Error +import Data.Domain 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 +import Wire.API.Routes.AssetBody +import Wire.API.Routes.Named -type FederationAPI = "federation" :> ToServantApi (FedApi 'Cargohold) +type FederationAPI = "federation" :> FedApi 'Cargohold federationSitemap :: ServerT FederationAPI Handler federationSitemap = - genericServerT $ - F.CargoholdApi {F.getAsset = getAsset} + Named @"get-asset" getAsset + :<|> Named @"stream-asset" streamAsset + +checkAsset :: F.GetAsset -> Handler Bool +checkAsset ga = + fmap isJust . runMaybeT $ + checkMetadata Nothing (F.gaKey ga) (F.gaToken ga) + +streamAsset :: Domain -> F.GetAsset -> Handler AssetSource +streamAsset _ ga = do + available <- checkAsset ga + unless available (throwE assetNotFound) + AssetSource <$> S3.downloadV3 (F.gaKey ga) -getAsset :: () -> Handler EmptyResponse -getAsset _ = throwE federationNotImplemented +getAsset :: Domain -> F.GetAsset -> Handler F.GetAssetResponse +getAsset _ = fmap F.GetAssetResponse . checkAsset diff --git a/services/cargohold/src/CargoHold/API/Public.hs b/services/cargohold/src/CargoHold/API/Public.hs index 0d141ad808c..0e2cd8295d0 100644 --- a/services/cargohold/src/CargoHold/API/Public.hs +++ b/services/cargohold/src/CargoHold/API/Public.hs @@ -1,6 +1,6 @@ -- This file is part of the Wire Server implementation. -- --- Copyright (C) 2020 Wire Swiss GmbH +-- 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 @@ -15,325 +15,166 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module CargoHold.API.Public - ( sitemap, - apiDocs, - ) -where +module CargoHold.API.Public (servantSitemap) where -import qualified CargoHold.API.Error as Error import qualified CargoHold.API.Legacy as LegacyAPI +import CargoHold.API.Util import qualified CargoHold.API.V3 as V3 -import qualified CargoHold.API.V3.Resumable as Resumable import CargoHold.App -import CargoHold.Options -import qualified CargoHold.TUS as TUS -import qualified CargoHold.Types.V3 as V3 (Principal (..)) -import Control.Error -import Control.Lens (view, (^.)) -import Data.ByteString.Conversion +import CargoHold.Federation +import qualified CargoHold.Types.V3 as V3 +import Control.Lens +import Data.ByteString.Builder +import qualified Data.ByteString.Lazy as LBS +import Data.Domain import Data.Id -import Data.Predicate -import qualified Data.Swagger.Build.Api as Doc -import Data.Text.Encoding (decodeLatin1) +import Data.Qualified import Imports hiding (head) -import Network.HTTP.Types.Status -import Network.Wai (Request, Response) -import Network.Wai.Conduit (sourceRequestBody) -import Network.Wai.Predicate hiding (Error, setStatus) -import Network.Wai.Routing -import Network.Wai.Utilities hiding (message) -import Network.Wai.Utilities.Swagger (document, mkSwaggerApi) -import qualified Network.Wai.Utilities.Swagger as Doc -import Network.Wai.Utilities.ZAuth +import qualified Network.HTTP.Types as HTTP +import Servant.API +import Servant.Server hiding (Handler) import URI.ByteString -import qualified Wire.API.Asset as Public - -sitemap :: Routes Doc.ApiBuilder Handler () -sitemap = do - --------------------------------------------------------------------------- - -- User API - - -- Simple (one-step) Upload - - post "/assets/v3" (continue uploadAssetV3) $ - header "Z-User" - .&. contentType "multipart" "mixed" - .&. request - document "POST" "uploadAsset" $ do - Doc.summary "Upload an asset. In the multipart/mixed body, the first section's content type should be application/json. The second section's content type should be always application/octet-stream. Other content types will be ignored by the server." - Doc.consumes "multipart/mixed" - Doc.errorResponse Error.assetTooLarge - Doc.errorResponse Error.invalidLength - Doc.response 201 "Asset posted" Doc.end - - --- Resumable (multi-step) Upload - - -- TODO: swagger doc - options "/assets/v3/resumable" (continue resumableOptionsV3) $ - header "Z-User" - - -- TODO (Compliance): Require and check Tus-Resumable header - -- against supported version(s). - post "/assets/v3/resumable" (continue createResumableV3) $ - header "Z-User" - .&. header "Upload-Length" - .&. jsonRequest @Public.ResumableSettings - - -- TODO (Compliance): Require and check Tus-Resumable header - -- against supported version(s). - head "/assets/v3/resumable/:key" (continue statusResumableV3) $ - header "Z-User" - .&. capture "key" - - -- TODO (Compliance): Require and check Tus-Resumable header - -- against supported version(s). - patch "/assets/v3/resumable/:key" (continue uploadResumableV3) $ - header "Z-User" - .&. header "Upload-Offset" - .&. header "Content-Length" - .&. contentType "application" "offset+octet-stream" - .&. capture "key" - .&. request - - --- Download - - get "/assets/v3/:key" (continue downloadAssetV3) $ - header "Z-User" - .&. capture "key" - .&. opt (header "Asset-Token" .|. query "asset_token") - document "GET" "downloadAsset" $ do - Doc.summary "Download an asset" - Doc.parameter Doc.Path "key" Doc.bytes' $ - Doc.description "Asset key" - Doc.parameter Doc.Header "Asset-Token" Doc.bytes' $ do - Doc.description "Asset token" - Doc.optional - Doc.errorResponse Error.assetNotFound - Doc.response 302 "Asset found" Doc.end - - --- Token Management - - post "/assets/v3/:key/token" (continue renewTokenV3) $ - header "Z-User" - .&. capture "key" - document "POST" "renewAssetToken" $ do - Doc.summary "Renew an asset token" - Doc.parameter Doc.Path "key" Doc.bytes' $ - Doc.description "Asset key" - Doc.response 200 "Asset token renewed" Doc.end - Doc.errorResponse Error.assetNotFound - Doc.errorResponse Error.unauthorised - - delete "/assets/v3/:key/token" (continue deleteTokenV3) $ - header "Z-User" - .&. capture "key" - document "DELETE" "deleteAssetToken" $ do - Doc.summary "Delete an asset token" - Doc.notes "Deleting the token makes the asset public." - Doc.parameter Doc.Path "key" Doc.bytes' $ - Doc.description "Asset key" - Doc.response 200 "Asset token deleted" Doc.end - - --- Deletion - - delete "/assets/v3/:key" (continue deleteAssetV3) $ - header "Z-User" - .&. capture "key" - document "DELETE" "deleteAsset" $ do - Doc.summary "Delete an asset" - Doc.parameter Doc.Path "key" Doc.bytes' $ - Doc.description "Asset key" - Doc.response 200 "Asset deleted" Doc.end - Doc.errorResponse Error.assetNotFound - Doc.errorResponse Error.unauthorised - - --------------------------------------------------------------------------- - -- Provider API - - post "/provider/assets" (continue providerUploadV3) $ - zauth ZAuthProvider - .&> contentType "multipart" "mixed" - .&> zauthProviderId - .&. request - - get "/provider/assets/:key" (continue providerDownloadV3) $ - zauth ZAuthProvider - .&> zauthProviderId - .&. capture "key" - .&. opt (header "Asset-Token" .|. query "asset_token") - - delete "/provider/assets/:key" (continue providerDeleteV3) $ - zauth ZAuthProvider - .&> zauthProviderId - .&. capture "key" - - --------------------------------------------------------------------------- - -- Bot API - - post "/bot/assets" (continue botUploadV3) $ - zauth ZAuthBot - .&> contentType "multipart" "mixed" - .&> zauthBotId - .&. request - - get "/bot/assets/:key" (continue botDownloadV3) $ - zauth ZAuthBot - .&> zauthBotId - .&. capture "key" - .&. opt (header "Asset-Token" .|. query "asset_token") - - delete "/bot/assets/:key" (continue botDeleteV3) $ - zauth ZAuthBot - .&> zauthBotId - .&. capture "key" - - -- Legacy - - get "/assets/:id" (continue legacyDownloadPlain) $ - header "Z-User" - .&. param "conv_id" - .&. capture "id" - - get "/conversations/:cnv/assets/:id" (continue legacyDownloadPlain) $ - header "Z-User" - .&. capture "cnv" - .&. capture "id" - - get "/conversations/:cnv/otr/assets/:id" (continue legacyDownloadOtr) $ - header "Z-User" - .&. capture "cnv" - .&. capture "id" - -apiDocs :: Routes Doc.ApiBuilder Handler () -apiDocs = do - get - "/assets/api-docs" - ( \(_ ::: url) k -> - let doc = mkSwaggerApi (decodeLatin1 url) [] sitemap - in k $ json doc - ) - $ accept "application" "json" - .&. query "base_url" - ------------------------------------------------------------------------------ --- User API Handlers - --- FUTUREWORK: make these types more descriptive than 'Request' -> 'Response' -uploadAssetV3 :: UserId ::: Media "multipart" "mixed" ::: Request -> Handler Response -uploadAssetV3 (usr ::: _ ::: req) = do - let principal = V3.UserPrincipal usr - assetResponse principal <$> V3.upload principal (sourceRequestBody req) - -downloadAssetV3 :: UserId ::: Public.AssetKey ::: Maybe Public.AssetToken -> Handler Response -downloadAssetV3 (usr ::: key ::: tok) = do - url <- V3.download (V3.UserPrincipal usr) key tok - redirect url - -deleteAssetV3 :: UserId ::: Public.AssetKey -> Handler Response -deleteAssetV3 (usr ::: key) = do - V3.delete (V3.UserPrincipal usr) key - return empty - -renewTokenV3 :: UserId ::: Public.AssetKey -> Handler Response -renewTokenV3 (usr ::: key) = do - tok <- V3.renewToken (V3.UserPrincipal usr) key - return $ json (Public.NewAssetToken tok) - -deleteTokenV3 :: UserId ::: Public.AssetKey -> Handler Response -deleteTokenV3 (usr ::: key) = do - V3.deleteToken (V3.UserPrincipal usr) key - return empty - -resumableOptionsV3 :: UserId -> Handler Response -resumableOptionsV3 _ = do - maxTotal <- view (settings . setMaxTotalBytes) - return $ TUS.optionsResponse (fromIntegral maxTotal) empty - -createResumableV3 :: UserId ::: Public.TotalSize ::: JsonRequest Public.ResumableSettings -> Handler Response -createResumableV3 (u ::: size ::: req) = do - sets <- parseBody req !>> Error.clientError - res <- Resumable.create (V3.UserPrincipal u) sets size - let key = res ^. Public.resumableAsset . Public.assetKey - let expiry = res ^. Public.resumableExpires - let loc = "/assets/v3/resumable/" <> toByteString' key - return . TUS.createdResponse loc expiry $ json (res :: Public.ResumableAsset) - -statusResumableV3 :: UserId ::: Public.AssetKey -> Handler Response -statusResumableV3 (u ::: a) = do - stat <- Resumable.status (V3.UserPrincipal u) a - return $ case stat of - Nothing -> setStatus status404 empty - Just st -> TUS.headResponse st empty - --- Request = raw bytestring -uploadResumableV3 :: UserId ::: Public.Offset ::: Word ::: Media "application" "offset+octet-stream" ::: Public.AssetKey ::: Request -> Handler Response -uploadResumableV3 (usr ::: offset ::: size ::: _ ::: aid ::: req) = do - (offset', expiry) <- Resumable.upload (V3.UserPrincipal usr) aid offset size (sourceRequestBody req) - return $ TUS.patchResponse offset' expiry empty - --------------------------------------------------------------------------------- --- Provider API Handlers - -providerUploadV3 :: ProviderId ::: Request -> Handler Response -providerUploadV3 (prv ::: req) = do - let principal = V3.ProviderPrincipal prv - assetResponse principal <$> V3.upload principal (sourceRequestBody req) - -providerDownloadV3 :: ProviderId ::: Public.AssetKey ::: Maybe Public.AssetToken -> Handler Response -providerDownloadV3 (prv ::: key ::: tok) = do - url <- V3.download (V3.ProviderPrincipal prv) key tok - redirect url - -providerDeleteV3 :: ProviderId ::: Public.AssetKey -> Handler Response -providerDeleteV3 (prv ::: key) = do - V3.delete (V3.ProviderPrincipal prv) key - return empty - --------------------------------------------------------------------------------- --- Bot API Handlers - -botUploadV3 :: BotId ::: Request -> Handler Response -botUploadV3 (bot ::: req) = do - let principal = V3.BotPrincipal bot - assetResponse principal <$> V3.upload principal (sourceRequestBody req) - -botDownloadV3 :: BotId ::: Public.AssetKey ::: Maybe Public.AssetToken -> Handler Response -botDownloadV3 (bot ::: key ::: tok) = do - url <- V3.download (V3.BotPrincipal bot) key tok - redirect url - -botDeleteV3 :: BotId ::: Public.AssetKey -> Handler Response -botDeleteV3 (bot ::: key) = do - V3.delete (V3.BotPrincipal bot) key - return empty - --------------------------------------------------------------------------------- --- Helpers - -assetResponse :: V3.Principal -> Public.Asset -> Response -assetResponse prc asset = - setStatus status201 . loc (asset ^. Public.assetKey) $ json asset +import Wire.API.Asset +import Wire.API.Routes.AssetBody +import Wire.API.Routes.Public.Cargohold + +servantSitemap :: ServerT ServantAPI Handler +servantSitemap = + renewTokenV3 :<|> deleteTokenV3 + :<|> userAPI + :<|> botAPI + :<|> providerAPI + :<|> qualifiedAPI + :<|> legacyAPI + :<|> internalAPI where - loc k = location $ case prc of - V3.UserPrincipal {} -> "/assets/v3/" <> toByteString k - V3.BotPrincipal {} -> "/bot/assets/" <> toByteString k - V3.ProviderPrincipal {} -> "/provider/assets/" <> toByteString k - -redirect :: Maybe URI -> Handler Response -redirect (Just url) = return . setStatus status302 $ location (serializeURIRef url) empty -redirect Nothing = throwE Error.assetNotFound -{-# INLINE redirect #-} - -location :: ToByteString a => a -> Response -> Response -location = addHeader "Location" . toByteString' -{-# INLINE location #-} - --------------------------------------------------------------------------------- --- Legacy - -legacyDownloadPlain :: UserId ::: ConvId ::: AssetId -> Handler Response -legacyDownloadPlain (usr ::: cnv ::: ast) = LegacyAPI.download usr cnv ast >>= redirect - -legacyDownloadOtr :: UserId ::: ConvId ::: AssetId -> Handler Response -legacyDownloadOtr (usr ::: cnv ::: ast) = LegacyAPI.downloadOtr usr cnv ast >>= redirect + userAPI :: forall tag. tag ~ 'UserPrincipalTag => ServerT (BaseAPIv3 tag) Handler + userAPI = uploadAssetV3 @tag :<|> downloadAssetV3 @tag :<|> deleteAssetV3 @tag + botAPI :: forall tag. tag ~ 'BotPrincipalTag => ServerT (BaseAPIv3 tag) Handler + botAPI = uploadAssetV3 @tag :<|> downloadAssetV3 @tag :<|> deleteAssetV3 @tag + providerAPI :: forall tag. tag ~ 'ProviderPrincipalTag => ServerT (BaseAPIv3 tag) Handler + providerAPI = uploadAssetV3 @tag :<|> downloadAssetV3 @tag :<|> deleteAssetV3 @tag + legacyAPI = legacyDownloadPlain :<|> legacyDownloadPlain :<|> legacyDownloadOtr + qualifiedAPI = downloadAssetV4 :<|> deleteAssetV4 + internalAPI = pure () + +class HasLocation (tag :: PrincipalTag) where + assetLocation :: Local AssetKey -> [Text] + +instance HasLocation 'UserPrincipalTag where + assetLocation key = + [ "assets", + "v4", + domainText (tDomain key), + assetKeyToText (tUnqualified key) + ] + +instance HasLocation 'BotPrincipalTag where + assetLocation key = + [ "bot", + "assets", + assetKeyToText (tUnqualified key) + ] + +instance HasLocation 'ProviderPrincipalTag where + assetLocation key = + [ "provider", + "assets", + assetKeyToText (tUnqualified key) + ] + +class HasLocation tag => MakePrincipal (tag :: PrincipalTag) (id :: *) | id -> tag, tag -> id where + mkPrincipal :: id -> V3.Principal + +instance MakePrincipal 'UserPrincipalTag (Local UserId) where + mkPrincipal = V3.UserPrincipal . tUnqualified + +instance MakePrincipal 'BotPrincipalTag BotId where + mkPrincipal = V3.BotPrincipal + +instance MakePrincipal 'ProviderPrincipalTag ProviderId where + mkPrincipal = V3.ProviderPrincipal + +mkAssetLocation :: + forall (tag :: PrincipalTag). + HasLocation tag => + Local AssetKey -> + AssetLocation Relative +mkAssetLocation key = + AssetLocation + RelativeRef + { rrAuthority = Nothing, + rrPath = path, + rrQuery = mempty, + rrFragment = Nothing + } + where + path = + LBS.toStrict + . toLazyByteString + . HTTP.encodePathSegmentsRelative + $ assetLocation @tag key + +uploadAssetV3 :: + forall tag id. + MakePrincipal tag id => + id -> + AssetSource -> + Handler (Asset, AssetLocation Relative) +uploadAssetV3 pid req = do + let principal = mkPrincipal pid + asset <- V3.upload principal (getAssetSource req) + pure (fmap qUntagged asset, mkAssetLocation @tag (asset ^. assetKey)) + +downloadAssetV3 :: + MakePrincipal tag id => + id -> + AssetKey -> + Maybe AssetToken -> + Maybe AssetToken -> + Handler (Maybe (AssetLocation Absolute)) +downloadAssetV3 usr key tok1 tok2 = do + AssetLocation <$$> V3.download (mkPrincipal usr) key (tok1 <|> tok2) + +downloadAssetV4 :: + Local UserId -> + Qualified AssetKey -> + Maybe AssetToken -> + Maybe AssetToken -> + Handler (Maybe LocalOrRemoteAsset) +downloadAssetV4 usr qkey tok1 tok2 = + let tok = tok1 <|> tok2 + in foldQualified + usr + ( \lkey -> + LocalAsset . AssetLocation + <$$> V3.download (mkPrincipal usr) (tUnqualified lkey) tok + ) + ( \rkey -> + RemoteAsset + <$$> downloadRemoteAsset usr rkey tok + ) + qkey + +deleteAssetV3 :: MakePrincipal tag id => id -> AssetKey -> Handler () +deleteAssetV3 usr key = V3.delete (mkPrincipal usr) key + +deleteAssetV4 :: Local UserId -> Qualified AssetKey -> Handler () +deleteAssetV4 usr qkey = do + key <- tUnqualified <$> ensureLocal qkey + V3.delete (mkPrincipal usr) key + +renewTokenV3 :: Local UserId -> AssetKey -> Handler NewAssetToken +renewTokenV3 (tUnqualified -> usr) key = + NewAssetToken <$> V3.renewToken (V3.UserPrincipal usr) key + +deleteTokenV3 :: Local UserId -> AssetKey -> Handler () +deleteTokenV3 (tUnqualified -> usr) key = V3.deleteToken (V3.UserPrincipal usr) key + +legacyDownloadPlain :: Local UserId -> ConvId -> AssetId -> Handler (Maybe (AssetLocation Absolute)) +legacyDownloadPlain (tUnqualified -> usr) cnv ast = + AssetLocation <$$> LegacyAPI.download usr cnv ast + +legacyDownloadOtr :: Local UserId -> ConvId -> AssetId -> Handler (Maybe (AssetLocation Absolute)) +legacyDownloadOtr (tUnqualified -> usr) cnv ast = + AssetLocation <$$> LegacyAPI.downloadOtr usr cnv ast diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ChunkSize_user.hs b/services/cargohold/src/CargoHold/API/Util.hs similarity index 62% rename from libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ChunkSize_user.hs rename to services/cargohold/src/CargoHold/API/Util.hs index c12c6163d29..33c30e480ff 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ChunkSize_user.hs +++ b/services/cargohold/src/CargoHold/API/Util.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedLists #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2021 Wire Swiss GmbH @@ -16,9 +14,26 @@ -- -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Test.Wire.API.Golden.Generated.ChunkSize_user where -import Wire.API.Asset (ChunkSize (..)) +module CargoHold.API.Util + ( ensureLocal, + qualifyLocal, + ) +where + +import CargoHold.App +import Control.Error +import Control.Lens +import Data.Qualified +import Imports +import Wire.API.Federation.Error + +ensureLocal :: Qualified a -> Handler (Local a) +ensureLocal value = do + loc <- view localUnit + foldQualified loc pure (\_ -> throwE federationNotImplemented) value -testObject_ChunkSize_user_1 :: ChunkSize -testObject_ChunkSize_user_1 = ChunkSize {chunkSizeBytes = 17} +qualifyLocal :: a -> Handler (Local a) +qualifyLocal x = do + loc <- view localUnit + pure (qualifyAs loc x) diff --git a/services/cargohold/src/CargoHold/API/V3.hs b/services/cargohold/src/CargoHold/API/V3.hs index fcbe55d5530..1a1c3a0ccf7 100644 --- a/services/cargohold/src/CargoHold/API/V3.hs +++ b/services/cargohold/src/CargoHold/API/V3.hs @@ -18,6 +18,7 @@ module CargoHold.API.V3 ( upload, download, + checkMetadata, delete, renewToken, deleteToken, @@ -26,6 +27,7 @@ module CargoHold.API.V3 where import CargoHold.API.Error +import CargoHold.API.Util import CargoHold.App import qualified CargoHold.Metrics as Metrics import CargoHold.Options @@ -48,6 +50,7 @@ import Data.Conduit import qualified Data.Conduit.Attoparsec as Conduit import Data.Id import qualified Data.List as List +import Data.Qualified import qualified Data.Text.Ascii as Ascii import Data.Text.Encoding (decodeLatin1) import qualified Data.Text.Lazy as LT @@ -57,8 +60,9 @@ import Imports hiding (take) import Network.HTTP.Types.Header import Network.Wai.Utilities (Error (..)) import URI.ByteString +import Wire.API.Asset -upload :: V3.Principal -> ConduitM () ByteString (ResourceT IO) () -> Handler V3.Asset +upload :: V3.Principal -> ConduitM () ByteString (ResourceT IO) () -> Handler (Asset' (Local AssetKey)) upload own bdy = do (rsrc, sets) <- parseMetadata bdy assetSettings (src, hdrs) <- parseHeaders rsrc assetHeaders @@ -71,8 +75,8 @@ upload own bdy = do ast <- liftIO $ Id <$> nextRandom tok <- if sets ^. V3.setAssetPublic then return Nothing else Just <$> randToken let ret = fromMaybe V3.AssetPersistent (sets ^. V3.setAssetRetention) - let key = V3.AssetKeyV3 ast ret - void $ S3.uploadV3 own key hdrs tok src + key <- qualifyLocal (V3.AssetKeyV3 ast ret) + void $ S3.uploadV3 own (tUnqualified key) hdrs tok src Metrics.s3UploadOk Metrics.s3UploadSize cl expires <- case V3.assetRetentionSeconds ret of @@ -103,14 +107,14 @@ randToken :: MonadIO m => m V3.AssetToken randToken = liftIO $ V3.AssetToken . Ascii.encodeBase64Url <$> getRandomBytes 16 download :: V3.Principal -> V3.AssetKey -> Maybe V3.AssetToken -> Handler (Maybe URI) -download own key tok = S3.getMetadataV3 key >>= maybe notFound found - where - notFound = return Nothing - found s3 - | own /= S3.v3AssetOwner s3 && tok /= S3.v3AssetToken s3 = return Nothing - | otherwise = do - url <- genSignedURL (S3.mkKey key) - return $! Just $! url +download own key tok = runMaybeT $ do + checkMetadata (Just own) key tok + lift $ genSignedURL (S3.mkKey key) + +checkMetadata :: Maybe V3.Principal -> V3.AssetKey -> Maybe V3.AssetToken -> MaybeT Handler () +checkMetadata mown key tok = do + s3 <- lift (S3.getMetadataV3 key) >>= maybe mzero pure + guard $ mown == Just (S3.v3AssetOwner s3) || tok == S3.v3AssetToken s3 delete :: V3.Principal -> V3.AssetKey -> Handler () delete own key = do diff --git a/services/cargohold/src/CargoHold/API/V3/Resumable.hs b/services/cargohold/src/CargoHold/API/V3/Resumable.hs deleted file mode 100644 index 878842375b4..00000000000 --- a/services/cargohold/src/CargoHold/API/V3/Resumable.hs +++ /dev/null @@ -1,149 +0,0 @@ --- 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 CargoHold.API.V3.Resumable - ( create, - status, - upload, - ) -where - -import qualified CargoHold.API.Error as Error -import CargoHold.API.V3 (randToken) -import CargoHold.App -import CargoHold.Options -import qualified CargoHold.S3 as S3 -import CargoHold.Types.V3 as V3 -import CargoHold.Types.V3.Resumable as V3 -import Control.Error (throwE) -import Control.Lens (set, view) -import Data.ByteString.Conversion -import Data.Coerce -import Data.Conduit -import Data.Id -import Data.Time.Clock -import Data.UUID.V4 (nextRandom) -import Imports -import System.Logger.Class (field, msg, val, (~~)) -import qualified System.Logger.Class as Log - -create :: V3.Principal -> V3.ResumableSettings -> V3.TotalSize -> Handler V3.ResumableAsset -create own sets size = do - let cl = fromIntegral size - when (cl <= 0) $ - throwE Error.invalidLength - maxTotalBytes <- view (settings . setMaxTotalBytes) - when (cl > maxTotalBytes) $ - throwE Error.assetTooLarge - aid <- liftIO $ Id <$> nextRandom - tok <- - if view setResumablePublic sets - then return Nothing - else Just <$> randToken - let ret = view setResumableRetention sets - let typ = view setResumableType sets - let key = V3.AssetKeyV3 aid ret - astExpire <- case V3.assetRetentionSeconds ret of - Just n -> Just . addUTCTime n <$> liftIO getCurrentTime - Nothing -> return Nothing - Log.debug $ - field "asset" (toByteString aid) - ~~ field "asset.size" (toByteString size) - ~~ msg (val "Initialising resumable upload") - r <- S3.createResumable key own typ size tok - let chunkSize = S3.resumableChunkSize r - let uplExpire = S3.resumableExpires r - let ast = - V3.mkAsset key - & set V3.assetExpires astExpire - & set V3.assetToken tok - return $! mkResumableAsset ast uplExpire chunkSize - -status :: V3.Principal -> AssetKey -> Handler (Maybe (V3.Offset, V3.TotalSize)) -status own key = do - Log.debug $ - field "asset" (toByteString key) - ~~ msg (val "Getting status of resumable upload") - r <- getResumable key - return $ - if own /= S3.resumableOwner r - then Nothing - else - let total = S3.resumableTotalSize r - offset = S3.resumableOffset r - in Just (offset, total) - -upload :: V3.Principal -> AssetKey -> Offset -> Word -> ConduitM () ByteString IO () -> Handler (Offset, UTCTime) -upload own key off len src = do - r <- getResumable key - let offset = S3.resumableOffset r - validate r offset - if off == Offset (totalSize r) - then complete r - else resume r offset - where - complete r = do - fin <- S3.getMetadataV3 key - unless (isJust fin) $ - S3.completeResumable r - return (off, S3.resumableExpires r) - resume r offset = do - Log.debug $ - field "asset" (toByteString key) - ~~ field "asset.offset" (toByteString offset) - ~~ msg (val "Resuming upload") - (r', offset') <- consume r offset len (sealConduitT src) - when (offset' == Offset (totalSize r')) $ - -- TODO: Completion might take a while, such that we may need to - -- keep the client connection alive by sending whitespace after the - -- response status line and headers but before the final response body, - -- just like S3 does when completing multipart uploads. - S3.completeResumable r' - return (offset', S3.resumableExpires r') - consume r offset 0 _ = return (r, offset) - consume r offset remaining rsrc = do - let totalBytes = V3.totalSizeBytes (S3.resumableTotalSize r) - let numBytes = min (chunkSize r) remaining - if numBytes < chunkSize r && coerce offset + remaining < totalBytes - then -- Remaining input that is not a full chunk size and does - -- not constitute the last chunk is ignored, i.e. all chunks - -- except the last must have the same size (the chunk size). - return (r, offset) - else do - (r', rsrc') <- S3.uploadChunk r offset rsrc - let offset' = offset + Offset numBytes - let remaining' = remaining - numBytes - consume r' offset' remaining' rsrc' - validate r o - | invalidOwner r = throwE Error.assetNotFound - | invalidOffset o = throwE (Error.invalidOffset o off) - | tooSmall r o = throwE Error.uploadTooSmall - | tooLarge r = throwE Error.uploadTooLarge - | otherwise = return () - invalidOwner r = own /= S3.resumableOwner r - invalidOffset o = o /= off - tooSmall r o = len < chunkSize r && missingBytes r o > chunkSize r - tooLarge r = proposedBytes > S3.resumableTotalSize r - chunkSize = chunkSizeBytes . S3.resumableChunkSize - totalSize = totalSizeBytes . S3.resumableTotalSize - missingBytes r o = totalSize r - V3.offsetBytes o - proposedBytes = V3.TotalSize (V3.offsetBytes off + len) - -getResumable :: AssetKey -> Handler S3.S3Resumable -getResumable key = do - rs <- S3.getResumable key - maybe (throwE Error.assetNotFound) return rs diff --git a/services/cargohold/src/CargoHold/AWS.hs b/services/cargohold/src/CargoHold/AWS.hs index b3b00d531f8..a25b90e0c20 100644 --- a/services/cargohold/src/CargoHold/AWS.hs +++ b/services/cargohold/src/CargoHold/AWS.hs @@ -34,16 +34,17 @@ module CargoHold.AWS send, sendCatch, exec, + execStream, execCatch, ) where import CargoHold.CloudFront import CargoHold.Options +import Conduit import Control.Lens hiding ((.=)) import Control.Monad.Catch import qualified Control.Monad.Trans.AWS as AWST -import Control.Monad.Trans.Resource import Control.Retry import Data.ByteString.Builder (toLazyByteString) import Imports @@ -90,17 +91,13 @@ newtype Amazon a = Amazon MonadCatch, MonadMask, MonadReader Env, - MonadResource + MonadResource, + MonadUnliftIO ) instance MonadLogger Amazon where log l m = view logger >>= \g -> Logger.log g l m -instance MonadUnliftIO Amazon where - askUnliftIO = Amazon . ReaderT $ \r -> - withUnliftIO $ \u -> - return (UnliftIO (unliftIO u . flip runReaderT r . unAmazon)) - instance AWS.MonadAWS Amazon where liftAWS a = view amazonkaEnv >>= flip AWS.runAWS a @@ -157,7 +154,7 @@ instance Exception Error -------------------------------------------------------------------------------- -- Utilities -sendCatch :: AWSRequest r => r -> Amazon (Either AWS.Error (Rs r)) +sendCatch :: (MonadCatch m, AWS.MonadAWS m, AWSRequest r) => r -> m (Either AWS.Error (Rs r)) sendCatch = AWST.trying AWS._Error . AWS.send send :: AWSRequest r => r -> Amazon (Rs r) @@ -176,7 +173,7 @@ exec env request = do resp <- execute env (sendCatch req) case resp of Left err -> do - Log.info $ + Logger.info (view logger env) $ Log.field "remote" (Log.val "S3") ~~ Log.msg (show err) ~~ Log.msg (show req) @@ -185,6 +182,25 @@ exec env request = do throwM (GeneralError err) Right r -> return r +execStream :: + (AWSRequest r, Show r) => + Env -> + (Text -> r) -> + ResourceT IO (Rs r) +execStream env request = do + let req = request (_s3Bucket env) + resp <- AWS.runAWS (view amazonkaEnv env) (sendCatch req) + case resp of + Left err -> do + Logger.info (view logger env) $ + Log.field "remote" (Log.val "S3") + ~~ Log.msg (show err) + ~~ Log.msg (show req) + -- We just re-throw the error, but logging it here also gives us the request + -- that caused it. + throwM (GeneralError err) + Right r -> pure r + execCatch :: (AWSRequest r, Show r, MonadLogger m, MonadIO m) => Env -> diff --git a/services/cargohold/src/CargoHold/App.hs b/services/cargohold/src/CargoHold/App.hs index 79aa9dddfa5..63f8d48543e 100644 --- a/services/cargohold/src/CargoHold/App.hs +++ b/services/cargohold/src/CargoHold/App.hs @@ -29,6 +29,8 @@ module CargoHold.App metrics, appLogger, requestId, + localUnit, + options, settings, -- * App Monad @@ -50,12 +52,13 @@ import qualified CargoHold.AWS as AWS import CargoHold.Options as Opt import Control.Error (ExceptT, exceptT) import Control.Exception (throw) -import Control.Lens (makeLenses, view, (^.)) +import Control.Lens (Lens', makeLenses, view, (^.)) import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) import Control.Monad.Trans.Resource (ResourceT, runResourceT, transResourceT) import Data.Default (def) import Data.Metrics.Middleware (Metrics) import qualified Data.Metrics.Middleware as Metrics +import Data.Qualified import Imports hiding (log) import Network.HTTP.Client (ManagerSettings (..), requestHeaders, responseTimeoutMicro) import Network.HTTP.Client.OpenSSL @@ -75,18 +78,23 @@ data Env = Env _appLogger :: Logger, _httpManager :: Manager, _requestId :: RequestId, - _settings :: Opt.Settings + _options :: Opt.Opts, + _localUnit :: Local () } makeLenses ''Env +settings :: Lens' Env Opt.Settings +settings = options . optSettings + newEnv :: Opts -> IO Env newEnv o = do met <- Metrics.metrics lgr <- Log.mkLogger (o ^. optLogLevel) (o ^. optLogNetStrings) (o ^. optLogFormat) mgr <- initHttpManager (o ^. optAws . awsS3Compatibility) ama <- initAws (o ^. optAws) lgr mgr - return $ Env ama met lgr mgr def (o ^. optSettings) + let loc = toLocalUnsafe (o ^. optSettings . Opt.setFederationDomain) () + return $ Env ama met lgr mgr def o loc initAws :: AWSOpts -> Logger -> Manager -> IO AWS.Env initAws o l m = diff --git a/services/cargohold/src/CargoHold/Federation.hs b/services/cargohold/src/CargoHold/Federation.hs new file mode 100644 index 00000000000..abe73afe8e7 --- /dev/null +++ b/services/cargohold/src/CargoHold/Federation.hs @@ -0,0 +1,113 @@ +-- 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.Federation where + +import CargoHold.App +import CargoHold.Options +import Control.Error +import Control.Exception (throw) +import Control.Lens +import Control.Monad.Codensity +import Data.Id +import Data.Qualified +import Imports hiding (head) +import Servant.API +import Servant.Types.SourceT +import Wire.API.Asset +import Wire.API.Federation.API +import Wire.API.Federation.API.Cargohold +import Wire.API.Federation.Client +import Wire.API.Federation.Error + +-- [Note] +-- There are several ways a remote asset could be streamed to the client: +-- +-- "all-the-way": the remote federator streams the asset back to us in the RPC +-- itself, and we forward it to the client +-- "two-step": the remote federator returns a redirect response, we follow it +-- and stream the data to the client +-- "one-step": the remote federator returns a redirect response, and we simply +-- forward it to the client +-- +-- For now, only the "all-the-way" solution is implemented. Note that the asset +-- is streamed back through our outward federator, as well as the remote one. + +downloadRemoteAsset :: + Local UserId -> + Remote AssetKey -> + Maybe AssetToken -> + Handler (Maybe (SourceIO ByteString)) +downloadRemoteAsset usr rkey tok = do + let ga = + GetAsset + { gaKey = tUnqualified rkey, + gaUser = tUnqualified usr, + gaToken = tok + } + exists <- + fmap gaAvailable . executeFederated rkey $ + fedClient @'Cargohold @"get-asset" ga + if exists + then + Just + <$> executeFederatedStreaming + rkey + ( toSourceIO + <$> fedClient @'Cargohold @"stream-asset" ga + ) + else pure Nothing + +mkFederatorClientEnv :: Remote x -> Handler FederatorClientEnv +mkFederatorClientEnv remote = do + loc <- view localUnit + endpoint <- + view (options . optFederator) + >>= maybe (throwE federationNotConfigured) pure + pure + FederatorClientEnv + { ceOriginDomain = tDomain loc, + ceTargetDomain = tDomain remote, + ceFederator = endpoint + } + +executeFederated :: Remote x -> FederatorClient 'Cargohold a -> Handler a +executeFederated remote c = do + env <- mkFederatorClientEnv remote + liftIO (runFederatorClient @'Cargohold env c) + >>= either (throwE . federationErrorToWai . FederationCallFailure) pure + +executeFederatedStreaming :: + Remote x -> + FederatorClient 'Cargohold (SourceIO ByteString) -> + Handler (SourceIO ByteString) +executeFederatedStreaming remote c = do + env <- mkFederatorClientEnv remote + -- To clean up resources correctly, we exploit the Codensity wrapper around + -- StepT to embed the result of @runFederatorClientToCodensity@. This works, but + -- using this within a Servant handler has the effect of delaying exceptions to + -- the point where response streaming has already started (i.e. we have already + -- committed to a successful response). + -- Fortunately, Warp does not actually send out the response headers until it + -- sees at least one chunk, so by throwing the exception in IO and having a + -- catch middleware in place, we make sure that the correct error response + -- ends up being generated. + pure $ + SourceT $ \k -> + runCodensity + (runFederatorClientToCodensity @'Cargohold env c) + (either (throw . federationErrorToWai . FederationCallFailure) (flip unSourceT k)) diff --git a/services/cargohold/src/CargoHold/Options.hs b/services/cargohold/src/CargoHold/Options.hs index 31992d462af..f46423b9104 100644 --- a/services/cargohold/src/CargoHold/Options.hs +++ b/services/cargohold/src/CargoHold/Options.hs @@ -19,10 +19,11 @@ module CargoHold.Options where -import CargoHold.CloudFront (Domain (..), KeyPairId (..)) +import qualified CargoHold.CloudFront as CF import Control.Lens hiding (Level) import Data.Aeson (FromJSON (..), withText) import Data.Aeson.TH +import Data.Domain import Imports import System.Logger.Extended (Level, LogFormat) import Util.Options @@ -31,9 +32,9 @@ import Util.Options.Common -- | AWS CloudFront settings. data CloudFrontOpts = CloudFrontOpts { -- | Domain - _cfDomain :: Domain, + _cfDomain :: CF.Domain, -- | Keypair ID - _cfKeyPairId :: KeyPairId, + _cfKeyPairId :: CF.KeyPairId, -- | Path to private key _cfPrivateKey :: FilePath } @@ -78,7 +79,18 @@ data Settings = Settings { -- | Maximum allowed size for uploads, in bytes _setMaxTotalBytes :: !Int, -- | TTL for download links, in seconds - _setDownloadLinkTTL :: !Word + _setDownloadLinkTTL :: !Word, + -- | FederationDomain is required, even when not wanting to federate with other backends + -- (in that case the 'setFederationAllowedDomains' can be set to empty in Federator) + -- Federation domain is used to qualify local IDs and handles, + -- e.g. 0c4d8944-70fa-480e-a8b7-9d929862d18c@wire.com and somehandle@wire.com. + -- It should also match the SRV DNS records under which other wire-server installations can find this backend: + -- _wire-server-federator._tcp. + -- Once set, DO NOT change it: if you do, existing users may have a broken experience and/or stop working + -- Remember to keep it the same in Galley and in Brig. + -- This is referred to as the 'backend domain' in the public documentation; See + -- https://docs.wire.com/how-to/install/configure-federation.html#choose-a-backend-domain-name + _setFederationDomain :: !Domain } deriving (Show, Generic) @@ -86,11 +98,15 @@ deriveFromJSON toOptionFieldName ''Settings makeLenses ''Settings +-- | Options consist of information the server needs to operate, and 'Settings' +-- modify the behavior. data Opts = Opts { -- | Hostname and port to bind to _optCargohold :: !Endpoint, _optAws :: !AWSOpts, _optSettings :: !Settings, + -- | Federator endpoint + _optFederator :: Maybe Endpoint, -- Logging -- | Log level (Debug, Info, etc) diff --git a/services/cargohold/src/CargoHold/Run.hs b/services/cargohold/src/CargoHold/Run.hs index bf305eb2d06..bd66227050d 100644 --- a/services/cargohold/src/CargoHold/Run.hs +++ b/services/cargohold/src/CargoHold/Run.hs @@ -17,18 +17,21 @@ module CargoHold.Run ( run, + mkApp, ) where -import CargoHold.API (sitemap) import CargoHold.API.Federation +import CargoHold.API.Public import CargoHold.App import CargoHold.Options +import Control.Exception (bracket) import Control.Lens (set, (^.)) -import Control.Monad.Catch (finally) +import Control.Monad.Codensity import Data.Default +import Data.Domain import Data.Id -import Data.Metrics.Middleware.Prometheus (waiPrometheusMiddleware) +import Data.Metrics.Servant import Data.Proxy import Data.Text (unpack) import Imports @@ -37,36 +40,55 @@ 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 Servant.Server hiding (Handler, runHandler) import Util.Options +import qualified Wire.API.Routes.Public.Cargohold as Public -type CombinedAPI = FederationAPI :<|> Servant.Raw +type CombinedAPI = FederationAPI :<|> Public.ServantAPI run :: Opts -> IO () -run o = do - e <- newEnv o - s <- Server.newSettings (server e) - runSettingsWithShutdown s (middleware e $ servantApp e) 5 - `finally` closeEnv e +run o = lowerCodensity $ do + (app, e) <- mkApp o + liftIO $ do + s <- + Server.newSettings $ + defaultServer + (unpack $ o ^. optCargohold . epHost) + (o ^. optCargohold . epPort) + (e ^. appLogger) + (e ^. metrics) + runSettingsWithShutdown s app 5 + +mkApp :: Opts -> Codensity IO (Application, Env) +mkApp o = Codensity $ \k -> + bracket (newEnv o) closeEnv $ \e -> + k (middleware e (servantApp e), e) where - rtree = compile sitemap - server e = defaultServer (unpack $ o ^. optCargohold . epHost) (o ^. optCargohold . epPort) (e ^. appLogger) (e ^. metrics) middleware :: Env -> Wai.Middleware middleware e = - waiPrometheusMiddleware sitemap + servantPrometheusMiddleware (Proxy @CombinedAPI) . GZip.gzip GZip.def . catchErrors (e ^. appLogger) [Right $ e ^. metrics] - 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 + in Servant.serveWithContext (Proxy @CombinedAPI) - ( hoistServer (Proxy @FederationAPI) (toServantHandler e) federationSitemap - :<|> Servant.Tagged (serve e) + ((o ^. optSettings . setFederationDomain) :. Servant.EmptyContext) + ( hoistServer' @FederationAPI (toServantHandler e) federationSitemap + :<|> hoistServer' @Public.ServantAPI (toServantHandler e) servantSitemap ) r toServantHandler :: Env -> Handler a -> Servant.Handler a toServantHandler env = liftIO . runHandler env + +-- | See 'Galley.Run' for an explanation of this function. +hoistServer' :: + forall api m n. + HasServer api '[Domain] => + (forall x. m x -> n x) -> + ServerT api m -> + ServerT api n +hoistServer' = hoistServerWithContext (Proxy @api) (Proxy @'[Domain]) diff --git a/services/cargohold/src/CargoHold/S3.hs b/services/cargohold/src/CargoHold/S3.hs index c71220e9beb..22fecb6dc67 100644 --- a/services/cargohold/src/CargoHold/S3.hs +++ b/services/cargohold/src/CargoHold/S3.hs @@ -23,24 +23,12 @@ module CargoHold.S3 ( S3AssetKey, S3AssetMeta (..), uploadV3, + downloadV3, getMetadataV3, updateMetadataV3, deleteV3, mkKey, signedURL, - - -- * Resumable Uploads - S3Resumable, - resumableOwner, - resumableTotalSize, - resumableExpires, - resumableChunkSize, - resumableOffset, - createResumable, - getResumable, - completeResumable, - S3Chunk, - uploadChunk, -- Legacy plainKey, otrKey, @@ -54,23 +42,18 @@ import qualified CargoHold.AWS as AWS import CargoHold.App hiding (Env, Handler) import CargoHold.Options import qualified CargoHold.Types.V3 as V3 -import qualified CargoHold.Types.V3.Resumable as V3 import qualified Codec.MIME.Parse as MIME import qualified Codec.MIME.Type as MIME import Conduit import Control.Error (ExceptT, throwE) import Control.Lens hiding (parts, (.=), (:<), (:>)) import Data.ByteString.Builder (toLazyByteString) -import qualified Data.ByteString.Char8 as C8 import Data.ByteString.Conversion import qualified Data.ByteString.Lazy as LBS import qualified Data.CaseInsensitive as CI -import qualified Data.Conduit.Binary as Conduit +import Data.Conduit.Binary import qualified Data.HashMap.Lazy as HML import Data.Id -import qualified Data.List.NonEmpty as NE -import Data.Sequence (Seq, ViewL (..), ViewR (..)) -import qualified Data.Sequence as Seq import qualified Data.Text as Text import qualified Data.Text.Ascii as Ascii import Data.Text.Encoding (decodeLatin1, encodeUtf8) @@ -82,7 +65,6 @@ import Network.AWS hiding (Error) import Network.AWS.Data.Body import Network.AWS.S3 import Network.Wai.Utilities.Error (Error (..)) -import Safe (readMay) import qualified System.Logger.Class as Log import System.Logger.Message (msg, val, (.=), (~~)) import URI.ByteString @@ -114,7 +96,7 @@ uploadV3 :: V3.AssetKey -> V3.AssetHeaders -> Maybe V3.AssetToken -> - Conduit.ConduitM () ByteString (ResourceT IO) () -> + ConduitM () ByteString (ResourceT IO) () -> ExceptT Error App () uploadV3 prc (s3Key . mkKey -> key) originalHeaders@(V3.AssetHeaders _ cl) tok src = do Log.info $ @@ -134,9 +116,9 @@ uploadV3 prc (s3Key . mkKey -> key) originalHeaders@(V3.AssetHeaders _ cl) tok s src -- Rechunk bytestream to ensure we satisfy AWS's minimum chunk size -- on uploads - .| Conduit.chunksOfCE (fromIntegral defaultChunkSize) + .| chunksOfCE (fromIntegral defaultChunkSize) -- Ignore any 'junk' after the content; take only 'cl' bytes. - .| Conduit.isolate (fromIntegral cl) + .| isolate (fromIntegral cl) reqBdy :: ChunkedBody reqBdy = ChunkedBody defaultChunkSize (fromIntegral cl) stream @@ -147,6 +129,28 @@ uploadV3 prc (s3Key . mkKey -> key) originalHeaders@(V3.AssetHeaders _ cl) tok s & poContentType ?~ MIME.showType ct & poMetadata .~ metaHeaders tok prc +-- | Turn a 'ResourceT IO' action into a pure @Conduit@. +-- +-- This is possible because @Conduit@ itself is a monad transformer over +-- 'ResourceT IO'. Removing the outer 'ResourceT IO' layer makes it possible to +-- pass this @Conduit@ to resource-oblivious code. +flattenResourceT :: + ResourceT IO (ConduitT () ByteString (ResourceT IO) ()) -> + ConduitT () ByteString (ResourceT IO) () +flattenResourceT = join . lift + +downloadV3 :: + V3.AssetKey -> + ExceptT Error App (ConduitM () ByteString (ResourceT IO) ()) +downloadV3 (s3Key . mkKey -> key) = do + env <- view aws + pure . flattenResourceT $ _streamBody . view gorsBody <$> AWS.execStream env req + where + req :: Text -> GetObject + req b = + getObject (BucketName b) (ObjectKey key) + & goResponseContentType ?~ MIME.showType octets + getMetadataV3 :: V3.AssetKey -> ExceptT Error App (Maybe S3AssetMeta) getMetadataV3 (s3Key . mkKey -> key) = do Log.debug $ @@ -237,408 +241,6 @@ metaHeaders tok prc = Just (setAmzMetaPrincipal prc) ] -------------------------------------------------------------------------------- --- Resumable Uploads - -newtype S3ResumableKey = S3ResumableKey {s3ResumableKey :: Text} - deriving (Eq, Show, ToByteString) - -newtype S3ChunkKey = S3ChunkKey {s3ChunkKey :: Text} - deriving (Eq, Show, ToByteString) - -newtype S3ChunkNr = S3ChunkNr Word - deriving (Eq, Ord, Show, ToByteString, FromByteString, Num, Integral, Enum, Real) - -newtype S3ETag = S3ETag {s3ETag :: Text} - deriving (Eq, Show, ToByteString, FromByteString) - -data S3Resumable = S3Resumable - { -- | The resumable asset key. - resumableKey :: S3ResumableKey, - -- | The final asset key. - resumableAsset :: V3.AssetKey, - -- | The creator (i.e. owner). - resumableOwner :: V3.Principal, - -- | Size of each chunk. - resumableChunkSize :: V3.ChunkSize, - -- | Size of the final asset. - resumableTotalSize :: V3.TotalSize, - -- | MIME type of the final asset. - resumableType :: MIME.Type, - -- | Token of the final asset. - resumableToken :: Maybe V3.AssetToken, - -- | Expiry of the resumable upload. - resumableExpires :: UTCTime, - -- | S3 multipart upload ID, if any. - resumableUploadId :: Maybe Text, - resumableChunks :: Seq S3Chunk - } - deriving (Show) - -data S3Chunk = S3Chunk - { -- | Sequence nr. - chunkNr :: S3ChunkNr, - -- | Offset of the first byte. - chunkOffset :: V3.Offset, - -- | (Actual) Size of the chunk. - chunkSize :: Word, - -- | S3 ETag. - chunkETag :: S3ETag - } - deriving (Show) - -mkChunkNr :: S3Resumable -> V3.Offset -> S3ChunkNr -mkChunkNr r o = S3ChunkNr ((offBytes `quot` chunkBytes) + 1) - where - offBytes = V3.offsetBytes o - chunkBytes = V3.chunkSizeBytes (resumableChunkSize r) - -mkOffset :: S3Resumable -> S3ChunkNr -> V3.Offset -mkOffset r n = V3.Offset ((fromIntegral n - 1) * chunkBytes) - where - chunkBytes = V3.chunkSizeBytes (resumableChunkSize r) - -resumableOffset :: S3Resumable -> V3.Offset -resumableOffset r = case Seq.viewr (resumableChunks r) of - Seq.EmptyR -> V3.Offset 0 - _ :> c -> chunkOffset c + V3.Offset (chunkSize c) - --- | Given a total size for an upload, calculates the desired --- size of individual chunks. Semantically, the calculation grows --- the number of chunks and the chunk size in an alternating fashion --- until the number of chunks multiplied by the chunk size is equal --- or greater than the given total size: --- --- [0. If the total size is less than 'minSmallSize', then 'minSmallSize' --- is the chunk size and we are done.] --- 1. Starting with a chunk size of 'minSmallSize', the number --- of chunks is increased up to 'maxSmallChunks'. --- 2. Staying at 'maxSmallChunks', the chunk size is increased --- up to 'maxSmallSize'. --- 3. Starting with a chunk size of 'minBigSize' and 1 chunk, the number --- of chunks is increased up to 'maxTotalChunks'. --- 4. Staying at 'maxTotalChunks', the chunk size is increased --- until the total size is accommodated. -calculateChunkSize :: V3.TotalSize -> V3.ChunkSize -calculateChunkSize (fromIntegral -> total) = - let smallChunks = max 1 (min maxSmallChunks (total `quot` minSmallSize)) - bigChunks = max 1 (min maxTotalChunks (total `quot` minBigSize)) - smallSize = total `quot` smallChunks - bigSize = total `quot` bigChunks - in V3.ChunkSize $ - if - | smallChunks < maxSmallChunks -> minSmallSize - | smallSize <= maxSmallSize -> smallSize - | bigChunks < maxTotalChunks -> minBigSize - | otherwise -> bigSize - --- | The maximum number of small chunks, sized ['minSmallChunk', 'maxSmallChunk'] --- that we are willing to assemble on our side, to compensate for the 5MiB lower --- bound on S3 multipart uploads. -maxSmallChunks :: Word -maxSmallChunks = 25 - --- | The maximum number of chunks we are willing to process in total for a --- single upload, regardless of where the final assembly is performed. -maxTotalChunks :: Word -maxTotalChunks = 1000 - --- | Lower bound (inclusive) for small chunks. -minSmallSize :: Word -minSmallSize = 100 * 1024 -- 100 KiB - --- | Upper bound (inclusive) for small chunks. -maxSmallSize :: Word -maxSmallSize = 1 * 1024 * 1024 -- 1 MiB - --- | Lower bound (inclusive) for large chunks, i.e. the lower bound for S3 --- multipart upload uploads. -minBigSize :: Word -minBigSize = 5 * 1024 * 1024 -- 5 MiB - -getResumable :: V3.AssetKey -> ExceptT Error App (Maybe S3Resumable) -getResumable k = do - Log.debug $ - "remote" .= val "S3" - ~~ "asset" .= toByteString k - ~~ "asset.key" .= toByteString rk - ~~ "asset.key.meta" .= toByteString mk - ~~ msg (val "Getting resumable asset metadata") - maybe (return Nothing) handle =<< execCatch req - where - rk = mkResumableKey k - mk = mkResumableKeyMeta k - req b = headObject (BucketName b) (ObjectKey $ s3ResumableKey mk) - handle r = do - let ct = fromMaybe octets (MIME.parseMIMEType =<< view horsContentType r) - let meta = HML.toList $ view horsMetadata r - case parse ct meta of - Nothing -> return Nothing - Just r' -> fmap (\cs -> r' {resumableChunks = cs}) <$> listChunks r' - parse ct h = - S3Resumable rk k - <$> getAmzMetaPrincipal h - <*> getAmzMetaChunkSize h - <*> getAmzMetaTotalSize h - <*> pure ct - <*> Just (getAmzMetaToken h) - <*> getAmzMetaUploadExpires h - <*> Just (getAmzMetaUploadId h) - <*> pure Seq.empty - -createResumable :: - V3.AssetKey -> - V3.Principal -> - MIME.Type -> - V3.TotalSize -> - Maybe V3.AssetToken -> - ExceptT Error App S3Resumable -createResumable k p _ size tok = do - let typ = octets -- see note: overrideMimeTypeAsOctetStream - let csize = calculateChunkSize size - ex <- addUTCTime V3.assetVolatileSeconds <$> liftIO getCurrentTime - let key = mkResumableKey k - mk = mkResumableKeyMeta k - let res = S3Resumable key k p csize size typ tok ex Nothing Seq.empty - up <- initMultipart res - let ct = resumableType res - void . exec $ first (s3ResumableKey mk) ct (resumableMeta csize ex up) - return res {resumableUploadId = up} - where - initMultipart r - | canUseMultipart r = do - let cmu b = - createMultipartUpload (BucketName b) (ObjectKey $ s3Key (mkKey k)) - & cmuContentType ?~ MIME.showType (resumableType r) - & cmuMetadata .~ metaHeaders (resumableToken r) p - imur <- exec cmu - return $! view cmursUploadId imur - | otherwise = return Nothing - first key ct meta b = - putObject (BucketName b) (ObjectKey key) (toBody (mempty :: ByteString)) - & poContentType ?~ MIME.showType ct - & poMetadata .~ HML.fromList meta - -- Determine whether a given 'S3Resumable' is eligible for the - -- S3 multipart upload API. That is the case if the chunk size - -- is >= 5 MiB or if there is only 1 chunk (<= 'minSmallSize'). - canUseMultipart r = chunkBytes >= minBigSize || totalBytes <= minSmallSize - where - chunkBytes = V3.chunkSizeBytes (resumableChunkSize r) - totalBytes = V3.totalSizeBytes (resumableTotalSize r) - resumableMeta csize expires upl = - setAmzMetaPrincipal p : - setAmzMetaTotalSize size : - setAmzMetaChunkSize csize : - setAmzMetaUploadExpires expires : - catMaybes - [ setAmzMetaToken <$> tok, - setAmzMetaUploadId <$> upl - ] - -uploadChunk :: - S3Resumable -> - V3.Offset -> - Conduit.SealedConduitT () ByteString IO () -> - ExceptT Error App (S3Resumable, Conduit.SealedConduitT () ByteString IO ()) -uploadChunk r offset rsrc = do - let chunkSize = fromIntegral (resumableChunkSize r) - (rest, chunk) <- liftIO $ rsrc $$++ Conduit.take chunkSize - let size = fromIntegral (LBS.length chunk) - Log.debug $ - "remote" .= val "S3" - ~~ "asset" .= toByteString (resumableAsset r) - ~~ "asset.owner" .= toByteString (resumableOwner r) - ~~ "asset.key" .= toByteString (resumableKey r) - ~~ "asset.chunk" .= toByteString nr - ~~ "asset.offset" .= toByteString offset - ~~ "asset.size" .= toByteString size - ~~ msg (val "Uploading chunk") - c <- case resumableUploadId r of - Nothing -> putChunk chunk size - Just up -> putPart up chunk size - let r' = r {resumableChunks = resumableChunks r Seq.|> c} - return (r', rest) - where - nr = mkChunkNr r offset - ct = MIME.showType octets -- see note overrideMimeTypeAsOctetStream - putChunk chunk size = do - let S3ChunkKey k = mkChunkKey (resumableKey r) nr - let req b = - putObject (BucketName b) (ObjectKey k) (toBody chunk) - & poContentType ?~ ct - void $ exec req - return $! S3Chunk nr offset size (S3ETag "") - putPart up chunk size = do - let S3AssetKey k = mkKey (resumableAsset r) - let req b = - uploadPart (BucketName b) (ObjectKey k) (fromIntegral nr) up (toBody chunk) - tg <- view uprsETag <$> exec req - etag <- case tg of - Just (ETag t) -> return $ S3ETag (Text.decodeLatin1 t) - Nothing -> throwE serverError - return $! S3Chunk nr offset size etag - --- | Complete a resumable upload, assembling all chunks into a final asset. -completeResumable :: S3Resumable -> ExceptT Error App () -completeResumable r = do - Log.debug $ - "remote" .= val "S3" - ~~ "asset" .= toByteString ast - ~~ "asset.owner" .= toByteString own - ~~ "asset.key" .= toByteString (resumableKey r) - ~~ msg (val "Completing resumable upload") - let chunks = resumableChunks r - verifyChunks chunks - case resumableUploadId r of - Nothing -> assembleLocal chunks - Just up -> assembleRemote up (NE.nonEmpty $ toList chunks) - Log.debug $ - "remote" .= val "S3" - ~~ "asset" .= toByteString ast - ~~ "asset.owner" .= toByteString own - ~~ "asset.key" .= toByteString (resumableKey r) - ~~ msg (val "Resumable upload completed") - where - (own, ast) = (resumableOwner r, resumableAsset r) - -- Local assembly for small chunk sizes (< 5 MiB): Download and re-upload - -- the chunks in a streaming fashion one-by-one to create the final object. - assembleLocal :: Seq S3Chunk -> ExceptT Error App () - assembleLocal chunks = do - e <- view aws - let totalSize = fromIntegral (resumableTotalSize r) - let chunkSize = calcChunkSize chunks - let reqBdy = Chunked $ ChunkedBody chunkSize totalSize (chunkSource e chunks) - let putRq b = - putObject (BucketName b) (ObjectKey (s3Key (mkKey ast))) reqBdy - & poContentType ?~ MIME.showType octets -- see note overrideMimeTypeAsOctetStream - & poMetadata .~ metaHeaders (resumableToken r) own - void $ exec putRq - - -- For symmetry with the behavior of the S3 multipart API, where the - -- resumable upload and all parts are removed upon completion, we do - -- the same here. - let rk = resumableKey r - let keys = - s3ResumableKey rk : - map (s3ChunkKey . mkChunkKey rk . chunkNr) (toList chunks) - let del = - delete' & dObjects .~ map (objectIdentifier . ObjectKey) keys - & dQuiet ?~ True - let delRq b = deleteObjects (BucketName b) del - void $ exec delRq - - -- All chunks except for the last should be of the same size so it makes - -- sense to use that as our default - calcChunkSize cs = case Seq.viewl cs of - EmptyL -> defaultChunkSize - c :< _ -> ChunkSize $ fromIntegral (chunkSize c) - -- Remote assembly for large(r) chunk sizes (>= 5 MiB) via the - -- S3 multipart upload API. - assembleRemote _ Nothing = throwE serverError - assembleRemote up (Just chunks) = do - let key = s3Key (mkKey ast) - let parts = fmap mkPart chunks - let completeRq b = - completeMultipartUpload (BucketName b) (ObjectKey key) up - & cMultipartUpload ?~ (completedMultipartUpload & cmuParts ?~ parts) - void $ exec completeRq - let S3ResumableKey rkey = resumableKey r - let delRq b = deleteObject (BucketName b) (ObjectKey rkey) - void $ exec delRq - mkPart c = completedPart (fromIntegral (chunkNr c)) (ETag . Text.encodeUtf8 $ s3ETag (chunkETag c)) - -- Verify that the chunks constitute the full asset, i.e. that the - -- upload is complete. - verifyChunks cs = do - let !total = V3.TotalSize $ foldl' (\t v -> t + chunkSize v) 0 cs - unless (total == resumableTotalSize r) $ - throwE $ - uploadIncomplete (resumableTotalSize r) total - -- Construct a 'Source' by downloading the chunks. - -- chunkSource :: AWS.Env - -- -> Seq S3Chunk - -- -> Source (ResourceT IO) ByteString - chunkSource env cs = case Seq.viewl cs of - EmptyL -> mempty - c :< cc -> do - let S3ChunkKey ck = mkChunkKey (resumableKey r) (chunkNr c) - let b = view AWS.s3Bucket env - let req = getObject (BucketName b) (ObjectKey ck) - v <- - lift $ - AWS.execute env $ - AWS.send req - >>= flip sinkBody Conduit.sinkLbs . view gorsBody - Conduit.yield (LBS.toStrict v) >> chunkSource env cc - -listChunks :: S3Resumable -> ExceptT Error App (Maybe (Seq S3Chunk)) -listChunks r = do - let ast = resumableAsset r - let S3ResumableKey key = resumableKey r - Log.debug $ - "remote" .= val "S3" - ~~ "asset" .= toByteString ast - ~~ "asset.resumable" .= key - ~~ msg (val "Listing chunks") - fmap Seq.fromList <$> case resumableUploadId r of - Nothing -> listBucket key - Just up -> listMultiParts up - where - listBucket k = do - let req b = - listObjects (BucketName b) - & loPrefix ?~ (k <> "/") - & loMaxKeys ?~ fromIntegral maxTotalChunks - maybe (return Nothing) parseObjects =<< execCatch req - parseObjects = - return . Just . mapMaybe chunkFromObject - . view lorsContents - listMultiParts up = do - let req b = - listParts - (BucketName b) - (ObjectKey $ s3Key (mkKey (resumableAsset r))) - up - maybe (return Nothing) parseParts =<< execCatch req - parseParts = - return . Just . mapMaybe chunkFromPart - . view lprsParts - chunkFromObject :: Object -> Maybe S3Chunk - chunkFromObject o = do - let (ObjectKey okey) = view oKey o - nr <- parseNr okey - let etag = - let (ETag t) = (view oETag o) - in S3ETag (Text.decodeLatin1 t) - let size = fromIntegral (view oSize o) - let off = mkOffset r nr - Just $! S3Chunk nr off size etag - chunkFromPart :: Part -> Maybe S3Chunk - chunkFromPart p = case (view pPartNumber p, view pETag p, view pSize p) of - (Just x, Just (ETag y), Just z) -> - let nr = S3ChunkNr (fromIntegral x) - off = mkOffset r nr - size = (fromIntegral z) - etag = S3ETag (Text.decodeLatin1 y) - in Just $! S3Chunk nr off size etag - _ -> Nothing - parseNr = fmap S3ChunkNr . readMay . Text.unpack . snd . Text.breakOnEnd "/" - -mkResumableKey :: V3.AssetKey -> S3ResumableKey -mkResumableKey (V3.AssetKeyV3 aid _) = - S3ResumableKey $ "v3/resumable/" <> UUID.toText (toUUID aid) - -mkResumableKeyMeta :: V3.AssetKey -> S3ResumableKey -mkResumableKeyMeta (V3.AssetKeyV3 aid _) = - S3ResumableKey $ "v3/resumable/" <> UUID.toText (toUUID aid) <> "/meta" - -mkChunkKey :: S3ResumableKey -> S3ChunkNr -> S3ChunkKey -mkChunkKey (S3ResumableKey k) (S3ChunkNr n) = - S3ChunkKey $ k <> "/" <> nr - where - -- Chunk numbers must be between 1 and 10000, as per the S3 - -- multipart upload API, hence the max. left padding of 5 digits. - nr = Text.justifyRight 5 '0' (Text.pack (show n)) - ------------------------------------------------------------------------------- -- S3 Metadata Headers @@ -651,21 +253,9 @@ hAmzMetaBot = "bot" hAmzMetaProvider :: Text hAmzMetaProvider = "provider" -hAmzMetaSize :: Text -hAmzMetaSize = "total-size" - hAmzMetaToken :: Text hAmzMetaToken = "token" -hAmzMetaChunkSize :: Text -hAmzMetaChunkSize = "chunk-size" - -hAmzMetaUploadExpires :: Text -hAmzMetaUploadExpires = "upload-expires" - -hAmzMetaUploadId :: Text -hAmzMetaUploadId = "upload-id" - ------------------------------------------------------------------------------- -- S3 Metadata Setters @@ -681,18 +271,6 @@ setAmzMetaProvider p = (hAmzMetaProvider, UUID.toText (toUUID p)) setAmzMetaToken :: V3.AssetToken -> (Text, Text) setAmzMetaToken t = (hAmzMetaToken, Ascii.toText (V3.assetTokenAscii t)) -setAmzMetaTotalSize :: V3.TotalSize -> (Text, Text) -setAmzMetaTotalSize s = (hAmzMetaSize, Text.decodeLatin1 (toByteString' s)) - -setAmzMetaChunkSize :: V3.ChunkSize -> (Text, Text) -setAmzMetaChunkSize s = (hAmzMetaChunkSize, Text.decodeLatin1 (toByteString' s)) - -setAmzMetaUploadExpires :: UTCTime -> (Text, Text) -setAmzMetaUploadExpires t = (hAmzMetaUploadExpires, Text.pack (show t)) - -setAmzMetaUploadId :: Text -> (Text, Text) -setAmzMetaUploadId i = (hAmzMetaUploadId, i) - setAmzMetaPrincipal :: V3.Principal -> (Text, Text) setAmzMetaPrincipal (V3.UserPrincipal u) = setAmzMetaUser u setAmzMetaPrincipal (V3.BotPrincipal b) = setAmzMetaBot b @@ -724,20 +302,6 @@ getAmzMetaToken h = V3.AssetToken . Ascii.unsafeFromText <$> lookupCI hAmzMetaToken h -getAmzMetaUploadExpires :: [(Text, Text)] -> Maybe UTCTime -getAmzMetaUploadExpires h = - readMay . C8.unpack . encodeUtf8 - =<< lookupCI hAmzMetaUploadExpires h - -getAmzMetaTotalSize :: [(Text, Text)] -> Maybe V3.TotalSize -getAmzMetaTotalSize = parseAmzMeta hAmzMetaSize - -getAmzMetaChunkSize :: [(Text, Text)] -> Maybe V3.ChunkSize -getAmzMetaChunkSize = parseAmzMeta hAmzMetaChunkSize - -getAmzMetaUploadId :: [(Text, Text)] -> Maybe Text -getAmzMetaUploadId = lookupCI hAmzMetaUploadId - parseAmzMeta :: FromByteString a => Text -> [(Text, Text)] -> Maybe a parseAmzMeta k h = lookupCI k h >>= fromByteString . encodeUtf8 diff --git a/services/cargohold/src/CargoHold/TUS.hs b/services/cargohold/src/CargoHold/TUS.hs deleted file mode 100644 index 542833ca0c7..00000000000 --- a/services/cargohold/src/CargoHold/TUS.hs +++ /dev/null @@ -1,89 +0,0 @@ --- 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 CargoHold.TUS - ( createdResponse, - headResponse, - patchResponse, - optionsResponse, - ) -where - -import CargoHold.Types.V3.Resumable (Offset, TotalSize) -import qualified Data.ByteString.Char8 as C8 -import Data.ByteString.Conversion -import Data.Time.Clock -import Data.Time.Format -import Data.Time.LocalTime -import Imports -import Network.HTTP.Types.Status -import Network.Wai -import Network.Wai.Utilities hiding (message) - -createdResponse :: ByteString -> UTCTime -> Response -> Response -createdResponse loc expiry = - setStatus status201 - . addHeader "Location" loc - . uploadExpires expiry - --- cf. http://tus.io/protocols/resumable-upload.html#head -headResponse :: (Offset, TotalSize) -> Response -> Response -headResponse (offset, total) = - setStatus status200 - . addHeader "Cache-Control" "no-store" - . hResumable - . hOffset offset - . hLength total - --- cf. http://tus.io/protocols/resumable-upload.html#patch -patchResponse :: Offset -> UTCTime -> Response -> Response -patchResponse offset expiry = - setStatus status204 - . hOffset offset - . hResumable - . uploadExpires expiry - --- cf. http://tus.io/protocols/resumable-upload.html#options -optionsResponse :: Word -> Response -> Response -optionsResponse maxSize = - setStatus status204 - . addHeader "Tus-Extension" "creation,expiration" - . addHeader "Tus-Max-Size" (toByteString' maxSize) - . hVersion - . hResumable - --- Internal -------------------------------------------------------------------- - --- cf. http://tus.io/protocols/resumable-upload.html#expiration -uploadExpires :: UTCTime -> Response -> Response -uploadExpires = addHeader "Upload-Expires" . C8.pack . time - where - -- Must be according to RFC 7231 - time = formatTime defaultTimeLocale "%a, %d %B %Y %H:%M:%S %Z" . utcToZonedTime gmt - gmt = TimeZone 0 False "GMT" - -hVersion :: Response -> Response -hVersion = addHeader "Tus-Version" "1.0.0" - -hResumable :: Response -> Response -hResumable = addHeader "Tus-Resumable" "1.0.0" - -hOffset :: Offset -> Response -> Response -hOffset = addHeader "Upload-Offset" . toByteString' - -hLength :: TotalSize -> Response -> Response -hLength = addHeader "Upload-Length" . toByteString' diff --git a/services/cargohold/test/integration/API.hs b/services/cargohold/test/integration/API.hs new file mode 100644 index 00000000000..2442e4fa047 --- /dev/null +++ b/services/cargohold/test/integration/API.hs @@ -0,0 +1,351 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- 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 API (tests) where + +import API.Util +import Bilge hiding (body) +import Bilge.Assert +import CargoHold.API.Error +import CargoHold.Types +import qualified CargoHold.Types.V3 as V3 +import qualified Codec.MIME.Type as MIME +import Control.Exception (throw) +import Control.Lens hiding (sets) +import qualified Data.Aeson as Aeson +import Data.ByteString.Builder +import qualified Data.ByteString.Char8 as C8 +import Data.ByteString.Conversion +import Data.Domain +import Data.Id +import Data.Qualified +import qualified Data.Text.Encoding.Error as Text +import qualified Data.Text.Lazy.Encoding as LText +import Data.Time.Clock +import Data.Time.Format +import Data.UUID.V4 +import Federator.MockServer +import Imports hiding (head) +import Network.HTTP.Client (parseUrlThrow) +import Network.HTTP.Media ((//)) +import qualified Network.HTTP.Types as HTTP +import Network.Wai.Utilities (Error (label)) +import qualified Network.Wai.Utilities.Error as Wai +import Test.Tasty +import Test.Tasty.HUnit +import TestSetup +import Wire.API.Federation.API.Cargohold +import Wire.API.Federation.Component + +tests :: IO TestSetup -> TestTree +tests s = + testGroup + "API Integration" + [ testGroup + "simple" + [ test s "roundtrip" testSimpleRoundtrip, + test s "tokens" testSimpleTokens, + test s "s3-upstream-closed" testSimpleS3ClosedConnectionReuse, + test s "client-compatibility" testUploadCompatibility + ], + testGroup + "remote" + [ test s "remote download wrong domain" testRemoteDownloadWrongDomain, + test s "remote download no asset" testRemoteDownloadNoAsset, + test s "federator failure on remote download" testRemoteDownloadFederationFailure, + test s "remote download" (testRemoteDownload "asset content"), + test s "large remote download" $ + testRemoteDownload + ( toLazyByteString + (mconcat (replicate 20000 (byteString "hello world\n"))) + ) + ] + ] + +-------------------------------------------------------------------------------- +-- Simple (single-step) uploads + +testSimpleRoundtrip :: TestM () +testSimpleRoundtrip = do + let def = V3.defAssetSettings + let rets = [minBound ..] + let sets = def : map (\r -> def & V3.setAssetRetention ?~ r) rets + mapM_ simpleRoundtrip sets + where + simpleRoundtrip sets = do + uid <- liftIO $ Id <$> nextRandom + uid2 <- liftIO $ Id <$> nextRandom + -- Initial upload + let bdy = (applicationText, "Hello World") + r1 <- + uploadSimple (path "/assets/v3") uid sets bdy + lookup "Date" (responseHeaders r1) + let utc = parseTimeOrError False defaultTimeLocale rfc822DateFormat date :: UTCTime + -- Potentially check for the expires header + when (isJust $ join (V3.assetRetentionSeconds <$> (sets ^. V3.setAssetRetention))) $ do + liftIO $ assertBool "invalid expiration" (Just utc < view V3.assetExpires ast) + -- Lookup with token and download via redirect. + r2 <- + downloadAsset uid loc (Just tok) lookup "Date" (responseHeaders r4) + let utc' = parseTimeOrError False defaultTimeLocale rfc822DateFormat date' :: UTCTime + liftIO $ assertBool "bad date" (utc' >= utc) + +testSimpleTokens :: TestM () +testSimpleTokens = do + uid <- liftIO $ Id <$> nextRandom + uid2 <- liftIO $ Id <$> nextRandom + -- Initial upload + let sets = V3.defAssetSettings & set V3.setAssetRetention (Just V3.AssetVolatile) + let bdy = (applicationText, "Hello World") + r1 <- + uploadSimple (path "/assets/v3") uid sets bdy + responseJsonMaybe r2 + liftIO $ assertBool "token unchanged" (tok /= tok') + -- Download by owner with new token. + r3 <- + downloadAsset uid loc (Just tok') > wait >> go + where + wait = liftIO $ putStrLn "Waiting for S3 idle timeout ..." >> threadDelay 7000000 + go = do + uid <- liftIO $ Id <$> nextRandom + let sets = V3.defAssetSettings & set V3.setAssetRetention (Just V3.AssetVolatile) + let part2 = (MIME.Type (MIME.Text "plain") [], C8.replicate 100000 'c') + uploadSimple (path "/assets/v3") uid sets part2 + !!! const 201 === statusCode + +-------------------------------------------------------------------------------- +-- Client compatibility tests + +-- Since the other tests use functions from the server code, it can happen that +-- an API change also changes the requests made here in the tests. +-- This test tries to prevent us from breaking the API without noticing. +-- +-- The body is taken directly from a request made by the web app +-- (just replaced the content with a shorter one and updated the MD5 header). +testUploadCompatibility :: TestM () +testUploadCompatibility = do + uid <- liftIO $ Id <$> nextRandom + -- Initial upload + r1 <- + uploadRaw (path "/assets/v3") uid exampleMultipart + nextRandom + uid <- liftIO $ Id <$> nextRandom + + let key = AssetKeyV3 assetId AssetPersistent + qkey = Qualified key (Domain "invalid.example.com") + downloadAsset uid qkey () !!! do + const 422 === statusCode + +testRemoteDownloadNoAsset :: TestM () +testRemoteDownloadNoAsset = do + assetId <- liftIO $ Id <$> nextRandom + uid <- liftIO $ Id <$> nextRandom + let key = AssetKeyV3 assetId AssetPersistent + qkey = Qualified key (Domain "faraway.example.com") + respond req + | frRPC req == "get-asset" = + pure ("application" // "json", Aeson.encode (GetAssetResponse False)) + | otherwise = + throw + . MockErrorResponse HTTP.status404 + . LText.decodeUtf8With Text.lenientDecode + . Aeson.encode + $ assetNotFound + (_, reqs) <- withMockFederator respond $ do + downloadAsset uid qkey () !!! do + const 404 === statusCode + localDomain <- viewFederationDomain + liftIO $ + reqs + @?= [ FederatedRequest + { frOriginDomain = localDomain, + frTargetDomain = Domain "faraway.example.com", + frComponent = Cargohold, + frRPC = "get-asset", + frBody = Aeson.encode (GetAsset uid key Nothing) + } + ] + +testRemoteDownloadFederationFailure :: TestM () +testRemoteDownloadFederationFailure = do + assetId <- liftIO $ Id <$> nextRandom + uid <- liftIO $ Id <$> nextRandom + let key = AssetKeyV3 assetId AssetPersistent + qkey = Qualified key (Domain "faraway.example.com") + respond req + | frRPC req == "get-asset" = + pure ("application" // "json", Aeson.encode (GetAssetResponse True)) + | otherwise = throw (MockErrorResponse HTTP.status500 "mock error") + (resp, _) <- + withMockFederator respond $ do + responseJsonError =<< downloadAsset uid qkey () TestM () +testRemoteDownload assetContent = do + assetId <- liftIO $ Id <$> nextRandom + uid <- liftIO $ Id <$> nextRandom + + let key = AssetKeyV3 assetId AssetPersistent + qkey = Qualified key (Domain "faraway.example.com") + respond req + | frRPC req == "get-asset" = + pure ("application" // "json", Aeson.encode (GetAssetResponse True)) + | otherwise = pure ("application" // "octet-stream", assetContent) + (_, reqs) <- withMockFederator respond $ do + downloadAsset uid qkey () !!! do + const 200 === statusCode + const (Just assetContent) === responseBody + + localDomain <- viewFederationDomain + let ga = Aeson.encode (GetAsset uid key Nothing) + liftIO $ + reqs + @?= [ FederatedRequest + { frOriginDomain = localDomain, + frTargetDomain = Domain "faraway.example.com", + frComponent = Cargohold, + frRPC = "get-asset", + frBody = ga + }, + FederatedRequest + { frOriginDomain = localDomain, + frTargetDomain = Domain "faraway.example.com", + frComponent = Cargohold, + frRPC = "stream-asset", + frBody = ga + } + ] diff --git a/services/cargohold/test/integration/API/Federation.hs b/services/cargohold/test/integration/API/Federation.hs new file mode 100644 index 00000000000..bb22a7d5822 --- /dev/null +++ b/services/cargohold/test/integration/API/Federation.hs @@ -0,0 +1,226 @@ +module API.Federation (tests) where + +import API.Util +import Bilge +import Bilge.Assert +import CargoHold.API.V3 (randToken) +import Conduit +import Control.Lens +import Crypto.Random +import Data.Id +import Data.Qualified +import Data.UUID.V4 +import Imports +import qualified Network.HTTP.Types as HTTP +import qualified Network.Wai.Utilities.Error as Wai +import Test.Tasty +import Test.Tasty.HUnit +import TestSetup +import Wire.API.Asset +import Wire.API.Federation.API +import Wire.API.Federation.API.Cargohold +import Wire.API.Routes.AssetBody + +tests :: IO TestSetup -> TestTree +tests s = + testGroup + "API Federation" + [ testGroup + "get-asset" + [ test s "private asset is available" (testGetAssetAvailable False), + test s "public asset is available" (testGetAssetAvailable True), + test s "not available" testGetAssetNotAvailable, + test s "wrong token" testGetAssetWrongToken + ], + testGroup + "stream-asset" + [ test s "streaming large asset" testLargeAsset, + test s "stream an asset" testStreamAsset, + test s "stream asset not available" testStreamAssetNotAvailable, + test s "stream asset wrong token" testStreamAssetWrongToken + ] + ] + +testGetAssetAvailable :: Bool -> TestM () +testGetAssetAvailable isPublicAsset = do + -- Initial upload + let bdy = (applicationOctetStream, "Hello World") + settings = + defAssetSettings + & set setAssetRetention (Just AssetVolatile) + & set setAssetPublic isPublicAsset + uid <- liftIO $ Id <$> nextRandom + ast :: Asset <- + responseJsonError + =<< uploadSimple (path "/assets/v3") uid settings bdy + runFederationClient (fedClientIn @'Cargohold @"get-asset" ga) + + -- check that asset is available + liftIO $ ok @?= True + +testGetAssetNotAvailable :: TestM () +testGetAssetNotAvailable = do + uid <- liftIO $ Id <$> nextRandom + token <- randToken + + assetId <- liftIO $ Id <$> nextRandom + let key = AssetKeyV3 assetId AssetPersistent + let ga = + GetAsset + { gaUser = uid, + gaToken = Just token, + gaKey = key + } + ok <- + withFederationClient $ + gaAvailable <$> runFederationClient (fedClientIn @'Cargohold @"get-asset" ga) + + -- check that asset is not available + liftIO $ ok @?= False + +testGetAssetWrongToken :: TestM () +testGetAssetWrongToken = do + -- Initial upload + let bdy = (applicationOctetStream, "Hello World") + settings = defAssetSettings & set setAssetRetention (Just AssetVolatile) + uid <- liftIO $ Id <$> nextRandom + ast :: Asset <- + responseJsonError + =<< uploadSimple (path "/assets/v3") uid settings bdy + runFederationClient (fedClientIn @'Cargohold @"get-asset" ga) + + -- check that asset is not available + liftIO $ ok @?= False + +testLargeAsset :: TestM () +testLargeAsset = do + -- Initial upload + let settings = + defAssetSettings + & set setAssetRetention (Just AssetVolatile) + uid <- liftIO $ Id <$> nextRandom + -- generate random bytes + let size = 1024 * 1024 + bs <- liftIO $ getRandomBytes size + + ast :: Asset <- + responseJsonError + =<< uploadSimple (path "/assets/v3") uid settings (applicationOctetStream, bs) + runFederationClient (fedClientIn @'Cargohold @"stream-asset" ga) + liftIO . runResourceT $ connect source sinkList + liftIO $ do + let minNumChunks = 8 + assertBool + ("Expected at least " <> show minNumChunks <> " chunks, got " <> show (length chunks)) + (length chunks > minNumChunks) + mconcat chunks @?= bs + +testStreamAsset :: TestM () +testStreamAsset = do + -- Initial upload + let bdy = (applicationOctetStream, "Hello World") + settings = + defAssetSettings + & set setAssetRetention (Just AssetVolatile) + uid <- liftIO $ Id <$> nextRandom + ast :: Asset <- + responseJsonError + =<< uploadSimple (path "/assets/v3") uid settings bdy + runFederationClient (fedClientIn @'Cargohold @"stream-asset" ga) + liftIO . runResourceT $ connect source sinkLazy + liftIO $ respBody @?= "Hello World" + +testStreamAssetNotAvailable :: TestM () +testStreamAssetNotAvailable = do + uid <- liftIO $ Id <$> nextRandom + token <- randToken + + assetId <- liftIO $ Id <$> nextRandom + let key = AssetKeyV3 assetId AssetPersistent + let ga = + GetAsset + { gaUser = uid, + gaToken = Just token, + gaKey = key + } + err <- withFederationError $ do + runFederationClient (fedClientIn @'Cargohold @"stream-asset" ga) + liftIO $ do + Wai.code err @?= HTTP.notFound404 + Wai.label err @?= "not-found" + +testStreamAssetWrongToken :: TestM () +testStreamAssetWrongToken = do + -- Initial upload + let bdy = (applicationOctetStream, "Hello World") + settings = defAssetSettings & set setAssetRetention (Just AssetVolatile) + uid <- liftIO $ Id <$> nextRandom + ast :: Asset <- + responseJsonError + =<< uploadSimple (path "/assets/v3") uid settings bdy + +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module API.Util where + +import Bilge hiding (body) +import CargoHold.Options +import CargoHold.Run +import qualified Codec.MIME.Parse as MIME +import qualified Codec.MIME.Type as MIME +import Control.Lens +import Control.Monad.Catch +import Control.Monad.Codensity +import Data.ByteString.Builder +import Data.ByteString.Conversion +import qualified Data.ByteString.Lazy as Lazy +import Data.Domain +import Data.Id +import Data.Qualified +import Data.Text.Encoding (decodeLatin1) +import qualified Data.UUID as UUID +import Federator.MockServer +import Imports hiding (head) +import qualified Network.HTTP.Media as HTTP +import Network.HTTP.Types.Header +import Network.HTTP.Types.Method +import qualified Network.Wai as Wai +import TestSetup +import Util.Options +import Wire.API.Asset + +uploadSimple :: + (Request -> Request) -> + UserId -> + AssetSettings -> + (MIME.Type, ByteString) -> + TestM (Response (Maybe Lazy.ByteString)) +uploadSimple c usr sts (ct, bs) = + let mp = buildMultipartBody sts ct (Lazy.fromStrict bs) + in uploadRaw c usr (toLazyByteString mp) + +decodeHeaderOrFail :: (HasCallStack, FromByteString a) => HeaderName -> Response b -> a +decodeHeaderOrFail h = + fromMaybe (error $ "decodeHeaderOrFail: missing or invalid header: " ++ show h) + . fromByteString + . getHeader' h + +uploadRaw :: + (Request -> Request) -> + UserId -> + Lazy.ByteString -> + TestM (Response (Maybe Lazy.ByteString)) +uploadRaw c usr bs = do + cargohold <- viewCargohold + post $ + c . cargohold + . method POST + . zUser usr + . zConn "conn" + . content "multipart/mixed" + . lbytes bs + +getContentType :: Response a -> Maybe MIME.Type +getContentType = MIME.parseContentType . decodeLatin1 . getHeader' "Content-Type" + +applicationText :: MIME.Type +applicationText = MIME.Type (MIME.Application "text") [] + +applicationOctetStream :: MIME.Type +applicationOctetStream = MIME.Type (MIME.Application "octet-stream") [] + +zUser :: UserId -> Request -> Request +zUser = header "Z-User" . UUID.toASCIIBytes . toUUID + +zConn :: ByteString -> Request -> Request +zConn = header "Z-Connection" + +deleteAssetV3 :: UserId -> Qualified AssetKey -> TestM (Response (Maybe Lazy.ByteString)) +deleteAssetV3 u k = do + c <- viewCargohold + delete $ c . zUser u . paths ["assets", "v3", toByteString' (qUnqualified k)] + +deleteAsset :: UserId -> Qualified AssetKey -> TestM (Response (Maybe Lazy.ByteString)) +deleteAsset u k = do + c <- viewCargohold + delete $ + c . zUser u + . paths + [ "assets", + "v4", + toByteString' (qDomain k), + toByteString' (qUnqualified k) + ] + +class IsAssetLocation key where + locationPath :: key -> Request -> Request + +instance IsAssetLocation AssetKey where + locationPath k = paths ["assets", "v3", toByteString' k] + +instance IsAssetLocation (Qualified AssetKey) where + locationPath k = paths ["assets", "v4", toByteString' (qDomain k), toByteString' (qUnqualified k)] + +instance IsAssetLocation ByteString where + locationPath = path + +class IsAssetToken tok where + tokenParam :: tok -> Request -> Request + +instance IsAssetToken () where + tokenParam _ = id + +instance IsAssetToken (Maybe AssetToken) where + tokenParam = maybe id (header "Asset-Token" . toByteString') + +instance IsAssetToken (Request -> Request) where + tokenParam = id + +downloadAsset :: + (IsAssetLocation loc, IsAssetToken tok) => + UserId -> + loc -> + tok -> + TestM (Response (Maybe LByteString)) +downloadAsset uid loc tok = do + c <- viewCargohold + get $ + c . zUser uid + . locationPath loc + . tokenParam tok + . noRedirect + +postToken :: UserId -> AssetKey -> TestM (Response (Maybe LByteString)) +postToken uid key = do + c <- viewCargohold + post $ + c . zUser uid + . paths ["assets", "v3", toByteString' key, "token"] + +deleteToken :: UserId -> AssetKey -> TestM (Response (Maybe LByteString)) +deleteToken uid key = do + c <- viewCargohold + delete $ + c . zUser uid + . paths ["assets", "v3", toByteString' key, "token"] + +viewFederationDomain :: TestM Domain +viewFederationDomain = view (tsOpts . optSettings . setFederationDomain) + +-------------------------------------------------------------------------------- +-- Mocking utilities + +withMockServer :: Wai.Application -> Codensity IO Word16 +withMockServer app = Codensity $ \k -> + bracket + (liftIO $ startMockServer Nothing app) + (liftIO . fst) + (k . fromIntegral . snd) + +withSettingsOverrides :: (Opts -> Opts) -> TestM a -> TestM a +withSettingsOverrides f action = do + ts <- ask + let opts = f (view tsOpts ts) + liftIO . lowerCodensity $ do + (app, _) <- mkApp opts + p <- withMockServer app + liftIO $ runTestM (ts & tsEndpoint %~ setLocalEndpoint p) action + +setLocalEndpoint :: Word16 -> Endpoint -> Endpoint +setLocalEndpoint p = (epPort .~ p) . (epHost .~ "127.0.0.1") + +withMockFederator :: + (FederatedRequest -> IO (HTTP.MediaType, LByteString)) -> + TestM a -> + TestM (a, [FederatedRequest]) +withMockFederator respond action = do + withTempMockFederator [] respond $ \p -> + withSettingsOverrides + (optFederator . _Just %~ setLocalEndpoint (fromIntegral p)) + action diff --git a/services/cargohold/test/integration/API/V3.hs b/services/cargohold/test/integration/API/V3.hs index bde128d4f42..d04b9d18ef8 100644 --- a/services/cargohold/test/integration/API/V3.hs +++ b/services/cargohold/test/integration/API/V3.hs @@ -17,35 +17,25 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module API.V3 where +module API.V3 (tests) where +import API.Util import Bilge hiding (body) import Bilge.Assert -import qualified CargoHold.Types.V3 as V3 -import qualified CargoHold.Types.V3.Resumable as V3 -import qualified Codec.MIME.Parse as MIME -import qualified Codec.MIME.Type as MIME import Control.Lens hiding (sets) -import Data.Aeson hiding (json) -import Data.ByteString.Builder import qualified Data.ByteString.Char8 as C8 -import Data.ByteString.Conversion -import qualified Data.ByteString.Lazy as Lazy import Data.Id -import Data.Text.Encoding (decodeLatin1) +import Data.Qualified import Data.Time.Clock import Data.Time.Format -import qualified Data.UUID as UUID import Data.UUID.V4 import Imports hiding (head) import Network.HTTP.Client (parseUrlThrow) -import Network.HTTP.Types.Header -import Network.HTTP.Types.Method -import Network.HTTP.Types.Status (status200, status204) -import Network.Wai.Utilities (Error (label)) +import Network.HTTP.Types.Status (status200) import Test.Tasty import Test.Tasty.HUnit import TestSetup +import Wire.API.Asset tests :: IO TestSetup -> TestTree tests s = @@ -53,32 +43,17 @@ tests s = "API Integration v3" [ testGroup "simple" - [ test s "roundtrip" testSimpleRoundtrip, - test s "tokens" testSimpleTokens, - test s "s3-upstream-closed" testSimpleS3ClosedConnectionReuse, - test s "client-compatibility" testUploadCompatibility - ], - testGroup - "RealAWS" - [ testGroup - "resumable" - [ test s "small" testResumableSmall, - test s "large" testResumableBig, - test s "last-small" testResumableLastSmall, - test s "stepwise-small" testResumableStepSmall, - test s "stepwise-big" testResumableStepBig - ] - ] + [test s "roundtrip using v3 API" testSimpleRoundtrip] ] -------------------------------------------------------------------------------- -- Simple (single-step) uploads -testSimpleRoundtrip :: TestSignature () -testSimpleRoundtrip c = do - let def = V3.defAssetSettings +testSimpleRoundtrip :: TestM () +testSimpleRoundtrip = do + let def = defAssetSettings let rets = [minBound ..] - let sets = def : map (\r -> def & V3.setAssetRetention ?~ r) rets + let sets = def : map (\r -> def & setAssetRetention ?~ r) rets mapM_ simpleRoundtrip sets where simpleRoundtrip sets = do @@ -87,362 +62,37 @@ testSimpleRoundtrip c = do -- Initial upload let bdy = (applicationText, "Hello World") r1 <- - uploadSimple (c . path "/assets/v3") uid sets bdy + uploadSimple (path "/assets/v3") uid sets bdy lookup "Date" (responseHeaders r1) let utc = parseTimeOrError False defaultTimeLocale rfc822DateFormat date :: UTCTime -- Potentially check for the expires header - when (isJust $ join (V3.assetRetentionSeconds <$> (sets ^. V3.setAssetRetention))) $ do - liftIO $ assertBool "invalid expiration" (Just utc < view V3.assetExpires ast) + when (isJust $ join (assetRetentionSeconds <$> (sets ^. setAssetRetention))) $ do + liftIO $ assertBool "invalid expiration" (Just utc < view assetExpires ast) -- Lookup with token and download via redirect. r2 <- - get (c . path loc . zUser uid . header "Asset-Token" (toByteString' tok) . noRedirect) lookup "Date" (responseHeaders r4) let utc' = parseTimeOrError False defaultTimeLocale rfc822DateFormat date' :: UTCTime liftIO $ assertBool "bad date" (utc' >= utc) - -testSimpleTokens :: TestSignature () -testSimpleTokens c = do - uid <- liftIO $ Id <$> nextRandom - uid2 <- liftIO $ Id <$> nextRandom - -- Initial upload - let sets = V3.defAssetSettings & set V3.setAssetRetention (Just V3.AssetVolatile) - let bdy = (applicationText, "Hello World") - r1 <- - uploadSimple (c . path "/assets/v3") uid sets bdy - responseJsonMaybe r2 - liftIO $ assertBool "token unchanged" (tok /= tok') - -- Download by owner with new token. - r3 <- - get (c . path loc . zUser uid . header "Asset-Token" (toByteString' tok') . noRedirect) > wait >> go - where - wait = liftIO $ putStrLn "Waiting for S3 idle timeout ..." >> threadDelay 7000000 - go = do - uid <- liftIO $ Id <$> nextRandom - let sets = V3.defAssetSettings & set V3.setAssetRetention (Just V3.AssetVolatile) - let part2 = (MIME.Type (MIME.Text "plain") [], C8.replicate 100000 'c') - uploadSimple (c . path "/assets/v3") uid sets part2 - !!! const 201 === statusCode - --------------------------------------------------------------------------------- --- Client compatibility tests - --- Since the other tests use functions from the server code, it can happen that --- an API change also changes the requests made here in the tests. --- This test tries to prevent us from breaking the API without noticing. --- --- The body is taken directly from a request made by the web app --- (just replaced the content with a shorter one and updated the MD5 header). -testUploadCompatibility :: TestSignature () -testUploadCompatibility c = do - uid <- liftIO $ Id <$> nextRandom - -- Initial upload - r1 <- - uploadRaw (c . path "/assets/v3") uid exampleMultipart - CargoHold -> V3.TotalSize -> V3.ChunkSize -> UploadType -> Http () -assertRandomResumable c totalSize chunkSize typ = do - (uid, dat, ast) <- randomResumable c totalSize - let key = ast ^. V3.resumableAsset . V3.assetKey - liftIO $ assertEqual "chunksize" chunkSize (ast ^. V3.resumableChunkSize) - case typ of - UploadStepwise -> uploadStepwise c uid key chunkSize dat - UploadFull -> void $ uploadResumable c uid key 0 dat - r <- downloadAsset c uid key Nothing - liftIO $ do - assertEqual "status" status200 (responseStatus r) - assertEqual "content-type should always be application/octet-stream" (Just applicationOctetStream) (getContentType r) - assertEqual "user mismatch" uid (decodeHeader "x-amz-meta-user" r) - assertEqual "data mismatch" (Just $ Lazy.fromStrict dat) (responseBody r) - -randomResumable :: CargoHold -> V3.TotalSize -> Http (UserId, ByteString, V3.ResumableAsset) -randomResumable c size = do - uid <- liftIO $ Id <$> nextRandom - let sets = V3.mkResumableSettings V3.AssetPersistent True textPlain - let dat = C8.replicate (fromIntegral size) 'a' - ast <- createResumable c uid sets size - return (uid, dat, ast) - --- API Calls ------------------------------------------------------------------ - -uploadSimple :: - CargoHold -> - UserId -> - V3.AssetSettings -> - (MIME.Type, ByteString) -> - Http (Response (Maybe Lazy.ByteString)) -uploadSimple c usr sets (ct, bs) = - let mp = V3.buildMultipartBody sets ct (Lazy.fromStrict bs) - in uploadRaw c usr (toLazyByteString mp) - -uploadRaw :: - CargoHold -> - UserId -> - Lazy.ByteString -> - Http (Response (Maybe Lazy.ByteString)) -uploadRaw c usr bs = - post $ - c - . method POST - . zUser usr - . zConn "conn" - . content "multipart/mixed" - . lbytes bs - -createResumable :: - HasCallStack => - CargoHold -> - UserId -> - V3.ResumableSettings -> - V3.TotalSize -> - Http V3.ResumableAsset -createResumable c u sets size = do - rsp <- - post - ( c - . path "/assets/v3/resumable" - . zUser u - . header "Content-Type" "application/json" - . header "Upload-Length" (toByteString' size) - . lbytes (encode sets) - ) - toByteString' (ast ^. V3.resumableAsset . V3.assetKey) - liftIO $ assertEqual "Location" loc' loc - return ast - -getResumableStatus :: HasCallStack => CargoHold -> UserId -> V3.AssetKey -> Http V3.Offset -getResumableStatus c u k = do - r <- - head - ( c - . paths ["assets", "v3", "resumable", toByteString' k] - . zUser u - ) - UserId -> V3.AssetKey -> V3.Offset -> ByteString -> Http V3.Offset -uploadResumable c u k off bs = do - r <- - patch - ( c - . paths ["assets", "v3", "resumable", toByteString' k] - . header "Upload-Offset" (toByteString' off) - . header "Content-Type" applicationOffset - . zUser u - . bytes bs - ) - liftIO $ assertEqual "status" status204 (responseStatus r) - return $ getOffset r - -uploadStepwise :: CargoHold -> UserId -> V3.AssetKey -> V3.ChunkSize -> ByteString -> Http () -uploadStepwise c u k s d = next 0 d - where - totalSize = fromIntegral (C8.length d) - chunkSize = fromIntegral s - next pos dat = do - off <- uploadResumable c u k pos (C8.take chunkSize dat) - unless (V3.offsetBytes off == totalSize) $ do - off' <- getResumableStatus c u k - liftIO $ assertEqual "offset" off off' - next off (C8.drop (fromIntegral (off - pos)) dat) - -getAsset :: CargoHold -> UserId -> V3.AssetKey -> Maybe V3.AssetToken -> Http (Response (Maybe Lazy.ByteString)) -getAsset c u k t = - get $ - c - . paths ["assets", "v3", toByteString' k] - . zUser u - . maybe id (header "Asset-Token" . toByteString') t - . noRedirect - -downloadAsset :: HasCallStack => CargoHold -> UserId -> V3.AssetKey -> Maybe V3.AssetToken -> Http (Response (Maybe Lazy.ByteString)) -downloadAsset c u k t = do - r <- - getAsset c u k t UserId -> V3.AssetKey -> Http (Response (Maybe Lazy.ByteString)) -deleteAsset c u k = delete $ c . zUser u . paths ["assets", "v3", toByteString' k] - --- Utilities ------------------------------------------------------------------ - -type ContentType = ByteString - -decodeHeader :: FromByteString a => HeaderName -> Response b -> a -decodeHeader h = - fromMaybe (error $ "decodeHeader: missing or invalid header: " ++ show h) - . fromByteString - . getHeader' h - -getOffset :: Response b -> V3.Offset -getOffset = decodeHeader "Upload-Offset" - -getContentType :: Response a -> Maybe MIME.Type -getContentType = MIME.parseContentType . decodeLatin1 . getHeader' "Content-Type" - -applicationText :: MIME.Type -applicationText = MIME.Type (MIME.Application "text") [] - -applicationOctetStream :: MIME.Type -applicationOctetStream = MIME.Type (MIME.Application "octet-stream") [] - -textPlain :: MIME.Type -textPlain = MIME.Type (MIME.Text "plain") [] - -applicationOffset :: ContentType -applicationOffset = "application/offset+octet-stream" - -zUser :: UserId -> Request -> Request -zUser = header "Z-User" . UUID.toASCIIBytes . toUUID - -zConn :: ByteString -> Request -> Request -zConn = header "Z-Connection" diff --git a/services/cargohold/test/integration/Main.hs b/services/cargohold/test/integration/Main.hs index ea5156ec567..5c288ecf922 100644 --- a/services/cargohold/test/integration/Main.hs +++ b/services/cargohold/test/integration/Main.hs @@ -20,37 +20,19 @@ module Main ) where +import qualified API +import API.Federation (tests) import qualified API.V3 -import Bilge hiding (body, header) -import qualified CargoHold.API (sitemap) -import Data.Metrics.Test (pathsConsistencyCheck) -import Data.Metrics.WaiRoute (treeToPaths) import Data.Proxy import Data.Tagged -import Data.Text.Encoding (encodeUtf8) -import Data.Yaml hiding (Parser) import Imports hiding (local) import qualified Metrics -import Network.HTTP.Client (responseTimeoutMicro) -import Network.HTTP.Client.TLS -import Network.Wai.Utilities.Server (compile) import Options.Applicative import Test.Tasty -import Test.Tasty.HUnit import Test.Tasty.Options import TestSetup -import Util.Options -import Util.Options.Common import Util.Test -data IntegrationConfig = IntegrationConfig - -- internal endpoint - { cargohold :: Endpoint - } - deriving (Show, Generic) - -instance FromJSON IntegrationConfig - newtype ServiceConfigFile = ServiceConfigFile String deriving (Eq, Ord, Typeable) @@ -67,11 +49,24 @@ instance IsOption ServiceConfigFile where <> help (untag (optionHelp :: Tagged ServiceConfigFile String)) ) -runTests :: (String -> String -> TestTree) -> IO () -runTests run = defaultMainWithIngredients ings $ - askOption $ - \(ServiceConfigFile c) -> - askOption $ \(IntegrationConfigFile i) -> run c i +main :: IO () +main = do + defaultMainWithIngredients ings $ + askOption $ \(IntegrationConfigFile configPath) -> + askOption $ \(ServiceConfigFile optsPath) -> + -- we treat the configuration file as a tasty "resource", so that we can + -- read it once before all tests + withResource + (createTestSetup optsPath configPath) + (const (pure ())) + $ \ts -> + testGroup + "Cargohold" + [ API.tests ts, + API.V3.tests ts, + Metrics.tests ts, + API.Federation.tests ts + ] where ings = includingOptions @@ -79,34 +74,3 @@ runTests run = defaultMainWithIngredients ings $ Option (Proxy :: Proxy IntegrationConfigFile) ] : defaultIngredients - -main :: IO () -main = runTests go - where - go c i = withResource (getOpts c i) releaseOpts $ \opts -> - testGroup - "Cargohold" - [ testCase "sitemap" $ - assertEqual - "inconcistent sitemap" - mempty - (pathsConsistencyCheck . treeToPaths . compile $ CargoHold.API.sitemap), - API.V3.tests opts, - Metrics.tests opts - ] - getOpts _ i = do - -- TODO: It would actually be useful to read some - -- values from cargohold (max bytes, for instance) - -- so that tests do not need to keep those values - -- in sync and the user _knows_ what they are - m <- - newManager - tlsManagerSettings - { managerResponseTimeout = responseTimeoutMicro 300000000 - } - let local p = Endpoint {_epHost = "127.0.0.1", _epPort = p} - iConf <- handleParseError =<< decodeFileEither i - cargo <- mkRequest <$> optOrEnv cargohold iConf (local . read) "CARGOHOLD_WEB_PORT" - return $ TestSetup m cargo - mkRequest (Endpoint h p) = host (encodeUtf8 h) . port p - releaseOpts _ = return () diff --git a/services/cargohold/test/integration/Metrics.hs b/services/cargohold/test/integration/Metrics.hs index 590fb28c302..d16e4dbc727 100644 --- a/services/cargohold/test/integration/Metrics.hs +++ b/services/cargohold/test/integration/Metrics.hs @@ -29,8 +29,9 @@ import TestSetup tests :: IO TestSetup -> TestTree tests s = testGroup "Metrics" [test s "prometheus" testPrometheusMetrics] -testPrometheusMetrics :: TestSignature () -testPrometheusMetrics cargohold = +testPrometheusMetrics :: TestM () +testPrometheusMetrics = do + cargohold <- viewCargohold get (cargohold . path "/i/metrics") !!! do const 200 === statusCode -- Should contain the request duration metric in its output diff --git a/services/cargohold/test/integration/TestSetup.hs b/services/cargohold/test/integration/TestSetup.hs index 872332dbc24..2f43e562a7e 100644 --- a/services/cargohold/test/integration/TestSetup.hs +++ b/services/cargohold/test/integration/TestSetup.hs @@ -18,34 +18,144 @@ module TestSetup ( test, tsManager, - tsCargohold, - TestSignature, + tsEndpoint, + tsOpts, TestSetup (..), - CargoHold, + Cargohold, + TestM, + runTestM, + viewCargohold, + createTestSetup, + runFederationClient, + withFederationClient, + withFederationError, ) where -import Bilge (Request) -import Bilge.IO (Http, Manager, runHttpT) -import Control.Lens (makeLenses, (^.)) +import Bilge hiding (body, responseBody) +import CargoHold.Options +import Control.Exception (catch) +import Control.Lens +import Control.Monad.Codensity +import Control.Monad.Except +import Control.Monad.Morph +import qualified Data.Aeson as Aeson +import Data.ByteString.Conversion +import qualified Data.Text as T +import Data.Text.Encoding +import Data.Yaml import Imports +import Network.HTTP.Client hiding (responseBody) +import Network.HTTP.Client.TLS +import qualified Network.Wai.Utilities.Error as Wai +import Servant.Client.Streaming import Test.Tasty import Test.Tasty.HUnit +import Util.Options +import Util.Options.Common +import Util.Test +import Wire.API.Federation.Domain -type CargoHold = Request -> Request +type Cargohold = Request -> Request -type TestSignature a = CargoHold -> Http a +type TestM = ReaderT TestSetup Http + +mkRequest :: Endpoint -> Request -> Request +mkRequest (Endpoint h p) = Bilge.host (encodeUtf8 h) . Bilge.port p data TestSetup = TestSetup { _tsManager :: Manager, - _tsCargohold :: CargoHold + _tsEndpoint :: Endpoint, + _tsOpts :: Opts } makeLenses ''TestSetup -test :: IO TestSetup -> TestName -> TestSignature a -> TestTree -test s n h = testCase n runTest - where - runTest = do - setup <- s - (void $ runHttpT (setup ^. tsManager) (h (setup ^. tsCargohold))) +viewCargohold :: TestM Cargohold +viewCargohold = mkRequest <$> view tsEndpoint + +runTestM :: TestSetup -> TestM a -> IO a +runTestM ts action = runHttpT (view tsManager ts) (runReaderT action ts) + +test :: IO TestSetup -> TestName -> TestM () -> TestTree +test s name action = testCase name $ do + ts <- s + runTestM ts action + +data IntegrationConfig = IntegrationConfig + -- internal endpoint + { cargohold :: Endpoint + } + deriving (Show, Generic) + +instance FromJSON IntegrationConfig + +createTestSetup :: FilePath -> FilePath -> IO TestSetup +createTestSetup optsPath configPath = do + -- FUTUREWORK: It would actually be useful to read some + -- values from cargohold (max bytes, for instance) + -- so that tests do not need to keep those values + -- in sync and the user _knows_ what they are + m <- + newManager + tlsManagerSettings + { managerResponseTimeout = responseTimeoutMicro 300000000 + } + let localEndpoint p = Endpoint {_epHost = "127.0.0.1", _epPort = p} + iConf <- handleParseError =<< decodeFileEither configPath + opts <- decodeFileThrow optsPath + endpoint <- optOrEnv cargohold iConf (localEndpoint . read) "CARGOHOLD_WEB_PORT" + pure $ + TestSetup + { _tsManager = m, + _tsEndpoint = endpoint, + _tsOpts = opts + } + +runFederationClient :: ClientM a -> ReaderT TestSetup (ExceptT ClientError (Codensity IO)) a +runFederationClient action = do + man <- view tsManager + Endpoint cHost cPort <- view tsEndpoint + domain <- view (tsOpts . optSettings . setFederationDomain) + let base = BaseUrl Http (T.unpack cHost) (fromIntegral cPort) "/federation" + let env = + (mkClientEnv man base) + { makeClientRequest = \burl req -> + let req' = defaultMakeClientRequest burl req + in req' + { requestHeaders = + (originDomainHeaderName, toByteString' domain) : + requestHeaders req' + } + } + + r <- lift . lift $ + Codensity $ \k -> + -- Servant's streaming client throws exceptions in IO for some reason + catch (withClientM action env k) (k . Left) + + either throwError pure r + +hoistFederation :: ReaderT TestSetup (ExceptT ClientError (Codensity IO)) a -> ExceptT ClientError TestM a +hoistFederation action = do + env <- ask + hoist (liftIO . lowerCodensity) $ runReaderT action env + +withFederationClient :: ReaderT TestSetup (ExceptT ClientError (Codensity IO)) a -> TestM a +withFederationClient action = + runExceptT (hoistFederation action) >>= \case + Left err -> + liftIO . assertFailure $ + "Unexpected federation client error: " + <> displayException err + Right x -> pure x + +withFederationError :: ReaderT TestSetup (ExceptT ClientError (Codensity IO)) a -> TestM Wai.Error +withFederationError action = + runExceptT (hoistFederation action) + >>= liftIO . \case + Left (FailureResponse _ resp) -> case Aeson.eitherDecode (responseBody resp) of + Left err -> assertFailure $ "Error while parsing error response: " <> err + Right e -> (Wai.code e @?= responseStatusCode resp) $> e + Left err -> assertFailure $ "Unexpected federation client error: " <> displayException err + Right _ -> assertFailure "Unexpected success" diff --git a/services/federator/federator.cabal b/services/federator/federator.cabal index fca3d7731cf..97a98e21d42 100644 --- a/services/federator/federator.cabal +++ b/services/federator/federator.cabal @@ -1,10 +1,8 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack --- --- hash: 2131bf1a367dd734cbccd900c4724c5b48e3f494501b2221e3f32ecaf0a12ec4 name: federator version: 1.0.0 @@ -58,7 +56,46 @@ library Paths_federator 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 + 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 build-depends: aeson @@ -80,9 +117,11 @@ library , hinotify , http-client , http-client-openssl + , http-media , http-types , http2 , imports + , kan-extensions , lens , metrics-core , metrics-wai @@ -94,7 +133,7 @@ library , polysemy-wire-zoo , retry , servant - , servant-server + , servant-client-core , streaming-commons , string-conversions , text @@ -123,7 +162,46 @@ executable federator Paths_federator hs-source-dirs: exec - 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 + 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=-N1 -with-rtsopts=-T -rtsopts build-depends: aeson @@ -146,9 +224,11 @@ executable federator , hinotify , http-client , http-client-openssl + , http-media , http-types , http2 , imports + , kan-extensions , lens , metrics-core , metrics-wai @@ -160,7 +240,7 @@ executable federator , polysemy-wire-zoo , retry , servant - , servant-server + , servant-client-core , streaming-commons , string-conversions , text @@ -193,10 +273,50 @@ executable federator-integration Paths_federator hs-source-dirs: test/integration - 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 + 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 build-depends: - aeson + QuickCheck + , aeson , async , base , bilge @@ -221,9 +341,11 @@ executable federator-integration , http-client , http-client-openssl , http-client-tls + , http-media , http-types , http2 , imports + , kan-extensions , lens , metrics-core , metrics-wai @@ -237,7 +359,7 @@ executable federator-integration , random , retry , servant - , servant-server + , servant-client-core , streaming-commons , string-conversions , tasty @@ -279,7 +401,46 @@ test-suite federator-tests Paths_federator hs-source-dirs: test/unit - 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 + 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-depends: QuickCheck @@ -304,10 +465,12 @@ test-suite federator-tests , hinotify , http-client , http-client-openssl + , http-media , http-types , http2 , imports , interpolate + , kan-extensions , lens , metrics-core , metrics-wai @@ -316,12 +479,11 @@ test-suite federator-tests , network-uri , pem , polysemy - , polysemy-mocks , polysemy-wire-zoo , retry , servant , servant-client - , servant-server + , servant-client-core , streaming-commons , string-conversions , tasty diff --git a/services/federator/package.yaml b/services/federator/package.yaml index bb4c0b9655a..b17c45b078f 100644 --- a/services/federator/package.yaml +++ b/services/federator/package.yaml @@ -29,8 +29,10 @@ dependencies: - hinotify - http-client - http-client-openssl +- http-media - http-types - http2 +- kan-extensions - imports - lens - metrics-core @@ -43,7 +45,7 @@ dependencies: - polysemy-wire-zoo - retry - servant -- servant-server +- servant-client-core - streaming-commons - string-conversions - text @@ -92,6 +94,7 @@ executables: - http-client-tls - mtl - optparse-applicative + - QuickCheck - random - retry - tasty @@ -111,7 +114,6 @@ tests: - directory - federator - interpolate - - polysemy-mocks - QuickCheck - servant-client - streaming-commons diff --git a/services/federator/src/Federator/App.hs b/services/federator/src/Federator/App.hs index e1601ed8900..2a33cd98600 100644 --- a/services/federator/src/Federator/App.hs +++ b/services/federator/src/Federator/App.hs @@ -34,8 +34,6 @@ import Federator.Env (Env, applog, httpManager, requestId) import Imports import Polysemy import Polysemy.Input -import Servant.API.Generic () -import Servant.Server () import System.Logger.Class as LC import qualified System.Logger.Extended as Log diff --git a/services/federator/src/Federator/Discovery.hs b/services/federator/src/Federator/Discovery.hs index 65844e33d86..4148e67c136 100644 --- a/services/federator/src/Federator/Discovery.hs +++ b/services/federator/src/Federator/Discovery.hs @@ -49,7 +49,7 @@ instance AsWai DiscoveryFailure where where (status, label) = case e of DiscoveryFailureSrvNotAvailable _ -> (HTTP.status422, "invalid-domain") - DiscoveryFailureDNSError _ -> (HTTP.status500, "discovery-failure") + DiscoveryFailureDNSError _ -> (HTTP.status400, "discovery-failure") waiErrorDescription :: DiscoveryFailure -> Text waiErrorDescription (DiscoveryFailureSrvNotAvailable msg) = "srv record not found: " <> Text.decodeUtf8 msg diff --git a/services/federator/src/Federator/Env.hs b/services/federator/src/Federator/Env.hs index 4594b4fd852..ced29deb2bd 100644 --- a/services/federator/src/Federator/Env.hs +++ b/services/federator/src/Federator/Env.hs @@ -21,7 +21,6 @@ module Federator.Env where import Bilge (RequestId) -import qualified Bilge as RPC import Control.Lens (makeLenses) import Data.Metrics (Metrics) import Data.X509.CertificateStore @@ -31,6 +30,7 @@ import Network.DNS.Resolver (Resolver) import qualified Network.HTTP.Client as HTTP import qualified Network.TLS as TLS import qualified System.Logger.Class as LC +import Util.Options import Wire.API.Federation.Component data TLSSettings = TLSSettings @@ -44,7 +44,7 @@ data Env = Env _requestId :: RequestId, _dnsResolver :: Resolver, _runSettings :: RunSettings, - _service :: Component -> RPC.Request, + _service :: Component -> Endpoint, _httpManager :: HTTP.Manager, _tls :: IORef TLSSettings } diff --git a/services/federator/src/Federator/ExternalServer.hs b/services/federator/src/Federator/ExternalServer.hs index 59546eb2165..092c1a31aff 100644 --- a/services/federator/src/Federator/ExternalServer.hs +++ b/services/federator/src/Federator/ExternalServer.hs @@ -18,8 +18,9 @@ module Federator.ExternalServer (callInward, serveInward, parseRequestData, RequestData (..)) where import qualified Data.ByteString as BS -import Data.ByteString.Builder (toLazyByteString) +import Data.ByteString.Builder import qualified Data.ByteString.Lazy as LBS +import qualified Data.Sequence as Seq import qualified Data.Text as Text import Federator.Discovery import Federator.Env @@ -36,6 +37,7 @@ import Polysemy.Error import Polysemy.Input import Polysemy.TinyLog (TinyLog) import qualified Polysemy.TinyLog as Log +import Servant.Client.Core import qualified System.Logger.Message as Log import Wire.API.Federation.Component import Wire.API.Federation.Domain @@ -43,7 +45,7 @@ import Wire.API.Federation.Domain -- FUTUREWORK(federation): Versioning of the federation API. callInward :: Members - '[ Service, + '[ ServiceStreaming, Embed IO, TinyLog, DiscoverFederator, @@ -67,12 +69,18 @@ callInward wreq = do let path = LBS.toStrict (toLazyByteString (HTTP.encodePathSegments ["federation", rdRPC req])) - (status, body) <- serviceCall (rdComponent req) path (rdBody req) validatedDomain + resp <- serviceCall (rdComponent req) path (rdBody req) validatedDomain Log.debug $ Log.msg ("Inward Request response" :: ByteString) - . Log.field "status" (show status) - - pure $ Wai.responseLBS status defaultHeaders (fromMaybe mempty body) + . Log.field "status" (show (responseStatusCode resp)) + pure $ + streamingResponseToWai + resp + { responseHeaders = + Seq.filter + (\(name, _) -> name == "Content-Type") + (responseHeaders resp) + } data RequestData = RequestData { rdComponent :: Component, @@ -99,14 +107,14 @@ parseRequestData req = do when (Wai.requestMethod req /= HTTP.methodPost) $ throw InvalidRoute -- No query parameters are allowed - when (not . BS.null . Wai.rawQueryString $ req) $ + unless (BS.null . Wai.rawQueryString $ req) $ throw InvalidRoute -- check that the path has the expected form (componentSeg, rpcPath) <- case Wai.pathInfo req of ["federation", comp, rpc] -> pure (comp, rpc) _ -> throw InvalidRoute - when (not (Text.all isAllowedRPCChar rpcPath)) $ + unless (Text.all isAllowedRPCChar rpcPath) $ throw InvalidRoute when (Text.null rpcPath) $ diff --git a/services/federator/src/Federator/InternalServer.hs b/services/federator/src/Federator/InternalServer.hs index a3fadf6f2ec..c9aeace7b55 100644 --- a/services/federator/src/Federator/InternalServer.hs +++ b/services/federator/src/Federator/InternalServer.hs @@ -65,6 +65,7 @@ import qualified Polysemy.Input as Polysemy import qualified Polysemy.Resource as Polysemy import Polysemy.TinyLog (TinyLog) import qualified Polysemy.TinyLog as Log +import Servant.Client.Core import qualified System.TimeManager as T import qualified System.X509 as TLS import Wire.API.Federation.Component @@ -89,7 +90,7 @@ parseRequestData req = do when (Wai.requestMethod req /= HTTP.methodPost) $ throw InvalidRoute -- No query parameters are allowed - when (not . BS.null . Wai.rawQueryString $ req) $ + unless (BS.null . Wai.rawQueryString $ req) $ throw InvalidRoute -- check that the path has the expected form (domain, componentSeg, rpcPath) <- case Wai.pathInfo req of @@ -118,14 +119,14 @@ callOutward req = do rd <- parseRequestData req domain <- parseDomainText (rdTargetDomain rd) ensureCanFederateWith domain - (status, result) <- + resp <- discoverAndCall domain (rdComponent rd) (rdRPC rd) (rdHeaders rd) (fromLazyByteString (rdBody rd)) - pure $ Wai.responseBuilder status defaultHeaders result + pure $ streamingResponseToWai resp serveOutward :: Env -> Int -> IO () serveOutward = serve callOutward diff --git a/services/federator/src/Federator/MockServer.hs b/services/federator/src/Federator/MockServer.hs index ec28270ca9f..a501b0fb33c 100644 --- a/services/federator/src/Federator/MockServer.hs +++ b/services/federator/src/Federator/MockServer.hs @@ -39,6 +39,7 @@ import Federator.InternalServer import Federator.Response import Federator.Validation import Imports hiding (fromException) +import qualified Network.HTTP.Media as HTTP import Network.HTTP.Types as HTTP import qualified Network.Wai as Wai import qualified Network.Wai.Handler.Warp as Warp @@ -53,7 +54,7 @@ import Wire.API.Federation.Domain -- | Thrown in IO by mock federator if the server could not be started after 10 -- seconds. -data MockTimeout = MockTimeout Warp.Port +newtype MockTimeout = MockTimeout Warp.Port deriving (Eq, Show, Typeable) instance Exception MockTimeout @@ -125,7 +126,7 @@ data FederatedRequest = FederatedRequest withTempMockFederator :: (MonadIO m, MonadMask m) => [HTTP.Header] -> - (FederatedRequest -> IO LByteString) -> + (FederatedRequest -> IO (HTTP.MediaType, LByteString)) -> (Warp.Port -> m a) -> m (a, [FederatedRequest]) withTempMockFederator headers resp action = do @@ -159,12 +160,13 @@ withTempMockFederator headers resp action = do frBody = rdBody } ) - embed @IO $ modifyIORef remoteCalls $ (<> [fedRequest]) - body <- + embed @IO $ modifyIORef remoteCalls (<> [fedRequest]) + (ct, body) <- fromException @MockException . handle (throw . handleException) $ resp fedRequest - pure $ Wai.responseLBS HTTP.status200 headers body + let headers' = ("Content-Type", HTTP.renderHeader ct) : headers + pure $ Wai.responseLBS HTTP.status200 headers' body respond response result <- bracket diff --git a/services/federator/src/Federator/Monitor/Internal.hs b/services/federator/src/Federator/Monitor/Internal.hs index 28351d384db..9833077cdfe 100644 --- a/services/federator/src/Federator/Monitor/Internal.hs +++ b/services/federator/src/Federator/Monitor/Internal.hs @@ -72,7 +72,7 @@ data WatchedPath deriving stock (Eq, Ord, Show, Generic) deriving (Arbitrary) via (GenericUniform WatchedPath) -mergePaths :: [WatchedPath] -> (Set WatchedPath) +mergePaths :: [WatchedPath] -> Set WatchedPath mergePaths = Set.fromList . merge . sort where merge [] = [] diff --git a/services/federator/src/Federator/Remote.hs b/services/federator/src/Federator/Remote.hs index bbf5146da53..a206fcea360 100644 --- a/services/federator/src/Federator/Remote.hs +++ b/services/federator/src/Federator/Remote.hs @@ -26,7 +26,9 @@ module Federator.Remote ) where +import qualified Control.Exception as E import Control.Lens ((^.)) +import Control.Monad.Codensity import Data.Binary.Builder import Data.ByteString.Conversion (toByteString') import qualified Data.ByteString.Lazy as LBS @@ -49,6 +51,7 @@ import qualified Network.TLS.Extra.Cipher as TLS import Polysemy import Polysemy.Error import Polysemy.Input +import Servant.Client.Core import Wire.API.Federation.Client import Wire.API.Federation.Component import Wire.API.Federation.Error @@ -93,13 +96,13 @@ data Remote m a where Text -> [HTTP.Header] -> Builder -> - Remote m (HTTP.Status, Builder) + Remote m StreamingResponse makeSem ''Remote interpretRemote :: Members - '[ Embed IO, + '[ Embed (Codensity IO), DiscoverFederator, Error DiscoveryFailure, Error RemoteError, @@ -117,12 +120,21 @@ interpretRemote = interpret $ \case HTTP.encodePathSegments ["federation", componentName component, rpc] req' = HTTP2.requestBuilder HTTP.methodPost path headers body tlsConfig = mkTLSConfig settings hostname port - (status, _, result) <- - mapError (RemoteError target) . (fromEither =<<) . embed $ - performHTTP2Request (Just tlsConfig) req' hostname (fromIntegral port) - unless (HTTP.statusIsSuccessful status) $ - throw $ RemoteErrorResponse target status (toLazyByteString result) - pure (status, result) + + resp <- mapError (RemoteError target) . (fromEither @FederatorClientHTTP2Error =<<) . embed $ + Codensity $ \k -> + E.catch + (withHTTP2Request (Just tlsConfig) req' hostname (fromIntegral port) (k . Right)) + (k . Left) + + unless (HTTP.statusIsSuccessful (responseStatusCode resp)) $ do + bdy <- embed @(Codensity IO) . liftIO $ streamingResponseStrictBody resp + throw $ + RemoteErrorResponse + target + (responseStatusCode resp) + (toLazyByteString bdy) + pure resp mkTLSConfig :: TLSSettings -> ByteString -> Word16 -> TLS.ClientParams mkTLSConfig settings hostname port = diff --git a/services/federator/src/Federator/Response.hs b/services/federator/src/Federator/Response.hs index 7edab1111b2..76e2649a85f 100644 --- a/services/federator/src/Federator/Response.hs +++ b/services/federator/src/Federator/Response.hs @@ -20,10 +20,13 @@ module Federator.Response serve, runWaiError, runWaiErrors, + streamingResponseToWai, ) where import Control.Lens +import Control.Monad.Codensity +import Data.ByteString.Builder import Federator.Discovery import Federator.Env import Federator.Error @@ -39,10 +42,13 @@ import qualified Network.Wai.Handler.Warp as Warp import qualified Network.Wai.Utilities.Error as Wai import qualified Network.Wai.Utilities.Server as Wai import Polysemy +import Polysemy.Embed import Polysemy.Error import Polysemy.Input import Polysemy.Internal import Polysemy.TinyLog +import Servant.Client.Core +import Servant.Types.SourceT import Wire.Network.DNS.Effect defaultHeaders :: [HTTP.Header] @@ -96,14 +102,13 @@ serve action env port = where app :: Wai.Application app req respond = - runFederator env (action req) - >>= respond + runCodensity (runFederator env (action req)) respond type AllEffects = '[ Remote, DiscoverFederator, DNSLookup, -- needed by DiscoverFederator - Service, + ServiceStreaming, Input RunSettings, Input TLSSettings, -- needed by Remote Input Env, -- needed by Service @@ -112,14 +117,16 @@ type AllEffects = Error ServerError, Error DiscoveryFailure, TinyLog, - Embed IO + Embed IO, + Embed (Codensity IO) ] -- | Run Sem action containing HTTP handlers. All errors have to been handled -- already by this point. -runFederator :: Env -> Sem AllEffects Wai.Response -> IO Wai.Response +runFederator :: Env -> Sem AllEffects Wai.Response -> Codensity IO Wai.Response runFederator env = - runM @IO + runM + . runEmbedded @IO @(Codensity IO) liftIO . runTinyLog (view applog env) -- FUTUREWORK: add request id . runWaiErrors @'[ ValidationError, @@ -130,7 +137,18 @@ runFederator env = . runInputConst env . runInputSem (embed @IO (readIORef (view tls env))) . runInputConst (view runSettings env) - . interpretService + . interpretServiceHTTP . runDNSLookupWithResolver (view dnsResolver env) . runFederatorDiscovery . interpretRemote + +streamingResponseToWai :: StreamingResponse -> Wai.Response +streamingResponseToWai resp = + let headers = toList (responseHeaders resp) + status = responseStatusCode resp + streamingBody output flush = + foreach + (const (pure ())) + (\chunk -> output (byteString chunk) *> flush) + (responseBody resp) + in Wai.responseStream status headers streamingBody diff --git a/services/federator/src/Federator/Run.hs b/services/federator/src/Federator/Run.hs index 3e9312a4604..a41b259451b 100644 --- a/services/federator/src/Federator/Run.hs +++ b/services/federator/src/Federator/Run.hs @@ -34,13 +34,11 @@ module Federator.Run ) where -import qualified Bilge as RPC import Control.Concurrent.Async import Control.Exception (bracket) import Control.Lens ((^.)) import Data.Default (def) import qualified Data.Metrics.Middleware as Metrics -import Data.Text.Encoding (encodeUtf8) import Federator.Env import Federator.ExternalServer (serveInward) import Federator.InternalServer (serveOutward) @@ -95,14 +93,12 @@ newEnv o _dnsResolver = do _applog <- LogExt.mkLogger (Opt.logLevel o) (Opt.logNetStrings o) (Opt.logFormat o) let _requestId = def let _runSettings = Opt.optSettings o - let _service Brig = mkEndpoint (Opt.brig o) - _service Galley = mkEndpoint (Opt.galley o) - _service Cargohold = mkEndpoint (Opt.cargohold o) + let _service Brig = Opt.brig o + _service Galley = Opt.galley o + _service Cargohold = Opt.cargohold o _httpManager <- initHttpManager _tls <- mkTLSSettingsOrThrow _runSettings >>= newIORef return Env {..} - where - mkEndpoint s = RPC.host (encodeUtf8 (s ^. epHost)) . RPC.port (s ^. epPort) $ RPC.empty closeEnv :: Env -> IO () closeEnv e = do diff --git a/services/federator/src/Federator/Service.hs b/services/federator/src/Federator/Service.hs index 99b024fcc31..9514f9ecf24 100644 --- a/services/federator/src/Federator/Service.hs +++ b/services/federator/src/Federator/Service.hs @@ -15,35 +15,57 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Federator.Service where +module Federator.Service + ( Service (..), + ServiceStreaming, + interpretServiceHTTP, + serviceCall, + ) +where -- FUTUREWORK(federation): Once we authenticate the call, we should send authentication data -- to brig so brig can do some authorization as required. import qualified Bilge as RPC -import Bilge.RPC (rpc') +import Control.Exception import Control.Lens (view) +import Control.Monad.Codensity +import qualified Data.ByteString as BS import Data.Domain +import qualified Data.Sequence as Seq import Data.String.Conversions (cs) -import qualified Data.Text.Lazy as LText -import Federator.App +import qualified Data.Text.Encoding as Text import Federator.Env import Imports +import Network.HTTP.Client import qualified Network.HTTP.Types as HTTP import Polysemy import Polysemy.Input +import Polysemy.TinyLog +import qualified Servant.Client.Core as Servant +import Servant.Types.SourceT +import Util.Options import Wire.API.Federation.Component import Wire.API.Federation.Domain (originDomainHeaderName) -newtype ServiceError = ServiceErrorInvalidStatus HTTP.Status - deriving (Eq, Show) +type ServiceStreaming = Service (SourceT IO ByteString) -data Service m a where - -- | Returns status and body, 'HTTP.Response' is not nice to work with in tests - ServiceCall :: Component -> ByteString -> LByteString -> Domain -> Service m (HTTP.Status, Maybe LByteString) +data Service body m a where + -- | Returns status, headers and body, 'HTTP.Response' is not nice to work with in tests + ServiceCall :: Component -> ByteString -> LByteString -> Domain -> Service body m (Servant.ResponseF body) makeSem ''Service +bodyReaderToStreamT :: Monad m => m ByteString -> SourceT m ByteString +bodyReaderToStreamT action = fromStepT go + where + go = Effect $ do + chunk <- action + pure $ + if BS.null chunk + then Stop + else Yield chunk go + -- FUTUREWORK(federation): Do we want to use servant client here? May make -- everything typed and safe -- @@ -52,19 +74,36 @@ makeSem ''Service -- -- FUTUREWORK: unify this interpretation with similar ones in Galley -- --- FUTUREWORK: does it make sense to use a lower level abstraction instead of bilge here? -interpretService :: - Members '[Embed IO, Input Env] r => - Sem (Service ': r) a -> +interpretServiceHTTP :: + Members '[Embed (Codensity IO), Input Env, TinyLog] r => + Sem (ServiceStreaming ': r) a -> Sem r a -interpretService = interpret $ \case - ServiceCall component path body domain -> embedApp @IO $ do - serviceReq <- view service <$> ask - res <- - rpc' (LText.pack (show component)) (serviceReq component) $ - RPC.method HTTP.POST - . RPC.path path - . RPC.body (RPC.RequestBodyLBS body) - . RPC.contentJson - . RPC.header originDomainHeaderName (cs (domainText domain)) - pure (RPC.responseStatus res, RPC.responseBody res) +interpretServiceHTTP = interpret $ \case + ServiceCall component rpcPath body domain -> do + Endpoint serviceHost servicePort <- inputs (view service) <*> pure component + manager <- inputs (view httpManager) + reqId <- inputs (view requestId) + let req = + defaultRequest + { method = HTTP.methodPost, + host = Text.encodeUtf8 serviceHost, + port = fromIntegral servicePort, + requestBody = RequestBodyLBS body, + path = rpcPath, + requestHeaders = + [ ("Content-Type", "application/json"), + (originDomainHeaderName, cs (domainText domain)), + (RPC.requestIdName, RPC.unRequestId reqId) + ] + } + + embed $ + Codensity $ \k -> + bracket (responseOpen req manager) responseClose $ \resp -> + k $ + Servant.Response + { Servant.responseStatusCode = responseStatus resp, + Servant.responseHeaders = Seq.fromList (responseHeaders resp), + Servant.responseHttpVersion = HTTP.http11, + Servant.responseBody = bodyReaderToStreamT (responseBody resp) + } diff --git a/services/federator/src/Federator/Validation.hs b/services/federator/src/Federator/Validation.hs index 4d7f35867d6..6dc9e21ebd8 100644 --- a/services/federator/src/Federator/Validation.hs +++ b/services/federator/src/Federator/Validation.hs @@ -150,6 +150,7 @@ validateDomain :: validateDomain Nothing _ = throw NoClientCertificate validateDomain (Just encodedCertificate) unparsedDomain = do targetDomain <- parseDomain unparsedDomain + ensureCanFederateWith targetDomain -- run discovery to find the hostname of the client federator certificate <- @@ -160,7 +161,7 @@ validateDomain (Just encodedCertificate) unparsedDomain = do unless (any null validationErrors) $ throw $ AuthenticationFailure validationErrors - ensureCanFederateWith targetDomain $> targetDomain + pure targetDomain -- | Match a hostname against the domain names of a certificate. -- diff --git a/services/federator/test/integration/Test/Federator/IngressSpec.hs b/services/federator/test/integration/Test/Federator/IngressSpec.hs index 04d80bb147d..f1b2b891bf3 100644 --- a/services/federator/test/integration/Test/Federator/IngressSpec.hs +++ b/services/federator/test/integration/Test/Federator/IngressSpec.hs @@ -18,6 +18,7 @@ module Test.Federator.IngressSpec where import Control.Lens (view) +import Control.Monad.Codensity import qualified Data.Aeson as Aeson import Data.Binary.Builder import Data.Domain @@ -32,16 +33,21 @@ import Federator.Remote import Imports import qualified Network.HTTP.Types as HTTP import Polysemy +import Polysemy.Embed import Polysemy.Error import Polysemy.Input +import Servant.Client.Core import Test.Federator.Util import Test.Hspec import Util.Options (Endpoint (Endpoint)) +import Wire.API.Federation.Client import Wire.API.Federation.Component import Wire.API.Federation.Domain import Wire.API.User import Wire.Network.DNS.SRV +-- | This module contains tests for the interface between federator and ingress. Ingress is +-- mocked with nginz. spec :: TestEnv -> Spec spec env = do describe "Ingress" $ do @@ -53,17 +59,28 @@ spec env = do _ <- putHandle brig (userId user) hdl let expectedProfile = (publicProfile user UserLegalHoldNoConsent) {profileHandle = Just (Handle hdl)} - (status, resp) <- + resp <- runTestSem . assertNoError @RemoteError - $ inwardBrigCallViaIngress "get-user-by-handle" $ + $ inwardBrigCallViaIngress + "get-user-by-handle" (Aeson.fromEncoding (Aeson.toEncoding hdl)) - let actualProfile = Aeson.decode (toLazyByteString resp) liftIO $ do - status `shouldBe` HTTP.status200 - actualProfile `shouldBe` (Just expectedProfile) + bdy <- streamingResponseStrictBody resp + let actualProfile = Aeson.decode (toLazyByteString bdy) + responseStatusCode resp `shouldBe` HTTP.status200 + actualProfile `shouldBe` Just expectedProfile - it "should not be accessible without a client certificate" $ + -- @SF.Federation @TSFI.RESTfulAPI @S2 @S3 @S7 + -- + -- This test was primarily intended to test that federator is using the API right (header + -- name etc.), but it is also effectively testing that federator rejects clients without + -- certificates that have been validated by ingress. + -- + -- We can't test end-to-end here: the TLS termination happens in k8s, and would have to be + -- tested there (and with a good emulation of the concrete configuration of the prod + -- system). + it "rejectRequestsWithoutClientCertIngress" $ runTestFederator env $ do brig <- view teBrig <$> ask user <- randomUser brig @@ -80,7 +97,9 @@ spec env = do r <- runTestSem . runError @RemoteError - $ inwardBrigCallViaIngressWithSettings tlsSettings "get-user-by-handle" $ + $ inwardBrigCallViaIngressWithSettings + tlsSettings + "get-user-by-handle" (Aeson.fromEncoding (Aeson.toEncoding hdl)) liftIO $ case r of Right _ -> expectationFailure "Expected client certificate error, got response" @@ -88,6 +107,10 @@ spec env = do expectationFailure "Expected client certificate error, got remote error" Left (RemoteErrorResponse _ status _) -> status `shouldBe` HTTP.status400 +-- FUTUREWORK: ORMOLU_DISABLE +-- @END +-- ORMOLU_ENABLE + runTestSem :: Sem '[Input TestEnv, Embed IO] a -> TestFederator IO a runTestSem action = do e <- ask @@ -102,7 +125,7 @@ inwardBrigCallViaIngress :: Members [Input TestEnv, Embed IO, Error RemoteError] r => Text -> Builder -> - Sem r (HTTP.Status, Builder) + Sem r StreamingResponse inwardBrigCallViaIngress path payload = do tlsSettings <- inputs (view teTLSSettings) inwardBrigCallViaIngressWithSettings tlsSettings path payload @@ -112,7 +135,7 @@ inwardBrigCallViaIngressWithSettings :: TLSSettings -> Text -> Builder -> - Sem r (HTTP.Status, Builder) + Sem r StreamingResponse inwardBrigCallViaIngressWithSettings tlsSettings requestPath payload = do Endpoint ingressHost ingressPort <- cfgNginxIngress . view teTstOpts <$> input @@ -122,5 +145,6 @@ inwardBrigCallViaIngressWithSettings tlsSettings requestPath payload = runInputConst tlsSettings . assertNoError @DiscoveryFailure . discoverConst target + . runEmbedded @(Codensity IO) @IO lowerCodensity . interpretRemote $ discoverAndCall (Domain "example.com") Brig requestPath headers payload diff --git a/services/federator/test/integration/Test/Federator/InwardSpec.hs b/services/federator/test/integration/Test/Federator/InwardSpec.hs index da02ec6f459..c9213ed9011 100644 --- a/services/federator/test/integration/Test/Federator/InwardSpec.hs +++ b/services/federator/test/integration/Test/Federator/InwardSpec.hs @@ -34,13 +34,18 @@ import qualified Network.HTTP.Types as HTTP import qualified Network.Wai.Utilities.Error as E import Test.Federator.Util import Test.Hspec +import Test.QuickCheck (arbitrary, generate) import Util.Options (Endpoint (Endpoint)) +import Wire.API.Federation.API.Cargohold import Wire.API.Federation.Domain import Wire.API.User -- FUTUREWORK(federation): move these tests to brig-integration (benefit: avoid duplicating all of the brig helper code) +-- FUTUREWORK(fisx): better yet, reorganize integration tests (or at least the helpers) so +-- they don't spread out over the different sevices. --- | Path covered by this test +-- | This module contains tests for the interface between federator and brig. The tests call +-- federator directly, circumnventing ingress: -- -- +----------+ -- |federator-| +------+--+ @@ -72,10 +77,21 @@ spec env = view teTstOpts hdl <- randomHandle @@ -110,6 +128,10 @@ spec env = (encode hdl) !!! const 403 === statusCode +-- TODO: ORMOLU_DISABLE +-- @END +-- ORMOLU_ENABLE + inwardCallWithHeaders :: (MonadIO m, MonadHttp m, MonadReader TestEnv m, HasCallStack) => ByteString -> @@ -132,8 +154,17 @@ inwardCall :: LBS.ByteString -> m (Response (Maybe LByteString)) inwardCall requestPath payload = do + originDomain :: Text <- cfgOriginDomain <$> view teTstOpts + inwardCallWithOriginDomain (toByteString' originDomain) requestPath payload + +inwardCallWithOriginDomain :: + (MonadIO m, MonadHttp m, MonadReader TestEnv m, HasCallStack) => + ByteString -> + ByteString -> + LBS.ByteString -> + m (Response (Maybe LByteString)) +inwardCallWithOriginDomain originDomain requestPath payload = do Endpoint fedHost fedPort <- cfgFederatorExternal <$> view teTstOpts - originDomain <- cfgOriginDomain <$> view teTstOpts clientCertFilename <- clientCertificate . optSettings . view teOpts <$> ask clientCert <- liftIO $ BS.readFile clientCertFilename post @@ -141,6 +172,6 @@ inwardCall requestPath payload = do . port fedPort . path requestPath . header "X-SSL-Certificate" (HTTP.urlEncode True clientCert) - . header originDomainHeaderName (toByteString' originDomain) + . header originDomainHeaderName originDomain . bytes (toByteString' payload) ) diff --git a/services/federator/test/unit/Test/Federator/Client.hs b/services/federator/test/unit/Test/Federator/Client.hs index a0d172050f9..3d70887271e 100644 --- a/services/federator/test/unit/Test/Federator/Client.hs +++ b/services/federator/test/unit/Test/Federator/Client.hs @@ -18,20 +18,32 @@ module Test.Federator.Client (tests) where import Control.Exception hiding (handle) +import Control.Monad.Codensity +import Control.Monad.Except import qualified Data.Aeson as Aeson import Data.Bifunctor (first) +import qualified Data.ByteString as BS +import Data.ByteString.Builder (Builder, byteString, toLazyByteString) +import qualified Data.ByteString.Lazy as LBS import Data.Domain +import Data.Proxy +import qualified Data.Text.Encoding as Text import Federator.MockServer import Imports +import Network.HTTP.Media import Network.HTTP.Types as HTTP import qualified Network.HTTP2.Client as HTTP2 -import Network.Wai.Utilities.Error as Wai +import qualified Network.Wai as Wai +import qualified Network.Wai.Utilities.Error as Wai +import Servant.API +import Servant.Client +import Servant.Client.Core +import Servant.Types.SourceT import Test.QuickCheck (arbitrary, generate) import Test.Tasty import Test.Tasty.HUnit import Util.Options import Wire.API.Federation.API -import Wire.API.Federation.API.Brig import Wire.API.Federation.Client import Wire.API.Federation.Component import Wire.API.Federation.Error @@ -53,6 +65,7 @@ tests = [ testGroup "Servant" [ testCase "testClientSuccess" testClientSuccess, + testCase "testClientStreaming" testClientStreaming, testCase "testClientFailure" testClientFailure, testCase "testFederatorFailure" testFederatorFailure, testCase "testClientException" testClientExceptions, @@ -60,7 +73,8 @@ tests = ], testGroup "HTTP2 client" - [ testCase "testResponseHeaders" testResponseHeaders + [ testCase "testResponseHeaders" testResponseHeaders, + testCase "testStreaming" testStreaming ] ] @@ -70,7 +84,7 @@ newtype ResponseFailure = ResponseFailure Wai.Error withMockFederatorClient :: KnownComponent c => [HTTP.Header] -> - (FederatedRequest -> IO LByteString) -> + (FederatedRequest -> IO (MediaType, LByteString)) -> FederatorClient c a -> IO (Either ResponseFailure a, [FederatedRequest]) withMockFederatorClient headers resp action = withTempMockFederator headers resp $ \port -> do @@ -92,8 +106,10 @@ testClientSuccess = do expectedResponse :: UserProfile <- generate arbitrary (actualResponse, sentRequests) <- - withMockFederatorClient defaultHeaders (const (pure (Aeson.encode (Just expectedResponse)))) $ - getUserByHandle clientRoutes handle + withMockFederatorClient + defaultHeaders + (const (pure ("application/json", Aeson.encode (Just expectedResponse)))) + $ fedClient @'Brig @"get-user-by-handle" handle sentRequests @?= [ FederatedRequest @@ -106,6 +122,24 @@ testClientSuccess = do ] first (const ()) actualResponse @?= Right (Just expectedResponse) +type StreamingAPI = StreamGet NewlineFraming PlainText (SourceIO Text) + +testClientStreaming :: IO () +testClientStreaming = withInfiniteMockServer $ \port -> do + let env = + FederatorClientEnv + { ceOriginDomain = originDomain, + ceTargetDomain = targetDomain, + ceFederator = Endpoint "127.0.0.1" (fromIntegral port) + } + let c = clientIn (Proxy @StreamingAPI) (Proxy @(FederatorClient 'Brig)) + runCodensity (runFederatorClientToCodensity env c) $ \case + Left err -> assertFailure $ "Unexpected error: " <> displayException err + Right out -> do + let expected = mconcat (replicate 500 "Hello") + actual <- takeSourceT (fromIntegral (LBS.length expected)) (fmap Text.encodeUtf8 out) + actual @?= expected + testClientFailure :: IO () testClientFailure = do handle <- generate arbitrary @@ -115,7 +149,7 @@ testClientFailure = do defaultHeaders (const (throw (MockErrorResponse HTTP.status422 "wrong domain"))) $ do - getUserByHandle clientRoutes handle + fedClient @'Brig @"get-user-by-handle" handle case actualResponse of Right _ -> assertFailure "unexpected success" @@ -132,7 +166,7 @@ testFederatorFailure = do defaultHeaders (const (throw (MockErrorResponse HTTP.status403 "invalid path"))) $ do - getUserByHandle clientRoutes handle + fedClient @'Brig @"get-user-by-handle" handle case actualResponse of Right _ -> assertFailure "unexpected success" @@ -146,7 +180,7 @@ testClientExceptions = do (response, _) <- withMockFederatorClient defaultHeaders (const (evaluate (error "unhandled exception"))) $ - getUserByHandle clientRoutes handle + fedClient @'Brig @"get-user-by-handle" handle case response of Right _ -> assertFailure "unexpected success" @@ -161,7 +195,7 @@ testClientConnectionError = do ceTargetDomain = targetDomain, ceFederator = Endpoint "127.0.0.1" 1 } - result <- runFederatorClient env (getUserByHandle clientRoutes handle) + result <- runFederatorClient env (fedClient @'Brig @"get-user-by-handle" handle) case result of Left (FederatorClientHTTP2Error (FederatorClientConnectionError _)) -> pure () Left x -> assertFailure $ "Expected connection error, got: " <> show x @@ -169,18 +203,55 @@ testClientConnectionError = do testResponseHeaders :: IO () testResponseHeaders = do - (r, _) <- withTempMockFederator [("X-Foo", "bar")] (const mempty) $ \port -> do - let req = - HTTP2.requestBuilder - HTTP.methodPost - "/rpc/target.example.com/brig/test" - [("Wire-Origin-Domain", "origin.example.com")] - "body" - performHTTP2Request Nothing req "127.0.0.1" port + (r, _) <- withTempMockFederator + [("X-Foo", "bar")] + (const $ pure ("application" // "json", mempty)) + $ \port -> do + let req = + HTTP2.requestBuilder + HTTP.methodPost + "/rpc/target.example.com/brig/test" + [("Wire-Origin-Domain", "origin.example.com")] + "body" + performHTTP2Request Nothing req "127.0.0.1" port case r of Left err -> assertFailure $ "Unexpected error while connecting to mock federator: " <> show err - Right (status, headers, _) -> do - status @?= HTTP.status200 - lookup "X-Foo" headers @?= Just "bar" + Right resp -> do + responseStatusCode resp @?= HTTP.status200 + lookup "X-Foo" (toList (responseHeaders resp)) @?= Just "bar" + +testStreaming :: IO () +testStreaming = withInfiniteMockServer $ \port -> do + let req = HTTP2.requestBuilder HTTP.methodPost "test" [] mempty + withHTTP2Request Nothing req "127.0.0.1" port $ \resp -> do + let expected = mconcat (replicate 512 "Hello\n") + actual <- takeSourceT (fromIntegral (LBS.length expected)) (responseBody resp) + actual @?= expected + +withInfiniteMockServer :: (Int -> IO a) -> IO a +withInfiniteMockServer k = bracket (startMockServer Nothing app) fst (k . snd) + where + app _ respond = respond $ + Wai.responseStream HTTP.ok200 mempty $ \write flush -> + let go n = do + when (n == 0) flush + write (byteString "Hello\n") *> go (if n == 0 then 100 else n - 1) + in go (1000 :: Int) + +-- SourceT utilities + +takeStepT :: Builder -> Int -> StepT IO ByteString -> IO LByteString +takeStepT acc _ Stop = pure (toLazyByteString acc) +takeStepT acc _ (Error _) = pure (toLazyByteString acc) +takeStepT acc s (Skip next) = takeStepT acc s next +takeStepT acc s (Yield chunk next) + | BS.length chunk >= s = + pure $ toLazyByteString (acc <> byteString (BS.take s chunk)) + | otherwise = do + takeStepT (acc <> byteString chunk) (s - BS.length chunk) next +takeStepT acc s (Effect m) = m >>= takeStepT acc s + +takeSourceT :: Int -> SourceT IO ByteString -> IO LByteString +takeSourceT s m = unSourceT m (takeStepT mempty s) diff --git a/services/federator/test/unit/Test/Federator/ExternalServer.hs b/services/federator/test/unit/Test/Federator/ExternalServer.hs index a1c749cec4a..a70934f8dac 100644 --- a/services/federator/test/unit/Test/Federator/ExternalServer.hs +++ b/services/federator/test/unit/Test/Federator/ExternalServer.hs @@ -26,7 +26,7 @@ import qualified Data.Text.Encoding as Text import Federator.Discovery import Federator.Error.ServerError (ServerError (..)) import Federator.ExternalServer -import Federator.Service (Service) +import Federator.Service (Service (..), ServiceStreaming) import Federator.Validation import Imports import qualified Network.HTTP.Types as HTTP @@ -35,18 +35,17 @@ import qualified Network.Wai.Utilities.Server as Wai import Polysemy import Polysemy.Error import Polysemy.Input -import qualified Polysemy.TinyLog as TinyLog +import Polysemy.Output +import Polysemy.TinyLog +import qualified Servant.Client.Core as Servant +import Servant.Types.SourceT import Test.Federator.Options (noClientCertSettings) import Test.Federator.Util import Test.Federator.Validation (mockDiscoveryTrivial) -import Test.Polysemy.Mock (Mock (mock), evalMock) -import Test.Polysemy.Mock.TH (genMock) import Test.Tasty import Test.Tasty.HUnit import Wire.API.Federation.Component -genMock ''Service - tests :: TestTree tests = testGroup @@ -72,59 +71,79 @@ exampleRequest certFile path = do trBody = "\"foo\"" } +data Call = Call + { cComponent :: Component, + cPath :: ByteString, + cBody :: LByteString, + cDomain :: Domain + } + deriving (Eq, Show) + +mockService :: + Members [Output Call, Embed IO] r => + HTTP.Status -> + Sem (ServiceStreaming ': r) a -> + Sem r a +mockService status = interpret $ \case + ServiceCall comp path body domain -> do + output (Call comp path body domain) + pure + Servant.Response + { Servant.responseStatusCode = status, + Servant.responseHeaders = mempty, + Servant.responseHttpVersion = HTTP.http11, + Servant.responseBody = source ["\"bar\""] + } + requestBrigSuccess :: TestTree requestBrigSuccess = - testCase "should translate response from brig to 'InwardResponseBody' when response has status 200" $ do + testCase "should forward response from brig when status is 200" $ do request <- exampleRequest "test/resources/unit/localhost.example.com.pem" "/federation/brig/get-user-by-handle" - runM . evalMock @Service @IO $ do - mockServiceCallReturns @IO (\_ _ _ _ -> pure (HTTP.ok200, Just "\"bar\"")) - - res <- - mock @Service @IO - . assertNoError @ValidationError - . assertNoError @DiscoveryFailure - . assertNoError @ServerError - . TinyLog.discardLogs - . mockDiscoveryTrivial - . runInputConst noClientCertSettings - $ callInward request - actualCalls <- mockServiceCallCalls @IO - let expectedCall = (Brig, "/federation/get-user-by-handle", "\"foo\"", aValidDomain) - embed $ assertEqual "one call to brig should be made" [expectedCall] actualCalls - embed $ Wai.responseStatus res @?= HTTP.status200 - body <- embed $ Wai.lazyResponseBody res - embed $ body @?= "\"bar\"" + (actualCalls, res) <- + runM + . runOutputList + . mockService HTTP.ok200 + . assertNoError @ValidationError + . assertNoError @DiscoveryFailure + . assertNoError @ServerError + . discardLogs + . mockDiscoveryTrivial + . runInputConst noClientCertSettings + $ callInward request + let expectedCall = Call Brig "/federation/get-user-by-handle" "\"foo\"" aValidDomain + assertEqual "one call to brig should be made" [expectedCall] actualCalls + Wai.responseStatus res @?= HTTP.status200 + body <- Wai.lazyResponseBody res + body @?= "\"bar\"" requestBrigFailure :: TestTree requestBrigFailure = - testCase "should translate response from brig to 'InwardResponseError' when response has status 404" $ do + testCase "should preserve the status code returned by the service" $ do request <- exampleRequest "test/resources/unit/localhost.example.com.pem" "/federation/brig/get-user-by-handle" - runM . evalMock @Service @IO $ do - let brigResponseBody = "response body" - mockServiceCallReturns @IO (\_ _ _ _ -> pure (HTTP.notFound404, Just brigResponseBody)) - res <- - mock @Service @IO - . assertNoError @ValidationError - . assertNoError @DiscoveryFailure - . assertNoError @ServerError - . TinyLog.discardLogs - . mockDiscoveryTrivial - . runInputConst noClientCertSettings - $ callInward request - - actualCalls <- mockServiceCallCalls @IO - let expectedCall = (Brig, "/federation/get-user-by-handle", "\"foo\"", aValidDomain) - embed $ assertEqual "one call to brig should be made" [expectedCall] actualCalls - embed $ Wai.responseStatus res @?= HTTP.notFound404 - body <- embed $ Wai.lazyResponseBody res - embed $ body @?= brigResponseBody + (actualCalls, res) <- + runM + . runOutputList + . mockService HTTP.notFound404 + . assertNoError @ValidationError + . assertNoError @DiscoveryFailure + . assertNoError @ServerError + . discardLogs + . mockDiscoveryTrivial + . runInputConst noClientCertSettings + $ callInward request + + let expectedCall = Call Brig "/federation/get-user-by-handle" "\"foo\"" aValidDomain + assertEqual "one call to brig should be made" [expectedCall] actualCalls + Wai.responseStatus res @?= HTTP.notFound404 + body <- Wai.lazyResponseBody res + body @?= "\"bar\"" requestGalleySuccess :: TestTree requestGalleySuccess = @@ -134,20 +153,18 @@ requestGalleySuccess = "test/resources/unit/localhost.example.com.pem" "/federation/galley/get-conversations" - runM . evalMock @Service @IO $ do - mockServiceCallReturns @IO (\_ _ _ _ -> pure (HTTP.ok200, Just "\"bar\"")) - - res <- - mock @Service @IO + runM $ do + (actualCalls, res) <- + runOutputList + . mockService HTTP.ok200 . assertNoError @ValidationError . assertNoError @DiscoveryFailure . assertNoError @ServerError - . TinyLog.discardLogs + . discardLogs . mockDiscoveryTrivial . runInputConst noClientCertSettings $ callInward request - actualCalls <- mockServiceCallCalls @IO - let expectedCall = (Galley, "/federation/get-conversations", "\"foo\"", aValidDomain) + let expectedCall = Call Galley "/federation/get-conversations" "\"foo\"" aValidDomain embed $ assertEqual "one call to galley should be made" [expectedCall] actualCalls embed $ Wai.responseStatus res @?= HTTP.status200 body <- embed $ Wai.lazyResponseBody res @@ -164,20 +181,18 @@ requestNoDomain = trPath = "/federation/brig/get-users" } - runM . evalMock @Service @IO $ do - mockServiceCallReturns @IO (\_ _ _ _ -> pure (HTTP.ok200, Just "\"bar\"")) - - res <- - runError - . mock @Service @IO + runM $ do + (actualCalls, res) <- + runOutputList @Call + . mockService HTTP.ok200 + . runError . assertNoError @ValidationError . assertNoError @DiscoveryFailure - . TinyLog.discardLogs + . discardLogs . mockDiscoveryTrivial . runInputConst noClientCertSettings $ callInward request - actualCalls <- mockServiceCallCalls @IO embed $ assertEqual "no calls to services should be made" [] actualCalls embed $ void res @?= Left NoOriginDomain @@ -191,22 +206,20 @@ requestNoCertificate = trPath = "/federation/brig/get-users" } - runM . evalMock @Service @IO $ do - mockServiceCallReturns @IO (\_ _ _ _ -> pure (HTTP.ok200, Just "\"bar\"")) - - res <- - runError - . mock @Service @IO - . assertNoError @ServerError - . assertNoError @DiscoveryFailure - . TinyLog.discardLogs - . mockDiscoveryTrivial - . runInputConst noClientCertSettings - $ callInward request - - actualCalls <- mockServiceCallCalls @IO - embed $ assertEqual "no calls to services should be made" [] actualCalls - embed $ void res @?= Left NoClientCertificate + (actualCalls, res) <- + runM + . runOutputList @Call + . mockService HTTP.ok200 + . runError + . assertNoError @ServerError + . assertNoError @DiscoveryFailure + . discardLogs + . mockDiscoveryTrivial + . runInputConst noClientCertSettings + $ callInward request + + assertEqual "no calls to services should be made" [] actualCalls + void res @?= Left NoClientCertificate testInvalidPaths :: TestTree testInvalidPaths = do @@ -244,23 +257,20 @@ testInvalidPaths = do "test/resources/unit/localhost.example.com.pem" invalidPath - runM . evalMock @Service @IO $ do - mockServiceCallReturns @IO (\_ _ _ _ -> pure (HTTP.ok200, Just "\"bar\"")) - - res <- - runError @ServerError - . mock @Service @IO - . assertNoError @ValidationError - . assertNoError @DiscoveryFailure - . TinyLog.discardLogs - . mockDiscoveryTrivial - . runInputConst noClientCertSettings - $ callInward request - - embed $ assertEqual ("Expected request with path \"" <> cs invalidPath <> "\" to fail") (Left InvalidRoute) (void res) + (actualCalls, res) <- + runM + . runOutputList @Call + . mockService HTTP.ok200 + . runError @ServerError + . assertNoError @ValidationError + . assertNoError @DiscoveryFailure + . discardLogs + . mockDiscoveryTrivial + . runInputConst noClientCertSettings + $ callInward request - actualCalls <- mockServiceCallCalls @IO - embed $ assertEqual "no calls to any service should be made" [] actualCalls + assertEqual ("Expected request with path \"" <> cs invalidPath <> "\" to fail") (Left InvalidRoute) (void res) + assertEqual "no calls to any service should be made" [] actualCalls testInvalidComponent :: TestTree testInvalidComponent = @@ -270,22 +280,20 @@ testInvalidComponent = "test/resources/unit/localhost.example.com.pem" "/federation/mast/get-users" - runM . evalMock @Service @IO $ do - mockServiceCallReturns @IO (\_ _ _ _ -> pure (HTTP.ok200, Just "\"bar\"")) - - res <- - runError @ServerError - . mock @Service @IO - . assertNoError @ValidationError - . assertNoError @DiscoveryFailure - . TinyLog.discardLogs - . mockDiscoveryTrivial - . runInputConst noClientCertSettings - $ callInward request - - embed $ void res @?= Left (UnknownComponent "mast") - actualCalls <- mockServiceCallCalls @IO - embed $ assertEqual "no calls to any service should be made" [] actualCalls + (actualCalls, res) <- + runM + . runOutputList @Call + . mockService HTTP.ok200 + . runError @ServerError + . assertNoError @ValidationError + . assertNoError @DiscoveryFailure + . discardLogs + . mockDiscoveryTrivial + . runInputConst noClientCertSettings + $ callInward request + + void res @?= Left (UnknownComponent "mast") + assertEqual "no calls to any service should be made" [] actualCalls testMethod :: TestTree testMethod = @@ -304,10 +312,10 @@ testMethod = res <- runM . runError @ServerError - . interpret @Service (\_ -> embed $ assertFailure "unexpected call to service") + . interpret @ServiceStreaming (\_ -> embed $ assertFailure "unexpected call to service") . assertNoError @ValidationError . assertNoError @DiscoveryFailure - . TinyLog.discardLogs + . discardLogs . mockDiscoveryTrivial . runInputConst noClientCertSettings $ callInward request diff --git a/services/federator/test/unit/Test/Federator/InternalServer.hs b/services/federator/test/unit/Test/Federator/InternalServer.hs index 3def6a2c2a9..55452911f4b 100644 --- a/services/federator/test/unit/Test/Federator/InternalServer.hs +++ b/services/federator/test/unit/Test/Federator/InternalServer.hs @@ -19,7 +19,7 @@ module Test.Federator.InternalServer (tests) where -import Data.Binary.Builder +import Data.ByteString.Builder import Data.ByteString.Conversion import Data.Default import Data.Domain @@ -36,6 +36,8 @@ import Polysemy import Polysemy.Error import Polysemy.Input import Polysemy.TinyLog +import Servant.Client.Core +import Servant.Types.SourceT import Test.Federator.Options (noClientCertSettings) import Test.Federator.Util import Test.Tasty @@ -47,7 +49,8 @@ tests :: TestTree tests = testGroup "Federate" - [ testGroup "with remote" $ + [ testGroup + "with remote" [ federatedRequestSuccess, federatedRequestFailureAllowList ] @@ -78,7 +81,13 @@ federatedRequestSuccess = rpc @?= "get-user-by-handle" headers @?= requestHeaders toLazyByteString body @?= "\"foo\"" - pure (HTTP.status200, fromLazyByteString "\"bar\"") + pure + Response + { responseStatusCode = HTTP.ok200, + responseHeaders = mempty, + responseHttpVersion = HTTP.http20, + responseBody = source ["\"bar\""] + } res <- runM . interpretCall @@ -91,6 +100,9 @@ federatedRequestSuccess = body <- Wai.lazyResponseBody res body @?= "\"bar\"" +-- @SF.Federation @TSFI.RESTfulAPI @S2 @S3 @S7 +-- +-- Refuse to send outgoing request to non-included domain when allowlist is configured. federatedRequestFailureAllowList :: TestTree federatedRequestFailureAllowList = testCase "should not make a call when target domain not in the allowList" $ do @@ -107,7 +119,14 @@ federatedRequestFailureAllowList = let checkRequest :: Sem (Remote ': r) a -> Sem r a checkRequest = interpret $ \case - DiscoverAndCall {} -> pure (HTTP.status200, fromLazyByteString "\"bar\"") + DiscoverAndCall {} -> + pure + Response + { responseStatusCode = HTTP.ok200, + responseHeaders = mempty, + responseHttpVersion = HTTP.http20, + responseBody = source ["\"bar\""] + } eith <- runM @@ -119,3 +138,5 @@ federatedRequestFailureAllowList = . runInputConst settings $ callOutward request eith @?= Left (FederationDenied targetDomain) + +-- @END diff --git a/services/federator/test/unit/Test/Federator/Options.hs b/services/federator/test/unit/Test/Federator/Options.hs index 3bf5930a2dd..90345862734 100644 --- a/services/federator/test/unit/Test/Federator/Options.hs +++ b/services/federator/test/unit/Test/Federator/Options.hs @@ -171,7 +171,8 @@ testSettings = assertFailure $ "expected failure for non-existing client certificate, got: " <> show (tlsSettings ^. creds), - testCase "fail on invalid certificate" $ do + -- @SF.Federation @TSFI.RESTfulAPI @S3 @S7 + testCase "failToStartWithInvalidServerCredentials" $ do let settings = defRunSettings "test/resources/unit/invalid.pem" @@ -193,6 +194,7 @@ testSettings = assertFailure $ "expected failure for invalid client certificate, got: " <> show (tlsSettings ^. creds), + -- @END testCase "fail on invalid private key" $ do let settings = defRunSettings diff --git a/services/federator/test/unit/Test/Federator/Remote.hs b/services/federator/test/unit/Test/Federator/Remote.hs index 66689a26291..ce13842fb9c 100644 --- a/services/federator/test/unit/Test/Federator/Remote.hs +++ b/services/federator/test/unit/Test/Federator/Remote.hs @@ -18,6 +18,7 @@ module Test.Federator.Remote where import Control.Exception (bracket) +import Control.Monad.Codensity import Data.Domain import Federator.Discovery import Federator.Env (TLSSettings) @@ -31,6 +32,7 @@ import Network.Wai import qualified Network.Wai.Handler.Warp as Warp import qualified Network.Wai.Handler.WarpTLS as Warp import Polysemy +import Polysemy.Embed import Polysemy.Error import Polysemy.Input import Test.Federator.Options (defRunSettings) @@ -83,6 +85,7 @@ mkTestCall tlsSettings port = . runInputConst tlsSettings . discoverLocalhost port . assertNoError @DiscoveryFailure + . runEmbedded @(Codensity IO) @IO lowerCodensity . interpretRemote $ discoverAndCall (Domain "localhost") Brig "test" [] mempty diff --git a/services/federator/test/unit/Test/Federator/Response.hs b/services/federator/test/unit/Test/Federator/Response.hs index 8413b9b95a2..b8addefb8de 100644 --- a/services/federator/test/unit/Test/Federator/Response.hs +++ b/services/federator/test/unit/Test/Federator/Response.hs @@ -72,7 +72,7 @@ testDiscoveryFailure = throw (DiscoveryFailureDNSError "mock error") body <- Wai.lazyResponseBody resp let merr = Aeson.decode body - Wai.responseStatus resp @?= HTTP.status500 + Wai.responseStatus resp @?= HTTP.status400 fmap Wai.label merr @?= Just "discovery-failure" testRemoteError :: TestTree diff --git a/services/federator/test/unit/Test/Federator/Util.hs b/services/federator/test/unit/Test/Federator/Util.hs index a299276c396..ff8acc1be24 100644 --- a/services/federator/test/unit/Test/Federator/Util.hs +++ b/services/federator/test/unit/Test/Federator/Util.hs @@ -62,10 +62,9 @@ testRequest tr = do pure . flip Wai.setPath (trPath tr) $ Wai.defaultRequest { Wai.requestMethod = trMethod tr, - Wai.requestBody = atomicModifyIORef refChunks $ \bss -> - case bss of - [] -> ([], mempty) - x : y -> (y, x), + Wai.requestBody = atomicModifyIORef refChunks $ \case + [] -> ([], mempty) + x : y -> (y, x), Wai.requestHeaders = [("X-SSL-Certificate", HTTP.urlEncode True h) | h <- toList (trCertificateHeader tr)] <> [(originDomainHeaderName, h) | h <- toList (trDomainHeader tr)] diff --git a/services/federator/test/unit/Test/Federator/Validation.hs b/services/federator/test/unit/Test/Federator/Validation.hs index 4c4597a6c51..012ab593083 100644 --- a/services/federator/test/unit/Test/Federator/Validation.hs +++ b/services/federator/test/unit/Test/Federator/Validation.hs @@ -60,12 +60,15 @@ mockDiscoveryFailure = Polysemy.interpret $ \case tests :: TestTree tests = - testGroup "Validation" $ - [ testGroup "federateWith" $ + testGroup + "Validation" + [ testGroup + "federateWith" [ federateWithAllowListSuccess, federateWithAllowListFail ], - testGroup "validateDomain" $ + testGroup + "validateDomain" [ validateDomainAllowListFailSemantic, validateDomainAllowListFail, validateDomainAllowListSuccess, @@ -113,6 +116,9 @@ validateDomainAllowListFailSemantic = $ validateDomain (Just exampleCert) "invalid//.><-semantic-&@-domain" res @?= Left (DomainParseError "invalid//.><-semantic-&@-domain") +-- @SF.Federation @TSFI.RESTfulAPI @S2 @S3 @S7 +-- +-- Refuse to send outgoing request to non-included domain when allowlist is configured. validateDomainAllowListFail :: TestTree validateDomainAllowListFail = testCase "allow list validation" $ do @@ -127,6 +133,8 @@ validateDomainAllowListFail = $ validateDomain (Just exampleCert) "localhost.example.com" res @?= Left (FederationDenied (Domain "localhost.example.com")) +-- @END + validateDomainAllowListSuccess :: TestTree validateDomainAllowListSuccess = testCase "should give parsed domain if in the allow list" $ do @@ -153,6 +161,7 @@ validateDomainCertMissing = $ validateDomain Nothing "foo.example.com" res @?= Left NoClientCertificate +-- @SF.Federation @TSFI.RESTfulAPI @S2 @S3 @S7 validateDomainCertInvalid :: TestTree validateDomainCertInvalid = testCase "should fail if the client certificate is invalid" $ do @@ -164,6 +173,12 @@ validateDomainCertInvalid = $ validateDomain (Just "not a certificate") "foo.example.com" res @?= Left (CertificateParseError "no certificate found") +-- @END + +-- @SF.Federation @TSFI.RESTfulAPI @S3 @S7 +-- +-- Reject request if the infrastructure domain in the client cert does not match the backend +-- domain in the `Wire-origin-domain` header. validateDomainCertWrongDomain :: TestTree validateDomainCertWrongDomain = testCase "should fail if the client certificate has a wrong domain" $ do @@ -176,6 +191,8 @@ validateDomainCertWrongDomain = $ validateDomain (Just exampleCert) "foo.example.com" res @?= Left (AuthenticationFailure (pure [X509.NameMismatch "foo.example.com"])) +-- @END + validateDomainCertCN :: TestTree validateDomainCertCN = testCase "should succeed if the certificate has subject CN but no SAN" $ do diff --git a/services/galley/Makefile b/services/galley/Makefile index 0ab7e4bc276..5dbde93dabf 100644 --- a/services/galley/Makefile +++ b/services/galley/Makefile @@ -127,7 +127,7 @@ db-migrate-data: docker: $(foreach executable,$(EXECUTABLES),\ docker build -t $(DOCKER_USER)/$(executable):$(DOCKER_TAG) \ - -f ../../build/alpine/Dockerfile.executable \ + -f ../../build/ubuntu/Dockerfile.executable \ --build-arg executable=$(executable) \ ../.. && \ docker tag $(DOCKER_USER)/$(executable):$(DOCKER_TAG) $(DOCKER_USER)/$(executable):latest && \ diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index 680261a3317..94cca2e39b9 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -1,10 +1,8 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack --- --- hash: 7b6d6110c4a94aa87c7d65d1e004acb6cbc1ce6775be39cde27ff7e5eca83f59 name: galley version: 0.83.0 @@ -38,6 +36,7 @@ library Galley.API.Message Galley.API.One2One Galley.API.Public + Galley.API.Public.Servant Galley.API.Query Galley.API.Teams Galley.API.Teams.Features @@ -126,7 +125,46 @@ library Paths_galley 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 + 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 build-depends: HsOpenSSL >=0.11 @@ -222,7 +260,46 @@ executable galley main-is: src/Main.hs other-modules: Paths_galley - 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 + 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=-T -rtsopts build-depends: HsOpenSSL @@ -253,6 +330,7 @@ executable galley-integration API API.CustomBackend API.Federation + API.Federation.Util API.MessageTimer API.Roles API.SQS @@ -267,7 +345,46 @@ executable galley-integration Paths_galley hs-source-dirs: test/integration - 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 + 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 build-depends: HsOpenSSL @@ -304,6 +421,7 @@ executable galley-integration , http-client , http-client-openssl , http-client-tls + , http-media , http-types , imports , lens @@ -365,7 +483,46 @@ executable galley-migrate-data Paths_galley hs-source-dirs: migrate-data/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 + 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 build-depends: base @@ -438,10 +595,50 @@ executable galley-schema V54_TeamFeatureSelfDeletingMessages V55_SelfDeletingMessagesLockStatus V56_GuestLinksTeamFeatureStatus + V57_GuestLinksLockStatus Paths_galley hs-source-dirs: schema/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 + 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 build-depends: base @@ -479,7 +676,46 @@ test-suite galley-tests Paths_galley hs-source-dirs: test/unit - 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 + 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-depends: QuickCheck diff --git a/services/galley/package.yaml b/services/galley/package.yaml index e0b49c8d9ab..0b490e184b2 100644 --- a/services/galley/package.yaml +++ b/services/galley/package.yaml @@ -182,6 +182,7 @@ executables: - http-client - http-client-openssl - http-client-tls + - http-media - http-types - lens - lens-aeson diff --git a/services/galley/schema/src/Main.hs b/services/galley/schema/src/Main.hs index 63cda90e089..e67775ed7a6 100644 --- a/services/galley/schema/src/Main.hs +++ b/services/galley/schema/src/Main.hs @@ -59,6 +59,7 @@ import qualified V53_AddRemoteConvStatus import qualified V54_TeamFeatureSelfDeletingMessages import qualified V55_SelfDeletingMessagesLockStatus import qualified V56_GuestLinksTeamFeatureStatus +import qualified V57_GuestLinksLockStatus main :: IO () main = do @@ -103,7 +104,8 @@ main = do V53_AddRemoteConvStatus.migration, V54_TeamFeatureSelfDeletingMessages.migration, V55_SelfDeletingMessagesLockStatus.migration, - V56_GuestLinksTeamFeatureStatus.migration + V56_GuestLinksTeamFeatureStatus.migration, + V57_GuestLinksLockStatus.migration -- When adding migrations here, don't forget to update -- 'schemaVersion' in Galley.Cassandra -- (see also docs/developer/cassandra-interaction.md) diff --git a/services/cannon/src/Cannon/API.hs b/services/galley/schema/src/V57_GuestLinksLockStatus.hs similarity index 69% rename from services/cannon/src/Cannon/API.hs rename to services/galley/schema/src/V57_GuestLinksLockStatus.hs index 7160ed50abe..6afa380236e 100644 --- a/services/cannon/src/Cannon/API.hs +++ b/services/galley/schema/src/V57_GuestLinksLockStatus.hs @@ -15,19 +15,19 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Cannon.API - ( sitemap, +module V57_GuestLinksLockStatus + ( migration, ) where -import qualified Cannon.API.Internal as Internal -import qualified Cannon.API.Public as Public -import Cannon.Types (Cannon) -import qualified Data.Swagger.Build.Api as Doc -import Network.Wai.Routing (Routes) +import Cassandra.Schema +import Imports +import Text.RawString.QQ -sitemap :: Routes Doc.ApiBuilder Cannon () -sitemap = do - Public.sitemap - Public.apiDocs - Internal.sitemap +migration :: Migration +migration = Migration 57 "Add lock status for guest links team feature" $ do + schema' + [r| ALTER TABLE team_features ADD ( + guest_links_lock_status int + ) + |] diff --git a/services/galley/src/Galley/API.hs b/services/galley/src/Galley/API.hs index 1ae9c9a234d..f5d86ff5c88 100644 --- a/services/galley/src/Galley/API.hs +++ b/services/galley/src/Galley/API.hs @@ -17,13 +17,14 @@ module Galley.API ( sitemap, - Public.servantSitemap, + servantSitemap, ) where import qualified Data.Swagger.Build.Api as Doc import qualified Galley.API.Internal as Internal import qualified Galley.API.Public as Public +import Galley.API.Public.Servant import Galley.App (GalleyEffects) import Network.Wai.Routing (Routes) import Polysemy diff --git a/services/galley/src/Galley/API/Action.hs b/services/galley/src/Galley/API/Action.hs index 7a13e8396e1..4275f105d86 100644 --- a/services/galley/src/Galley/API/Action.hs +++ b/services/galley/src/Galley/API/Action.hs @@ -75,7 +75,7 @@ import Wire.API.Conversation.Role import Wire.API.ErrorDescription import Wire.API.Event.Conversation hiding (Conversation) import Wire.API.Federation.API -import qualified Wire.API.Federation.API.Galley as F +import Wire.API.Federation.API.Galley import Wire.API.Federation.Error import Wire.API.Team.LegalHold import Wire.API.Team.Member @@ -526,8 +526,8 @@ notifyConversationAction quid con lcnv targets action = do -- notify remote participants E.runFederatedConcurrently_ (toList (bmRemotes targets)) $ \ruids -> - F.onConversationUpdated clientRoutes $ - F.ConversationUpdate now quid (tUnqualified lcnv) (tUnqualified ruids) action + fedClient @'Galley @"on-conversation-updated" $ + ConversationUpdate now quid (tUnqualified lcnv) (tUnqualified ruids) action -- notify local participants and bots pushConversationEvent con e (qualifyAs lcnv (bmLocals targets)) (bmBots targets) $> e diff --git a/services/galley/src/Galley/API/Error.hs b/services/galley/src/Galley/API/Error.hs index a4569e788c9..2e5a8a9afd5 100644 --- a/services/galley/src/Galley/API/Error.hs +++ b/services/galley/src/Galley/API/Error.hs @@ -122,6 +122,7 @@ data ConversationError | ConvMemberNotFound | NoBindingTeamMembers | NoManagedTeamConv + | GuestLinksDisabled instance APIError ConversationError where toWai ConvAccessDenied = errorDescriptionTypeToWai @ConvAccessDenied @@ -130,6 +131,7 @@ instance APIError ConversationError where toWai ConvMemberNotFound = errorDescriptionTypeToWai @ConvMemberNotFound toWai NoBindingTeamMembers = noBindingTeamMembers toWai NoManagedTeamConv = noManagedTeamConv + toWai GuestLinksDisabled = guestLinksDisabled data TeamError = NoBindingTeam @@ -396,6 +398,9 @@ teamMemberNotFound = mkError status404 "no-team-member" "team member not found" noManagedTeamConv :: Error noManagedTeamConv = mkError status400 "no-managed-team-conv" "Managed team conversations have been deprecated." +guestLinksDisabled :: Error +guestLinksDisabled = mkError status409 "guest-links-disabled" "The guest link feature is disabled and all guest links have been revoked." + userBindingExists :: Error userBindingExists = mkError status403 "binding-exists" "User already bound to a different team." diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index 1dbc5805967..87a36835cea 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -53,8 +53,6 @@ import Polysemy.Input import qualified Polysemy.TinyLog as P import Servant (ServerT) import Servant.API -import Servant.API.Generic (ToServantApi) -import Servant.Server.Generic (genericServerT) import qualified System.Logger.Class as Log import qualified Wire.API.Conversation as Public import Wire.API.Conversation.Action @@ -65,23 +63,21 @@ import Wire.API.Federation.API import Wire.API.Federation.API.Common (EmptyResponse (..)) import qualified Wire.API.Federation.API.Galley as F import Wire.API.Routes.Internal.Brig.Connection +import Wire.API.Routes.Named import Wire.API.ServantProto import Wire.API.User.Client (userClientMap) -type FederationAPI = "federation" :> ToServantApi (FedApi 'Galley) +type FederationAPI = "federation" :> FedApi 'Galley federationSitemap :: ServerT FederationAPI (Sem GalleyEffects) federationSitemap = - genericServerT $ - F.GalleyApi - { F.onConversationCreated = onConversationCreated, - F.getConversations = getConversations, - F.onConversationUpdated = onConversationUpdated, - F.leaveConversation = leaveConversation, - F.onMessageSent = onMessageSent, - F.sendMessage = sendMessage, - F.onUserDeleted = onUserDeleted - } + Named @"on-conversation-created" onConversationCreated + :<|> Named @"get-conversations" getConversations + :<|> Named @"on-conversation-updated" onConversationUpdated + :<|> Named @"leave-conversation" leaveConversation + :<|> Named @"on-message-sent" onMessageSent + :<|> Named @"send-message" sendMessage + :<|> Named @"on-user-deleted-conversations" onUserDeleted onConversationCreated :: Members '[BrigAccess, GundeckAccess, ExternalAccess, Input (Local ()), MemberStore, P.TinyLog] r => diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index ff2b743f92f..34fca3d53c3 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -97,7 +97,7 @@ import Wire.API.Conversation (ConvIdsPage, pattern GetPaginatedConversationIds) import Wire.API.Conversation.Action (ConversationAction (ConversationActionRemoveMembers)) import Wire.API.ErrorDescription import Wire.API.Federation.API -import Wire.API.Federation.API.Galley hiding (getConversations) +import Wire.API.Federation.API.Galley import Wire.API.Federation.Error import Wire.API.Routes.MultiTablePaging (mtpHasMore, mtpPagingState, mtpResults) import Wire.API.Routes.MultiVerb (MultiVerb, RespondEmpty) @@ -198,6 +198,15 @@ data InternalApi routes = InternalApi iTeamFeatureLockStatusSelfDeletingMessagesPut :: routes :- IFeatureStatusLockStatusPut 'Public.TeamFeatureSelfDeletingMessages, + iTeamFeatureStatusGuestLinksGet :: + routes + :- IFeatureStatusGet 'Public.WithLockStatus 'Public.TeamFeatureGuestLinks, + iTeamFeatureStatusGuestLinksPut :: + routes + :- IFeatureStatusPut 'Public.TeamFeatureGuestLinks, + iTeamFeatureLockStatusGuestLinksPut :: + routes + :- IFeatureStatusLockStatusPut 'Public.TeamFeatureGuestLinks, -- This endpoint can lead to the following events being sent: -- - MemberLeave event to members for all conversations the user was in iDeleteUser :: @@ -318,6 +327,9 @@ servantSitemap = iTeamFeatureStatusSelfDeletingMessagesPut = iPutTeamFeature @'Public.TeamFeatureSelfDeletingMessages Features.setSelfDeletingMessagesInternal, iTeamFeatureStatusSelfDeletingMessagesGet = iGetTeamFeature @'Public.WithLockStatus @'Public.TeamFeatureSelfDeletingMessages Features.getSelfDeletingMessagesInternal, iTeamFeatureLockStatusSelfDeletingMessagesPut = Features.setLockStatus @'Public.TeamFeatureSelfDeletingMessages, + iTeamFeatureStatusGuestLinksGet = iGetTeamFeature @'Public.WithLockStatus @'Public.TeamFeatureGuestLinks Features.getGuestLinkInternal, + iTeamFeatureStatusGuestLinksPut = iPutTeamFeature @'Public.TeamFeatureGuestLinks Features.setGuestLinkInternal, + iTeamFeatureLockStatusGuestLinksPut = Features.setLockStatus @'Public.TeamFeatureGuestLinks, iDeleteUser = rmUser, iConnect = Create.createConnectConversation, iUpsertOne2OneConversation = One2One.iUpsertOne2OneConversation @@ -615,7 +627,7 @@ rmUser lusr conn = do cuAlreadyPresentUsers = tUnqualified remotes, cuAction = ConversationActionRemoveMembers (pure qUser) } - let rpc = onConversationUpdated clientRoutes convUpdate + let rpc = fedClient @'Galley @"on-conversation-updated" convUpdate runFederatedEither remotes rpc >>= logAndIgnoreError "Error in onConversationUpdated call" (qUnqualified qUser) @@ -623,7 +635,7 @@ rmUser lusr conn = do leaveRemoteConversations cids = do for_ (bucketRemote (fromRange cids)) $ \remoteConvs -> do let userDelete = UserDeletedConversationsNotification (tUnqualified lusr) (unsafeRange (tUnqualified remoteConvs)) - let rpc = onUserDeleted clientRoutes userDelete + let rpc = fedClient @'Galley @"on-user-deleted-conversations" userDelete runFederatedEither remoteConvs rpc >>= logAndIgnoreError "Error in onUserDeleted call" (tUnqualified lusr) diff --git a/services/galley/src/Galley/API/Message.hs b/services/galley/src/Galley/API/Message.hs index d67099657ef..d17247040d7 100644 --- a/services/galley/src/Galley/API/Message.hs +++ b/services/galley/src/Galley/API/Message.hs @@ -192,7 +192,7 @@ getRemoteClients remoteMembers = where getRemoteClientsFromDomain (qUntagged -> Qualified uids domain) = Map.mapKeys (domain,) . fmap (Set.map pubClientId) . userMap - <$> getUserClients clientRoutes (GetUserClients uids) + <$> fedClient @'Brig @"get-user-clients" (GetUserClients uids) -- FUTUREWORK: sender should be Local UserId postRemoteOtrMessage :: @@ -208,7 +208,7 @@ postRemoteOtrMessage sender conv rawMsg = do msrSender = qUnqualified sender, msrRawMessage = Base64ByteString rawMsg } - rpc = sendMessage clientRoutes msr + rpc = fedClient @'Galley @"send-message" msr msResponse <$> runFederated conv rpc postQualifiedOtrMessage :: @@ -409,7 +409,7 @@ sendRemoteMessages domain now sender senderClient lcnv metadata messages = (hand rmTransient = mmTransient metadata, rmRecipients = UserClientMap rcpts } - let rpc = onMessageSent clientRoutes rm + let rpc = fedClient @'Galley @"on-message-sent" rm runFederatedEither domain rpc where handle :: Either FederationError a -> Sem r (Set (UserId, ClientId)) diff --git a/services/galley/src/Galley/API/Public.hs b/services/galley/src/Galley/API/Public.hs index 31d41ae0531..d298dc30641 100644 --- a/services/galley/src/Galley/API/Public.hs +++ b/services/galley/src/Galley/API/Public.hs @@ -18,7 +18,6 @@ module Galley.API.Public ( sitemap, apiDocs, filterMissing, -- for tests - servantSitemap, ) where @@ -31,17 +30,14 @@ import qualified Data.Set as Set import Data.Swagger.Build.Api hiding (Response, def, min) import qualified Data.Swagger.Build.Api as Swagger import Data.Text.Encoding (decodeLatin1) -import qualified Galley.API.Create as Create import qualified Galley.API.CustomBackend as CustomBackend import qualified Galley.API.Error as Error import qualified Galley.API.LegalHold as LegalHold import qualified Galley.API.Query as Query import qualified Galley.API.Teams as Teams -import Galley.API.Teams.Features (DoAuth (..), getFeatureStatus, setFeatureStatus) import qualified Galley.API.Teams.Features as Features import qualified Galley.API.Update as Update import Galley.App -import Galley.Cassandra.Paging import Imports hiding (head) import Network.HTTP.Types import Network.Wai @@ -53,9 +49,6 @@ import Network.Wai.Utilities import Network.Wai.Utilities.Swagger import Network.Wai.Utilities.ZAuth hiding (ZAuthUser) import Polysemy -import Servant hiding (Handler, JSON, addHeader, contentType, respond) -import Servant.Server.Generic (genericServerT) -import Servant.Swagger.Internal.Orphans () import qualified Wire.API.Conversation.Code as Public import qualified Wire.API.Conversation.Typing as Public import qualified Wire.API.CustomBackend as Public @@ -63,10 +56,8 @@ import qualified Wire.API.ErrorDescription as Error import qualified Wire.API.Event.Team as Public () import qualified Wire.API.Message as Public import qualified Wire.API.Notification as Public -import qualified Wire.API.Routes.Public.Galley as GalleyAPI import qualified Wire.API.Swagger as Public.Swagger (models) import qualified Wire.API.Team as Public -import qualified Wire.API.Team.Feature as Public import qualified Wire.API.Team.LegalHold as Public import qualified Wire.API.Team.Member as Public import qualified Wire.API.Team.Permission as Public @@ -74,172 +65,10 @@ import qualified Wire.API.Team.SearchVisibility as Public import qualified Wire.API.User as Public (UserIdList, modelUserIdList) import Wire.Swagger (int32Between) -servantSitemap :: ServerT GalleyAPI.ServantAPI (Sem GalleyEffects) -servantSitemap = - genericServerT $ - GalleyAPI.Api - { GalleyAPI.getUnqualifiedConversation = Query.getUnqualifiedConversation, - GalleyAPI.getConversation = Query.getConversation, - GalleyAPI.getConversationRoles = Query.getConversationRoles, - GalleyAPI.listConversationIdsUnqualified = Query.conversationIdsPageFromUnqualified, - GalleyAPI.listConversationIds = Query.conversationIdsPageFrom, - GalleyAPI.getConversations = Query.getConversations, - GalleyAPI.getConversationByReusableCode = Query.getConversationByReusableCode, - GalleyAPI.listConversations = Query.listConversations, - GalleyAPI.createGroupConversation = Create.createGroupConversation, - GalleyAPI.createSelfConversation = Create.createSelfConversation, - GalleyAPI.createOne2OneConversation = Create.createOne2OneConversation, - GalleyAPI.addMembersToConversationUnqualified = Update.addMembersUnqualified, - GalleyAPI.addMembersToConversation = Update.addMembers, - GalleyAPI.removeMemberUnqualified = Update.removeMemberUnqualified, - GalleyAPI.removeMember = Update.removeMemberQualified, - GalleyAPI.updateOtherMemberUnqualified = Update.updateOtherMemberUnqualified, - GalleyAPI.updateOtherMember = Update.updateOtherMember, - GalleyAPI.updateConversationNameDeprecated = Update.updateUnqualifiedConversationName, - GalleyAPI.updateConversationNameUnqualified = Update.updateUnqualifiedConversationName, - GalleyAPI.updateConversationName = Update.updateConversationName, - GalleyAPI.updateConversationMessageTimerUnqualified = - Update.updateConversationMessageTimerUnqualified, - GalleyAPI.updateConversationMessageTimer = Update.updateConversationMessageTimer, - GalleyAPI.updateConversationReceiptModeUnqualified = - Update.updateConversationReceiptModeUnqualified, - GalleyAPI.updateConversationReceiptMode = Update.updateConversationReceiptMode, - GalleyAPI.updateConversationAccessUnqualified = - Update.updateConversationAccessUnqualified, - GalleyAPI.updateConversationAccess = Update.updateConversationAccess, - GalleyAPI.getConversationSelfUnqualified = Query.getLocalSelf, - GalleyAPI.updateConversationSelfUnqualified = Update.updateUnqualifiedSelfMember, - GalleyAPI.updateConversationSelf = Update.updateSelfMember, - GalleyAPI.getTeamConversationRoles = Teams.getTeamConversationRoles, - GalleyAPI.getTeamConversations = Teams.getTeamConversations, - GalleyAPI.getTeamConversation = Teams.getTeamConversation, - GalleyAPI.deleteTeamConversation = Teams.deleteTeamConversation, - GalleyAPI.postOtrMessageUnqualified = Update.postOtrMessageUnqualified, - GalleyAPI.postProteusMessage = Update.postProteusMessage, - GalleyAPI.teamFeatureStatusSSOGet = - getFeatureStatus @'Public.WithoutLockStatus @'Public.TeamFeatureSSO Features.getSSOStatusInternal - . DoAuth, - GalleyAPI.teamFeatureStatusLegalHoldGet = - getFeatureStatus @'Public.WithoutLockStatus @'Public.TeamFeatureLegalHold Features.getLegalholdStatusInternal - . DoAuth, - GalleyAPI.teamFeatureStatusLegalHoldPut = - setFeatureStatus @'Public.TeamFeatureLegalHold (Features.setLegalholdStatusInternal @InternalPaging) . DoAuth, - GalleyAPI.teamFeatureStatusSearchVisibilityGet = - getFeatureStatus @'Public.WithoutLockStatus @'Public.TeamFeatureSearchVisibility Features.getTeamSearchVisibilityAvailableInternal - . DoAuth, - GalleyAPI.teamFeatureStatusSearchVisibilityPut = - setFeatureStatus @'Public.TeamFeatureSearchVisibility Features.setTeamSearchVisibilityAvailableInternal - . DoAuth, - GalleyAPI.teamFeatureStatusSearchVisibilityDeprecatedGet = - getFeatureStatus @'Public.WithoutLockStatus @'Public.TeamFeatureSearchVisibility Features.getTeamSearchVisibilityAvailableInternal - . DoAuth, - GalleyAPI.teamFeatureStatusSearchVisibilityDeprecatedPut = - setFeatureStatus @'Public.TeamFeatureSearchVisibility Features.setTeamSearchVisibilityAvailableInternal - . DoAuth, - GalleyAPI.teamFeatureStatusValidateSAMLEmailsGet = - getFeatureStatus @'Public.WithoutLockStatus @'Public.TeamFeatureValidateSAMLEmails Features.getValidateSAMLEmailsInternal - . DoAuth, - GalleyAPI.teamFeatureStatusValidateSAMLEmailsDeprecatedGet = - getFeatureStatus @'Public.WithoutLockStatus @'Public.TeamFeatureValidateSAMLEmails Features.getValidateSAMLEmailsInternal - . DoAuth, - GalleyAPI.teamFeatureStatusDigitalSignaturesGet = - getFeatureStatus @'Public.WithoutLockStatus @'Public.TeamFeatureDigitalSignatures Features.getDigitalSignaturesInternal - . DoAuth, - GalleyAPI.teamFeatureStatusDigitalSignaturesDeprecatedGet = - getFeatureStatus @'Public.WithoutLockStatus @'Public.TeamFeatureDigitalSignatures Features.getDigitalSignaturesInternal - . DoAuth, - GalleyAPI.teamFeatureStatusAppLockGet = - getFeatureStatus @'Public.WithoutLockStatus @'Public.TeamFeatureAppLock Features.getAppLockInternal - . DoAuth, - GalleyAPI.teamFeatureStatusAppLockPut = - setFeatureStatus @'Public.TeamFeatureAppLock Features.setAppLockInternal - . DoAuth, - GalleyAPI.teamFeatureStatusFileSharingGet = - getFeatureStatus @'Public.WithoutLockStatus @'Public.TeamFeatureFileSharing Features.getFileSharingInternal . DoAuth, - GalleyAPI.teamFeatureStatusFileSharingPut = - setFeatureStatus @'Public.TeamFeatureFileSharing Features.setFileSharingInternal . DoAuth, - GalleyAPI.teamFeatureStatusClassifiedDomainsGet = - getFeatureStatus @'Public.WithoutLockStatus @'Public.TeamFeatureClassifiedDomains Features.getClassifiedDomainsInternal - . DoAuth, - GalleyAPI.teamFeatureStatusConferenceCallingGet = - getFeatureStatus @'Public.WithoutLockStatus @'Public.TeamFeatureConferenceCalling Features.getConferenceCallingInternal - . DoAuth, - GalleyAPI.teamFeatureStatusSelfDeletingMessagesGet = - 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.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) () sitemap = do -- Team API ----------------------------------------------------------- - post "/teams" (continue Teams.createNonBindingTeamH) $ - zauthUserId - .&. zauthConnId - .&. jsonRequest @Public.NonBindingNewTeam - .&. accept "application" "json" - document "POST" "createNonBindingTeam" $ do - summary "Create a new non binding team" - body (ref Public.modelNewNonBindingTeam) $ - description "JSON body" - response 201 "Team ID as `Location` header value" end - errorResponse (Error.errorDescriptionTypeToWai @Error.NotConnected) - - put "/teams/:tid" (continue Teams.updateTeamH) $ - zauthUserId - .&. zauthConnId - .&. capture "tid" - .&. jsonRequest @Public.TeamUpdateData - .&. accept "application" "json" - document "PUT" "updateTeam" $ do - summary "Update team properties" - parameter Path "tid" bytes' $ - description "Team ID" - body (ref Public.modelUpdateData) $ - description "JSON body" - errorResponse (Error.errorDescriptionTypeToWai @Error.NotATeamMember) - errorResponse (Error.errorDescriptionToWai (Error.operationDenied Public.SetTeamData)) - - get "/teams" (continue Teams.getManyTeamsH) $ - zauthUserId - .&. opt (query "ids" ||| query "start") - .&. def (unsafeRange 100) (query "size") - .&. accept "application" "json" - document "GET" "getManyTeams" $ do - parameter Query "ids" (array string') $ do - optional - description "At most 32 team IDs per request. Mutually exclusive with `start`." - parameter Query "start" string' $ do - optional - description "Team ID to start from (exclusive). Mutually exclusive with `ids`." - parameter Query "size" (int32Between 1 100) $ do - optional - description "Max. number of teams to return" - summary "Get teams" - returns (ref Public.modelTeamList) - response 200 "Teams list" end - get "/teams/:tid" (continue Teams.getTeamH) $ zauthUserId .&. capture "tid" diff --git a/services/galley/src/Galley/API/Public/Servant.hs b/services/galley/src/Galley/API/Public/Servant.hs new file mode 100644 index 00000000000..90ce6ca3a39 --- /dev/null +++ b/services/galley/src/Galley/API/Public/Servant.hs @@ -0,0 +1,234 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.API.Public.Servant (servantSitemap) where + +import Galley.API.Create +import Galley.API.Query +import Galley.API.Teams +import Galley.API.Teams.Features +import Galley.API.Update +import Galley.App +import Galley.Cassandra.Paging +import Imports +import Polysemy +import Servant.API +import Servant.Server +import Wire.API.Routes.Named +import Wire.API.Routes.Public.Galley +import Wire.API.Team.Feature + +servantSitemap :: ServerT ServantAPI (Sem GalleyEffects) +servantSitemap = conversations :<|> teamConversations :<|> messaging :<|> team :<|> features + where + conversations = + Named @"get-unqualified-conversation" getUnqualifiedConversation + :<|> Named @"get-conversation" getConversation + :<|> Named @"get-conversation-roles" getConversationRoles + :<|> Named @"list-conversation-ids-unqualified" conversationIdsPageFromUnqualified + :<|> Named @"list-conversation-ids" conversationIdsPageFrom + :<|> Named @"get-conversations" getConversations + :<|> Named @"list-conversations" listConversations + :<|> Named @"get-conversation-by-reusable-code" getConversationByReusableCode + :<|> Named @"create-group-conversation" createGroupConversation + :<|> Named @"create-self-conversation" createSelfConversation + :<|> Named @"create-one-to-one-conversation" createOne2OneConversation + :<|> Named @"add-members-to-conversation-unqualified" addMembersUnqualified + :<|> Named @"add-members-to-conversation" addMembers + :<|> Named @"remove-member-unqualified" removeMemberUnqualified + :<|> Named @"remove-member" removeMemberQualified + :<|> Named @"update-other-member-unqualified" updateOtherMemberUnqualified + :<|> Named @"update-other-member" updateOtherMember + :<|> Named @"update-conversation-name-deprecated" updateUnqualifiedConversationName + :<|> Named @"update-conversation-name-unqualified" updateUnqualifiedConversationName + :<|> Named @"update-conversation-name" updateConversationName + :<|> Named @"update-conversation-message-timer-unqualified" updateConversationMessageTimerUnqualified + :<|> Named @"update-conversation-message-timer" updateConversationMessageTimer + :<|> Named @"update-conversation-receipt-mode-unqualified" updateConversationReceiptModeUnqualified + :<|> Named @"update-conversation-receipt-mode" updateConversationReceiptMode + :<|> Named @"update-conversation-access-unqualified" updateConversationAccessUnqualified + :<|> Named @"update-conversation-access" updateConversationAccess + :<|> Named @"get-conversation-self-unqualified" getLocalSelf + :<|> Named @"update-conversation-self-unqualified" updateUnqualifiedSelfMember + :<|> Named @"update-conversation-self" updateSelfMember + + teamConversations = + Named @"get-team-conversation-roles" getTeamConversationRoles + :<|> Named @"get-team-conversations" getTeamConversations + :<|> Named @"get-team-conversation" getTeamConversation + :<|> Named @"delete-team-conversation" deleteTeamConversation + + messaging = + Named @"post-otr-message-unqualified" postOtrMessageUnqualified + :<|> Named @"post-proteus-message" postProteusMessage + + team = + Named @"create-non-binding-team" createNonBindingTeamH + :<|> Named @"update-team" updateTeamH + :<|> Named @"get-teams" getManyTeams + + features = + Named @'("get", 'TeamFeatureSSO) + ( getFeatureStatus @'WithoutLockStatus @'TeamFeatureSSO + getSSOStatusInternal + . DoAuth + ) + :<|> Named @'("get", 'TeamFeatureLegalHold) + ( getFeatureStatus @'WithoutLockStatus @'TeamFeatureLegalHold + getLegalholdStatusInternal + . DoAuth + ) + :<|> Named @'("put", 'TeamFeatureLegalHold) + ( setFeatureStatus @'TeamFeatureLegalHold + (setLegalholdStatusInternal @InternalPaging) + . DoAuth + ) + :<|> Named @'("get", 'TeamFeatureSearchVisibility) + ( getFeatureStatus @'WithoutLockStatus @'TeamFeatureSearchVisibility + getTeamSearchVisibilityAvailableInternal + . DoAuth + ) + :<|> Named @'("put", 'TeamFeatureSearchVisibility) + ( setFeatureStatus @'TeamFeatureSearchVisibility + setTeamSearchVisibilityAvailableInternal + . DoAuth + ) + :<|> Named @'("get-deprecated", 'TeamFeatureSearchVisibility) + ( getFeatureStatus @'WithoutLockStatus @'TeamFeatureSearchVisibility + getTeamSearchVisibilityAvailableInternal + . DoAuth + ) + :<|> Named @'("put-deprecated", 'TeamFeatureSearchVisibility) + ( setFeatureStatus @'TeamFeatureSearchVisibility + setTeamSearchVisibilityAvailableInternal + . DoAuth + ) + :<|> Named @'("get", 'TeamFeatureValidateSAMLEmails) + ( getFeatureStatus @'WithoutLockStatus @'TeamFeatureValidateSAMLEmails + getValidateSAMLEmailsInternal + . DoAuth + ) + :<|> Named @'("get-deprecated", 'TeamFeatureValidateSAMLEmails) + ( getFeatureStatus @'WithoutLockStatus @'TeamFeatureValidateSAMLEmails + getValidateSAMLEmailsInternal + . DoAuth + ) + :<|> Named @'("get", 'TeamFeatureDigitalSignatures) + ( getFeatureStatus @'WithoutLockStatus @'TeamFeatureDigitalSignatures + getDigitalSignaturesInternal + . DoAuth + ) + :<|> Named @'("get-deprecated", 'TeamFeatureDigitalSignatures) + ( getFeatureStatus @'WithoutLockStatus @'TeamFeatureDigitalSignatures + getDigitalSignaturesInternal + . DoAuth + ) + :<|> Named @'("get", 'TeamFeatureAppLock) + ( getFeatureStatus @'WithoutLockStatus @'TeamFeatureAppLock + getAppLockInternal + . DoAuth + ) + :<|> Named @'("put", 'TeamFeatureAppLock) + ( setFeatureStatus @'TeamFeatureAppLock + setAppLockInternal + . DoAuth + ) + :<|> Named @'("get", 'TeamFeatureFileSharing) + ( getFeatureStatus @'WithoutLockStatus @'TeamFeatureFileSharing + getFileSharingInternal + . DoAuth + ) + :<|> Named @'("put", 'TeamFeatureFileSharing) + ( setFeatureStatus @'TeamFeatureFileSharing + setFileSharingInternal + . DoAuth + ) + :<|> Named @'("get", 'TeamFeatureClassifiedDomains) + ( getFeatureStatus @'WithoutLockStatus @'TeamFeatureClassifiedDomains + getClassifiedDomainsInternal + . DoAuth + ) + :<|> Named @'("get", 'TeamFeatureConferenceCalling) + ( getFeatureStatus @'WithoutLockStatus @'TeamFeatureConferenceCalling + getConferenceCallingInternal + . DoAuth + ) + :<|> Named @'("get", 'TeamFeatureSelfDeletingMessages) + ( getFeatureStatus @'WithLockStatus @'TeamFeatureSelfDeletingMessages + getSelfDeletingMessagesInternal + . DoAuth + ) + :<|> Named @'("put", 'TeamFeatureSelfDeletingMessages) + ( setFeatureStatus @'TeamFeatureSelfDeletingMessages + setSelfDeletingMessagesInternal + . DoAuth + ) + :<|> Named @'("get", 'TeamFeatureGuestLinks) + ( getFeatureStatus @'WithLockStatus @'TeamFeatureGuestLinks + getGuestLinkInternal + . DoAuth + ) + :<|> Named @'("put", 'TeamFeatureGuestLinks) + ( setFeatureStatus @'TeamFeatureGuestLinks + setGuestLinkInternal + . DoAuth + ) + :<|> Named @"get-all-feature-configs" getAllFeatureConfigs + :<|> Named @'("get-config", 'TeamFeatureLegalHold) + ( getFeatureConfig @'WithoutLockStatus @'TeamFeatureLegalHold + getLegalholdStatusInternal + ) + :<|> Named @'("get-config", 'TeamFeatureSSO) + ( getFeatureConfig @'WithoutLockStatus @'TeamFeatureSSO + getSSOStatusInternal + ) + :<|> Named @'("get-config", 'TeamFeatureSearchVisibility) + ( getFeatureConfig @'WithoutLockStatus @'TeamFeatureSearchVisibility + getTeamSearchVisibilityAvailableInternal + ) + :<|> Named @'("get-config", 'TeamFeatureValidateSAMLEmails) + ( getFeatureConfig @'WithoutLockStatus @'TeamFeatureValidateSAMLEmails + getValidateSAMLEmailsInternal + ) + :<|> Named @'("get-config", 'TeamFeatureDigitalSignatures) + ( getFeatureConfig @'WithoutLockStatus @'TeamFeatureDigitalSignatures + getDigitalSignaturesInternal + ) + :<|> Named @'("get-config", 'TeamFeatureAppLock) + ( getFeatureConfig @'WithoutLockStatus @'TeamFeatureAppLock + getAppLockInternal + ) + :<|> Named @'("get-config", 'TeamFeatureFileSharing) + ( getFeatureConfig @'WithoutLockStatus @'TeamFeatureFileSharing + getFileSharingInternal + ) + :<|> Named @'("get-config", 'TeamFeatureClassifiedDomains) + ( getFeatureConfig @'WithoutLockStatus @'TeamFeatureClassifiedDomains + getClassifiedDomainsInternal + ) + :<|> Named @'("get-config", 'TeamFeatureConferenceCalling) + ( getFeatureConfig @'WithoutLockStatus @'TeamFeatureConferenceCalling + getConferenceCallingInternal + ) + :<|> Named @'("get-config", 'TeamFeatureSelfDeletingMessages) + ( getFeatureConfig @'WithLockStatus @'TeamFeatureSelfDeletingMessages + getSelfDeletingMessagesInternal + ) + :<|> Named @'("get-config", 'TeamFeatureGuestLinks) + ( getFeatureConfig @'WithLockStatus @'TeamFeatureGuestLinks + getGuestLinkInternal + ) diff --git a/services/galley/src/Galley/API/Query.hs b/services/galley/src/Galley/API/Query.hs index b2c678d8371..451726ef0ad 100644 --- a/services/galley/src/Galley/API/Query.hs +++ b/services/galley/src/Galley/API/Query.hs @@ -30,10 +30,12 @@ module Galley.API.Query internalGetMemberH, getConversationMetaH, getConversationByReusableCode, + ensureGuestLinksEnabled, ) where import qualified Cassandra as C +import Control.Lens import qualified Data.ByteString.Lazy as LBS import Data.Code import Data.CommaSeparatedList @@ -54,9 +56,12 @@ import qualified Galley.Effects.ConversationStore as E import qualified Galley.Effects.FederatorAccess as E import qualified Galley.Effects.ListItems as E import qualified Galley.Effects.MemberStore as E +import qualified Galley.Effects.TeamFeatureStore as TeamFeatures +import Galley.Options import Galley.Types import Galley.Types.Conversations.Members import Galley.Types.Conversations.Roles +import Galley.Types.Teams import Imports import Network.HTTP.Types import Network.Wai @@ -72,11 +77,11 @@ import qualified Wire.API.Conversation as Public import qualified Wire.API.Conversation.Role as Public import Wire.API.ErrorDescription import Wire.API.Federation.API -import Wire.API.Federation.API.Galley hiding (getConversations) -import qualified Wire.API.Federation.API.Galley as F +import Wire.API.Federation.API.Galley import Wire.API.Federation.Error import qualified Wire.API.Provider.Bot as Public import qualified Wire.API.Routes.MultiTablePaging as Public +import Wire.API.Team.Feature as Public getBotConversationH :: Members '[ConversationStore, Error ConversationError, Input (Local ())] r => @@ -220,7 +225,7 @@ getRemoteConversationsWithFailures lusr convs = do | otherwise = [failedGetConversationLocally (map qUntagged locallyNotFound)] -- request conversations from remote backends - let rpc = F.getConversations clientRoutes + let rpc = fedClient @'Galley @"get-conversations" resp <- E.runFederatedConcurrentlyEither locallyFound $ \someConvs -> rpc $ GetConversationsRequest (tUnqualified lusr) (tUnqualified someConvs) @@ -490,16 +495,17 @@ getConversationMeta cnv = do pure Nothing getConversationByReusableCode :: - Members - '[ BrigAccess, - CodeStore, - ConversationStore, - Error CodeError, - Error ConversationError, - Error NotATeamMember, - TeamStore - ] - r => + forall r. + ( Member BrigAccess r, + Member CodeStore r, + Member ConversationStore r, + Member (Error CodeError) r, + Member (Error ConversationError) r, + Member (Error NotATeamMember) r, + Member TeamStore r, + Member TeamFeatureStore r, + Member (Input Opts) r + ) => Local UserId -> Key -> Value -> @@ -507,6 +513,7 @@ getConversationByReusableCode :: getConversationByReusableCode lusr key value = do c <- verifyReusableCode (ConversationCode key value Nothing) conv <- ensureConversationAccess (tUnqualified lusr) (Data.codeConversation c) CodeAccess + ensureGuestLinksEnabled conv pure $ coverView conv where coverView :: Data.Conversation -> ConversationCoverView @@ -515,3 +522,24 @@ getConversationByReusableCode lusr key value = do { cnvCoverConvId = Data.convId conv, cnvCoverName = Data.convName conv } + +-- FUTUREWORK(leif): refactor and make it consistent for all team features +ensureGuestLinksEnabled :: + forall r. + ( Member (Error ConversationError) r, + Member TeamFeatureStore r, + Member (Input Opts) r + ) => + Data.Conversation -> + Sem r () +ensureGuestLinksEnabled conv = do + defaultStatus <- getDefaultFeatureStatus + maybeFeatureStatus <- join <$> TeamFeatures.getFeatureStatusNoConfig @'TeamFeatureGuestLinks `traverse` Data.convTeam conv + case maybe defaultStatus tfwoStatus maybeFeatureStatus of + TeamFeatureEnabled -> pure () + TeamFeatureDisabled -> throw GuestLinksDisabled + where + getDefaultFeatureStatus :: Sem r TeamFeatureStatusValue + getDefaultFeatureStatus = do + status <- input <&> view (optSettings . setFeatureFlags . flagConversationGuestLinks . unDefaults) + pure $ tfwoapsStatus status diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index 9d46c2fcd7a..a9e332d6e16 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -25,7 +25,7 @@ module Galley.API.Teams getTeamNameInternalH, getBindingTeamIdH, getBindingTeamMembersH, - getManyTeamsH, + getManyTeams, deleteTeamH, uncheckedDeleteTeam, addTeamMemberH, @@ -60,9 +60,9 @@ where import Brig.Types.Intra (accountUser) import Brig.Types.Team (TeamSize (..)) import Control.Lens +import Data.ByteString.Builder (lazyByteString) import Data.ByteString.Conversion (List, toByteString) import qualified Data.ByteString.Conversion -import Data.ByteString.Lazy.Builder (lazyByteString) import qualified Data.CaseInsensitive as CI import Data.Csv (EncodeOptions (..), Quoting (QuoteAll), encodeDefaultOrderedByNameWith) import qualified Data.Handle as Handle @@ -73,6 +73,7 @@ import Data.List1 (list1) import qualified Data.Map as Map import qualified Data.Map.Strict as M import Data.Misc (HttpsUrl, mkHttpsUrl) +import Data.Proxy import Data.Qualified import Data.Range as Range import qualified Data.Set as Set @@ -135,6 +136,7 @@ import qualified Wire.API.Team as Public import qualified Wire.API.Team.Conversation as Public import Wire.API.Team.Export (TeamExportUser (..)) import qualified Wire.API.Team.Feature as Public +import Wire.API.Team.Member (ntmNewTeamMember, teamMemberJson, teamMemberListJson) import qualified Wire.API.Team.Member as Public import qualified Wire.API.Team.SearchVisibility as Public import Wire.API.User (User, UserSSOId (UserScimExternalId), userSCIMExternalId, userSSOId) @@ -169,21 +171,25 @@ getTeamNameInternalH (tid ::: _) = getTeamNameInternal :: Member TeamStore r => TeamId -> Sem r (Maybe TeamName) getTeamNameInternal = fmap (fmap TeamName) . E.getTeamName -getManyTeamsH :: - (Members '[TeamStore, Queue DeleteItem, ListItems LegacyPaging TeamId] r) => - UserId ::: Maybe (Either (Range 1 32 (List TeamId)) TeamId) ::: Range 1 100 Int32 ::: JSON -> - Sem r Response -getManyTeamsH (zusr ::: range ::: size ::: _) = - json <$> getManyTeams zusr range size - +-- | DEPRECATED. +-- +-- The endpoint was designed to query non-binding teams. However, non-binding teams is a feature +-- that has never been adopted by clients, but the endpoint also returns the binding team of a user and it is +-- possible that this is being used by a client, even though unlikely. +-- +-- The following functionality has been changed: query parameters will be ignored, which has the effect +-- that regardless of the parameters the response will always contain the binding team of the user if +-- it exists. Even though they are ignored, the use of query parameters will not result in an error. +-- +-- (If you want to be pedantic, the `size` parameter is still honored: its allowed range is +-- between 1 and 100, and that will always be an upper bound of the result set of size 0 or +-- one.) getManyTeams :: (Members '[TeamStore, Queue DeleteItem, ListItems LegacyPaging TeamId] r) => UserId -> - Maybe (Either (Range 1 32 (List TeamId)) TeamId) -> - Range 1 100 Int32 -> Sem r Public.TeamList -getManyTeams zusr range size = - withTeamIds zusr range size $ \more ids -> do +getManyTeams zusr = + withTeamIds zusr Nothing (toRange (Proxy @100)) $ \more ids -> do teams <- mapM (lookupTeam zusr) ids pure (Public.newTeamList (catMaybes teams) more) @@ -203,41 +209,22 @@ lookupTeam zusr tid = do else pure Nothing createNonBindingTeamH :: - Members - '[ BrigAccess, - Error ActionError, - Error TeamError, - GundeckAccess, - Input UTCTime, - P.TinyLog, - TeamStore, - WaiRoutes - ] - r => - UserId ::: ConnId ::: JsonRequest Public.NonBindingNewTeam ::: JSON -> - Sem r Response -createNonBindingTeamH (zusr ::: zcon ::: req ::: _) = do - newTeam <- fromJsonBody req - newTeamId <- createNonBindingTeam zusr zcon newTeam - pure (empty & setStatus status201 . location newTeamId) - -createNonBindingTeam :: - Members - '[ BrigAccess, - Error ActionError, - Error TeamError, - GundeckAccess, - Input UTCTime, - TeamStore, - P.TinyLog - ] - r => + forall r. + ( Member BrigAccess r, + Member (Error ActionError) r, + Member (Error TeamError) r, + Member GundeckAccess r, + Member (Input UTCTime) r, + Member P.TinyLog r, + Member TeamStore r, + Member WaiRoutes r + ) => UserId -> ConnId -> Public.NonBindingNewTeam -> Sem r TeamId -createNonBindingTeam zusr zcon (Public.NonBindingNewTeam body) = do - let owner = Public.TeamMember zusr fullPermissions Nothing LH.defUserLegalHoldStatus +createNonBindingTeamH zusr zcon (Public.NonBindingNewTeam body) = do + let owner = Public.mkTeamMember zusr fullPermissions Nothing LH.defUserLegalHoldStatus let others = filter ((zusr /=) . view userId) . maybe [] fromRange @@ -275,7 +262,7 @@ createBindingTeam :: BindingNewTeam -> Sem r TeamId createBindingTeam zusr tid (BindingNewTeam body) = do - let owner = Public.TeamMember zusr fullPermissions Nothing LH.defUserLegalHoldStatus + let owner = Public.mkTeamMember zusr fullPermissions Nothing LH.defUserLegalHoldStatus team <- E.createTeam (Just tid) zusr (body ^. newTeamName) (body ^. newTeamIcon) (body ^. newTeamIconKey) Binding finishCreateTeam team owner [] Nothing @@ -344,23 +331,6 @@ updateTeamStatus tid (TeamStatusUpdate newStatus cur) = do (_, _) -> throw InvalidTeamStatusUpdate updateTeamH :: - Members - '[ Error ActionError, - Error NotATeamMember, - GundeckAccess, - Input UTCTime, - TeamStore, - WaiRoutes - ] - r => - UserId ::: ConnId ::: TeamId ::: JsonRequest Public.TeamUpdateData ::: JSON -> - Sem r Response -updateTeamH (zusr ::: zcon ::: tid ::: req ::: _) = do - updateData <- fromJsonBody req - updateTeam zusr zcon tid updateData - pure empty - -updateTeam :: Members '[ Error ActionError, Error NotATeamMember, @@ -374,7 +344,7 @@ updateTeam :: TeamId -> Public.TeamUpdateData -> Sem r () -updateTeam zusr zcon tid updateData = do +updateTeamH zusr zcon tid updateData = do zusrMembership <- E.getTeamMember tid zusr -- let zothers = map (view userId) membs -- Log.debug $ @@ -835,7 +805,7 @@ addTeamMember :: Public.NewTeamMember -> Sem r () addTeamMember zusr zcon tid nmem = do - let uid = nmem ^. ntmNewTeamMember . userId + let uid = nmem ^. nUserId P.debug $ Log.field "targets" (toByteString uid) . Log.field "action" (Log.val "Teams.addTeamMember") @@ -843,7 +813,7 @@ addTeamMember zusr zcon tid nmem = do zusrMembership <- E.getTeamMember tid zusr >>= permissionCheck AddTeamMember - let targetPermissions = nmem ^. ntmNewTeamMember . permissions + let targetPermissions = nmem ^. nPermissions targetPermissions `ensureNotElevated` zusrMembership ensureNonBindingTeam tid ensureUnboundUsers [uid] @@ -904,7 +874,7 @@ uncheckedAddTeamMember tid nmem = do (TeamSize sizeBeforeJoin) <- E.getSize tid ensureNotTooLargeForLegalHold tid (fromIntegral sizeBeforeJoin + 1) (TeamSize sizeBeforeAdd) <- addTeamMemberInternal tid Nothing Nothing nmem mems - billingUserIds <- Journal.getBillingUserIds tid $ Just $ newTeamMemberList ((nmem ^. ntmNewTeamMember) : mems ^. teamMembers) (mems ^. teamMemberListType) + billingUserIds <- Journal.getBillingUserIds tid $ Just $ newTeamMemberList (ntmNewTeamMember nmem : mems ^. teamMembers) (mems ^. teamMemberListType) Journal.teamUpdate tid (sizeBeforeAdd + 1) billingUserIds updateTeamMemberH :: @@ -925,7 +895,7 @@ updateTeamMemberH :: Sem r Response updateTeamMemberH (zusr ::: zcon ::: tid ::: req ::: _) = do -- the team member to be updated - targetMember <- view ntmNewTeamMember <$> (fromJsonBody req) + targetMember <- ntmNewTeamMember <$> fromJsonBody req updateTeamMember zusr zcon tid targetMember pure empty @@ -1385,7 +1355,7 @@ addTeamMemberInternal :: NewTeamMember -> TeamMemberList -> Sem r TeamSize -addTeamMemberInternal tid origin originConn (view ntmNewTeamMember -> new) memList = do +addTeamMemberInternal tid origin originConn (ntmNewTeamMember -> new) memList = do P.debug $ Log.field "targets" (toByteString (new ^. userId)) . Log.field "action" (Log.val "Teams.addTeamMemberInternal") diff --git a/services/galley/src/Galley/API/Teams/Features.hs b/services/galley/src/Galley/API/Teams/Features.hs index 63ef91cd19a..4593501051f 100644 --- a/services/galley/src/Galley/API/Teams/Features.hs +++ b/services/galley/src/Galley/API/Teams/Features.hs @@ -17,6 +17,7 @@ module Galley.API.Teams.Features ( getFeatureStatus, + getFeatureStatusNoConfig, setFeatureStatus, getFeatureConfig, getAllFeatureConfigs, @@ -590,8 +591,8 @@ getSelfDeletingMessagesInternal = \case Right tid -> do cfgDefault <- getCfgDefault let defLockStatus = Public.tfwcapsLockStatus cfgDefault - (maybeFeatureStatus, fromMaybe defLockStatus -> lockStatus) <- TeamFeatures.getSelfDeletingMessagesStatus tid - pure $ case (lockStatus, maybeFeatureStatus) of + (mbFeatureStatus, fromMaybe defLockStatus -> lockStatus) <- TeamFeatures.getSelfDeletingMessagesStatus tid + pure $ case (lockStatus, mbFeatureStatus) of (Public.Unlocked, Just featureStatus) -> Public.TeamFeatureStatusWithConfigAndLockStatus (Public.tfwcStatus featureStatus) @@ -616,15 +617,14 @@ setSelfDeletingMessagesInternal :: 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 + getDftLockStatus >>= guardLockStatus @'Public.TeamFeatureSelfDeletingMessages tid let pushEvent = pushFeatureConfigEvent tid $ Event.Event Event.Update Public.TeamFeatureSelfDeletingMessages (EdFeatureSelfDeletingMessagesChanged st) TeamFeatures.setSelfDeletingMessagesStatus tid st <* pushEvent where - getCfgDefault :: Sem r (Public.TeamFeatureStatusWithConfigAndLockStatus Public.TeamFeatureSelfDeletingMessagesConfig) - getCfgDefault = input <&> view (optSettings . setFeatureFlags . flagSelfDeletingMessages . unDefaults) + getDftLockStatus :: Sem r Public.LockStatusValue + getDftLockStatus = input <&> view (optSettings . setFeatureFlags . flagSelfDeletingMessages . unDefaults . to Public.tfwcapsLockStatus) getGuestLinkInternal :: forall r. @@ -635,15 +635,14 @@ 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 + (mbFeatureStatus, fromMaybe (Public.tfwoapsLockStatus cfgDefault) -> lockStatus) <- TeamFeatures.getFeatureStatusNoConfigAndLockStatus @'Public.TeamFeatureGuestLinks tid + pure $ case (lockStatus, mbFeatureStatus) 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} + lockStatus + (Public.Unlocked, Nothing) -> cfgDefault {Public.tfwoapsLockStatus = lockStatus} + (Public.Locked, _) -> cfgDefault {Public.tfwoapsLockStatus = lockStatus} where getCfgDefault :: Sem r (Public.TeamFeatureStatus 'Public.WithLockStatus 'Public.TeamFeatureGuestLinks) getCfgDefault = input <&> view (optSettings . setFeatureFlags . flagConversationGuestLinks . unDefaults) @@ -661,8 +660,7 @@ setGuestLinkInternal :: 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 + getDftLockStatus >>= guardLockStatus @'Public.TeamFeatureGuestLinks tid let pushEvent = pushFeatureConfigEvent tid $ Event.Event @@ -673,8 +671,8 @@ setGuestLinkInternal tid status = do ) TeamFeatures.setFeatureStatusNoConfig @'Public.TeamFeatureGuestLinks tid status <* pushEvent where - getCfgDefault :: Sem r (Public.TeamFeatureStatus 'Public.WithLockStatus 'Public.TeamFeatureGuestLinks) - getCfgDefault = input <&> view (optSettings . setFeatureFlags . flagConversationGuestLinks . unDefaults) + getDftLockStatus :: Sem r Public.LockStatusValue + getDftLockStatus = input <&> view (optSettings . setFeatureFlags . flagConversationGuestLinks . unDefaults . to Public.tfwoapsLockStatus) -- TODO(fisx): move this function to a more suitable place / module. guardLockStatus :: diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index 26af1fabcb2..2969c49d438 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -82,6 +82,7 @@ import Galley.API.Error import Galley.API.LegalHold.Conflicts import Galley.API.Mapping import Galley.API.Message +import qualified Galley.API.Query as Query import Galley.API.Util import qualified Galley.Data.Conversation as Data import Galley.Data.Services as Data @@ -522,16 +523,17 @@ getUpdateResult :: Sem (Error NoChanges ': r) a -> Sem r (UpdateResult a) getUpdateResult = fmap (either (const Unchanged) Updated) . runError addCodeH :: - Members - '[ CodeStore, - ConversationStore, - Error ConversationError, - ExternalAccess, - GundeckAccess, - Input (Local ()), - Input UTCTime - ] - r => + forall r. + ( Member CodeStore r, + Member ConversationStore r, + Member (Error ConversationError) r, + Member ExternalAccess r, + Member GundeckAccess r, + Member (Input (Local ())) r, + Member (Input UTCTime) r, + Member (Input Opts) r, + Member TeamFeatureStore r + ) => UserId ::: ConnId ::: ConvId -> Sem r Response addCodeH (usr ::: zcon ::: cnv) = do @@ -547,21 +549,22 @@ data AddCodeResult addCode :: forall r. - Members - '[ CodeStore, - ConversationStore, - Error ConversationError, - ExternalAccess, - GundeckAccess, - Input UTCTime - ] - r => + ( Member CodeStore r, + Member ConversationStore r, + Member (Error ConversationError) r, + Member ExternalAccess r, + Member GundeckAccess r, + Member (Input UTCTime) r, + Member (Input Opts) r, + Member TeamFeatureStore r + ) => Local UserId -> ConnId -> Local ConvId -> Sem r AddCodeResult addCode lusr zcon lcnv = do conv <- E.getConversation (tUnqualified lcnv) >>= note ConvNotFound + Query.ensureGuestLinksEnabled conv ensureConvMember (Data.convLocalMembers conv) (tUnqualified lusr) ensureAccess conv CodeAccess let (bots, users) = localBotsAndUsers $ Data.convLocalMembers conv @@ -582,8 +585,7 @@ addCode lusr zcon lcnv = do where createCode :: Code -> Sem r ConversationCode createCode code = do - urlPrefix <- E.getConversationCodeURI - return $ mkConversationCode (codeKey code) (codeValue code) urlPrefix + mkConversationCode (codeKey code) (codeValue code) <$> E.getConversationCodeURI rmCodeH :: Members @@ -631,32 +633,35 @@ rmCode lusr zcon lcnv = do pure event getCodeH :: - Members - '[ CodeStore, - ConversationStore, - Error CodeError, - Error ConversationError - ] - r => + forall r. + ( Member CodeStore r, + Member ConversationStore r, + Member (Error CodeError) r, + Member (Error ConversationError) r, + Member (Input Opts) r, + Member TeamFeatureStore r + ) => UserId ::: ConvId -> Sem r Response getCodeH (usr ::: cnv) = setStatus status200 . json <$> getCode usr cnv getCode :: - Members - '[ CodeStore, - ConversationStore, - Error CodeError, - Error ConversationError - ] - r => + forall r. + ( Member CodeStore r, + Member ConversationStore r, + Member (Error CodeError) r, + Member (Error ConversationError) r, + Member (Input Opts) r, + Member TeamFeatureStore r + ) => UserId -> ConvId -> Sem r Public.ConversationCode getCode usr cnv = do conv <- E.getConversation cnv >>= note ConvNotFound + Query.ensureGuestLinksEnabled conv ensureAccess conv CodeAccess ensureConvMember (Data.convLocalMembers conv) usr key <- E.makeKey cnv @@ -665,8 +670,7 @@ getCode usr cnv = do returnCode :: Member CodeStore r => Code -> Sem r Public.ConversationCode returnCode c = do - urlPrefix <- E.getConversationCodeURI - pure $ Public.mkConversationCode (codeKey c) (codeValue c) urlPrefix + Public.mkConversationCode (codeKey c) (codeValue c) <$> E.getConversationCodeURI checkReusableCodeH :: Members '[CodeStore, Error CodeError, WaiRoutes] r => @@ -1097,7 +1101,7 @@ removeMemberFromRemoteConv :: removeMemberFromRemoteConv cnv lusr victim | qUntagged lusr == victim = do let lc = LeaveConversationRequest (tUnqualified cnv) (qUnqualified victim) - let rpc = leaveConversation clientRoutes lc + let rpc = fedClient @'Galley @"leave-conversation" lc (either handleError handleSuccess =<<) . fmap leaveResponse $ E.runFederated cnv rpc | otherwise = throw (ActionDenied RemoveConversationMember) diff --git a/services/galley/src/Galley/API/Util.hs b/services/galley/src/Galley/API/Util.hs index 607236545eb..cdc1bdbed69 100644 --- a/services/galley/src/Galley/API/Util.hs +++ b/services/galley/src/Galley/API/Util.hs @@ -735,7 +735,7 @@ registerRemoteConversationMemberships now localDomain c = do let allRemoteMembers = nubOrd (map rmId (Data.convRemoteMembers c)) rc = toNewRemoteConversation now localDomain c runFederatedConcurrently_ allRemoteMembers $ \_ -> - onConversationCreated clientRoutes rc + fedClient @'Galley @"on-conversation-created" rc -------------------------------------------------------------------------------- -- Legalhold diff --git a/services/galley/src/Galley/Aws.hs b/services/galley/src/Galley/Aws.hs index 5f5f055a7c6..9121ab43751 100644 --- a/services/galley/src/Galley/Aws.hs +++ b/services/galley/src/Galley/Aws.hs @@ -91,14 +91,10 @@ newtype Amazon a = Amazon MonadCatch, MonadMask, MonadReader Env, - MonadResource + MonadResource, + MonadUnliftIO ) -instance MonadUnliftIO Amazon where - askUnliftIO = Amazon . ReaderT $ \r -> - withUnliftIO $ \u -> - return (UnliftIO (unliftIO u . flip runReaderT r . unAmazon)) - instance MonadLogger Amazon where log l m = view logger >>= \g -> Logger.log g l m diff --git a/services/galley/src/Galley/Cassandra.hs b/services/galley/src/Galley/Cassandra.hs index a5477dd16d9..2840865d44c 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 = 56 +schemaVersion = 57 diff --git a/services/galley/src/Galley/Cassandra/Team.hs b/services/galley/src/Galley/Cassandra/Team.hs index 7d0f373a290..a89af42d6d4 100644 --- a/services/galley/src/Galley/Cassandra/Team.hs +++ b/services/galley/src/Galley/Cassandra/Team.hs @@ -410,8 +410,8 @@ newTeamMember' lh tid (uid, perms, minvu, minvt, fromMaybe defUserLegalHoldStatu UserLegalHoldPending -> UserLegalHoldPending UserLegalHoldEnabled -> UserLegalHoldEnabled - mk (Just invu) (Just invt) = pure $ TeamMember uid perms (Just (invu, invt)) lhStatus - mk Nothing Nothing = pure $ TeamMember uid perms Nothing lhStatus + mk (Just invu) (Just invt) = pure $ mkTeamMember uid perms (Just (invu, invt)) lhStatus + mk Nothing Nothing = pure $ mkTeamMember uid perms Nothing lhStatus mk _ _ = throwM $ ErrorCall "TeamMember with incomplete metadata." teamConversationsForPagination :: TeamId -> Maybe ConvId -> Range 1 HardTruncationLimit Int32 -> Client (Page TeamConversation) diff --git a/services/galley/src/Galley/Cassandra/TeamFeatures.hs b/services/galley/src/Galley/Cassandra/TeamFeatures.hs index 53a4065f874..4bd104cbe9e 100644 --- a/services/galley/src/Galley/Cassandra/TeamFeatures.hs +++ b/services/galley/src/Galley/Cassandra/TeamFeatures.hs @@ -29,9 +29,6 @@ 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) => diff --git a/services/galley/src/Galley/Data/TeamFeatures.hs b/services/galley/src/Galley/Data/TeamFeatures.hs index 12cd3dc28b6..8d694625601 100644 --- a/services/galley/src/Galley/Data/TeamFeatures.hs +++ b/services/galley/src/Galley/Data/TeamFeatures.hs @@ -65,7 +65,8 @@ instance {-# OVERLAPPABLE #-} HasLockStatusCol a => MaybeHasLockStatusCol a wher instance HasLockStatusCol 'TeamFeatureSelfDeletingMessages where lockStatusCol = "self_deleting_messages_lock_status" -instance MaybeHasLockStatusCol 'TeamFeatureGuestLinks where maybeLockStatusCol = Nothing +instance HasLockStatusCol 'TeamFeatureGuestLinks where + lockStatusCol = "guest_links_lock_status" instance MaybeHasLockStatusCol 'TeamFeatureLegalHold where maybeLockStatusCol = Nothing diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index d394a30c025..f1e16b0fbd3 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -25,6 +25,7 @@ where import qualified API.CustomBackend as CustomBackend import qualified API.Federation as Federation +import API.Federation.Util import qualified API.MessageTimer as MessageTimer import qualified API.Roles as Roles import API.SQS @@ -33,13 +34,14 @@ import qualified API.Teams.Feature as TeamFeature import qualified API.Teams.LegalHold as Teams.LegalHold import qualified API.Teams.LegalHold.DisabledByDefault import API.Util +import qualified API.Util as Util +import API.Util.TeamFeature as TeamFeatures import Bilge hiding (timeout) import Bilge.Assert import Brig.Types import qualified Control.Concurrent.Async as Async import Control.Exception (throw) import Control.Lens (at, ix, preview, view, (.~), (?~)) -import Control.Monad.Except (MonadError (throwError)) import Control.Monad.Trans.Maybe import Data.Aeson hiding (json) import qualified Data.ByteString as BS @@ -53,11 +55,9 @@ import Data.List.NonEmpty (NonEmpty (..)) import Data.List1 import qualified Data.List1 as List1 import qualified Data.Map.Strict as Map -import Data.Proxy (Proxy (..)) import Data.Qualified import Data.Range import qualified Data.Set as Set -import Data.String.Conversions (cs) import qualified Data.Text as T import qualified Data.Text.Ascii as Ascii import Data.Time.Clock (getCurrentTime) @@ -74,9 +74,7 @@ import Gundeck.Types.Notification import Imports import qualified Network.HTTP.Types as HTTP import Network.Wai.Utilities.Error -import Servant (ServerError (errBody), err501, err503) -import Servant.Server (Handler) -import Servant.Server.Generic (AsServerT) +import Servant hiding (respond) import Test.QuickCheck (arbitrary, generate) import Test.Tasty import Test.Tasty.Cannon (TimeoutUnit (..), (#)) @@ -93,6 +91,8 @@ import Wire.API.Federation.API.Galley import qualified Wire.API.Federation.API.Galley as F import qualified Wire.API.Message as Message import Wire.API.Routes.MultiTablePaging +import Wire.API.Routes.Named +import qualified Wire.API.Team.Feature as Public import Wire.API.User.Client import Wire.API.UserMap (UserMap (..)) @@ -199,11 +199,11 @@ tests s = test s "conversation receipt mode update with remote members" putReceiptModeWithRemotesOk, test s "send typing indicators" postTypingIndicators, test s "leave connect conversation" leaveConnectConversation, - test s "post conversations/:cnv/otr/message: message delivery and missing clients" postCryptoMessage1, - test s "post conversations/:cnv/otr/message: mismatch and prekey fetching" postCryptoMessage2, - test s "post conversations/:cnv/otr/message: mismatch with protobuf" postCryptoMessage3, - test s "post conversations/:cnv/otr/message: unknown sender client" postCryptoMessage4, - test s "post conversations/:cnv/otr/message: ignore_missing and report_missing" postCryptoMessage5, + test s "post conversations/:cnv/otr/message: message delivery and missing clients" postCryptoMessageVerifyMsgSentAndRejectIfMissingClient, + test s "post conversations/:cnv/otr/message: mismatch and prekey fetching" postCryptoMessageVerifyRejectMissingClientAndRepondMissingPrekeysJson, + test s "post conversations/:cnv/otr/message: mismatch with protobuf" postCryptoMessageVerifyRejectMissingClientAndRepondMissingPrekeysProto, + test s "post conversations/:cnv/otr/message: unknown sender client" postCryptoMessageNotAuthorizeUnknownClient, + test s "post conversations/:cnv/otr/message: ignore_missing and report_missing" postCryptoMessageVerifyCorrectResponseIfIgnoreAndReportMissingQueryParam, test s "post message qualified - local owning backend - success" postMessageQualifiedLocalOwningBackendSuccess, test s "post message qualified - local owning backend - missing clients" postMessageQualifiedLocalOwningBackendMissingClients, test s "post message qualified - local owning backend - redundant and deleted clients" postMessageQualifiedLocalOwningBackendRedundantAndDeletedClients, @@ -218,41 +218,17 @@ tests s = test s "convert code to team-access conversation" postConvertTeamConv, test s "local and remote guests are removed when access changes" testAccessUpdateGuestRemoved, test s "cannot join private conversation" postJoinConvFail, + test s "revoke guest links for team conversation" testJoinTeamConvGuestLinksDisabled, + test s "revoke guest links for non-team conversation" testJoinNonTeamConvGuestLinksDisabled, + test s "get code rejected if guest links disabled" testGetCodeRejectedIfGuestLinksDisabled, + test s "post code rejected if guest links disabled" testPostCodeRejectedIfGuestLinksDisabled, test s "remove user with only local convs" removeUserNoFederation, test s "remove user with local and remote convs" removeUser, - test s "iUpsertOne2OneConversation" testAllOne2OneConversationRequests + test s "iUpsertOne2OneConversation" testAllOne2OneConversationRequests, + test s "post message - reject if missing client" postMessageRejectIfMissingClients, + test s "post message - client that is not in group doesn't receive message" postMessageClientNotInGroupDoesNotReceiveMsg ] -emptyFederatedBrig :: F.BrigApi (AsServerT Handler) -emptyFederatedBrig = - let e :: Text -> Handler a - e s = throwError err501 {errBody = cs ("mock not implemented: " <> s)} - in F.BrigApi - { F.getUserByHandle = \_ -> e "getUserByHandle", - F.getUsersByIds = \_ -> e "getUsersByIds", - F.claimPrekey = \_ -> e "claimPrekey", - F.claimPrekeyBundle = \_ -> e "claimPrekeyBundle", - F.claimMultiPrekeyBundle = \_ -> e "claimMultiPrekeyBundle", - F.searchUsers = \_ -> e "searchUsers", - F.getUserClients = \_ -> e "getUserClients", - F.sendConnectionAction = \_ _ -> e "sendConnectionAction", - F.onUserDeleted = \_ _ -> e "onUserDeleted" - } - -emptyFederatedGalley :: F.GalleyApi (AsServerT Handler) -emptyFederatedGalley = - let e :: Text -> Handler a - e s = throwError err501 {errBody = cs ("mock not implemented: " <> s)} - in F.GalleyApi - { F.onConversationCreated = \_ _ -> e "onConversationCreated", - F.getConversations = \_ _ -> e "getConversations", - F.onConversationUpdated = \_ _ -> e "onConversationUpdated", - F.leaveConversation = \_ _ -> e "leaveConversation", - F.onMessageSent = \_ _ -> e "onMessageSent", - F.sendMessage = \_ _ -> e "sendMessage", - F.onUserDeleted = \_ _ -> e "onUserDeleted" - } - ------------------------------------------------------------------------------- -- API Tests @@ -364,10 +340,11 @@ postConvWithRemoteUsersOk = do EdConversation c' -> assertConvEquals cnv c' _ -> assertFailure "Unexpected event data" --- | This test verifies whether a message actually gets sent all the way to +-- @SF.Separation @TSFI.RESTfulAPI @S2 +-- This test verifies whether a message actually gets sent all the way to -- cannon. -postCryptoMessage1 :: TestM () -postCryptoMessage1 = do +postCryptoMessageVerifyMsgSentAndRejectIfMissingClient :: TestM () +postCryptoMessageVerifyMsgSentAndRejectIfMissingClient = do localDomain <- viewFederationDomain c <- view tsCannon (alice, ac) <- randomUserWithClient (someLastPrekeys !! 0) @@ -449,9 +426,12 @@ postCryptoMessage1 = do liftIO $ assertBool "unexpected equal clients" (bc /= bc2) assertNoMsg wsB2 (wsAssertOtr qconv qalice ac bc cipher) --- | This test verifies basic mismatch behaviour of the the JSON endpoint. -postCryptoMessage2 :: TestM () -postCryptoMessage2 = do +-- @END + +-- @SF.Separation @TSFI.RESTfulAPI @S2 +-- This test verifies basic mismatch behavior of the the JSON endpoint. +postCryptoMessageVerifyRejectMissingClientAndRepondMissingPrekeysJson :: TestM () +postCryptoMessageVerifyRejectMissingClientAndRepondMissingPrekeysJson = do b <- view tsBrig (alice, ac) <- randomUserWithClient (someLastPrekeys !! 0) (bob, bc) <- randomUserWithClient (someLastPrekeys !! 1) @@ -474,9 +454,12 @@ postCryptoMessage2 = do Map.keys (userClientMap (getUserClientPrekeyMap p)) @=? [eve] Map.keys <$> Map.lookup eve (userClientMap (getUserClientPrekeyMap p)) @=? Just [ec] --- | This test verifies basic mismatch behaviour of the protobuf endpoint. -postCryptoMessage3 :: TestM () -postCryptoMessage3 = do +-- @END + +-- @SF.Separation @TSFI.RESTfulAPI @S2 +-- This test verifies basic mismatch behaviour of the protobuf endpoint. +postCryptoMessageVerifyRejectMissingClientAndRepondMissingPrekeysProto :: TestM () +postCryptoMessageVerifyRejectMissingClientAndRepondMissingPrekeysProto = do b <- view tsBrig (alice, ac) <- randomUserWithClient (someLastPrekeys !! 0) (bob, bc) <- randomUserWithClient (someLastPrekeys !! 1) @@ -501,10 +484,12 @@ postCryptoMessage3 = do Map.keys (userClientMap (getUserClientPrekeyMap p)) @=? [eve] Map.keys <$> Map.lookup eve (userClientMap (getUserClientPrekeyMap p)) @=? Just [ec] --- | This test verfies behaviour when an unknown client posts the message. Only +-- @END + +-- | This test verifies behaviour when an unknown client posts the message. Only -- tests the Protobuf endpoint. -postCryptoMessage4 :: TestM () -postCryptoMessage4 = do +postCryptoMessageNotAuthorizeUnknownClient :: TestM () +postCryptoMessageNotAuthorizeUnknownClient = do alice <- randomUser bob <- randomUser bc <- randomClient bob (someLastPrekeys !! 0) @@ -516,10 +501,69 @@ postCryptoMessage4 = do postProtoOtrMessage alice (ClientId "172618352518396") conv m !!! const 403 === statusCode --- | This test verifies behaviour under various values of ignore_missing and +-- @SF.Separation @TSFI.RESTfulAPI @S2 +-- This test verifies the following scenario. +-- A client sends a message to all clients of a group and one more who is not part of the group. +-- The server must not send this message to client ids not part of the group. +postMessageClientNotInGroupDoesNotReceiveMsg :: TestM () +postMessageClientNotInGroupDoesNotReceiveMsg = do + localDomain <- viewFederationDomain + cannon <- view tsCannon + (alice, ac) <- randomUserWithClient (someLastPrekeys !! 0) + (bob, bc) <- randomUserWithClient (someLastPrekeys !! 1) + (eve, ec) <- randomUserWithClient (someLastPrekeys !! 2) + (chad, cc) <- randomUserWithClient (someLastPrekeys !! 3) + connectUsers alice (list1 bob [eve, chad]) + conversationWithAllButChad <- decodeConvId <$> postConv alice [bob, eve] (Just "gossip") [] Nothing Nothing + let qalice = Qualified alice localDomain + qconv = Qualified conversationWithAllButChad localDomain + WS.bracketR3 cannon bob eve chad $ \(wsBob, wsEve, wsChad) -> do + let msgToAllIncludingChad = [(bob, bc, toBase64Text "ciphertext2"), (eve, ec, toBase64Text "ciphertext2"), (chad, cc, toBase64Text "ciphertext2")] + postOtrMessage id alice ac conversationWithAllButChad msgToAllIncludingChad !!! const 201 === statusCode + let checkBobGetsMsg = void . liftIO $ WS.assertMatch (5 # Second) wsBob (wsAssertOtr qconv qalice ac bc (toBase64Text "ciphertext2")) + let checkEveGetsMsg = void . liftIO $ WS.assertMatch (5 # Second) wsEve (wsAssertOtr qconv qalice ac ec (toBase64Text "ciphertext2")) + let checkChadDoesNotGetMsg = assertNoMsg wsChad (wsAssertOtr qconv qalice ac ac (toBase64Text "ciphertext2")) + checkBobGetsMsg + checkEveGetsMsg + checkChadDoesNotGetMsg + +-- @END + +-- @SF.Separation @TSFI.RESTfulAPI @S2 +-- This test verifies that when a client sends a message not to all clients of a group then the server should reject the message and sent a notification to the sender (412 Missing clients). +-- The test is somewhat redundant because this is already tested as part of other tests already. This is a stand alone test that solely tests the behavior described above. +postMessageRejectIfMissingClients :: TestM () +postMessageRejectIfMissingClients = do + (sender, senderClient) : allReceivers <- randomUserWithClient `traverse` someLastPrekeys + let (receiver1, receiverClient1) : otherReceivers = allReceivers + connectUsers sender (list1 receiver1 (fst <$> otherReceivers)) + conv <- decodeConvId <$> postConv sender (receiver1 : (fst <$> otherReceivers)) (Just "gossip") [] Nothing Nothing + let msgToAllClients = mkMsg "hello!" <$> allReceivers + let msgMissingClients = mkMsg "hello!" <$> drop 1 allReceivers + + let checkSendToAllClientShouldBeSuccessful = + postOtrMessage id sender senderClient conv msgToAllClients !!! do + const 201 === statusCode + assertMismatch [] [] [] + + let checkSendWitMissingClientsShouldFail = + postOtrMessage id sender senderClient conv msgMissingClients !!! do + const 412 === statusCode + assertMismatch [(receiver1, Set.singleton receiverClient1)] [] [] + + checkSendToAllClientShouldBeSuccessful + checkSendWitMissingClientsShouldFail + where + mkMsg :: ByteString -> (UserId, ClientId) -> (UserId, ClientId, Text) + mkMsg text (userId, clientId) = (userId, clientId, toBase64Text text) + +-- @END + +-- @SF.Separation @TSFI.RESTfulAPI @S2 +-- This test verifies behaviour under various values of ignore_missing and -- report_missing. Only tests the JSON endpoint. -postCryptoMessage5 :: TestM () -postCryptoMessage5 = do +postCryptoMessageVerifyCorrectResponseIfIgnoreAndReportMissingQueryParam :: TestM () +postCryptoMessageVerifyCorrectResponseIfIgnoreAndReportMissingQueryParam = do (alice, ac) <- randomUserWithClient (someLastPrekeys !! 0) (bob, bc) <- randomUserWithClient (someLastPrekeys !! 1) (chad, cc) <- randomUserWithClient (someLastPrekeys !! 2) @@ -573,6 +617,8 @@ postCryptoMessage5 = do where listToByteString = BS.intercalate "," . map toByteString' +-- @END + -- | Sets up a conversation on Backend A known as "owning backend". All user's -- on this backend have names begining with 'A'. The conversation has a couple -- of users from backend B and one user from backend C. @@ -626,22 +672,20 @@ postMessageQualifiedLocalOwningBackendSuccess = do let mkPubClient c = PubClient c Nothing brigApi d = - emptyFederatedBrig - { F.getUserClients = \_ -> - pure $ - if - | d == bDomain -> - UserMap . Map.fromList $ - [ (qUnqualified bob, Set.singleton (mkPubClient bobClient)), - (qUnqualified bart, Set.fromList (map mkPubClient [bartClient1, bartClient2])) - ] - | d == cDomain -> UserMap (Map.singleton (qUnqualified carl) (Set.singleton (PubClient carlClient Nothing))) - | otherwise -> mempty - } + mkHandler @(FedApi 'Brig) $ + Named @"get-user-clients" $ \_ _ -> + pure $ + if + | d == bDomain -> + UserMap . Map.fromList $ + [ (qUnqualified bob, Set.singleton (mkPubClient bobClient)), + (qUnqualified bart, Set.fromList (map mkPubClient [bartClient1, bartClient2])) + ] + | d == cDomain -> UserMap (Map.singleton (qUnqualified carl) (Set.singleton (PubClient carlClient Nothing))) + | otherwise -> mempty + galleyApi _ = - emptyFederatedGalley - { F.onMessageSent = \_ _ -> pure () - } + mkHandler @(FedApi 'Galley) $ Named @"on-message-sent" $ \_ _ -> pure () (resp2, requests) <- postProteusMessageQualifiedWithMockFederator aliceU aliceClient convId message "data" Message.MismatchReportAll brigApi galleyApi pure resp2 !!! do @@ -706,7 +750,8 @@ postMessageQualifiedLocalOwningBackendSuccess = do WS.assertMatch_ t wsAlex2 (wsAssertOtr' encodedData convId alice aliceClient alexClient2 encodedTextForAlex2) WS.assertMatch_ t wsAmy (wsAssertOtr' encodedData convId alice aliceClient amyClient encodedTextForAmy) --- | Sets up a conversation on Backend A known as "owning backend". One of the +-- @SF.Separation @TSFI.RESTfulAPI @S2 +-- Sets up a conversation on Backend A known as "owning backend". One of the -- users from Backend A will send the message but have a missing client. It is -- expected that the message will not be sent. postMessageQualifiedLocalOwningBackendMissingClients :: TestM () @@ -745,11 +790,10 @@ postMessageQualifiedLocalOwningBackendMissingClients = do -- FUTUREWORK: Mock federator and ensure that message is not propagated to remotes WS.bracketR2 cannon bobUnqualified chadUnqualified $ \(wsBob, wsChad) -> do let brigApi _ = - emptyFederatedBrig - { F.getUserClients = \_ -> - pure $ UserMap (Map.singleton (qUnqualified deeRemote) (Set.singleton (PubClient deeClient Nothing))) - } - galleyApi _ = emptyFederatedGalley + mkHandler @(FedApi 'Brig) $ + Named @"get-user-clients" $ \_ _ -> + pure $ UserMap (Map.singleton (qUnqualified deeRemote) (Set.singleton (PubClient deeClient Nothing))) + galleyApi _ = mkHandler @(FedApi 'Galley) EmptyAPI (resp2, _requests) <- postProteusMessageQualifiedWithMockFederator aliceUnqualified aliceClient convId message "data" Message.MismatchReportAll brigApi galleyApi @@ -771,6 +815,8 @@ postMessageQualifiedLocalOwningBackendMissingClients = do assertMismatchQualified mempty expectedMissing mempty mempty WS.assertNoEvent (1 # Second) [wsBob, wsChad] +-- @END + -- | Sets up a conversation on Backend A known as "owning backend". One of the -- users from Backend A will send the message, it is expected that message will -- be sent successfully. @@ -822,18 +868,16 @@ postMessageQualifiedLocalOwningBackendRedundantAndDeletedClients = do -- FUTUREWORK: Mock federator and ensure that a message to Dee is sent let brigApi _ = - emptyFederatedBrig - { F.getUserClients = \getUserClients -> - let lookupClients uid - | uid == deeRemoteUnqualified = Just (uid, Set.fromList [PubClient deeClient Nothing]) - | uid == nonMemberRemoteUnqualified = Just (uid, Set.fromList [PubClient nonMemberRemoteClient Nothing]) - | otherwise = Nothing - in pure $ UserMap . Map.fromList . mapMaybe lookupClients $ F.gucUsers getUserClients - } + mkHandler @(FedApi 'Brig) $ + Named @"get-user-clients" $ \_ getUserClients -> + let lookupClients uid + | uid == deeRemoteUnqualified = Just (uid, Set.fromList [PubClient deeClient Nothing]) + | uid == nonMemberRemoteUnqualified = Just (uid, Set.fromList [PubClient nonMemberRemoteClient Nothing]) + | otherwise = Nothing + in pure $ UserMap . Map.fromList . mapMaybe lookupClients $ F.gucUsers getUserClients galleyApi _ = - emptyFederatedGalley - { F.onMessageSent = \_ _ -> pure () - } + mkHandler @(FedApi 'Galley) $ + Named @"on-message-sent" $ \_ _ -> pure () (resp2, _requests) <- postProteusMessageQualifiedWithMockFederator aliceUnqualified aliceClient convId message "data" Message.MismatchReportAll brigApi galleyApi pure resp2 !!! do @@ -864,7 +908,8 @@ postMessageQualifiedLocalOwningBackendRedundantAndDeletedClients = do -- Wait less for no message WS.assertNoEvent (1 # Second) [wsNonMember] --- | Sets up a conversation on Backend A known as "owning backend". One of the +-- @SF.Separation @TSFI.RESTfulAPI @S2 +-- Sets up a conversation on Backend A known as "owning backend". One of the -- users from Backend A will send the message but have a missing client. It is -- expected that the message will be sent except when it is specifically -- requested to report on missing clients of a user. @@ -902,10 +947,10 @@ postMessageQualifiedLocalOwningBackendIgnoreMissingClients = do let convId = (`Qualified` owningDomain) . decodeConvId $ resp let brigApi _ = - emptyFederatedBrig - { F.getUserClients = \_ -> pure $ UserMap (Map.singleton (qUnqualified deeRemote) (Set.singleton (PubClient deeClient Nothing))) - } - galleyApi _ = emptyFederatedGalley + mkHandler @(FedApi 'Brig) $ + Named @"get-user-clients" $ \_ _ -> + pure $ UserMap (Map.singleton (qUnqualified deeRemote) (Set.singleton (PubClient deeClient Nothing))) + galleyApi _ = mkHandler @(FedApi 'Galley) EmptyAPI -- Missing Bob, chadClient2 and Dee let message = [(chadOwningDomain, chadClient, "text-for-chad")] @@ -994,6 +1039,8 @@ postMessageQualifiedLocalOwningBackendIgnoreMissingClients = do assertMismatchQualified mempty expectedMissing mempty mempty WS.assertNoEvent (1 # Second) [wsBob, wsChad] +-- @END + postMessageQualifiedLocalOwningBackendFailedToSendClients :: TestM () postMessageQualifiedLocalOwningBackendFailedToSendClients = do -- WS receive timeout @@ -1035,14 +1082,13 @@ postMessageQualifiedLocalOwningBackendFailedToSendClients = do ] let brigApi _ = - emptyFederatedBrig - { F.getUserClients = \_ -> - pure $ UserMap (Map.singleton (qUnqualified deeRemote) (Set.singleton (PubClient deeClient Nothing))) - } + mkHandler @(FedApi 'Brig) $ + Named @"get-user-clients" $ \_ _ -> + pure $ UserMap (Map.singleton (qUnqualified deeRemote) (Set.singleton (PubClient deeClient Nothing))) galleyApi _ = - emptyFederatedGalley - { F.onMessageSent = \_ _ -> throwError err503 {errBody = "Down for maintenance."} - } + mkHandler @(FedApi 'Galley) $ + Named @"on-message-sent" $ \_ _ -> + throwError err503 {errBody = "Down for maintenance."} (resp2, _requests) <- postProteusMessageQualifiedWithMockFederator aliceUnqualified aliceClient convId message "data" Message.MismatchReportAll brigApi galleyApi @@ -1073,13 +1119,14 @@ postMessageQualifiedRemoteOwningBackendFailure = do let remoteDomain = Domain "far-away.example.com" convId = Qualified convIdUnqualified remoteDomain + let brigApi _ = mkHandler @(FedApi 'Brig) EmptyAPI let galleyApi _ = - emptyFederatedGalley - { F.sendMessage = \_ _ -> throwError err503 {errBody = "Down for maintenance."} - } + mkHandler @(FedApi 'Galley) $ + Named @"send-message" $ \_ _ -> + throwError err503 {errBody = "Down for maintenance."} (resp2, _requests) <- - postProteusMessageQualifiedWithMockFederator aliceUnqualified aliceClient convId [] "data" Message.MismatchReportAll (const emptyFederatedBrig) galleyApi + postProteusMessageQualifiedWithMockFederator aliceUnqualified aliceClient convId [] "data" Message.MismatchReportAll brigApi galleyApi pure resp2 !!! do const 503 === statusCode @@ -1113,13 +1160,13 @@ postMessageQualifiedRemoteOwningBackendSuccess = do Message.mssFailedToSend = mempty } message = [(bobOwningDomain, bobClient, "text-for-bob"), (deeRemote, deeClient, "text-for-dee")] - galleyApi _ = - emptyFederatedGalley - { F.sendMessage = \_ _ -> pure (F.MessageSendResponse (Right mss)) - } + brigApi _ = mkHandler @(FedApi 'Brig) EmptyAPI + galleyApi _ = mkHandler @(FedApi 'Galley) $ + Named @"send-message" $ \_ _ -> + pure (F.MessageSendResponse (Right mss)) (resp2, _requests) <- - postProteusMessageQualifiedWithMockFederator aliceUnqualified aliceClient convId message "data" Message.MismatchReportAll (const emptyFederatedBrig) galleyApi + postProteusMessageQualifiedWithMockFederator aliceUnqualified aliceClient convId message "data" Message.MismatchReportAll brigApi galleyApi pure resp2 !!! do const 201 === statusCode @@ -1158,6 +1205,96 @@ testJoinCodeConv = do getJoinCodeConv eve (conversationKey cCode) (conversationCode cCode) !!! do const 403 === statusCode +testGetCodeRejectedIfGuestLinksDisabled :: TestM () +testGetCodeRejectedIfGuestLinksDisabled = do + galley <- view tsGalley + (owner, teamId, []) <- Util.createBindingTeamWithNMembers 0 + let createConvWithGuestLink = do + convId <- decodeConvId <$> postTeamConv teamId owner [] (Just "testConversation") [CodeAccess] (Just ActivatedAccessRole) Nothing + void $ decodeConvCodeEvent <$> postConvCode owner convId + pure convId + convId <- createConvWithGuestLink + let checkGetCode expectedStatus = getConvCode owner convId !!! statusCode === const expectedStatus + let setStatus tfStatus = + TeamFeatures.putTeamFeatureFlagWithGalley @'Public.TeamFeatureGuestLinks galley owner teamId (Public.TeamFeatureStatusNoConfig tfStatus) !!! do + const 200 === statusCode + + checkGetCode 200 + setStatus Public.TeamFeatureDisabled + checkGetCode 409 + setStatus Public.TeamFeatureEnabled + checkGetCode 200 + +testPostCodeRejectedIfGuestLinksDisabled :: TestM () +testPostCodeRejectedIfGuestLinksDisabled = do + galley <- view tsGalley + (owner, teamId, []) <- Util.createBindingTeamWithNMembers 0 + convId <- decodeConvId <$> postTeamConv teamId owner [] (Just "testConversation") [CodeAccess] (Just ActivatedAccessRole) Nothing + let checkPostCode expectedStatus = postConvCode owner convId !!! statusCode === const expectedStatus + let setStatus tfStatus = + TeamFeatures.putTeamFeatureFlagWithGalley @'Public.TeamFeatureGuestLinks galley owner teamId (Public.TeamFeatureStatusNoConfig tfStatus) !!! do + const 200 === statusCode + + checkPostCode 201 + setStatus Public.TeamFeatureDisabled + checkPostCode 409 + setStatus Public.TeamFeatureEnabled + checkPostCode 200 + +testJoinTeamConvGuestLinksDisabled :: TestM () +testJoinTeamConvGuestLinksDisabled = do + galley <- view tsGalley + let convName = "testConversation" + (owner, teamId, []) <- Util.createBindingTeamWithNMembers 0 + userNotInTeam <- randomUser + convId <- decodeConvId <$> postTeamConv teamId owner [] (Just convName) [CodeAccess] (Just ActivatedAccessRole) Nothing + cCode <- decodeConvCodeEvent <$> postConvCode owner convId + + -- works by default + getJoinCodeConv userNotInTeam (conversationKey cCode) (conversationCode cCode) !!! do + const (Right (ConversationCoverView convId (Just convName))) === responseJsonEither + const 200 === statusCode + + -- fails if disabled + let tfStatus = Public.TeamFeatureStatusNoConfig Public.TeamFeatureDisabled + TeamFeatures.putTeamFeatureFlagWithGalley @'Public.TeamFeatureGuestLinks galley owner teamId tfStatus !!! do + const 200 === statusCode + + getJoinCodeConv userNotInTeam (conversationKey cCode) (conversationCode cCode) !!! do + const 409 === statusCode + + -- after re-enabling, the old link is still valid + let tfStatus' = Public.TeamFeatureStatusNoConfig Public.TeamFeatureEnabled + TeamFeatures.putTeamFeatureFlagWithGalley @'Public.TeamFeatureGuestLinks galley owner teamId tfStatus' !!! do + const 200 === statusCode + + getJoinCodeConv userNotInTeam (conversationKey cCode) (conversationCode cCode) !!! do + const (Right (ConversationCoverView convId (Just convName))) === responseJsonEither + const 200 === statusCode + +testJoinNonTeamConvGuestLinksDisabled :: TestM () +testJoinNonTeamConvGuestLinksDisabled = do + galley <- view tsGalley + let convName = "testConversation" + (owner, teamId, []) <- Util.createBindingTeamWithNMembers 0 + userNotInTeam <- randomUser + convId <- decodeConvId <$> postConv owner [] (Just convName) [CodeAccess] (Just ActivatedAccessRole) Nothing + cCode <- decodeConvCodeEvent <$> postConvCode owner convId + + -- works by default + getJoinCodeConv userNotInTeam (conversationKey cCode) (conversationCode cCode) !!! do + const (Right (ConversationCoverView convId (Just convName))) === responseJsonEither + const 200 === statusCode + + -- for non-team conversations it still works if status is disabled for the team but not server wide + let tfStatus = Public.TeamFeatureStatusNoConfig Public.TeamFeatureDisabled + TeamFeatures.putTeamFeatureFlagWithGalley @'Public.TeamFeatureGuestLinks galley owner teamId tfStatus !!! do + const 200 === statusCode + + getJoinCodeConv userNotInTeam (conversationKey cCode) (conversationCode cCode) !!! do + const (Right (ConversationCoverView convId (Just convName))) === responseJsonEither + const 200 === statusCode + postJoinCodeConvOk :: TestM () postJoinCodeConvOk = do c <- view tsCannon @@ -1490,7 +1627,7 @@ paginateConvListIds = do F.cuAlreadyPresentUsers = [], F.cuAction = ConversationActionAddMembers (pure qAlice) roleNameWireMember } - F.onConversationUpdated (fedGalleyClient chadDomain) cu + runFedClient @"on-conversation-updated" fedGalleyClient chadDomain cu remoteDee <- randomId let deeDomain = Domain "dee.example.com" @@ -1506,7 +1643,7 @@ paginateConvListIds = do F.cuAlreadyPresentUsers = [], F.cuAction = ConversationActionAddMembers (pure qAlice) roleNameWireMember } - F.onConversationUpdated (fedGalleyClient deeDomain) cu + runFedClient @"on-conversation-updated" fedGalleyClient deeDomain cu -- 1 self conv + 2 convs with bob and eve + 197 local convs + 25 convs on -- chad.example.com + 31 on dee.example = 256 convs. Getting them 16 at a time @@ -1551,7 +1688,7 @@ paginateConvListIdsPageEndingAtLocalsAndDomain = do F.cuAlreadyPresentUsers = [], F.cuAction = ConversationActionAddMembers (pure qAlice) roleNameWireMember } - F.onConversationUpdated (fedGalleyClient chadDomain) cu + runFedClient @"on-conversation-updated" fedGalleyClient chadDomain cu remoteDee <- randomId let deeDomain = Domain "dee.example.com" @@ -1569,7 +1706,7 @@ paginateConvListIdsPageEndingAtLocalsAndDomain = do F.cuAlreadyPresentUsers = [], F.cuAction = ConversationActionAddMembers (pure qAlice) roleNameWireMember } - F.onConversationUpdated (fedGalleyClient deeDomain) cu + runFedClient @"on-conversation-updated" fedGalleyClient deeDomain cu foldM_ (getChunkedConvs 16 0 alice) Nothing [4, 3, 2, 1, 0 :: Int] @@ -2049,11 +2186,8 @@ testDeleteTeamConversationWithRemoteMembers = do connectWithRemoteUser alice remoteBob - let brigApi _ = emptyFederatedBrig - galleyApi _ = - emptyFederatedGalley - { onConversationUpdated = \_domain _update -> pure () - } + let brigApi _ = mkHandler @(FedApi 'Brig) EmptyAPI + galleyApi _ = mkHandler @(FedApi 'Galley) $ Named @"on-conversation-updated" $ \_ _ -> pure () (_, received) <- withTempServantMockFederator brigApi galleyApi localDomain $ do postQualifiedMembers alice (remoteBob :| []) convId @@ -3021,7 +3155,7 @@ putRemoteConvMemberOk update = do cuAction = ConversationActionAddMembers (pure qalice) roleNameWireMember } - F.onConversationUpdated (fedGalleyClient remoteDomain) cu + runFedClient @"on-conversation-updated" fedGalleyClient remoteDomain cu -- Expected member state let memberAlice = @@ -3284,10 +3418,10 @@ removeUser = do F.rcMessageTimer = Nothing, F.rcReceiptMode = Nothing } - F.onConversationCreated (fedGalleyClient bDomain) $ nc convB1 bart [alice, alexDel] - F.onConversationCreated (fedGalleyClient bDomain) $ nc convB2 bart [alexDel] - F.onConversationCreated (fedGalleyClient cDomain) $ nc convC1 carl [alexDel] - F.onConversationCreated (fedGalleyClient dDomain) $ nc convD1 dory [alexDel] + runFedClient @"on-conversation-created" fedGalleyClient bDomain $ nc convB1 bart [alice, alexDel] + runFedClient @"on-conversation-created" fedGalleyClient bDomain $ nc convB2 bart [alexDel] + runFedClient @"on-conversation-created" fedGalleyClient cDomain $ nc convC1 carl [alexDel] + runFedClient @"on-conversation-created" fedGalleyClient dDomain $ nc convD1 dory [alexDel] WS.bracketR3 c alice' alexDel' amy' $ \(wsAlice, wsAlexDel, wsAmy) -> do let handler :: FederatedRequest -> IO LByteString @@ -3417,8 +3551,7 @@ testOne2OneConversationRequest shouldBeLocal actor desired = do RemoteActor -> do fedGalleyClient <- view tsFedGalleyClient GetConversationsResponse convs <- - F.getConversations - (fedGalleyClient (tDomain bob)) + runFedClient @"get-conversations" fedGalleyClient (tDomain bob) $ F.GetConversationsRequest { F.gcrUserId = tUnqualified bob, F.gcrConvIds = [qUnqualified convId] diff --git a/services/galley/test/integration/API/Federation.hs b/services/galley/test/integration/API/Federation.hs index 6dd267d9b8d..adbfafd507f 100644 --- a/services/galley/test/integration/API/Federation.hs +++ b/services/galley/test/integration/API/Federation.hs @@ -133,12 +133,10 @@ getConversationsAllFound = do fedGalleyClient <- view tsFedGalleyClient GetConversationsResponse convs <- - FedGalley.getConversations - (fedGalleyClient (qDomain aliceQ)) - ( GetConversationsRequest - (qUnqualified aliceQ) - (map qUnqualified [cnv1Id, cnvQualifiedId cnv2]) - ) + runFedClient @"get-conversations" fedGalleyClient (qDomain aliceQ) $ + GetConversationsRequest + (qUnqualified aliceQ) + (map qUnqualified [cnv1Id, cnvQualifiedId cnv2]) let c2 = find ((== qUnqualified (cnvQualifiedId cnv2)) . rcnvId) convs @@ -171,9 +169,8 @@ getConversationsNotPartOf = do localDomain <- viewFederationDomain rando <- Id <$> liftIO nextRandom GetConversationsResponse convs <- - FedGalley.getConversations - (fedGalleyClient localDomain) - (GetConversationsRequest rando [qUnqualified . cnvQualifiedId $ cnv1]) + runFedClient @"get-conversations" fedGalleyClient localDomain $ + GetConversationsRequest rando [qUnqualified . cnvQualifiedId $ cnv1] liftIO $ assertEqual "conversation list not empty" [] convs onConvCreated :: TestM () @@ -235,7 +232,7 @@ addLocalUser = do ConversationActionAddMembers (qalice :| [qdee]) roleNameWireMember } WS.bracketRN c [alice, charlie, dee] $ \[wsA, wsC, wsD] -> do - FedGalley.onConversationUpdated (fedGalleyClient remoteDomain) cu + runFedClient @"on-conversation-updated" fedGalleyClient remoteDomain cu liftIO $ do WS.assertMatch_ (5 # Second) wsA $ wsAssertMemberJoinWithRole qconv qbob [qalice] roleNameWireMember @@ -289,7 +286,7 @@ addUnconnectedUsersOnly = do ConversationActionAddMembers (qCharlie :| []) roleNameWireMember } -- Alice receives no notifications from this - FedGalley.onConversationUpdated (fedGalleyClient remoteDomain) cu + runFedClient @"on-conversation-updated" fedGalleyClient remoteDomain cu WS.assertNoEvent (5 # Second) [wsA] -- | This test invokes the federation endpoint: @@ -334,9 +331,9 @@ removeLocalUser = do connectWithRemoteUser alice qBob WS.bracketR c alice $ \ws -> do - FedGalley.onConversationUpdated (fedGalleyClient remoteDomain) cuAdd + runFedClient @"on-conversation-updated" fedGalleyClient remoteDomain cuAdd afterAddition <- listRemoteConvs remoteDomain alice - FedGalley.onConversationUpdated (fedGalleyClient remoteDomain) cuRemove + runFedClient @"on-conversation-updated" fedGalleyClient remoteDomain cuRemove liftIO $ do void . WS.assertMatch (3 # Second) ws $ wsAssertMemberJoinWithRole qconv qBob [qAlice] roleNameWireMember @@ -397,21 +394,21 @@ removeRemoteUser = do } WS.bracketRN c [alice, charlie, dee, flo] $ \[wsA, wsC, wsD, wsF] -> do - FedGalley.onConversationUpdated (fedGalleyClient remoteDomain) (cuRemove qEve) + runFedClient @"on-conversation-updated" fedGalleyClient remoteDomain (cuRemove qEve) liftIO $ do WS.assertMatchN_ (3 # Second) [wsA, wsD] $ wsAssertMembersLeave qconv qBob [qEve] WS.assertNoEvent (1 # Second) [wsC, wsF] WS.bracketRN c [alice, charlie, dee, flo] $ \[wsA, wsC, wsD, wsF] -> do - FedGalley.onConversationUpdated (fedGalleyClient remoteDomain) (cuRemove qDee) + runFedClient @"on-conversation-updated" fedGalleyClient remoteDomain (cuRemove qDee) liftIO $ do WS.assertMatchN_ (3 # Second) [wsA, wsD] $ wsAssertMembersLeave qconv qBob [qDee] WS.assertNoEvent (1 # Second) [wsC, wsF] WS.bracketRN c [alice, charlie, dee, flo] $ \[wsA, wsC, wsD, wsF] -> do - FedGalley.onConversationUpdated (fedGalleyClient remoteDomain) (cuRemove qFlo) + runFedClient @"on-conversation-updated" fedGalleyClient remoteDomain (cuRemove qFlo) liftIO $ do WS.assertMatchN_ (3 # Second) [wsA] $ wsAssertMembersLeave qconv qBob [qFlo] @@ -448,7 +445,7 @@ notifyUpdate extras action etype edata = do FedGalley.cuAction = action } WS.bracketR2 c alice charlie $ \(wsA, wsC) -> do - FedGalley.onConversationUpdated (fedGalleyClient bdom) cu + runFedClient @"on-conversation-updated" fedGalleyClient bdom cu liftIO $ do WS.assertMatch_ (5 # Second) wsA $ \n -> do let e = List1.head (WS.unpackPayload n) @@ -548,7 +545,7 @@ notifyDeletedConversation = do FedGalley.cuAlreadyPresentUsers = [alice], FedGalley.cuAction = ConversationActionDelete } - FedGalley.onConversationUpdated (fedGalleyClient bobDomain) cu + runFedClient @"on-conversation-updated" fedGalleyClient bobDomain cu liftIO $ do WS.assertMatch_ (5 # Second) wsAlice $ \n -> do @@ -606,7 +603,7 @@ addRemoteUser = do ConversationActionAddMembers (qdee :| [qeve, qflo]) roleNameWireMember } WS.bracketRN c (map qUnqualified [qalice, qcharlie, qdee, qflo]) $ \[wsA, wsC, wsD, wsF] -> do - FedGalley.onConversationUpdated (fedGalleyClient bdom) cu + runFedClient @"on-conversation-updated" fedGalleyClient bdom cu void . liftIO $ do WS.assertMatchN_ (5 # Second) [wsA, wsD] $ wsAssertMemberJoinWithRole qconv qbob [qeve, qdee] roleNameWireMember @@ -754,7 +751,7 @@ onMessageSent = do FedGalley.cuAction = ConversationActionAddMembers (pure qalice) roleNameWireMember } - FedGalley.onConversationUpdated (fedGalleyClient bdom) cu + runFedClient @"on-conversation-updated" fedGalleyClient bdom cu let txt = "Hello from another backend" msg client = Map.fromList [(client, txt)] @@ -776,7 +773,7 @@ onMessageSent = do -- send message to alice and check reception WS.bracketAsClientRN c [(alice, aliceC1), (alice, aliceC2), (eve, eveC)] $ \[wsA1, wsA2, wsE] -> do - FedGalley.onMessageSent (fedGalleyClient bdom) rm + runFedClient @"on-message-sent" fedGalleyClient bdom rm liftIO $ do -- alice should receive the message on her first client WS.assertMatch_ (5 # Second) wsA1 $ \n -> do diff --git a/services/galley/test/integration/API/Federation/Util.hs b/services/galley/test/integration/API/Federation/Util.hs new file mode 100644 index 00000000000..9f5d70c77de --- /dev/null +++ b/services/galley/test/integration/API/Federation/Util.hs @@ -0,0 +1,91 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module API.Federation.Util (mkHandler) where + +import Data.SOP +import Data.String.Conversions (cs) +import GHC.TypeLits +import Imports +import Servant +import Wire.API.Federation.Domain +import Wire.API.Routes.Named + +class HasTrivialHandler api where + trivialHandler :: String -> Server api + +instance HasTrivialHandler (Verb m c cs a) where + trivialHandler name = throwError err501 {errBody = cs ("mock not implemented: " <> name)} + +instance HasTrivialHandler api => HasTrivialHandler ((path :: Symbol) :> api) where + trivialHandler = trivialHandler @api + +instance HasTrivialHandler api => HasTrivialHandler (OriginDomainHeader :> api) where + trivialHandler name _ = trivialHandler @api name + +instance HasTrivialHandler api => HasTrivialHandler (ReqBody cs a :> api) where + trivialHandler name _ = trivialHandler @api name + +trivialNamedHandler :: + forall (name :: Symbol) api. + (KnownSymbol name, HasTrivialHandler api) => + Server (Named name api) +trivialNamedHandler = Named (trivialHandler @api (symbolVal (Proxy @name))) + +-- | Generate a servant handler from an incomplete list of handlers of named +-- endpoints. +class PartialAPI (api :: *) (hs :: *) where + mkHandler :: hs -> Server api + +instance + (KnownSymbol name, HasTrivialHandler endpoint) => + PartialAPI (Named (name :: Symbol) endpoint) EmptyAPI + where + mkHandler _ = trivialNamedHandler @name @endpoint + +instance + {-# OVERLAPPING #-} + (KnownSymbol name, HasTrivialHandler endpoint, PartialAPI api EmptyAPI) => + PartialAPI (Named (name :: Symbol) endpoint :<|> api) EmptyAPI + where + mkHandler h = trivialNamedHandler @name @endpoint :<|> mkHandler @api h + +instance + {-# OVERLAPPING #-} + (h ~ Server endpoint, PartialAPI api hs) => + PartialAPI (Named (name :: Symbol) endpoint :<|> api) (Named name h :<|> hs) + where + mkHandler (h :<|> hs) = h :<|> mkHandler @api hs + +instance + (KnownSymbol name, HasTrivialHandler endpoint, PartialAPI api hs) => + PartialAPI (Named (name :: Symbol) endpoint :<|> api) hs + where + mkHandler hs = trivialNamedHandler @name @endpoint :<|> mkHandler @api hs + +instance + (h ~ Server endpoint) => + PartialAPI (Named (name :: Symbol) endpoint) (Named name h) + where + mkHandler = id + +instance + {-# OVERLAPPING #-} + (h ~ Server endpoint, PartialAPI api EmptyAPI) => + PartialAPI (Named (name :: Symbol) endpoint :<|> api) (Named name h) + where + mkHandler h = h :<|> mkHandler @api EmptyAPI diff --git a/services/galley/test/integration/API/MessageTimer.hs b/services/galley/test/integration/API/MessageTimer.hs index f0e1d91fb21..e773e3a5491 100644 --- a/services/galley/test/integration/API/MessageTimer.hs +++ b/services/galley/test/integration/API/MessageTimer.hs @@ -189,7 +189,7 @@ messageTimerChangeWithoutAllowedAction = do -- Create a team and a guest user [owner, member, guest] <- randomUsers 3 connectUsers owner (list1 member [guest]) - tid <- createNonBindingTeam "team" owner [Member.TeamMember member Teams.fullPermissions Nothing LH.defUserLegalHoldStatus] + tid <- createNonBindingTeam "team" owner [Member.mkTeamMember member Teams.fullPermissions Nothing LH.defUserLegalHoldStatus] -- Create a conversation cid <- createTeamConvWithRole owner tid [member, guest] Nothing Nothing Nothing roleNameWireMember -- Try to change the timer (as a non admin, guest user) and observe failure diff --git a/services/galley/test/integration/API/Teams.hs b/services/galley/test/integration/API/Teams.hs index 837f499864b..25c5d03f4a3 100644 --- a/services/galley/test/integration/API/Teams.hs +++ b/services/galley/test/integration/API/Teams.hs @@ -83,7 +83,8 @@ tests :: IO TestSetup -> TestTree tests s = testGroup "Teams API" $ [ test s "create team" testCreateTeam, - test s "create multiple binding teams fail" testCreateMulitpleBindingTeams, + test s "GET /teams (deprecated)" testGetTeams, + test s "create multiple binding teams fail" testCreateMultipleBindingTeams, test s "create binding team with currency" testCreateBindingTeamWithCurrency, test s "create team with members" testCreateTeamWithMembers, testGroup "List Team Members" $ @@ -164,8 +165,30 @@ testCreateTeam = do e ^. eventData @?= Just (EdTeamCreate team) void $ WS.assertSuccess eventChecks -testCreateMulitpleBindingTeams :: TestM () -testCreateMulitpleBindingTeams = do +testGetTeams :: TestM () +testGetTeams = do + owner <- Util.randomUser + Util.getTeams owner [] >>= checkTeamList Nothing + tid <- Util.createBindingTeamInternal "foo" owner <* assertQueue "create team" tActivate + wrongTid <- (Util.randomUser >>= Util.createBindingTeamInternal "foobar") <* assertQueue "create team" tActivate + Util.getTeams owner [] >>= checkTeamList (Just tid) + Util.getTeams owner [("size", Just "1")] >>= checkTeamList (Just tid) + Util.getTeams owner [("ids", Just $ toByteString' tid)] >>= checkTeamList (Just tid) + Util.getTeams owner [("ids", Just $ toByteString' tid <> "," <> toByteString' wrongTid)] >>= checkTeamList (Just tid) + -- these two queries do not yield responses that are equivalent to the old wai route API + Util.getTeams owner [("ids", Just $ toByteString' wrongTid)] >>= checkTeamList (Just tid) + Util.getTeams owner [("start", Just $ toByteString' tid)] >>= checkTeamList (Just tid) + where + checkTeamList :: Maybe TeamId -> TeamList -> TestM () + checkTeamList mbTid tl = liftIO $ do + let teams = tl ^. teamListTeams + assertEqual "teamListHasMore" False (tl ^. teamListHasMore) + case mbTid of + Just tid -> assertEqual "teamId" tid (Imports.head teams ^. teamId) + Nothing -> assertEqual "teams size" 0 (length teams) + +testCreateMultipleBindingTeams :: TestM () +testCreateMultipleBindingTeams = do g <- view tsGalley owner <- Util.randomUser _ <- Util.createBindingTeamInternal "foo" owner @@ -480,7 +503,7 @@ testAddTeamMember = do Util.connectUsers (mem1 ^. userId) (list1 (mem2 ^. userId) []) tid <- Util.createNonBindingTeam "foo" owner [mem1, mem2] mem3 <- newTeamMember' p1 <$> Util.randomUser - let payload = json (newNewTeamMember (mem3 ^. userId) (mem3 ^. permissions) (mem3 ^. invitation)) + let payload = json (Member.mkNewTeamMember (mem3 ^. userId) (mem3 ^. permissions) (mem3 ^. invitation)) Util.connectUsers (mem1 ^. userId) (list1 (mem3 ^. userId) []) Util.connectUsers (mem2 ^. userId) (list1 (mem3 ^. userId) []) -- `mem1` lacks permission to add new team members @@ -566,7 +589,7 @@ testAddTeamMemberCheckBound = do ( g . paths ["teams", toByteString' tidBound, "members"] . zUser ownerBound . zConn "conn" - . json (newNewTeamMember (rndMem ^. userId) (rndMem ^. permissions) (rndMem ^. invitation)) + . json (Member.mkNewTeamMember (rndMem ^. userId) (rndMem ^. permissions) (rndMem ^. invitation)) ) !!! const 403 === statusCode owner <- Util.randomUser @@ -576,7 +599,7 @@ testAddTeamMemberCheckBound = do post ( g . paths ["teams", toByteString' tid, "members"] . zUser owner . zConn "conn" - . json (newNewTeamMember (boundMem ^. userId) (boundMem ^. permissions) (boundMem ^. invitation)) + . json (Member.mkNewTeamMember (boundMem ^. userId) (boundMem ^. permissions) (boundMem ^. invitation)) ) !!! const 403 === statusCode @@ -970,7 +993,7 @@ testUpdateTeamConv (rolePermissions -> perms) convRole = do owner <- Util.randomUser member <- Util.randomUser Util.connectUsers owner (list1 member []) - tid <- Util.createNonBindingTeam "foo" owner [Member.TeamMember member perms Nothing LH.defUserLegalHoldStatus] + tid <- Util.createNonBindingTeam "foo" owner [Member.mkTeamMember member perms Nothing LH.defUserLegalHoldStatus] cid <- Util.createTeamConvWithRole owner tid [member] (Just "gossip") Nothing Nothing convRole resp <- updateTeamConv member cid (ConversationRename "not gossip") -- FUTUREWORK: Ensure that the team role _really_ does not matter @@ -1459,7 +1482,7 @@ testBillingInLargeTeamWithoutIndexedBillingTeamMembers = do foldM ( \billingMembers n -> do newBillingMemberId <- randomUser - let mem = json $ newNewTeamMember newBillingMemberId (rolePermissions RoleOwner) Nothing + let mem = json $ Member.mkNewTeamMember newBillingMemberId (rolePermissions RoleOwner) Nothing -- We cannot properly add the new owner with an invite as we don't have a way to -- override galley settings while making a call to brig withoutIndexedBillingTeamMembers $ @@ -1477,7 +1500,7 @@ testBillingInLargeTeamWithoutIndexedBillingTeamMembers = do -- If we add another owner, one of them won't get notified ownerFanoutPlusTwo <- randomUser - let memFanoutPlusTwo = json $ newNewTeamMember ownerFanoutPlusTwo (rolePermissions RoleOwner) Nothing + let memFanoutPlusTwo = json $ Member.mkNewTeamMember ownerFanoutPlusTwo (rolePermissions RoleOwner) Nothing -- We cannot properly add the new owner with an invite as we don't have a way to -- override galley settings while making a call to brig withoutIndexedBillingTeamMembers $ @@ -1513,7 +1536,7 @@ testBillingInLargeTeamWithoutIndexedBillingTeamMembers = do refreshIndex -- Promotions and demotion should also be kept track of regardless of feature being enabled - let demoteFanoutPlusThree = newNewTeamMember ownerFanoutPlusThree (rolePermissions RoleAdmin) Nothing + let demoteFanoutPlusThree = Member.mkNewTeamMember ownerFanoutPlusThree (rolePermissions RoleAdmin) Nothing withoutIndexedBillingTeamMembers $ updateTeamMember galley team firstOwner demoteFanoutPlusThree !!! const 200 === statusCode ensureQueueEmpty @@ -1522,7 +1545,7 @@ testBillingInLargeTeamWithoutIndexedBillingTeamMembers = do tUpdateUncertainCount [4, 5] (allOwnersBeforeFanoutLimit <> [ownerFanoutPlusFour, ownerFanoutPlusFive]) refreshIndex - let promoteFanoutPlusThree = newNewTeamMember ownerFanoutPlusThree (rolePermissions RoleOwner) Nothing + let promoteFanoutPlusThree = Member.mkNewTeamMember ownerFanoutPlusThree (rolePermissions RoleOwner) Nothing withoutIndexedBillingTeamMembers $ updateTeamMember galley team firstOwner promoteFanoutPlusThree !!! const 200 === statusCode ensureQueueEmpty @@ -1548,28 +1571,28 @@ testUpdateTeamMember = do assertQueue "add member" $ tUpdate 2 [owner] refreshIndex -- non-owner can **NOT** demote owner - let demoteOwner = newNewTeamMember owner (rolePermissions RoleAdmin) Nothing + let demoteOwner = Member.mkNewTeamMember owner (rolePermissions RoleAdmin) Nothing updateTeamMember g tid (member ^. userId) demoteOwner !!! do const 403 === statusCode const "access-denied" === (Error.label . responseJsonUnsafeWithMsg "error label") -- owner can demote non-owner - let demoteMember = newNewTeamMember (member ^. userId) noPermissions (member ^. invitation) + let demoteMember = Member.mkNewTeamMember (member ^. userId) noPermissions (member ^. invitation) WS.bracketR2 c owner (member ^. userId) $ \(wsOwner, wsMember) -> do updateTeamMember g tid owner demoteMember !!! do const 200 === statusCode member' <- Util.getTeamMember owner tid (member ^. userId) - liftIO $ assertEqual "permissions" (member' ^. permissions) (demoteMember ^. ntmNewTeamMember . permissions) + liftIO $ assertEqual "permissions" (member' ^. permissions) (demoteMember ^. nPermissions) checkTeamMemberUpdateEvent tid (member ^. userId) wsOwner (pure noPermissions) checkTeamMemberUpdateEvent tid (member ^. userId) wsMember (pure noPermissions) WS.assertNoEvent timeout [wsOwner, wsMember] assertQueue "Member demoted" $ tUpdate 2 [owner] -- owner can promote non-owner - let promoteMember = newNewTeamMember (member ^. userId) fullPermissions (member ^. invitation) + let promoteMember = Member.mkNewTeamMember (member ^. userId) fullPermissions (member ^. invitation) WS.bracketR2 c owner (member ^. userId) $ \(wsOwner, wsMember) -> do updateTeamMember g tid owner promoteMember !!! do const 200 === statusCode member' <- Util.getTeamMember owner tid (member ^. userId) - liftIO $ assertEqual "permissions" (member' ^. permissions) (promoteMember ^. ntmNewTeamMember . permissions) + liftIO $ assertEqual "permissions" (member' ^. permissions) (promoteMember ^. nPermissions) checkTeamMemberUpdateEvent tid (member ^. userId) wsOwner (pure fullPermissions) checkTeamMemberUpdateEvent tid (member ^. userId) wsMember (pure fullPermissions) WS.assertNoEvent timeout [wsOwner, wsMember] @@ -1582,7 +1605,7 @@ testUpdateTeamMember = do updateTeamMember g tid (member ^. userId) demoteOwner !!! do const 200 === statusCode owner' <- Util.getTeamMember (member ^. userId) tid owner - liftIO $ assertEqual "permissions" (owner' ^. permissions) (demoteOwner ^. ntmNewTeamMember . permissions) + liftIO $ assertEqual "permissions" (owner' ^. permissions) (demoteOwner ^. nPermissions) -- owner no longer has GetPermissions, but she can still see the update because it's about her! checkTeamMemberUpdateEvent tid owner wsOwner (pure (rolePermissions RoleAdmin)) checkTeamMemberUpdateEvent tid owner wsMember (pure (rolePermissions RoleAdmin)) @@ -1881,7 +1904,7 @@ postCryptoBroadcastMessage100OrMaxConns = do (xxx, yyy, _, _) -> error ("Unexpected while connecting users: " ++ show xxx ++ " and " ++ show yyy) newTeamMember' :: Permissions -> UserId -> TeamMember -newTeamMember' perms uid = Member.TeamMember uid perms Nothing LH.defUserLegalHoldStatus +newTeamMember' perms uid = Member.mkTeamMember uid perms Nothing LH.defUserLegalHoldStatus -- NOTE: all client functions calling @{/i,}/teams/*/features/*@ can be replaced by -- hypothetical functions 'getTeamFeatureFlag', 'getTeamFeatureFlagInternal', diff --git a/services/galley/test/integration/API/Teams/Feature.hs b/services/galley/test/integration/API/Teams/Feature.hs index f3b1989bd91..04c283203de 100644 --- a/services/galley/test/integration/API/Teams/Feature.hs +++ b/services/galley/test/integration/API/Teams/Feature.hs @@ -70,7 +70,8 @@ tests s = test s "Feature Configs / Team Features Consistency" testFeatureConfigConsistency, test s "ConferenceCalling" $ testSimpleFlag @'Public.TeamFeatureConferenceCalling Public.TeamFeatureEnabled, test s "SelfDeletingMessages" testSelfDeletingMessages, - test s "ConversationGuestLinks" testGuestLinks + test s "ConversationGuestLinks - public API" testGuestLinksPublic, + test s "ConversationGuestLinks - internal API" testGuestLinksInternal ] testSSO :: TestM () @@ -474,26 +475,58 @@ testSelfDeletingMessages = do checkSetLockStatus Public.Unlocked checkGet TeamFeatureDisabled 30 Public.Unlocked -testGuestLinks :: TestM () -testGuestLinks = do +testGuestLinksInternal :: TestM () +testGuestLinksInternal = do galley <- view tsGalley + testGuestLinks + (const $ Util.getTeamFeatureFlagInternal Public.TeamFeatureGuestLinks) + (const $ Util.putTeamFeatureFlagInternal @'Public.TeamFeatureGuestLinks galley) + (Util.setLockStatusInternal @'Public.TeamFeatureGuestLinks galley) + +testGuestLinksPublic :: TestM () +testGuestLinksPublic = do + galley <- view tsGalley + testGuestLinks + (Util.getTeamFeatureFlagWithGalley Public.TeamFeatureGuestLinks galley) + (Util.putTeamFeatureFlagWithGalley @'Public.TeamFeatureGuestLinks galley) + (Util.setLockStatusInternal @'Public.TeamFeatureGuestLinks galley) + +testGuestLinks :: + (UserId -> TeamId -> TestM ResponseLBS) -> + (UserId -> TeamId -> Public.TeamFeatureStatusNoConfig -> TestM ResponseLBS) -> + (TeamId -> Public.LockStatusValue -> TestM ResponseLBS) -> + TestM () +testGuestLinks getStatus putStatus setLockStatusInternal = do (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 + getStatus owner tid !!! do + statusCode === const 200 + responseJsonEither === const (Right (Public.TeamFeatureStatusNoConfigAndLockStatus status lock)) + + checkSet :: HasCallStack => Public.TeamFeatureStatusValue -> Int -> TestM () + checkSet status expectedStatusCode = + putStatus owner tid (Public.TeamFeatureStatusNoConfig status) !!! statusCode === const expectedStatusCode + + checkSetLockStatusInternal :: HasCallStack => Public.LockStatusValue -> TestM () + checkSetLockStatusInternal lockStatus = + setLockStatusInternal tid lockStatus !!! statusCode === const 200 checkGet Public.TeamFeatureEnabled Public.Unlocked - checkSet Public.TeamFeatureDisabled + checkSet Public.TeamFeatureDisabled 200 checkGet Public.TeamFeatureDisabled Public.Unlocked - checkSet Public.TeamFeatureEnabled + checkSet Public.TeamFeatureEnabled 200 checkGet Public.TeamFeatureEnabled Public.Unlocked + checkSet Public.TeamFeatureDisabled 200 + checkGet Public.TeamFeatureDisabled Public.Unlocked + -- when locks status is locked the team default feature status should be returned + -- and the team feature status can not be changed + checkSetLockStatusInternal Public.Locked + checkGet Public.TeamFeatureEnabled Public.Locked + checkSet Public.TeamFeatureDisabled 409 + -- when lock status is unlocked again the previously set feature status is restored + checkSetLockStatusInternal Public.Unlocked + checkGet Public.TeamFeatureDisabled Public.Unlocked -- | Call 'GET /teams/:tid/features' and 'GET /feature-configs', and check if all -- features are there. diff --git a/services/galley/test/integration/API/Util.hs b/services/galley/test/integration/API/Util.hs index b1cb862d558..5ceee3a5303 100644 --- a/services/galley/test/integration/API/Util.hs +++ b/services/galley/test/integration/API/Util.hs @@ -92,13 +92,12 @@ import Gundeck.Types.Notification queuedTime, ) import Imports +import Network.HTTP.Media.MediaType import qualified Network.HTTP.Types as HTTP import Network.Wai (Application, defaultRequest) import qualified Network.Wai as Wai import qualified Network.Wai.Test as Wai import Servant (Handler, HasServer, Server, ServerT, serve, (:<|>) (..)) -import Servant.API.Generic (ToServantApi) -import Servant.Server.Generic (AsServerT, genericServerT) import System.Random import qualified Test.QuickCheck as Q import Test.Tasty.Cannon (TimeoutUnit (..), (#)) @@ -114,14 +113,14 @@ import qualified Wire.API.Conversation as Public import Wire.API.Conversation.Action import Wire.API.Event.Conversation (_EdConversation, _EdMembersJoin, _EdMembersLeave) import qualified Wire.API.Event.Team as TE -import qualified Wire.API.Federation.API.Brig as FederatedBrig -import qualified Wire.API.Federation.API.Galley as FederatedGalley -import Wire.API.Federation.Component +import Wire.API.Federation.API +import Wire.API.Federation.API.Galley import Wire.API.Federation.Domain (originDomainHeaderName) import Wire.API.Message import qualified Wire.API.Message.Proto as Proto import Wire.API.Routes.Internal.Brig.Connection import Wire.API.Routes.MultiTablePaging +import Wire.API.Team.Member (mkNewTeamMember) import Wire.API.User.Client (ClientCapability (..), UserClientsFull (UserClientsFull)) import qualified Wire.API.User.Client as Client import Wire.API.User.Identity (mkSimpleSampleUref) @@ -148,7 +147,7 @@ symmPermissions p = let s = Set.fromList p in fromJust (newPermissions s s) createBindingTeam :: HasCallStack => TestM (UserId, TeamId) createBindingTeam = do ownerid <- randomTeamCreator - teams <- getTeams ownerid + teams <- getTeams ownerid [] let [team] = view teamListTeams teams let tid = view teamId team SQS.assertQueue "create team" SQS.tActivate @@ -175,13 +174,14 @@ createBindingTeamWithQualifiedMembers num = do (tid, owner, users) <- createBindingTeamWithMembers num pure (tid, Qualified owner localDomain, map (`Qualified` localDomain) users) -getTeams :: UserId -> TestM TeamList -getTeams u = do +getTeams :: UserId -> [(ByteString, Maybe ByteString)] -> TestM TeamList +getTeams u queryItems = do g <- view tsGalley r <- get ( g . paths ["teams"] + . query queryItems . zUser u . zConn "conn" . zType "access" @@ -358,7 +358,7 @@ getTeamMemberInternal tid mid = do addTeamMember :: HasCallStack => UserId -> TeamId -> UserId -> Permissions -> Maybe (UserId, UTCTimeMillis) -> TestM () addTeamMember usr tid muid mperms mmbinv = do g <- view tsGalley - let payload = json (newNewTeamMember muid mperms mmbinv) + let payload = json (mkNewTeamMember muid mperms mmbinv) post (g . paths ["teams", toByteString' tid, "members"] . zUser usr . zConn "conn" . payload) !!! const 200 === statusCode @@ -370,7 +370,7 @@ addTeamMemberInternal tid muid mperms mmbinv = addTeamMemberInternal' tid muid m addTeamMemberInternal' :: HasCallStack => TeamId -> UserId -> Permissions -> Maybe (UserId, UTCTimeMillis) -> TestM ResponseLBS addTeamMemberInternal' tid muid mperms mmbinv = do g <- view tsGalley - let payload = json (newNewTeamMember muid mperms mmbinv) + let payload = json (mkNewTeamMember muid mperms mmbinv) post (g . paths ["i", "teams", toByteString' tid, "members"] . payload) addUserToTeam :: HasCallStack => UserId -> TeamId -> TestM TeamMember @@ -417,7 +417,7 @@ addUserToTeamWithSSO hasEmail tid = do makeOwner :: HasCallStack => UserId -> TeamMember -> TeamId -> TestM () makeOwner owner mem tid = do galley <- view tsGalley - let changeMember = newNewTeamMember (mem ^. Team.userId) fullPermissions (mem ^. Team.invitation) + let changeMember = mkNewTeamMember (mem ^. Team.userId) fullPermissions (mem ^. Team.invitation) put ( galley . paths ["teams", toByteString' tid, "members"] @@ -686,8 +686,8 @@ postProteusMessageQualifiedWithMockFederator :: [(Qualified UserId, ClientId, ByteString)] -> ByteString -> ClientMismatchStrategy -> - (Domain -> FederatedBrig.BrigApi (AsServerT Handler)) -> - (Domain -> FederatedGalley.GalleyApi (AsServerT Handler)) -> + (Domain -> ServerT (FedApi 'Brig) Handler) -> + (Domain -> ServerT (FedApi 'Galley) Handler) -> TestM (ResponseLBS, [FederatedRequest]) postProteusMessageQualifiedWithMockFederator senderUser senderClient convId recipients dat strat brigApi galleyApi = do localDomain <- viewFederationDomain @@ -1248,21 +1248,19 @@ registerRemoteConv :: Qualified ConvId -> UserId -> Maybe Text -> Set OtherMembe registerRemoteConv convId originUser name othMembers = do fedGalleyClient <- view tsFedGalleyClient now <- liftIO getCurrentTime - FederatedGalley.onConversationCreated - (fedGalleyClient (qDomain convId)) - ( FederatedGalley.NewRemoteConversation - { FederatedGalley.rcTime = now, - FederatedGalley.rcOrigUserId = originUser, - FederatedGalley.rcCnvId = qUnqualified convId, - FederatedGalley.rcCnvType = RegularConv, - FederatedGalley.rcCnvAccess = [], - FederatedGalley.rcCnvAccessRole = ActivatedAccessRole, - FederatedGalley.rcCnvName = name, - FederatedGalley.rcNonCreatorMembers = othMembers, - FederatedGalley.rcMessageTimer = Nothing, - FederatedGalley.rcReceiptMode = Nothing - } - ) + runFedClient @"on-conversation-created" fedGalleyClient (qDomain convId) $ + NewRemoteConversation + { rcTime = now, + rcOrigUserId = originUser, + rcCnvId = qUnqualified convId, + rcCnvType = RegularConv, + rcCnvAccess = [], + rcCnvAccessRole = ActivatedAccessRole, + rcCnvName = name, + rcNonCreatorMembers = othMembers, + rcMessageTimer = Nothing, + rcReceiptMode = Nothing + } ------------------------------------------------------------------------------- -- Common Assertions @@ -1505,10 +1503,10 @@ assertRemoveUpdate req qconvId remover alreadyPresentUsers victim = liftIO $ do frRPC req @?= "on-conversation-updated" frOriginDomain req @?= qDomain qconvId let Just cu = decode (frBody req) - FederatedGalley.cuOrigUserId cu @?= remover - FederatedGalley.cuConvId cu @?= qUnqualified qconvId - sort (FederatedGalley.cuAlreadyPresentUsers cu) @?= sort alreadyPresentUsers - FederatedGalley.cuAction cu @?= ConversationActionRemoveMembers (pure victim) + cuOrigUserId cu @?= remover + cuConvId cu @?= qUnqualified qconvId + sort (cuAlreadyPresentUsers cu) @?= sort alreadyPresentUsers + cuAction cu @?= ConversationActionRemoveMembers (pure victim) ------------------------------------------------------------------------------- -- Helpers @@ -1738,7 +1736,10 @@ randomTeamCreator :: HasCallStack => TestM UserId randomTeamCreator = qUnqualified <$> randomUser' True True True randomUser' :: HasCallStack => Bool -> Bool -> Bool -> TestM (Qualified UserId) -randomUser' isCreator hasPassword hasEmail = do +randomUser' isCreator hasPassword hasEmail = userQualifiedId . selfUser <$> randomUserProfile' isCreator hasPassword hasEmail + +randomUserProfile' :: HasCallStack => Bool -> Bool -> Bool -> TestM SelfProfile +randomUserProfile' isCreator hasPassword hasEmail = do b <- view tsBrig e <- liftIO randomEmail let p = @@ -1747,8 +1748,7 @@ randomUser' isCreator hasPassword hasEmail = do <> ["password" .= defPassword | hasPassword] <> ["email" .= fromEmail e | hasEmail] <> ["team" .= Team.BindingNewTeam (Team.newNewTeam (unsafeRange "teamName") (unsafeRange "defaultIcon")) | isCreator] - selfProfile <- responseJsonUnsafe <$> (post (b . path "/i/users" . json p) (post (b . path "/i/users" . json p) TestM UserId ephemeralUser = do @@ -2039,9 +2039,9 @@ mkConv :: UserId -> RoleName -> [OtherMember] -> - FederatedGalley.RemoteConversation + RemoteConversation mkConv cnvId creator selfRole otherMembers = - FederatedGalley.RemoteConversation + RemoteConversation cnvId ( ConversationMetadata RegularConv @@ -2053,7 +2053,7 @@ mkConv cnvId creator selfRole otherMembers = Nothing Nothing ) - (FederatedGalley.RemoteConvMembers selfRole otherMembers) + (RemoteConvMembers selfRole otherMembers) -- | ES is only refreshed occasionally; we don't want to wait for that in tests. refreshIndex :: TestM () @@ -2237,17 +2237,20 @@ withTempMockFederator' :: m (b, [FederatedRequest]) withTempMockFederator' resp action = do opts <- viewGalleyOpts - Mock.withTempMockFederator [("Content-Type", "application/json")] resp $ \mockPort -> do - let opts' = - opts & Opts.optFederator - ?~ Endpoint "127.0.0.1" (fromIntegral mockPort) - withSettingsOverrides opts' action + Mock.withTempMockFederator + [("Content-Type", "application/json")] + ((\r -> pure ("application" // "json", r)) <=< resp) + $ \mockPort -> do + let opts' = + opts & Opts.optFederator + ?~ Endpoint "127.0.0.1" (fromIntegral mockPort) + withSettingsOverrides opts' action -- Start a mock federator. Use proveded Servant handler for the mocking mocking function. withTempServantMockFederator :: (MonadMask m, MonadIO m, HasGalley m) => - (Domain -> FederatedBrig.BrigApi (AsServerT Handler)) -> - (Domain -> FederatedGalley.GalleyApi (AsServerT Handler)) -> + (Domain -> ServerT (FedApi 'Brig) Handler) -> + (Domain -> ServerT (FedApi 'Galley) Handler) -> Domain -> SessionT m b -> m (b, [FederatedRequest]) @@ -2255,13 +2258,13 @@ withTempServantMockFederator brigApi galleyApi originDomain = withTempMockFederator' mock where server :: Domain -> ServerT CombinedBrigAndGalleyAPI Handler - server d = genericServerT (brigApi d) :<|> genericServerT (galleyApi d) + server d = brigApi d :<|> galleyApi d mock :: FederatedRequest -> IO LByteString mock req = makeFedRequestToServant @CombinedBrigAndGalleyAPI originDomain (server (frTargetDomain req)) req -type CombinedBrigAndGalleyAPI = ToServantApi FederatedBrig.BrigApi :<|> ToServantApi FederatedGalley.GalleyApi +type CombinedBrigAndGalleyAPI = FedApi 'Brig :<|> FedApi 'Galley -- Starts a servant Application in Network.Wai.Test session and runs the -- FederatedRequest against it. diff --git a/services/galley/test/integration/Main.hs b/services/galley/test/integration/Main.hs index d17ec0d18ef..50d690b39ff 100644 --- a/services/galley/test/integration/Main.hs +++ b/services/galley/test/integration/Main.hs @@ -118,7 +118,7 @@ main = withOpenSSL $ runTests go let ck = fromJust gConf ^. optCassandra . casKeyspace lg <- Logger.new Logger.defSettings db <- defInitCassandra ck ch cp lg - return $ TestSetup (fromJust gConf) (fromJust iConf) m g b c awsEnv convMaxSize db (mkFedGalleyClient galleyEndpoint) + return $ TestSetup (fromJust gConf) (fromJust iConf) m g b c awsEnv convMaxSize db (FedClient m galleyEndpoint) queueName = fmap (view awsQueueName) . view optJournal endpoint = fmap (view awsEndpoint) . view optJournal maxSize = view (optSettings . setMaxConvSize) diff --git a/services/galley/test/integration/TestSetup.hs b/services/galley/test/integration/TestSetup.hs index 30550c46cbc..767c0ed2935 100644 --- a/services/galley/test/integration/TestSetup.hs +++ b/services/galley/test/integration/TestSetup.hs @@ -31,10 +31,10 @@ module TestSetup tsMaxConvSize, tsCass, tsFedGalleyClient, - mkFedGalleyClient, TestM (..), TestSetup (..), - FedGalleyClient, + FedClient (..), + runFedClient, GalleyR, BrigR, CannonR, @@ -48,16 +48,15 @@ import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) import Data.Aeson import Data.ByteString.Conversion import Data.Domain +import Data.Proxy import qualified Data.Text as Text +import GHC.TypeLits import qualified Galley.Aws as Aws import Galley.Options (Opts) import Imports import qualified Network.HTTP.Client as HTTP import qualified Servant.Client as Servant -import Servant.Client.Core.BaseUrl -import qualified Servant.Client.Core.Request as Client -import Servant.Client.Generic (AsClientT) -import qualified Servant.Client.Generic as Servant +import qualified Servant.Client.Core as Servant import Test.Tasty.HUnit import Util.Options import Wire.API.Federation.API @@ -106,7 +105,7 @@ newtype TestM a = TestM {runTestM :: ReaderT TestSetup IO a} MonadFail ) -type FedGalleyClient = FedApi 'Galley (AsClientT TestM) +data FedClient (comp :: Component) = FedClient HTTP.Manager Endpoint data TestSetup = TestSetup { _tsGConf :: Opts, @@ -118,7 +117,7 @@ data TestSetup = TestSetup _tsAwsEnv :: Maybe Aws.Env, _tsMaxConvSize :: Word16, _tsCass :: Cql.ClientState, - _tsFedGalleyClient :: Domain -> FedGalleyClient + _tsFedGalleyClient :: FedClient 'Galley } makeLenses ''TestSetup @@ -128,22 +127,32 @@ instance MonadHttp TestM where manager <- view tsManager liftIO $ withResponse req manager handler -mkFedGalleyClient :: Endpoint -> Domain -> FedGalleyClient -mkFedGalleyClient galleyEndpoint originDomain = Servant.genericClientHoist servantClienMToHttp +runFedClient :: + forall (name :: Symbol) comp m api. + ( HasFedEndpoint comp api name, + Servant.HasClient Servant.ClientM api, + MonadIO m + ) => + FedClient comp -> + Domain -> + Servant.Client m api +runFedClient (FedClient mgr endpoint) domain = + Servant.hoistClient (Proxy @api) (servantClientMToHttp domain) $ + Servant.clientIn (Proxy @api) (Proxy @Servant.ClientM) where - servantClienMToHttp :: Servant.ClientM a -> TestM a - servantClienMToHttp act = do - let galleyHost = Text.unpack $ galleyEndpoint ^. epHost - brigPort = fromInteger . toInteger $ galleyEndpoint ^. epPort - baseUrl = Servant.BaseUrl Servant.Http galleyHost brigPort "/federation" - mgr' <- view tsManager - let clientEnv = Servant.ClientEnv mgr' baseUrl Nothing makeClientRequest - eitherRes <- liftIO $ Servant.runClientM act clientEnv + servantClientMToHttp :: Domain -> Servant.ClientM a -> m a + servantClientMToHttp originDomain action = liftIO $ do + let host = Text.unpack $ endpoint ^. epHost + port = fromInteger . toInteger $ endpoint ^. epPort + baseUrl = Servant.BaseUrl Servant.Http host port "/federation" + clientEnv = Servant.ClientEnv mgr baseUrl Nothing (makeClientRequest originDomain) + eitherRes <- Servant.runClientM action clientEnv case eitherRes of Right res -> pure res - Left err -> liftIO $ assertFailure $ "Servant client failed with: " <> show err - makeClientRequest :: BaseUrl -> Client.Request -> HTTP.Request - makeClientRequest burl req = + Left err -> assertFailure $ "Servant client failed with: " <> show err + + makeClientRequest :: Domain -> Servant.BaseUrl -> Servant.Request -> HTTP.Request + makeClientRequest originDomain burl req = let req' = Servant.defaultMakeClientRequest burl req in req' { HTTP.requestHeaders = diff --git a/services/gundeck/Makefile b/services/gundeck/Makefile index ef0059ce50a..fcedb3ce780 100644 --- a/services/gundeck/Makefile +++ b/services/gundeck/Makefile @@ -127,7 +127,7 @@ db-migrate: fast docker: $(foreach executable,$(EXECUTABLES),\ docker build -t $(DOCKER_USER)/$(executable):$(DOCKER_TAG) \ - -f ../../build/alpine/Dockerfile.executable \ + -f ../../build/ubuntu/Dockerfile.executable \ --build-arg executable=$(executable) \ ../.. && \ docker tag $(DOCKER_USER)/$(executable):$(DOCKER_TAG) $(DOCKER_USER)/$(executable):latest && \ diff --git a/services/gundeck/gundeck.cabal b/services/gundeck/gundeck.cabal index cec259bf5ad..a8643ca98c1 100644 --- a/services/gundeck/gundeck.cabal +++ b/services/gundeck/gundeck.cabal @@ -1,10 +1,10 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack -- --- hash: 4bb58f9c4f7c25e77c57457292940bd69410c8a372272ad5afb14252c2ac399b +-- hash: 4b94342561027580e950514565f60bb0d8d1465d92c773a7c4f588966dab6ffc name: gundeck version: 1.45.0 @@ -58,7 +58,46 @@ library Paths_gundeck 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 + 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 -fwarn-incomplete-uni-patterns build-depends: HsOpenSSL >=0.11 @@ -120,7 +159,46 @@ executable gundeck main-is: src/Main.hs other-modules: Paths_gundeck - 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 + 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 -rtsopts -with-rtsopts=-T build-depends: HsOpenSSL @@ -146,13 +224,52 @@ executable gundeck-integration Paths_gundeck hs-source-dirs: test/integration - 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 + 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 build-depends: HsOpenSSL , aeson , async - , base >=4 && <5 + , base ==4.* , base16-bytestring >=0.1 , bilge , bytestring @@ -201,7 +318,46 @@ executable gundeck-schema Paths_gundeck hs-source-dirs: schema/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 + 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 build-depends: base @@ -230,7 +386,46 @@ test-suite gundeck-tests Paths_gundeck hs-source-dirs: test/unit - 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 + 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 build-depends: HsOpenSSL @@ -277,7 +472,46 @@ benchmark gundeck-bench Paths_gundeck hs-source-dirs: test/bench - 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 + 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 build-depends: HsOpenSSL diff --git a/services/gundeck/src/Gundeck/Aws.hs b/services/gundeck/src/Gundeck/Aws.hs index b4a05082752..75bc30c1953 100644 --- a/services/gundeck/src/Gundeck/Aws.hs +++ b/services/gundeck/src/Gundeck/Aws.hs @@ -136,14 +136,10 @@ newtype Amazon a = Amazon MonadCatch, MonadMask, MonadReader Env, - MonadResource + MonadResource, + MonadUnliftIO ) -instance MonadUnliftIO Amazon where - askUnliftIO = Amazon . ReaderT $ \r -> - withUnliftIO $ \u -> - return (UnliftIO (unliftIO u . flip runReaderT r . unAmazon)) - instance MonadLogger Amazon where log l m = view logger >>= \g -> Logger.log g l m diff --git a/services/gundeck/src/Gundeck/Monad.hs b/services/gundeck/src/Gundeck/Monad.hs index 22851a12d81..4bea200a2ec 100644 --- a/services/gundeck/src/Gundeck/Monad.hs +++ b/services/gundeck/src/Gundeck/Monad.hs @@ -70,15 +70,10 @@ newtype Gundeck a = Gundeck MonadCatch, MonadMask, MonadReader Env, - MonadClient + MonadClient, + MonadUnliftIO ) -instance MonadUnliftIO Gundeck where - askUnliftIO = - Gundeck . ReaderT $ \r -> - withUnliftIO $ \u -> - return (UnliftIO (unliftIO u . flip runReaderT r . unGundeck)) - instance Redis.MonadClient Gundeck where liftClient m = view rstate >>= \p -> Redis.runRedis p m diff --git a/services/gundeck/test/unit/ThreadBudget.hs b/services/gundeck/test/unit/ThreadBudget.hs index 2d03c388279..b730e43d5b5 100644 --- a/services/gundeck/test/unit/ThreadBudget.hs +++ b/services/gundeck/test/unit/ThreadBudget.hs @@ -28,7 +28,6 @@ import Control.Monad.Catch (MonadCatch, catch) import Data.Metrics.Middleware (metrics) import Data.String.Conversions (cs) import Data.Time -import Data.TreeDiff.Class (ToExpr) import GHC.Generics import Gundeck.Options import Gundeck.ThreadBudget.Internal @@ -307,10 +306,10 @@ sm = STM.postcondition = postcondition, STM.invariant = Nothing, STM.generator = generator, - STM.distribution = Nothing, STM.shrinker = shrinker, STM.semantics = semantics, - STM.mock = mock + STM.mock = mock, + STM.cleanup = const (pure ()) } -- | Remove resources created by the concrete 'STM.Commands', namely watcher and budgeted diff --git a/services/integration.yaml b/services/integration.yaml index f2e135bc461..0b51304dd6c 100644 --- a/services/integration.yaml +++ b/services/integration.yaml @@ -84,3 +84,6 @@ backendTwo: federatorExternal: host: 127.0.0.1 # in kubernetes, federator..svc.cluster.local port: 9097 + cargohold: + host: 127.0.0.1 + port: 9084 diff --git a/services/proxy/Makefile b/services/proxy/Makefile index 17a95642972..ed032ae8b23 100644 --- a/services/proxy/Makefile +++ b/services/proxy/Makefile @@ -58,7 +58,7 @@ $(DEB): docker: $(foreach executable,$(EXECUTABLES),\ docker build -t $(DOCKER_USER)/$(executable):$(DOCKER_TAG) \ - -f ../../build/alpine/Dockerfile.executable \ + -f ../../build/ubuntu/Dockerfile.executable \ --build-arg executable=$(executable) \ ../.. && \ docker tag $(DOCKER_USER)/$(executable):$(DOCKER_TAG) $(DOCKER_USER)/$(executable):latest && \ diff --git a/services/proxy/proxy.cabal b/services/proxy/proxy.cabal index 73b9dc80213..0aa5d2d426a 100644 --- a/services/proxy/proxy.cabal +++ b/services/proxy/proxy.cabal @@ -1,10 +1,10 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack -- --- hash: e36a48793e77087ee1a5e60f78c9c308b686a1d9318e083dc6bb78d0e27ac056 +-- hash: 4b0eeea49373b98eff5aa94f2c7ec6e198b9db932ceeb3ff4311ffc25ab44b86 name: proxy version: 0.9.0 @@ -35,7 +35,46 @@ library Paths_proxy 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 + 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 -funbox-strict-fields build-depends: aeson >=1.0 @@ -70,7 +109,46 @@ executable proxy main-is: src/Main.hs other-modules: Paths_proxy - 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 + 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 -rtsopts -with-rtsopts=-T build-depends: base diff --git a/services/spar/Makefile b/services/spar/Makefile index b3846b0a816..523ac6c9e71 100644 --- a/services/spar/Makefile +++ b/services/spar/Makefile @@ -115,7 +115,7 @@ db-migrate: fast docker: $(foreach executable,$(EXECUTABLES),\ docker build -t $(DOCKER_USER)/$(executable):$(DOCKER_TAG) \ - -f ../../build/alpine/Dockerfile.executable \ + -f ../../build/ubuntu/Dockerfile.executable \ --build-arg executable=$(executable) \ ../.. && \ docker tag $(DOCKER_USER)/$(executable):$(DOCKER_TAG) $(DOCKER_USER)/$(executable):latest && \ diff --git a/services/spar/package.yaml b/services/spar/package.yaml index fc27e3fb8a1..5efbb34c319 100644 --- a/services/spar/package.yaml +++ b/services/spar/package.yaml @@ -39,6 +39,7 @@ dependencies: - galley-types - ghc-prim - hscim + - hspec - HsOpenSSL - http-api-data - http-client @@ -53,7 +54,9 @@ dependencies: - network-uri - optparse-applicative - polysemy + - polysemy-check >= 0.9 - polysemy-plugin + - QuickCheck - raw-strings-qq - retry - saml2-web-sso >= 0.18 @@ -94,12 +97,9 @@ tests: - hspec-discover:hspec-discover dependencies: - lens-aeson - - hspec - metrics-wai - - QuickCheck - spar - uri-bytestring - - polysemy-check executables: spar: diff --git a/services/spar/spar.cabal b/services/spar/spar.cabal index a71562b0f42..b4823b1554f 100644 --- a/services/spar/spar.cabal +++ b/services/spar/spar.cabal @@ -1,10 +1,8 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack --- --- hash: 34138a2c7fa249191ae03bc1581a7c95c94b12080f104da084a9bc37ac54c9ad name: spar version: 0.1 @@ -50,19 +48,23 @@ library Spar.Sem.DefaultSsoCode Spar.Sem.DefaultSsoCode.Cassandra Spar.Sem.DefaultSsoCode.Mem + Spar.Sem.DefaultSsoCode.Spec Spar.Sem.GalleyAccess Spar.Sem.GalleyAccess.Http Spar.Sem.IdP Spar.Sem.IdP.Cassandra Spar.Sem.IdP.Mem + Spar.Sem.IdP.Spec Spar.Sem.IdPRawMetadataStore Spar.Sem.IdPRawMetadataStore.Cassandra Spar.Sem.IdPRawMetadataStore.Mem + Spar.Sem.IdPRawMetadataStore.Spec Spar.Sem.Logger Spar.Sem.Logger.TinyLog Spar.Sem.Now Spar.Sem.Now.Input Spar.Sem.Now.IO + Spar.Sem.Now.Spec Spar.Sem.Random Spar.Sem.Random.IO Spar.Sem.Reporter @@ -77,6 +79,7 @@ library Spar.Sem.ScimExternalIdStore Spar.Sem.ScimExternalIdStore.Cassandra Spar.Sem.ScimExternalIdStore.Mem + Spar.Sem.ScimExternalIdStore.Spec Spar.Sem.ScimTokenStore Spar.Sem.ScimTokenStore.Cassandra Spar.Sem.ScimTokenStore.Mem @@ -90,10 +93,50 @@ library Paths_spar 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 + 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 -j -Wno-redundant-constraints -Werror build-depends: HsOpenSSL + , QuickCheck , aeson , aeson-qq , attoparsec @@ -116,6 +159,7 @@ library , galley-types , ghc-prim , hscim + , hspec , http-api-data , http-client , http-media @@ -129,6 +173,7 @@ library , network-uri , optparse-applicative , polysemy + , polysemy-check >=0.9 , polysemy-plugin , raw-strings-qq , retry @@ -163,10 +208,50 @@ executable spar Paths_spar hs-source-dirs: exec - 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 + 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 -j -Wno-redundant-constraints -Werror -threaded -rtsopts -with-rtsopts=-N -with-rtsopts=-T build-depends: HsOpenSSL + , QuickCheck , aeson , aeson-qq , attoparsec @@ -189,6 +274,7 @@ executable spar , galley-types , ghc-prim , hscim + , hspec , http-api-data , http-client , http-media @@ -202,6 +288,7 @@ executable spar , network-uri , optparse-applicative , polysemy + , polysemy-check >=0.9 , polysemy-plugin , raw-strings-qq , retry @@ -251,7 +338,46 @@ executable spar-integration Paths_spar hs-source-dirs: test-integration - 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 + 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 -j -Wno-redundant-constraints -Werror -threaded -rtsopts -with-rtsopts=-N build-tool-depends: hspec-discover:hspec-discover @@ -298,6 +424,7 @@ executable spar-integration , network-uri , optparse-applicative , polysemy + , polysemy-check >=0.9 , polysemy-plugin , random , raw-strings-qq @@ -345,10 +472,50 @@ executable spar-migrate-data Paths_spar hs-source-dirs: migrate-data/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 + 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 -j -Wno-redundant-constraints -Werror -threaded -rtsopts -with-rtsopts=-N build-depends: HsOpenSSL + , QuickCheck , aeson , aeson-qq , attoparsec @@ -372,6 +539,7 @@ executable spar-migrate-data , galley-types , ghc-prim , hscim + , hspec , http-api-data , http-client , http-media @@ -385,6 +553,7 @@ executable spar-migrate-data , network-uri , optparse-applicative , polysemy + , polysemy-check >=0.9 , polysemy-plugin , raw-strings-qq , retry @@ -436,10 +605,50 @@ executable spar-schema Paths_spar hs-source-dirs: schema/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 + 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 -j -Wno-redundant-constraints -Werror -threaded -rtsopts -with-rtsopts=-N build-depends: HsOpenSSL + , QuickCheck , aeson , aeson-qq , attoparsec @@ -462,6 +671,7 @@ executable spar-schema , galley-types , ghc-prim , hscim + , hspec , http-api-data , http-client , http-media @@ -475,6 +685,7 @@ executable spar-schema , network-uri , optparse-applicative , polysemy + , polysemy-check >=0.9 , polysemy-plugin , raw-strings-qq , retry @@ -514,13 +725,55 @@ test-suite spec Test.Spar.Intra.BrigSpec Test.Spar.Roundtrip.ByteString Test.Spar.ScimSpec + Test.Spar.Sem.DefaultSsoCodeSpec Test.Spar.Sem.IdPRawMetadataStoreSpec Test.Spar.Sem.IdPSpec + Test.Spar.Sem.NowSpec + Test.Spar.Sem.ScimExternalIdStoreSpec Test.Spar.TypesSpec Paths_spar 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 + 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 -j -Wno-redundant-constraints -Werror -threaded -rtsopts -with-rtsopts=-N build-tool-depends: hspec-discover:hspec-discover @@ -564,7 +817,7 @@ test-suite spec , network-uri , optparse-applicative , polysemy - , polysemy-check + , polysemy-check >=0.9 , polysemy-plugin , raw-strings-qq , retry diff --git a/services/spar/src/Spar/Sem/DefaultSsoCode.hs b/services/spar/src/Spar/Sem/DefaultSsoCode.hs index c18f0334b15..af9a49bda4c 100644 --- a/services/spar/src/Spar/Sem/DefaultSsoCode.hs +++ b/services/spar/src/Spar/Sem/DefaultSsoCode.hs @@ -2,6 +2,7 @@ module Spar.Sem.DefaultSsoCode where import Imports import Polysemy +import Polysemy.Check (deriveGenericK) import qualified SAML2.WebSSO as SAML data DefaultSsoCode m a where @@ -9,4 +10,7 @@ data DefaultSsoCode m a where Store :: SAML.IdPId -> DefaultSsoCode m () Delete :: DefaultSsoCode m () +deriving instance Show (DefaultSsoCode m a) + makeSem ''DefaultSsoCode +deriveGenericK ''DefaultSsoCode diff --git a/services/spar/src/Spar/Sem/DefaultSsoCode/Spec.hs b/services/spar/src/Spar/Sem/DefaultSsoCode/Spec.hs new file mode 100644 index 00000000000..e9aac14b42a --- /dev/null +++ b/services/spar/src/Spar/Sem/DefaultSsoCode/Spec.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE QuantifiedConstraints #-} +{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} + +module Spar.Sem.DefaultSsoCode.Spec (propsForInterpreter) where + +import Imports +import Polysemy +import Polysemy.Check +import SAML2.WebSSO.Types +import qualified Spar.Sem.DefaultSsoCode as E +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck + +propsForInterpreter :: + PropConstraints r f => + String -> + (forall a. Sem r a -> IO (f a)) -> + Spec +propsForInterpreter interpreter lower = do + describe interpreter $ do + prop "delete/delete" $ prop_deleteDelete Nothing lower + prop "delete/get" $ prop_deleteGet Nothing lower + prop "delete/store" $ prop_deleteStore Nothing lower + prop "get/store" $ prop_getStore Nothing lower + prop "store/delete" $ prop_storeDelete Nothing lower + prop "store/get" $ prop_storeGet Nothing lower + prop "store/store" $ prop_storeStore Nothing lower + +-- | All the constraints we need to generalize properties in this module. +-- A regular type synonym doesn't work due to dreaded impredicative +-- polymorphism. +class + (Arbitrary IdPId, CoArbitrary IdPId, Functor f, Member E.DefaultSsoCode r, forall z. Show z => Show (f z), forall z. Eq z => Eq (f z)) => + PropConstraints r f + +instance + (Arbitrary IdPId, CoArbitrary IdPId, Functor f, Member E.DefaultSsoCode r, forall z. Show z => Show (f z), forall z. Eq z => Eq (f z)) => + PropConstraints r f + +prop_storeGet :: + PropConstraints r f => + Maybe (f (Maybe IdPId) -> String) -> + (forall a. Sem r a -> IO (f a)) -> + Property +prop_storeGet = + prepropLaw @'[E.DefaultSsoCode] $ do + s <- arbitrary + pure $ + simpleLaw + ( do + E.store s + E.get + ) + ( do + E.store s + pure (Just s) + ) + +prop_getStore :: + PropConstraints r f => + Maybe (f () -> String) -> + (forall a. Sem r a -> IO (f a)) -> + Property +prop_getStore = + prepropLaw @'[E.DefaultSsoCode] $ do + pure $ + simpleLaw + ( do + E.get >>= maybe (pure ()) E.store + ) + ( do + pure () + ) + +prop_storeDelete :: + PropConstraints r f => + Maybe (f () -> String) -> + (forall a. Sem r a -> IO (f a)) -> + Property +prop_storeDelete = + prepropLaw @'[E.DefaultSsoCode] $ do + s <- arbitrary + pure $ + simpleLaw + ( do + E.store s + E.delete + ) + ( do + E.delete + ) + +prop_deleteStore :: + PropConstraints r f => + Maybe (f () -> String) -> + (forall a. Sem r a -> IO (f a)) -> + Property +prop_deleteStore = + prepropLaw @'[E.DefaultSsoCode] $ do + s <- arbitrary + pure $ + simpleLaw + ( do + E.delete + E.store s + ) + ( do + E.store s + ) + +prop_storeStore :: + PropConstraints r f => + Maybe (f () -> String) -> + (forall a. Sem r a -> IO (f a)) -> + Property +prop_storeStore = + prepropLaw @'[E.DefaultSsoCode] $ do + s <- arbitrary + s' <- arbitrary + pure $ + simpleLaw + ( do + E.store s + E.store s' + ) + ( do + E.store s' + ) + +prop_deleteDelete :: + PropConstraints r f => + Maybe (f () -> String) -> + (forall a. Sem r a -> IO (f a)) -> + Property +prop_deleteDelete = + prepropLaw @'[E.DefaultSsoCode] $ do + pure $ + simpleLaw + ( do + E.delete + E.delete + ) + ( do + E.delete + ) + +prop_deleteGet :: + PropConstraints r f => + Maybe (f (Maybe IdPId) -> String) -> + (forall a. Sem r a -> IO (f a)) -> + Property +prop_deleteGet = + prepropLaw @'[E.DefaultSsoCode] $ do + pure $ + simpleLaw + ( do + E.delete + E.get + ) + ( do + E.delete + pure Nothing + ) diff --git a/services/spar/src/Spar/Sem/IdP.hs b/services/spar/src/Spar/Sem/IdP.hs index 53e94faed03..81674e06e6e 100644 --- a/services/spar/src/Spar/Sem/IdP.hs +++ b/services/spar/src/Spar/Sem/IdP.hs @@ -3,6 +3,7 @@ module Spar.Sem.IdP where import Data.Id import Imports import Polysemy +import Polysemy.Check (deriveGenericK) import qualified SAML2.WebSSO as SAML import qualified Wire.API.User.IdentityProvider as IP @@ -41,3 +42,4 @@ deriving stock instance Show (IdP m a) -- TODO(sandy): Inline this definition --- no TH makeSem ''IdP +deriveGenericK ''IdP diff --git a/services/spar/src/Spar/Sem/IdP/Spec.hs b/services/spar/src/Spar/Sem/IdP/Spec.hs new file mode 100644 index 00000000000..d561ebc28ff --- /dev/null +++ b/services/spar/src/Spar/Sem/IdP/Spec.hs @@ -0,0 +1,315 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} + +module Spar.Sem.IdP.Spec (propsForInterpreter) where + +import Control.Arrow +import Control.Lens +import Data.Data (Data) +import Imports +import Polysemy +import Polysemy.Check +import SAML2.WebSSO.Types +import qualified SAML2.WebSSO.Types as SAML +import qualified Spar.Sem.IdP as E +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck +import qualified Wire.API.User.IdentityProvider as IP + +deriving instance Data IdPId + +deriving instance Data (E.GetIdPResult IdPId) + +propsForInterpreter :: + (Member E.IdP r, PropConstraints r f) => + String -> + (forall x. f x -> x) -> + (forall x. Show x => Maybe (f x -> String)) -> + (forall x. Sem r x -> IO (f x)) -> + Spec +propsForInterpreter interpreter extract labeler lower = do + describe interpreter $ do + prop "deleteConfig/deleteConfig" $ prop_deleteDelete Nothing lower + prop "deleteConfig/getConfig" $ prop_deleteGet labeler lower + prop "getConfig/storeConfig" $ prop_getStore (Just $ show . (() <$) . extract) lower + prop "getConfig/getConfig" $ prop_getGet (Just $ show . ((() <$) *** (() <$)) . extract) lower + prop "setReplacedBy/clearReplacedBy" $ prop_setClear labeler lower + prop "setReplacedBy/getReplacedBy" $ prop_setGet (Just $ show . (fmap (() <$)) . extract) lower + prop "setReplacedBy/setReplacedBy" $ prop_setSet (Just $ show . (fmap (() <$)) . extract) lower + prop "storeConfig/getConfig" $ prop_storeGet (Just $ show . (() <$) . extract) lower + xit "storeConfig/getIdByIssuerWithoutTeam" $ property $ prop_storeGetByIssuer (Just $ constructorLabel . extract) lower + prop "storeConfig/storeConfig (different keys)" $ prop_storeStoreInterleave Nothing lower + prop "storeConfig/storeConfig (same keys)" $ prop_storeStore Nothing lower + +getReplacedBy :: Member E.IdP r => SAML.IdPId -> Sem r (Maybe (Maybe SAML.IdPId)) +getReplacedBy idpid = fmap (view $ SAML.idpExtraInfo . IP.wiReplacedBy) <$> E.getConfig idpid + +-- | All the constraints we need to generalize properties in this module. +-- A regular type synonym doesn't work due to dreaded impredicative +-- polymorphism. +class + (Arbitrary Issuer, CoArbitrary Issuer, Arbitrary E.Replaced, Arbitrary E.Replaced, Arbitrary E.Replacing, Arbitrary IdPId, CoArbitrary IdPId, Arbitrary IP.IdP, CoArbitrary IP.IdP, CoArbitrary (E.GetIdPResult IdPId), Functor f, Member E.IdP r, forall z. Show z => Show (f z), forall z. Eq z => Eq (f z)) => + PropConstraints r f + +instance + (Arbitrary Issuer, CoArbitrary Issuer, Arbitrary E.Replaced, Arbitrary E.Replaced, Arbitrary E.Replacing, Arbitrary IdPId, CoArbitrary IdPId, Arbitrary IP.IdP, CoArbitrary IP.IdP, CoArbitrary (E.GetIdPResult IdPId), Functor f, Member E.IdP r, forall z. Show z => Show (f z), forall z. Eq z => Eq (f z)) => + PropConstraints r f + +prop_storeStore :: + PropConstraints r f => + Maybe (f () -> String) -> + (forall x. Sem r x -> IO (f x)) -> + Property +prop_storeStore = + prepropLaw @'[E.IdP] $ do + s <- arbitrary + s' <- arbitrary + pure $ + Law + { lawLhs = do + E.storeConfig $ s & SAML.idpId .~ s' ^. SAML.idpId + E.storeConfig s', + lawRhs = do + E.storeConfig s', + lawPrelude = [], + lawPostlude = [E.getConfig $ s' ^. SAML.idpId] + } + +prop_storeStoreInterleave :: + PropConstraints r f => + Maybe (f () -> String) -> + (forall x. Sem r x -> IO (f x)) -> + Property +prop_storeStoreInterleave = + prepropLaw @'[E.IdP] $ do + s <- arbitrary + s' <- arbitrary + !_ <- + when (s ^. SAML.idpId == s' ^. SAML.idpId) discard + pure $ + Law + { lawLhs = do + E.storeConfig s + E.storeConfig s', + lawRhs = do + E.storeConfig s' + E.storeConfig s, + lawPrelude = [], + lawPostlude = [E.getConfig $ s ^. SAML.idpId, E.getConfig $ s' ^. SAML.idpId] + } + +prop_storeGet :: + PropConstraints r f => + Maybe (f (Maybe IP.IdP) -> String) -> + (forall x. Sem r x -> IO (f x)) -> + Property +prop_storeGet = + prepropLaw @'[E.IdP] $ + do + s <- arbitrary + pure $ + simpleLaw + ( do + E.storeConfig s + E.getConfig $ s ^. idpId + ) + ( do + E.storeConfig s + pure (Just s) + ) + +prop_deleteGet :: + PropConstraints r f => + Maybe (f (Maybe IP.IdP) -> String) -> + (forall x. Sem r x -> IO (f x)) -> + Property +prop_deleteGet = + prepropLaw @'[E.IdP] $ do + s <- arbitrary + pure $ + Law + { lawLhs = do + E.deleteConfig s + E.getConfig $ s ^. SAML.idpId, + lawRhs = do + E.deleteConfig s + pure Nothing, + lawPrelude = + [ E.storeConfig s + ], + lawPostlude = [] :: [Sem r ()] + } + +prop_deleteDelete :: + PropConstraints r f => + Maybe (f () -> String) -> + (forall x. Sem r x -> IO (f x)) -> + Property +prop_deleteDelete = + prepropLaw @'[E.IdP] $ do + s <- arbitrary + pure $ + simpleLaw + ( do + E.deleteConfig s + E.deleteConfig s + ) + ( do + E.deleteConfig s + ) + +prop_storeGetByIssuer :: + PropConstraints r f => + Maybe (f (E.GetIdPResult IdPId) -> String) -> + (forall x. Sem r x -> IO (f x)) -> + Property +prop_storeGetByIssuer = + prepropLaw @'[E.IdP] $ + do + s <- arbitrary + pure $ + simpleLaw + ( do + E.storeConfig s + E.getIdByIssuerWithoutTeam $ s ^. idpMetadata . edIssuer + ) + ( do + E.storeConfig s + -- NOT TRUE! This can also return E.GetIdPNonUnique with nonzero probability! + pure $ E.GetIdPFound $ s ^. idpId + ) + +prop_setClear :: + PropConstraints r f => + Maybe (f (Maybe (Maybe IdPId)) -> String) -> + (forall x. Sem r x -> IO (f x)) -> + Property +prop_setClear = + prepropLaw @'[E.IdP] $ + do + idp <- arbitrary + replaced_id <- arbitrary + let replaced = E.Replaced replaced_id + replacing <- arbitrary + pure $ + Law + { lawLhs = do + E.setReplacedBy replaced replacing + E.clearReplacedBy replaced + getReplacedBy replaced_id, + lawRhs = do + E.clearReplacedBy replaced + getReplacedBy replaced_id, + lawPrelude = + [ E.storeConfig $ idp & SAML.idpId .~ replaced_id + ], + lawPostlude = [] @(Sem _ ()) + } + +prop_getGet :: + forall r f. + PropConstraints r f => + Maybe (f (Maybe IP.IdP, Maybe IP.IdP) -> String) -> + (forall x. Sem r x -> IO (f x)) -> + Property +prop_getGet = + prepropLaw @'[E.IdP] $ + do + idpid <- arbitrary + idp <- arbitrary + pure $ + Law + { lawLhs = do + liftA2 (,) (E.getConfig idpid) (E.getConfig idpid), + lawRhs = do + cfg <- E.getConfig idpid + pure (cfg, cfg), + lawPrelude = + [ E.storeConfig $ idp & SAML.idpId .~ idpid + ], + lawPostlude = [] :: [Sem r ()] + } + +prop_getStore :: + PropConstraints r f => + Maybe (f (Maybe IP.IdP) -> String) -> + (forall x. Sem r x -> IO (f x)) -> + Property +prop_getStore = + prepropLaw @'[E.IdP] $ + do + idpid <- arbitrary + s <- arbitrary + let s' = s & SAML.idpId .~ idpid + pure $ + Law + { lawLhs = do + r <- E.getConfig idpid + maybe (pure ()) E.storeConfig r + pure r, + lawRhs = do + E.getConfig idpid, + lawPrelude = + [E.storeConfig s'], + lawPostlude = + [E.getConfig idpid] + } + +prop_setSet :: + PropConstraints r f => + Maybe (f (Maybe (Maybe IdPId)) -> String) -> + (forall x. Sem r x -> IO (f x)) -> + Property +prop_setSet = + prepropLaw @'[E.IdP] $ + do + replaced_id <- arbitrary + s <- arbitrary + let s' = s & SAML.idpId .~ replaced_id + let replaced = E.Replaced replaced_id + replacing <- arbitrary + replacing' <- arbitrary + pure $ + Law + { lawLhs = do + E.setReplacedBy replaced replacing + E.setReplacedBy replaced replacing' + getReplacedBy replaced_id, + lawRhs = do + E.setReplacedBy replaced replacing' + getReplacedBy replaced_id, + lawPrelude = + [E.storeConfig s'], + lawPostlude = [] @(Sem _ ()) + } + +prop_setGet :: + PropConstraints r f => + Maybe (f (Maybe (Maybe IdPId)) -> String) -> + (forall x. Sem r x -> IO (f x)) -> + Property +prop_setGet = + prepropLaw @'[E.IdP] $ + do + idp <- arbitrary + replaced_id <- arbitrary + let replaced = E.Replaced replaced_id + replacing_id <- arbitrary + let replacing = E.Replacing replacing_id + pure $ + Law + { lawLhs = do + E.setReplacedBy replaced replacing + getReplacedBy replaced_id, + lawRhs = do + E.setReplacedBy replaced replacing + (Just replacing_id <$) <$> E.getConfig replaced_id, + lawPrelude = + [ E.storeConfig $ idp & SAML.idpId .~ replaced_id + ], + lawPostlude = [] :: [Sem r ()] + } diff --git a/services/spar/src/Spar/Sem/IdPRawMetadataStore.hs b/services/spar/src/Spar/Sem/IdPRawMetadataStore.hs index 4cee44c4c80..5b000899378 100644 --- a/services/spar/src/Spar/Sem/IdPRawMetadataStore.hs +++ b/services/spar/src/Spar/Sem/IdPRawMetadataStore.hs @@ -2,6 +2,7 @@ module Spar.Sem.IdPRawMetadataStore where import Imports import Polysemy +import Polysemy.Check (deriveGenericK) import qualified SAML2.WebSSO as SAML data IdPRawMetadataStore m a where @@ -13,3 +14,4 @@ deriving stock instance Show (IdPRawMetadataStore m a) -- TODO(sandy): Inline this definition --- no TH makeSem ''IdPRawMetadataStore +deriveGenericK ''IdPRawMetadataStore diff --git a/services/spar/src/Spar/Sem/IdPRawMetadataStore/Spec.hs b/services/spar/src/Spar/Sem/IdPRawMetadataStore/Spec.hs new file mode 100644 index 00000000000..181aec23304 --- /dev/null +++ b/services/spar/src/Spar/Sem/IdPRawMetadataStore/Spec.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE QuantifiedConstraints #-} +{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} + +module Spar.Sem.IdPRawMetadataStore.Spec (propsForInterpreter) where + +import Imports +import Polysemy +import Polysemy.Check +import SAML2.WebSSO.Types (IdPId) +import qualified Spar.Sem.IdPRawMetadataStore as E +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck + +class + (Arbitrary IdPId, CoArbitrary IdPId, Arbitrary Text, CoArbitrary Text, Functor f, Member E.IdPRawMetadataStore r, forall z. Show z => Show (f z), forall z. Eq z => Eq (f z)) => + PropConstraints r f + +instance + (Arbitrary IdPId, CoArbitrary IdPId, Arbitrary Text, CoArbitrary Text, Functor f, Member E.IdPRawMetadataStore r, forall z. Show z => Show (f z), forall z. Eq z => Eq (f z)) => + PropConstraints r f + +prop_storeGetRaw :: + PropConstraints r f => + Maybe (f (Maybe Text) -> String) -> + (forall a. Sem r a -> IO (f a)) -> + Property +prop_storeGetRaw = + prepropLaw @'[E.IdPRawMetadataStore] + ( do + idpid <- arbitrary + t <- arbitrary + pure $ + simpleLaw + ( do + E.store idpid t + E.get idpid + ) + ( do + E.store idpid t + pure (Just t) + ) + ) + +prop_storeStoreRaw :: + PropConstraints r f => + Maybe (f (Maybe Text) -> String) -> + (forall a. Sem r a -> IO (f a)) -> + Property +prop_storeStoreRaw = + prepropLaw @'[E.IdPRawMetadataStore] + ( do + idpid <- arbitrary + t1 <- arbitrary + t2 <- arbitrary + pure $ + simpleLaw + ( do + E.store idpid t1 + E.store idpid t2 + E.get idpid + ) + ( do + E.store idpid t2 + E.get idpid + ) + ) + +prop_storeDeleteRaw :: + PropConstraints r f => + Maybe (f (Maybe Text) -> String) -> + (forall a. Sem r a -> IO (f a)) -> + Property +prop_storeDeleteRaw = + prepropLaw @'[E.IdPRawMetadataStore] $ + do + idpid <- arbitrary + t <- arbitrary + pure $ + simpleLaw + ( do + E.store idpid t + E.delete idpid + E.get idpid + ) + ( do + E.delete idpid + E.get idpid + ) + +prop_deleteGetRaw :: + PropConstraints r f => + Maybe (f (Maybe Text) -> String) -> + (forall a. Sem r a -> IO (f a)) -> + Property +prop_deleteGetRaw = + prepropLaw @'[E.IdPRawMetadataStore] + ( do + idpid <- arbitrary + t <- arbitrary + pure $ + Law + { lawLhs = do + E.delete idpid + E.get idpid, + lawRhs = do + E.delete idpid + pure Nothing, + lawPrelude = + [ E.store idpid t + ], + lawPostlude = [] @(Sem _ ()) + } + ) + +propsForInterpreter :: + PropConstraints r f => + (forall x. f x -> x) -> + (forall a. Sem r a -> IO (f a)) -> + Spec +propsForInterpreter extract lower = do + prop "store/store" $ prop_storeStoreRaw (Just $ constructorLabel . extract) lower + prop "store/get" $ prop_storeGetRaw (Just $ constructorLabel . extract) lower + prop "store/delete" $ prop_storeDeleteRaw (Just $ constructorLabel . extract) lower + prop "delete/get" $ prop_deleteGetRaw (Just $ constructorLabel . extract) lower diff --git a/services/spar/src/Spar/Sem/Now.hs b/services/spar/src/Spar/Sem/Now.hs index 63d8e740ad5..883eb8d44cf 100644 --- a/services/spar/src/Spar/Sem/Now.hs +++ b/services/spar/src/Spar/Sem/Now.hs @@ -2,12 +2,16 @@ module Spar.Sem.Now where import Imports import Polysemy +import Polysemy.Check (deriveGenericK) import qualified SAML2.WebSSO as SAML data Now m a where Get :: Now m SAML.Time makeSem ''Now +deriveGenericK ''Now + +deriving instance Show (Now m a) -- | Check a time against 'Now', checking if it's still alive (hasn't occurred yet.) boolTTL :: diff --git a/services/spar/src/Spar/Sem/Now/Spec.hs b/services/spar/src/Spar/Sem/Now/Spec.hs new file mode 100644 index 00000000000..f7fab8c9d1f --- /dev/null +++ b/services/spar/src/Spar/Sem/Now/Spec.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE QuantifiedConstraints #-} +{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} + +module Spar.Sem.Now.Spec (propsForInterpreter) where + +import Imports +import Polysemy +import Polysemy.Check +import Polysemy.Input +import qualified Spar.Sem.Now as E +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck + +propsForInterpreter :: + PropConstraints r f => + String -> + (forall a. Sem r a -> IO (f a)) -> + Spec +propsForInterpreter interpreter lower = do + describe interpreter $ do + prop "now/now" $ prop_nowNow Nothing lower + +-- | All the constraints we need to generalize properties in this module. +-- A regular type synonym doesn't work due to dreaded impredicative +-- polymorphism. +class + (Functor f, Member E.Now r, Member (Input ()) r, forall z. Show z => Show (f z), forall z. Eq z => Eq (f z)) => + PropConstraints r f + +instance + (Functor f, Member E.Now r, Member (Input ()) r, forall z. Show z => Show (f z), forall z. Eq z => Eq (f z)) => + PropConstraints r f + +prop_nowNow :: + PropConstraints r f => + Maybe (f Bool -> String) -> + (forall a. Sem r a -> IO (f a)) -> + Property +prop_nowNow = + -- NOTE: This @Input ()@ effect is a workaround to an oversight in + -- @polysemy-check@. 'prepropLaw' wants to synthesize some actions to run + -- before and after its generators, and check their results for equality. We + -- can't use 'Now' as this effect, because 'E.get' won't return equivalent + -- results! And we can't keep it empty, because that triggers a crash in + -- @polysemy-check@. Thus @Input ()@, which isn't beautiful, but works fine. + prepropLaw @'[Input ()] $ do + pure $ + simpleLaw + (liftA2 (<=) E.get E.get) + ( pure True + ) diff --git a/services/spar/src/Spar/Sem/ScimExternalIdStore.hs b/services/spar/src/Spar/Sem/ScimExternalIdStore.hs index b2a43f6b327..717daa58b8a 100644 --- a/services/spar/src/Spar/Sem/ScimExternalIdStore.hs +++ b/services/spar/src/Spar/Sem/ScimExternalIdStore.hs @@ -3,6 +3,7 @@ module Spar.Sem.ScimExternalIdStore where import Data.Id (TeamId, UserId) import Imports import Polysemy +import Polysemy.Check (deriveGenericK) import Wire.API.User.Identity (Email) data ScimExternalIdStore m a where @@ -10,4 +11,7 @@ data ScimExternalIdStore m a where Lookup :: TeamId -> Email -> ScimExternalIdStore m (Maybe UserId) Delete :: TeamId -> Email -> ScimExternalIdStore m () +deriving instance Show (ScimExternalIdStore m a) + makeSem ''ScimExternalIdStore +deriveGenericK ''ScimExternalIdStore diff --git a/services/spar/src/Spar/Sem/ScimExternalIdStore/Spec.hs b/services/spar/src/Spar/Sem/ScimExternalIdStore/Spec.hs new file mode 100644 index 00000000000..57c2a1742e9 --- /dev/null +++ b/services/spar/src/Spar/Sem/ScimExternalIdStore/Spec.hs @@ -0,0 +1,183 @@ +{-# LANGUAGE QuantifiedConstraints #-} +{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} + +module Spar.Sem.ScimExternalIdStore.Spec (propsForInterpreter) where + +import Data.Id +import Imports +import Polysemy +import Polysemy.Check +import qualified Spar.Sem.ScimExternalIdStore as E +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck + +propsForInterpreter :: + PropConstraints r f => + String -> + (forall a. f a -> a) -> + (forall a. Sem r a -> IO (f a)) -> + Spec +propsForInterpreter interpreter extract lower = do + describe interpreter $ do + prop "delete/delete" $ prop_deleteDelete Nothing lower + prop "delete/lookup" $ prop_deleteLookup (Just $ show . (() <$) . extract) lower + prop "delete/insert" $ prop_deleteInsert Nothing lower + prop "lookup/insert" $ prop_lookupInsert Nothing lower + prop "insert/delete" $ prop_insertDelete Nothing lower + prop "insert/lookup" $ prop_insertLookup (Just $ show . (() <$) . extract) lower + prop "insert/insert" $ prop_insertInsert (Just $ show . (() <$) . extract) lower + +-- | All the constraints we need to generalize properties in this module. +-- A regular type synonym doesn't work due to dreaded impredicative +-- polymorphism. +class + (Arbitrary UserId, CoArbitrary UserId, Functor f, Member E.ScimExternalIdStore r, forall z. Show z => Show (f z), forall z. Eq z => Eq (f z)) => + PropConstraints r f + +instance + (Arbitrary UserId, CoArbitrary UserId, Functor f, Member E.ScimExternalIdStore r, forall z. Show z => Show (f z), forall z. Eq z => Eq (f z)) => + PropConstraints r f + +prop_insertLookup :: + PropConstraints r f => + Maybe (f (Maybe UserId) -> String) -> + (forall a. Sem r a -> IO (f a)) -> + Property +prop_insertLookup = + prepropLaw @'[E.ScimExternalIdStore] $ do + tid <- arbitrary + email <- arbitrary + uid <- arbitrary + pure $ + simpleLaw + ( do + E.insert tid email uid + E.lookup tid email + ) + ( do + E.insert tid email uid + pure (Just uid) + ) + +prop_lookupInsert :: + PropConstraints r f => + Maybe (f () -> String) -> + (forall a. Sem r a -> IO (f a)) -> + Property +prop_lookupInsert = + prepropLaw @'[E.ScimExternalIdStore] $ do + tid <- arbitrary + email <- arbitrary + pure $ + simpleLaw + ( do + E.lookup tid email >>= maybe (pure ()) (E.insert tid email) + ) + ( do + pure () + ) + +prop_insertDelete :: + PropConstraints r f => + Maybe (f () -> String) -> + (forall a. Sem r a -> IO (f a)) -> + Property +prop_insertDelete = + prepropLaw @'[E.ScimExternalIdStore] $ do + tid <- arbitrary + email <- arbitrary + uid <- arbitrary + pure $ + simpleLaw + ( do + E.insert tid email uid + E.delete tid email + ) + ( do + E.delete tid email + ) + +prop_deleteInsert :: + PropConstraints r f => + Maybe (f () -> String) -> + (forall a. Sem r a -> IO (f a)) -> + Property +prop_deleteInsert = + prepropLaw @'[E.ScimExternalIdStore] $ do + tid <- arbitrary + email <- arbitrary + uid <- arbitrary + pure $ + simpleLaw + ( do + E.delete tid email + E.insert tid email uid + ) + ( do + E.insert tid email uid + ) + +prop_insertInsert :: + PropConstraints r f => + Maybe (f (Maybe UserId) -> String) -> + (forall a. Sem r a -> IO (f a)) -> + Property +prop_insertInsert = + prepropLaw @'[E.ScimExternalIdStore] $ do + tid <- arbitrary + email <- arbitrary + uid <- arbitrary + uid' <- arbitrary + pure $ + simpleLaw + ( do + E.insert tid email uid + E.insert tid email uid' + E.lookup tid email + ) + ( do + E.insert tid email uid' + E.lookup tid email + ) + +prop_deleteDelete :: + PropConstraints r f => + Maybe (f () -> String) -> + (forall a. Sem r a -> IO (f a)) -> + Property +prop_deleteDelete = + prepropLaw @'[E.ScimExternalIdStore] $ do + tid <- arbitrary + email <- arbitrary + pure $ + simpleLaw + ( do + E.delete tid email + E.delete tid email + ) + ( do + E.delete tid email + ) + +prop_deleteLookup :: + PropConstraints r f => + Maybe (f (Maybe UserId) -> String) -> + (forall a. Sem r a -> IO (f a)) -> + Property +prop_deleteLookup = + prepropLaw @'[E.ScimExternalIdStore] $ do + tid <- arbitrary + email <- arbitrary + uid <- arbitrary + pure $ + Law + { lawLhs = do + E.delete tid email + E.lookup tid email, + lawRhs = do + E.delete tid email + pure Nothing, + lawPrelude = [E.insert tid email uid], + lawPostlude = [] @(Sem _ ()) + } diff --git a/services/spar/test-integration/Test/Spar/APISpec.hs b/services/spar/test-integration/Test/Spar/APISpec.hs index 980a761aa04..7d73042cf0d 100644 --- a/services/spar/test-integration/Test/Spar/APISpec.hs +++ b/services/spar/test-integration/Test/Spar/APISpec.hs @@ -67,10 +67,12 @@ import SAML2.WebSSO (-/), ) import qualified SAML2.WebSSO as SAML +import SAML2.WebSSO.API.Example (SimpleSP) import SAML2.WebSSO.Test.Lenses import SAML2.WebSSO.Test.MockResponse import SAML2.WebSSO.Test.Util import qualified Spar.Intra.BrigApp as Intra +import qualified Spar.Sem.AReqIDStore as AReqIDStore import qualified Spar.Sem.BrigAccess as BrigAccess import qualified Spar.Sem.IdP as IdPEffect import Text.XML.DSig (SignPrivCreds, mkSignCredsWithCert) @@ -198,7 +200,8 @@ specInitiateLogin = do specFinalizeLogin :: SpecWith TestEnv specFinalizeLogin = do describe "POST /sso/finalize-login" $ do - context "access denied" $ do + -- @SF.Channel @TSFI.RESTfulAPI @S2 @S3 + context "rejectsSAMLResponseSayingAccessNotGranted" $ do it "responds with a very peculiar 'forbidden' HTTP response" $ do (_, tid, idp, (_, privcreds)) <- registerTestIdPWithMeta authnreq <- negotiateAuthnRequest idp @@ -206,12 +209,6 @@ specFinalizeLogin = do authnresp <- runSimpleSP $ mkAuthnResponse privcreds idp spmeta authnreq False sparresp <- submitAuthnResponse tid authnresp liftIO $ do - -- import Text.XML - -- putStrLn $ unlines - -- [ cs . renderLBS def { rsPretty = True } . fromSignedAuthnResponse $ authnresp - -- , show sparresp - -- , maybe "Nothing" cs (responseBody sparresp) - -- ] statusCode sparresp `shouldBe` 200 let bdy = maybe "" (cs @LBS @String) (responseBody sparresp) bdy `shouldContain` "" @@ -223,9 +220,9 @@ specFinalizeLogin = do bdy `shouldContain` "\"label\":\"forbidden\"" bdy `shouldContain` "}, receiverOrigin)" hasPersistentCookieHeader sparresp `shouldBe` Left "no set-cookie header" - context "user has been deleted" $ do - it "responds with 'forbidden'" $ do - pendingWith "or do we want to un-delete the user? or create a new one?" + + -- @END + context "access granted" $ do let loginSuccess :: HasCallStack => ResponseLBS -> TestSpar () loginSuccess sparresp = liftIO $ do @@ -299,7 +296,8 @@ specFinalizeLogin = do authnresp <- runSimpleSP $ mkAuthnResponse privcreds idp3 spmeta authnreq True loginSuccess =<< submitAuthnResponse tid3 authnresp - context "idp sends user to two teams with same issuer, nameid" $ do + -- @SF.Channel @TSFI.RESTfulAPI @S2 @S3 + context "rejectsSAMLResponseInWrongTeam" $ do it "fails" $ do skipIdPAPIVersions [ WireIdPAPIV1 @@ -323,6 +321,8 @@ specFinalizeLogin = do authnresp <- runSimpleSP $ mkAuthnResponseWithSubj subj privcreds idp2 spmeta authnreq True loginFailure =<< submitAuthnResponse tid2 authnresp + -- @END + context "user is created once, then deleted in team settings, then can login again." $ do it "responds with 'allowed'" $ do (ownerid, teamid, idp, (_, privcreds)) <- registerTestIdPWithMeta @@ -358,7 +358,7 @@ specFinalizeLogin = do ) liftIO $ threadDelay 100000 -- make sure deletion is done. if we don't want to take -- the time, we should find another way to robustly - -- confirm that deletion has compelted in the background. + -- confirm that deletion has completed in the background. -- second login do @@ -372,8 +372,8 @@ specFinalizeLogin = do context "known user A, but client device (probably a browser?) is already authenticated as another (probably non-sso) user B" $ do it "logs out user B, logs in user A" $ do + -- TODO(arianvp): Ask Matthias what this even means pending - -- TODO(arianvp): Ask Matthias what this even means context "more than one dsig cert" $ do it "accepts the first of two certs for signatures" $ do @@ -381,47 +381,111 @@ specFinalizeLogin = do it "accepts the second of two certs for signatures" $ do pending - context "unknown IdP Issuer" $ do - it "rejects" $ do - (_, teamid, idp, (_, privcreds)) <- registerTestIdPWithMeta - authnreq <- negotiateAuthnRequest idp - spmeta <- getTestSPMetadata teamid - authnresp <- - runSimpleSP $ - mkAuthnResponse - privcreds - (idp & idpMetadata . edIssuer .~ Issuer [uri|http://unknown-issuer/|]) - spmeta - authnreq - True - sparresp <- submitAuthnResponse teamid authnresp - let shouldContainInBase64 :: String -> String -> Expectation - shouldContainInBase64 hay needle = cs hay'' `shouldContain` needle - where - Right (Just hay'') = decodeBase64 <$> validateBase64 hay' - hay' = cs $ f hay - where - -- exercise to the reader: do this more idiomatically! - f (splitAt 5 -> ("
", s)) = g s
-                    f (_ : s) = f s
-                    f "" = ""
-                    g (splitAt 6 -> ("
", _)) = "" - g (c : s) = c : g s - g "" = "" - liftIO $ do - statusCode sparresp `shouldBe` 404 - -- body should contain the error label in the title, the verbatim haskell error, and the request: - (cs . fromJust . responseBody $ sparresp) `shouldContain` "wire:sso:error:not-found" - (cs . fromJust . responseBody $ sparresp) `shouldContainInBase64` "CustomError (SparIdPNotFound" - (cs . fromJust . responseBody $ sparresp) `shouldContainInBase64` "Input {iName = \"SAMLResponse\"" - -- TODO(arianvp): Ask Matthias what this even means - context "AuthnResponse does not match any request" $ do - it "rejects" $ do - pending - -- TODO(arianvp): Ask Matthias what this even means - context "AuthnResponse contains assertions that have been offered before" $ do - it "rejects" $ do - pending + context "bad AuthnResponse" $ do + let check :: + (IdP -> TestSpar SAML.AuthnRequest) -> + (SignPrivCreds -> IdP -> SAML.SPMetadata -> SAML.AuthnRequest -> SimpleSP SignedAuthnResponse) -> + (TeamId -> SignedAuthnResponse -> TestSpar (Response (Maybe LByteString))) -> + (ResponseLBS -> IO ()) -> + TestSpar () + check mkareq mkaresp submitaresp checkresp = do + (_, teamid, idp, (_, privcreds)) <- registerTestIdPWithMeta + authnreq <- mkareq idp + spmeta <- getTestSPMetadata teamid + authnresp <- + runSimpleSP $ + mkaresp + privcreds + idp + spmeta + authnreq + sparresp <- submitaresp teamid authnresp + liftIO $ checkresp sparresp + + shouldContainInBase64 :: String -> String -> Expectation + shouldContainInBase64 hay needle = cs hay'' `shouldContain` needle + where + Right (Just hay'') = decodeBase64 <$> validateBase64 hay' + hay' = cs $ f hay + where + -- exercise to the reader: do this more idiomatically! + f (splitAt 5 -> ("
", s)) = g s
+                  f (_ : s) = f s
+                  f "" = ""
+                  g (splitAt 6 -> ("
", _)) = "" + g (c : s) = c : g s + g "" = "" + + -- @SF.Channel @TSFI.RESTfulAPI @S2 @S3 + it "rejectsSAMLResponseFromWrongIssuer" $ do + let mkareq = negotiateAuthnRequest + mkaresp privcreds idp spmeta authnreq = + mkAuthnResponse + privcreds + (idp & idpMetadata . edIssuer .~ Issuer [uri|http://unknown-issuer/|]) + spmeta + authnreq + True + submitaresp = submitAuthnResponse + checkresp sparresp = do + statusCode sparresp `shouldBe` 404 + -- body should contain the error label in the title, the verbatim haskell error, and the request: + (cs . fromJust . responseBody $ sparresp) `shouldContain` "wire:sso:error:not-found" + (cs . fromJust . responseBody $ sparresp) `shouldContainInBase64` "CustomError (SparIdPNotFound" + (cs . fromJust . responseBody $ sparresp) `shouldContainInBase64` "Input {iName = \"SAMLResponse\"" + check mkareq mkaresp submitaresp checkresp + + -- @END + + -- @SF.Channel @TSFI.RESTfulAPI @S2 @S3 + it "rejectsSAMLResponseSignedWithWrongKey" $ do + (_, _, _, (_, badprivcreds)) <- registerTestIdPWithMeta + let mkareq = negotiateAuthnRequest + mkaresp _ idp spmeta authnreq = + mkAuthnResponse + badprivcreds + idp + spmeta + authnreq + True + submitaresp = submitAuthnResponse + checkresp sparresp = statusCode sparresp `shouldBe` 400 + check mkareq mkaresp submitaresp checkresp + + -- @END + + -- @SF.Channel @TSFI.RESTfulAPI @S2 @S3 + it "rejectsSAMLResponseIfRequestIsStale" $ do + let mkareq idp = do + req <- negotiateAuthnRequest idp + runSpar $ AReqIDStore.unStore (req ^. SAML.rqID) + pure req + mkaresp privcreds idp spmeta authnreq = mkAuthnResponse privcreds idp spmeta authnreq True + submitaresp = submitAuthnResponse + checkresp sparresp = do + statusCode sparresp `shouldBe` 200 + (cs . fromJust . responseBody $ sparresp) `shouldContain` "wire:sso:error:forbidden" + (cs . fromJust . responseBody $ sparresp) `shouldContain` "bad InResponseTo attribute(s)" + check mkareq mkaresp submitaresp checkresp + + -- @END + + -- @SF.Channel @TSFI.RESTfulAPI @S2 @S3 + it "rejectsSAMLResponseIfResponseIsStale" $ do + let mkareq = negotiateAuthnRequest + mkaresp privcreds idp spmeta authnreq = mkAuthnResponse privcreds idp spmeta authnreq True + submitaresp teamid authnresp = do + _ <- submitAuthnResponse teamid authnresp + submitAuthnResponse teamid authnresp + checkresp sparresp = do + statusCode sparresp `shouldBe` 200 + (cs . fromJust . responseBody $ sparresp) `shouldContain` "wire:sso:error:forbidden" + check mkareq mkaresp submitaresp checkresp + + -- {- ORMOLU_DISABLE -} -- FUTUREWORK: try a newer release of ormolu? + -- @END + -- {- ORMOLU_ENABLE -} + context "IdP changes response format" $ do it "treats NameId case-insensitively" $ do (_ownerid, tid, idp, (_, privcreds)) <- registerTestIdPWithMeta diff --git a/services/spar/test-integration/Test/Spar/Scim/AuthSpec.hs b/services/spar/test-integration/Test/Spar/Scim/AuthSpec.hs index 20c3bdc071c..bee95ef5112 100644 --- a/services/spar/test-integration/Test/Spar/Scim/AuthSpec.hs +++ b/services/spar/test-integration/Test/Spar/Scim/AuthSpec.hs @@ -52,7 +52,7 @@ spec = do specDeleteToken specListTokens describe "Miscellaneous" $ do - it "doesn't allow SCIM operations without a SCIM token" $ testAuthIsNeeded + it "doesn't allow SCIM operations with invalid or missing SCIM token" testAuthIsNeeded ---------------------------------------------------------------------------- -- Token creation @@ -60,11 +60,11 @@ spec = do -- | Tests for @POST /auth-tokens@. specCreateToken :: SpecWith TestEnv specCreateToken = describe "POST /auth-tokens" $ do - it "works" $ testCreateToken - it "respects the token limit" $ testTokenLimit - it "requires the team to have no more than one IdP" $ testNumIdPs - it "authorizes only admins and owners" $ testCreateTokenAuthorizesOnlyAdmins - it "requires a password" $ testCreateTokenRequiresPassword + it "works" testCreateToken + it "respects the token limit" testTokenLimit + it "requires the team to have no more than one IdP" testNumIdPs + it "authorizes only admins and owners" testCreateTokenAuthorizesOnlyAdmins + it "requires a password" testCreateTokenRequiresPassword -- FUTUREWORK: we should also test that for a password-less user, e.g. for an SSO user, -- reauthentication is not required. We currently (2019-03-05) can't test that because @@ -147,7 +147,8 @@ testNumIdPs = do createToken_ owner (CreateScimToken "drei" (Just defPassword)) (env ^. teSpar) !!! checkErr 400 (Just "more-than-one-idp") --- | Test that a token can only be created as a team owner +-- @SF.Provisioning @TSFI.RESTfulAPI @S2 +-- Test that a token can only be created as a team owner testCreateTokenAuthorizesOnlyAdmins :: TestSpar () testCreateTokenAuthorizesOnlyAdmins = do env <- ask @@ -177,6 +178,8 @@ testCreateTokenAuthorizesOnlyAdmins = do (mkUser Galley.RoleAdmin >>= createToken') !!! const 200 === statusCode +-- @END + -- | Test that for a user with a password, token creation requires reauthentication (i.e. the -- field @"password"@ should be provided). -- @@ -361,10 +364,17 @@ testDeletedTokensAreUnlistable = do ---------------------------------------------------------------------------- -- Miscellaneous tests --- | Test that without a token, the SCIM API can't be used. +-- @SF.Provisioning @TSFI.RESTfulAPI @S2 +-- This test verifies that the SCIM API responds with an authentication error +-- and can't be used if it receives an invalid secret token +-- or if no token is provided at all testAuthIsNeeded :: TestSpar () testAuthIsNeeded = do env <- ask + -- Try to do @GET /Users@ with an invalid token and check that it fails + let invalidToken = ScimToken "this-is-an-invalid-token" + listUsers_ (Just invalidToken) Nothing (env ^. teSpar) !!! checkErr 401 Nothing -- Try to do @GET /Users@ without a token and check that it fails - listUsers_ Nothing Nothing (env ^. teSpar) - !!! checkErr 401 Nothing + listUsers_ Nothing Nothing (env ^. teSpar) !!! checkErr 401 Nothing + +-- @END diff --git a/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs b/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs index a73b15ed147..7b23d24b6b3 100644 --- a/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs +++ b/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs @@ -35,7 +35,7 @@ import Brig.Types.User as Brig import qualified Control.Exception import Control.Lens import Control.Monad.Except (MonadError (throwError)) -import Control.Monad.Random (Random (randomRIO)) +import Control.Monad.Random (randomRIO) import Control.Monad.Trans.Except import Control.Monad.Trans.Maybe import Control.Retry (exponentialBackoff, limitRetries, recovering) @@ -203,7 +203,7 @@ specCreateUser = describe "POST /Users" $ do context "team has no SAML IdP" $ do it "creates a user with PendingInvitation, and user can follow usual invitation process" $ do testCreateUserNoIdP - it "fails if no email can be extraced from externalId" $ do + it "fails if no email can be extracted from externalId" $ do testCreateUserNoIdPNoEmail it "doesn't list users that exceed their invitation period, and allows recreating them" $ do testCreateUserTimeout @@ -466,7 +466,10 @@ testExternalIdIsRequired = do createUser_ (Just tok) user' (env ^. teSpar) !!! const 400 === statusCode --- | Test that user creation fails if handle is invalid +-- The next line contains a mapping from this test to the following test standards: +-- @SF.Provisioning @TSFI.RESTfulAPI @S2 +-- +-- Test that user creation fails if handle is invalid testCreateRejectsInvalidHandle :: TestSpar () testCreateRejectsInvalidHandle = do env <- ask @@ -476,6 +479,8 @@ testCreateRejectsInvalidHandle = do createUser_ (Just tok) (user {Scim.User.userName = "#invalid name"}) (env ^. teSpar) !!! const 400 === statusCode +-- @END + -- | Test that user creation fails if handle is already in use (even on different team). testCreateRejectsTakenHandle :: TestSpar () testCreateRejectsTakenHandle = do diff --git a/services/spar/test-integration/Util/Core.hs b/services/spar/test-integration/Util/Core.hs index f51f8789748..a621f285f1d 100644 --- a/services/spar/test-integration/Util/Core.hs +++ b/services/spar/test-integration/Util/Core.hs @@ -199,6 +199,7 @@ import Wire.API.Routes.Public.Spar import Wire.API.Team.Feature (TeamFeatureStatusValue (..)) import qualified Wire.API.Team.Feature as Public import qualified Wire.API.Team.Invitation as TeamInvitation +import qualified Wire.API.Team.Member as Member import Wire.API.User (HandleUpdate (HandleUpdate), UserUpdate) import qualified Wire.API.User as User import Wire.API.User.Identity (mkSampleUref) @@ -472,7 +473,7 @@ createTeamMember brigreq galleyreq teamid perms = do postUser name False (Just ssoid) (Just teamid) brigreq UserId -> TeamId -> UserId -> TestSpar () promoteTeamMember usr tid memid = do gly <- view teGalley let bdy :: Galley.NewTeamMember - bdy = Galley.newNewTeamMember memid Galley.fullPermissions Nothing + bdy = Member.mkNewTeamMember memid Galley.fullPermissions Nothing call $ put (gly . paths ["teams", toByteString' tid, "members"] . zAuthAccess usr "conn" . json bdy) !!! const 200 === statusCode @@ -1209,7 +1210,7 @@ ssoToUidSpar tid ssoid = do veid <- either (error . ("could not parse brig sso_id: " <>)) pure $ Intra.veidFromUserSSOId ssoid runSpar $ runValidExternalId - (SAMLUserStore.get) + SAMLUserStore.get (ScimExternalIdStore.lookup tid) veid diff --git a/services/spar/test/Arbitrary.hs b/services/spar/test/Arbitrary.hs index bc7ca9fae4e..a5536460c6c 100644 --- a/services/spar/test/Arbitrary.hs +++ b/services/spar/test/Arbitrary.hs @@ -23,7 +23,7 @@ module Arbitrary where import Data.Aeson -import Data.Id (TeamId) +import Data.Id (TeamId, UserId) import Data.Proxy import Data.String.Conversions (cs) import Data.Swagger hiding (Header (..)) @@ -97,6 +97,8 @@ instance Arbitrary E.Replaced where instance CoArbitrary a => CoArbitrary (E.GetIdPResult a) +-- TODO(sandy): IdPIds are unlikely to collide. Does the size parameter +-- affect them? instance CoArbitrary IdPId instance CoArbitrary WireIdP @@ -105,6 +107,10 @@ instance CoArbitrary WireIdPAPIVersion instance CoArbitrary TeamId +instance CoArbitrary UserId + +instance CoArbitrary Time + instance CoArbitrary Issuer where coarbitrary (Issuer ur) = coarbitrary $ show ur diff --git a/services/spar/test/Test/Spar/Sem/DefaultSsoCodeSpec.hs b/services/spar/test/Test/Spar/Sem/DefaultSsoCodeSpec.hs new file mode 100644 index 00000000000..bc55fa5e410 --- /dev/null +++ b/services/spar/test/Test/Spar/Sem/DefaultSsoCodeSpec.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE QuantifiedConstraints #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} + +module Test.Spar.Sem.DefaultSsoCodeSpec where + +import Arbitrary () +import Imports +import Polysemy +import Spar.Sem.DefaultSsoCode.Mem +import Spar.Sem.DefaultSsoCode.Spec +import Test.Hspec +import Test.Hspec.QuickCheck + +spec :: Spec +spec = modifyMaxSuccess (const 1000) $ do + propsForInterpreter "defaultSsoCodeToMem" $ pure . run . defaultSsoCodeToMem diff --git a/services/spar/test/Test/Spar/Sem/IdPRawMetadataStoreSpec.hs b/services/spar/test/Test/Spar/Sem/IdPRawMetadataStoreSpec.hs index c1d5f6b9b81..2f8ce187cc8 100644 --- a/services/spar/test/Test/Spar/Sem/IdPRawMetadataStoreSpec.hs +++ b/services/spar/test/Test/Spar/Sem/IdPRawMetadataStoreSpec.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} module Test.Spar.Sem.IdPRawMetadataStoreSpec where @@ -6,106 +5,15 @@ module Test.Spar.Sem.IdPRawMetadataStoreSpec where import Arbitrary () import Imports import Polysemy -import Polysemy.Check import qualified Spar.Sem.IdPRawMetadataStore as E import Spar.Sem.IdPRawMetadataStore.Mem +import Spar.Sem.IdPRawMetadataStore.Spec import Test.Hspec import Test.Hspec.QuickCheck -import Test.QuickCheck - -deriveGenericK ''E.IdPRawMetadataStore - -prop_storeGetRaw :: - Member E.IdPRawMetadataStore r => - (forall a. Sem r a -> IO (RawState, a)) -> - Property -prop_storeGetRaw x = - prepropLaw @'[E.IdPRawMetadataStore] - ( do - idpid <- arbitrary - t <- arbitrary - pure - ( do - E.store idpid t - E.get idpid, - do - E.store idpid t - pure (Just t) - ) - ) - x - -prop_storeStoreRaw :: - Member E.IdPRawMetadataStore r => - (forall a. Sem r a -> IO (RawState, a)) -> - Property -prop_storeStoreRaw x = - prepropLaw @'[E.IdPRawMetadataStore] - ( do - idpid <- arbitrary - t1 <- arbitrary - t2 <- arbitrary - pure - ( do - E.store idpid t1 - E.store idpid t2, - do - E.store idpid t2 - ) - ) - x - -prop_storeDeleteRaw :: - Member E.IdPRawMetadataStore r => - (forall a. Sem r a -> IO (RawState, a)) -> - Property -prop_storeDeleteRaw x = - prepropLaw @'[E.IdPRawMetadataStore] - ( do - idpid <- arbitrary - t <- arbitrary - pure - ( do - E.store idpid t - E.delete idpid, - do - E.delete idpid - ) - ) - x - -prop_deleteGetRaw :: - Member E.IdPRawMetadataStore r => - (forall a. Sem r a -> IO (RawState, a)) -> - Property -prop_deleteGetRaw x = - prepropLaw @'[E.IdPRawMetadataStore] - ( do - idpid <- arbitrary - pure - ( do - E.delete idpid - E.get idpid, - do - E.delete idpid - pure Nothing - ) - ) - x testInterpreter :: Sem '[E.IdPRawMetadataStore] a -> IO (RawState, a) testInterpreter = pure . run . idpRawMetadataStoreToMem -propsForInterpreter :: - Member E.IdPRawMetadataStore r => - (forall a. Sem r a -> IO (RawState, a)) -> - Spec -propsForInterpreter lower = do - prop "store/store" $ prop_storeStoreRaw lower - prop "store/get" $ prop_storeGetRaw lower - prop "store/deleteRawMetadata" $ prop_storeDeleteRaw lower - prop "deleteRawMetadata/get" $ prop_deleteGetRaw lower - spec :: Spec spec = modifyMaxSuccess (const 1000) $ do - propsForInterpreter testInterpreter + propsForInterpreter snd testInterpreter diff --git a/services/spar/test/Test/Spar/Sem/IdPSpec.hs b/services/spar/test/Test/Spar/Sem/IdPSpec.hs index 162f5b1625f..43232daa1b2 100644 --- a/services/spar/test/Test/Spar/Sem/IdPSpec.hs +++ b/services/spar/test/Test/Spar/Sem/IdPSpec.hs @@ -1,72 +1,19 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} module Test.Spar.Sem.IdPSpec where import Arbitrary () -import Control.Lens import Imports import Polysemy -import Polysemy.Check -import SAML2.WebSSO.Types -import qualified Spar.Sem.IdP as E import Spar.Sem.IdP.Mem +import Spar.Sem.IdP.Spec import Test.Hspec import Test.Hspec.QuickCheck -import Test.QuickCheck - -deriveGenericK ''E.IdP - -prop_storeGet :: - Member E.IdP r => - (forall a. Sem r a -> IO (TypedState, a)) -> - Property -prop_storeGet x = - prepropLaw @'[E.IdP] - ( do - s <- arbitrary - pure - ( do - E.storeConfig s - E.getConfig $ s ^. idpId, - do - E.storeConfig s - pure (Just s) - ) - ) - x - -prop_storeGetByIssuer :: - Member E.IdP r => - (forall a. Sem r a -> IO (TypedState, a)) -> - Property -prop_storeGetByIssuer x = - prepropLaw @'[E.IdP] - ( do - s <- arbitrary - pure - ( do - E.storeConfig s - E.getIdByIssuerWithoutTeam $ s ^. idpMetadata . edIssuer, - do - E.storeConfig s - pure $ E.GetIdPFound $ s ^. idpId - ) - ) - x - -testInterpreter :: Sem '[E.IdP] a -> IO (TypedState, a) -testInterpreter = pure . run . idPToMem - -propsForInterpreter :: - Member E.IdP r => - (forall a. Sem r a -> IO (TypedState, a)) -> - Spec -propsForInterpreter lower = do - describe "Config Actions" $ do - prop "storeConfig/getConfig" $ prop_storeGet lower - prop "storeConfig/getIdByIssuerWithoutTeam" $ prop_storeGetByIssuer lower spec :: Spec spec = modifyMaxSuccess (const 1000) $ do - propsForInterpreter testInterpreter + propsForInterpreter "idPToMem" snd (Just $ show . snd) $ pure . run . idPToMem diff --git a/services/spar/test/Test/Spar/Sem/NowSpec.hs b/services/spar/test/Test/Spar/Sem/NowSpec.hs new file mode 100644 index 00000000000..b31dae84d42 --- /dev/null +++ b/services/spar/test/Test/Spar/Sem/NowSpec.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE QuantifiedConstraints #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} + +module Test.Spar.Sem.NowSpec where + +import Arbitrary () +import Data.Time +import Data.Time.Calendar.Julian +import Imports +import Polysemy +import Polysemy.Input +import SAML2.WebSSO.Types +import Spar.Sem.Now.IO +import Spar.Sem.Now.Input +import Spar.Sem.Now.Spec +import Test.Hspec +import Test.Hspec.QuickCheck + +someTime :: Time +someTime = Time (UTCTime (fromJulianYearAndDay 1990 209) (secondsToDiffTime 0)) + +spec :: Spec +spec = do + modifyMaxSuccess (const 1000) $ do + propsForInterpreter "nowToIO" $ fmap Identity . runM . nowToIO . runInputConst () + propsForInterpreter "nowToInput" $ pure . Identity . run . runInputConst someTime . nowToInput . runInputConst () diff --git a/services/spar/test/Test/Spar/Sem/ScimExternalIdStoreSpec.hs b/services/spar/test/Test/Spar/Sem/ScimExternalIdStoreSpec.hs new file mode 100644 index 00000000000..964eb9a74f6 --- /dev/null +++ b/services/spar/test/Test/Spar/Sem/ScimExternalIdStoreSpec.hs @@ -0,0 +1,15 @@ +{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} + +module Test.Spar.Sem.ScimExternalIdStoreSpec where + +import Arbitrary () +import Imports +import Polysemy +import Spar.Sem.ScimExternalIdStore.Mem +import Spar.Sem.ScimExternalIdStore.Spec +import Test.Hspec +import Test.Hspec.QuickCheck + +spec :: Spec +spec = modifyMaxSuccess (const 1000) $ do + propsForInterpreter "scimExternalIdStoreToMem" snd $ pure . run . scimExternalIdStoreToMem diff --git a/stack-deps.nix b/stack-deps.nix index b19d261cd7b..f7cc47ae211 100644 --- a/stack-deps.nix +++ b/stack-deps.nix @@ -25,7 +25,7 @@ pkgs.haskell.lib.buildStackProject { zlib lzma ]; - ghc = pkgs.haskell.compiler.ghc884; + ghc = pkgs.haskell.compiler.ghc8107; # This is required as the environment variables exported before running stack # do not make it into the shell in which stack runs test. diff --git a/stack.yaml b/stack.yaml index 12671354d5b..15a73f6b123 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,19 @@ -resolver: lts-16.14 +resolver: lts-18.18 + +# to bump blocks of custom dependencies to the latest version on hackage: +# +# /tmp/1.sh: +# #!/bin/bash +# cabal list "$1" | perl -ne '/^..'$1'$/ && { $x=1 }; /^$/ && { $x=0 }; if ($x) { /version: (.+)$/ && print "$1" }' +# +# /tmp/2.sh: +# #!/bin/bash +# perl -ne '/^- (\S+)-([01123456789\.]+)(\@\S+)?(.*)$/ && do { print "- $1-"; system("/tmp/1.sh $1"); print "$4\n" }' +# +# ... and then pipe the blocks of extra-deps through /tmp/2.sh. +# sorry for the hideous code, couldn't get it into one line (some +# limitation to perl that i don't want to have to understand). +# anyway it works! packages: - libs/api-bot @@ -70,7 +85,7 @@ extra-deps: # a version > 1.0.0 of wai-middleware-prometheus is available # (required: https://github.com/fimad/prometheus-haskell/pull/45) - git: https://github.com/wireapp/saml2-web-sso - commit: 60398f375987b74d6b855b5d225e45dc3a96ac06 # https://github.com/wireapp/saml2-web-sso/pull/75 (Sep 10, 2021) + commit: 4227e38be5c0810012dc472fc6931f6087fbce68 # master (Dec 07, 2021) - git: https://github.com/kim/hs-collectd commit: 885da222be2375f78c7be36127620ed772b677c9 @@ -137,43 +152,42 @@ extra-deps: # Dropped from upstream snapshot - template-0.2.0.10 -- HaskellNet-0.5.2 -- smtp-mail-0.2.0.0 -- stm-containers-1.1.0.4 # Latest: lts-15.16 +- HaskellNet-0.6 +- smtp-mail-0.3.0.0 +- stm-containers-1.2 - redis-resp-1.0.0 -- stm-hamt-1.2.0.4 # Latest: lts-15.16 -- primitive-unlifted-0.1.2.0 # Latest: lts-15.16 +- stm-hamt-1.2.0.6 +- primitive-unlifted-1.0.0.0 - prometheus-2.2.2 # Only in nightly so far # Not on stackage - currency-codes-3.0.0.1 - mime-0.4.0.2 - data-timeout-0.3.1 -- geoip2-0.4.0.1 -- stomp-queue-0.3.1 +- geoip2-0.4.1.0 +- stomp-queue-0.5.1 - text-icu-translit-0.1.0.7 - wai-middleware-gunzip-0.0.2 - cql-io-tinylog-0.1.0 - invertible-hxt-0.1 - base58-bytestring-0.1.0 -- stompl-0.5.0 -- pattern-trie-0.1.0 +- stompl-0.6.0 +- pattern-trie-0.1.1 - markov-chain-usage-model-0.0.0 - wai-predicates-1.0.0 - redis-io-1.1.0 -- polysemy-mocks-0.2.0.0 - warp-3.3.17 # Not latest as last one breaks wai-routing - wai-route-0.4.0 # Not updated on Stackage yet -- QuickCheck-2.14 -- splitmix-0.0.4 # needed for QuickCheck +- QuickCheck-2.14.2 +- splitmix-0.1.0.4 # needed for QuickCheck - servant-mock-0.8.7 -- servant-swagger-ui-0.3.4.3.36.1 +- servant-swagger-ui-0.3.5.3.52.5 - tls-1.5.5 -- cryptonite-0.28 +- cryptonite-0.29 # For changes from #128 and #135, not released to hackage yet - git: https://github.com/haskell-servant/servant-swagger @@ -189,18 +203,18 @@ extra-deps: - servant-client - servant-client-core -- HsOpenSSL-x509-system-0.1.0.3@sha256:f4958ee0eec555c5c213662eff6764bddefe5665e2afcfd32733ce3801a9b687,1774 # Latest: lts-14.27 -- cql-4.0.2@sha256:a0006a5ac13d6f86d5eff28c11be80928246309f217ea6d5f5c8a76a5d16b48b,3157 # Latest: lts-14.27 -- cql-io-1.1.1@sha256:897ef0811b227c8b1a269b29b9c1ebfb09c46f00d66834e2e8c6f19ea7f90f7d,4611 # Latest: lts-14.27 -- primitive-extras-0.8@sha256:fca0310150496867f5b9421fe1541ecda87fae17eae44885a29f9c52dd00c8ff,2963 # Latest: lts-15.16 -- text-format-0.3.2@sha256:2a3fc17cf87120fcfdbca62a0da59759755549285841cdc1483081c35fb3d115,1814 # Latest: lts-14.27 -- hex-0.2.0@sha256:197d2561d2e216c4ead035b4911dabc6e678ac6257cb71b64e324c822f6f9f5a,726 # Latest: lts-14.27 +- HsOpenSSL-x509-system-0.1.0.4 +- cql-4.0.3 +- cql-io-1.1.1 +- primitive-extras-0.10.1.1 +- text-format-0.3.2 +- hex-0.2.0 # Not in the upstream snapshot and not using latest version on hackage due to # breaking change -- quickcheck-state-machine-0.6.0 -- servant-multipart-0.11.5@sha256:1633f715b5b53d648a1da69839bdc5046599f4f7244944d4bbf852dba38d8f4b,2319 +- quickcheck-state-machine-0.7.1 +- servant-multipart-0.12.1 # Dependencies on upstream source @@ -208,10 +222,9 @@ extra-deps: - git: https://github.com/dpwright/HaskellNet-SSL commit: ca84ef29a93eaef7673fa58056cdd8dae1568d2d # master (Sep 14, 2020) -# Fix for connection preface race condition -# https://github.com/kazu-yamamoto/http2/pull/33 +# Fix for server sending too many empty data frames - git: https://github.com/wireapp/http2 - commit: 1ee1ce432d923839dab6782410e91dc17df2a880 # preface-race branch + commit: aa3501ad58e1abbd196781fac25a84f41ec2a787 # avoid-empty-data branch # Fix in PR: https://github.com/bos/snappy/pull/7 - git: https://github.com/wireapp/snappy @@ -224,9 +237,19 @@ extra-deps: - x509-store # Not on stackage yet -- polysemy-1.7.0.0 +- polysemy-1.7.1.0 - polysemy-plugin-0.4.2.0 -- polysemy-check-0.8.1.0 +- polysemy-check-0.9.0.0 + +# polysemy-check has this upper bound +- kind-generics-0.4.1.0 + +# ad-hoc additions (on 2021-10-10) +- proto-lens-0.7.1.0 +- proto-lens-protoc-0.7.1.0 +- proto-lens-runtime-0.7.0.1 +- proto-lens-setup-0.4.0.5 +- tracing-0.0.7.2 ############################################################ # Development tools @@ -235,5 +258,5 @@ extra-deps: - ormolu-0.1.4.1 - ghc-lib-parser-8.10.1.20200412@sha256:b0517bb150a02957d7180f131f5b94abd2a7f58a7d1532a012e71618282339c2,8751 # for ormolu -- headroom-0.2.1.0 -- implicit-hie-0.1.2.5 +- headroom-0.4.2.0 +- implicit-hie-0.1.2.6 diff --git a/stack.yaml.lock b/stack.yaml.lock index 6da7fa2060c..1e1c531b533 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -23,11 +23,11 @@ packages: git: https://github.com/wireapp/saml2-web-sso pantry-tree: size: 4887 - sha256: 29e0138ca6bc33500b87cd6c06bbd899fe4ddaadcfd5117b211e7769f9f80161 - commit: 60398f375987b74d6b855b5d225e45dc3a96ac06 + sha256: 9d6d175cc7bbdb57558f25557e4d0d698c4aecc250f6ca03296a3d94671bf657 + commit: 4227e38be5c0810012dc472fc6931f6087fbce68 original: git: https://github.com/wireapp/saml2-web-sso - commit: 60398f375987b74d6b855b5d225e45dc3a96ac06 + commit: 4227e38be5c0810012dc472fc6931f6087fbce68 - completed: name: collectd version: 0.0.0.2 @@ -294,26 +294,26 @@ packages: original: hackage: template-0.2.0.10 - completed: - hackage: HaskellNet-0.5.2@sha256:77fb8466fcbeb76f17366ffd7deb37550b6ea08a4d08bf721d0b597c2573336d,2069 + hackage: HaskellNet-0.6@sha256:1b514b95acf1c56f39bebc27150c909988d0a6ad28a2db1210316cffed57cad7,2344 pantry-tree: - size: 1499 - sha256: 20f0361675729e606fb37b8a1865f4bd49d952f2d0148693b62f68fadf5801d5 + size: 1689 + sha256: 22cc61632129d47407d3e28c5291f21b7cc9a5df69304395d75d5ae341f567d4 original: - hackage: HaskellNet-0.5.2 + hackage: HaskellNet-0.6 - completed: - hackage: smtp-mail-0.2.0.0@sha256:b91c81f6dbb41a9ceee8c443385118684ecec55006b77f7d3c0e49cffd2468cf,1211 + hackage: smtp-mail-0.3.0.0@sha256:2e6d9cb29d09a5a04d77a905eb1b570b94b5654e24d40630ea96aa374474c12f,1239 pantry-tree: - size: 449 - sha256: 413c4c7e7c7573c8bf906c136a282aebfe37ecc25492ff4b5ec8c69ff8d190fe + size: 450 + sha256: 4d319cb6c22b35ca043a83210cd09bfbf99eec3dca4945cd53ed5b7c96f7daca original: - hackage: smtp-mail-0.2.0.0 + hackage: smtp-mail-0.3.0.0 - completed: - hackage: stm-containers-1.1.0.4@sha256:f83a683357b6e3b1dda3e70d2077a37224ed534df1f74c4e11f3f6daa7945c5b,3248 + hackage: stm-containers-1.2@sha256:a887f2e7692b7cf20e0b081e2d66e21076e2bd4b57016ec59c484edfa2d29397,3244 pantry-tree: size: 761 - sha256: 059c5a2d657d392aca0a887648f57380d6321734dc8879c056a44d4414308ac6 + sha256: 20b1076bdb121347ccc512a67df697eed34815a8e35279b6b9a0951963b1eba2 original: - hackage: stm-containers-1.1.0.4 + hackage: stm-containers-1.2 - completed: hackage: redis-resp-1.0.0@sha256:c134ac23e79d57071fdc8559e2b2e72280ea11786a8ba4118c10ed506dc7d991,1615 pantry-tree: @@ -322,19 +322,19 @@ packages: original: hackage: redis-resp-1.0.0 - completed: - hackage: stm-hamt-1.2.0.4@sha256:7957497c022554b7599e790696d1a3e56359ad99e5da36a251894c626ca1f60a,3970 + hackage: stm-hamt-1.2.0.6@sha256:fba86ccb4b45c5706c19b0e1315ba63dcac3b5d71de945ec001ba921fae80061,3972 pantry-tree: size: 1009 - sha256: d9a8be48da86bd4a2ba9d52ea29b9a74f1b686d439ba1bbfba04ab1a002391da + sha256: 1920790535af832b76e7583c33ecf51f8b0b0c3615ef1db1c8ed9be19622c1db original: - hackage: stm-hamt-1.2.0.4 + hackage: stm-hamt-1.2.0.6 - completed: - hackage: primitive-unlifted-0.1.2.0@sha256:9c3df73af54ed19fb3f4874da19334863cc414b22e578e27b5f52beeac4a60dd,1360 + hackage: primitive-unlifted-1.0.0.0@sha256:16c3f149cf2fb3da64a43ffd0020d78a198454baded3a7f7f49a59397eea5770,2293 pantry-tree: - size: 420 - sha256: cc6ffb1b48aa3f514c107f5188d5d5beb4e61a4232a81be7025b54f9be66a837 + size: 1719 + sha256: 0ca7abed459d0240ee880bc52d957e35ca01017313ea94b5d026fc1842aba93c original: - hackage: primitive-unlifted-0.1.2.0 + hackage: primitive-unlifted-1.0.0.0 - completed: hackage: prometheus-2.2.2@sha256:d794f5fe975be2f3ca7d7af71a7aeeb006615ad7d98835fa42caba9457a51936,4288 pantry-tree: @@ -364,19 +364,19 @@ packages: original: hackage: data-timeout-0.3.1 - completed: - hackage: geoip2-0.4.0.1@sha256:cee67aa8da78686c5e5e37f0e92502218ed7c6b2200a121dc4fb4060c703fa37,1316 + hackage: geoip2-0.4.1.0@sha256:f8b69ea86198817141edab06cd10b2dcf23a906ea9f0ba2ce52045c7fea2e5c5,1316 pantry-tree: size: 433 - sha256: 364b9ff8d4a85b1265b70f83e7ab81eb1f94c752aa32416de19e739ca6bb8a05 + sha256: 13b2f1557f8915c71902f576ccc1b42491f4fc38baef080a5b753df5e81b4766 original: - hackage: geoip2-0.4.0.1 + hackage: geoip2-0.4.1.0 - completed: - hackage: stomp-queue-0.3.1@sha256:0f4ced5b67107d4dc06498985058236505470ca742dbfe5c6af0534d67ace9b5,2186 + hackage: stomp-queue-0.5.1@sha256:47c47d21dc756c028c8253b51cf647d4fa0282777dda2265edde2f65284f9d14,2321 pantry-tree: - size: 686 - sha256: 29ffec14af759c9244c559dd54b7fcd13d3b054b0aea21d753d80fb3064720a5 + size: 608 + sha256: 2996c49e280fd1bf4111ffb8788d5729c48d663648e1dd6734c83ee20681c531 original: - hackage: stomp-queue-0.3.1 + hackage: stomp-queue-0.5.1 - completed: hackage: text-icu-translit-0.1.0.7@sha256:c8eaaee3331417a250365474067b7cb0f196ebabd04b3fe834c4e2b5a212b5ce,1723 pantry-tree: @@ -413,19 +413,19 @@ packages: original: hackage: base58-bytestring-0.1.0 - completed: - hackage: stompl-0.5.0@sha256:58a43198bc24a2332aecec65bc5de3ccb4fe93e470e217b892cd87545240e4ce,1895 + hackage: stompl-0.6.0@sha256:fd7b39a754926102d3f9917213f646d5cd765ebcf23e70daf9eb99e44e441cef,1896 pantry-tree: size: 357 - sha256: f4d7a11d9ee71ea0c5504aea227105a7528d41a26972d35f813bb82ab7dc0321 + sha256: 0bc21f1930468f6b75cab74ab6d4ff95bc1eedcda5c33c336d2599452eb45ace original: - hackage: stompl-0.5.0 + hackage: stompl-0.6.0 - completed: - hackage: pattern-trie-0.1.0@sha256:2ef9ad9a630f07e8e8c9a6689e47d7600b5ca3ebc7fe060d31bb687b1f122eed,2346 + hackage: pattern-trie-0.1.1@sha256:265ecc98c4345a89f2711b9b00e4f52ed7c143ea20f10b76ca6ddc3066658143,2236 pantry-tree: - size: 632 - sha256: 9cf57bcb24b5da4d9ab314750810dce6c28ae082348e0afd60bdb12afdeeca6f + size: 751 + sha256: dc1264e417abc23b25fc0b3b486880c0510a805cc0a19d2208f13d0ec8a0102d original: - hackage: pattern-trie-0.1.0 + hackage: pattern-trie-0.1.1 - completed: hackage: markov-chain-usage-model-0.0.0@sha256:1afa95faeb9213c4d960a669190078b41b89169462b8edd910472980671ba8c0,2112 pantry-tree: @@ -447,13 +447,6 @@ packages: sha256: db61f70aa7387090c26ccca0545ffdeea0adfcf93b76d5eaf6a954c0e5a34064 original: hackage: redis-io-1.1.0 -- completed: - hackage: polysemy-mocks-0.2.0.0@sha256:ed7b4aa8ee29995d0b840ac0c131a141636ca46493b82706b7e5ec5e33b9ffa7,1441 - pantry-tree: - size: 695 - sha256: 8218e3dde278ca1f01d19009fad40f603e1b17993a519d15fe6319e3a827cc01 - original: - hackage: polysemy-mocks-0.2.0.0 - completed: hackage: warp-3.3.17@sha256:3a3ea203141d00d2244b511ee99174b8ed58fc862552755d470a25a44ce5275b,10910 pantry-tree: @@ -469,19 +462,19 @@ packages: original: hackage: wai-route-0.4.0 - completed: - hackage: QuickCheck-2.14@sha256:3f536a4b86bef7ec39025f04ef8d76c5ac5a78ba0b42e660b25d0a8f9c811045,7004 + hackage: QuickCheck-2.14.2@sha256:4ce29211223d5e6620ebceba34a3ca9ccf1c10c0cf387d48aea45599222ee5aa,7736 pantry-tree: - size: 2203 - sha256: 7067593c50ff2e5e83c637ac73009f4bd8f43c29ff256e976bbb14674033abe9 + size: 2315 + sha256: 2fe423d0ed7cd64f0f165d708779f48814e66c4f181c568468134af55d86a5f8 original: - hackage: QuickCheck-2.14 + hackage: QuickCheck-2.14.2 - completed: - hackage: splitmix-0.0.4@sha256:fb9bb8b54a2e76c8a021fe5c4c3798047e1f60e168379a1f80693047fe00ad0e,4813 + hackage: splitmix-0.1.0.4@sha256:714a55fd28d3e2533bd5b49e74f604ef8e5d7b06f249c8816f6c54aed431dcf1,6483 pantry-tree: - size: 872 - sha256: e58892088b95190bfb59a7c0803f7ef65338e57fc9b938d7c166563605003902 + size: 1519 + sha256: 79f4645c11b7a3861db0b596297f72804f509444d639a8fd7c0162b1ed80c578 original: - hackage: splitmix-0.0.4 + hackage: splitmix-0.1.0.4 - completed: hackage: servant-mock-0.8.7@sha256:64cb3e52bbd51ab6cb25e3f412a99ea712c6c26f1efd117f01a8d1664df49c67,2306 pantry-tree: @@ -490,12 +483,12 @@ packages: original: hackage: servant-mock-0.8.7 - completed: - hackage: servant-swagger-ui-0.3.4.3.36.1@sha256:b696e28ed2c9090ae3306535a80f4a54a876def2d33db0c795c911826c107cda,1746 + hackage: servant-swagger-ui-0.3.5.3.52.5@sha256:4734c536b8b0c48993c337e880a5bd65ed521271937ce9da5feac360dea661ba,1746 pantry-tree: size: 878 - sha256: 137680a15ee0147cd19634d8296d90c2150ca4fd62ed3d56f7e07ccd8823810c + sha256: 822d19afe0e75bbc8bd2b685dc2cb4fd7d5972ed1e7b61546ce3e61cf77b8808 original: - hackage: servant-swagger-ui-0.3.4.3.36.1 + hackage: servant-swagger-ui-0.3.5.3.52.5 - completed: hackage: tls-1.5.5@sha256:f6681d6624071211edd509a8f56e0c96b4f003bb349b7dc706d4333775a373c5,6996 pantry-tree: @@ -504,12 +497,12 @@ packages: original: hackage: tls-1.5.5 - completed: - hackage: cryptonite-0.28@sha256:edf00c7b00b9a1c07a178c0fe446c6ebe462637d498590757c8eac2075bb0b43,18215 + hackage: cryptonite-0.29@sha256:147724f6a8e4394fcbd51bf52aba7a8b92d3fc8f42055cd6ca9486655e2ab614,18312 pantry-tree: - size: 23132 - sha256: 3737ee32d6629b4b915c01911fdb9dc0e255b96233799479c29420d986634726 + size: 23323 + sha256: 087de3ed0552cfb1f84d03629b0f98c77aadc076b85bb5cb787f77c5e5dac136 original: - hackage: cryptonite-0.28 + hackage: cryptonite-0.29 - completed: name: servant-swagger version: 1.1.11 @@ -574,61 +567,61 @@ packages: git: https://github.com/wireapp/servant.git commit: a4e15fe75f294816d9ead19ed8a48cae8e0b76e7 - completed: - hackage: HsOpenSSL-x509-system-0.1.0.3@sha256:f4958ee0eec555c5c213662eff6764bddefe5665e2afcfd32733ce3801a9b687,1774 + hackage: HsOpenSSL-x509-system-0.1.0.4@sha256:86be72558de4cee8f4e32f9cb8b63610d7624219910cfc205a23326078658676,1777 pantry-tree: - size: 503 - sha256: 2a097abbccc0382ebb565c8ab9932628f33471607c2174303c3c930d7685bd18 + size: 508 + sha256: 98f6b47d27550f29a90a8f5660cf09f72f139d9940fe00cd6b0cffbd5c210a15 original: - hackage: HsOpenSSL-x509-system-0.1.0.3@sha256:f4958ee0eec555c5c213662eff6764bddefe5665e2afcfd32733ce3801a9b687,1774 + hackage: HsOpenSSL-x509-system-0.1.0.4 - completed: - hackage: cql-4.0.2@sha256:a0006a5ac13d6f86d5eff28c11be80928246309f217ea6d5f5c8a76a5d16b48b,3157 + hackage: cql-4.0.3@sha256:10d6b09715699efec5c97f22887aaf65c8fa0b0916c926ef79bc21f4db460175,3157 pantry-tree: size: 1281 - sha256: 8cc6e57c6a794188ae79415cee38bd29e1c07f7426cfa533c9a57523c0a2ed23 + sha256: 94433b7c7c46bea532fdc64c6988643a48e39b643948003b27e5bde1bdad3b24 original: - hackage: cql-4.0.2@sha256:a0006a5ac13d6f86d5eff28c11be80928246309f217ea6d5f5c8a76a5d16b48b,3157 + hackage: cql-4.0.3 - completed: hackage: cql-io-1.1.1@sha256:897ef0811b227c8b1a269b29b9c1ebfb09c46f00d66834e2e8c6f19ea7f90f7d,4611 pantry-tree: size: 2067 sha256: 7ced76ae95b51fa1669b4fcaeec3825b5cb8cf1f4e37c53d0bddf6234742eba8 original: - hackage: cql-io-1.1.1@sha256:897ef0811b227c8b1a269b29b9c1ebfb09c46f00d66834e2e8c6f19ea7f90f7d,4611 + hackage: cql-io-1.1.1 - completed: - hackage: primitive-extras-0.8@sha256:fca0310150496867f5b9421fe1541ecda87fae17eae44885a29f9c52dd00c8ff,2963 + hackage: primitive-extras-0.10.1.1@sha256:47c4d211166bc31ebdb053f610e4b5387c01d00bde81840e59438469cef6c94e,2955 pantry-tree: - size: 1105 - sha256: e7c1d26202b80d1fca2ef780ec7fe76ede1275f4d9a996c6d44c08d8de1c45db + size: 1096 + sha256: 55ee00adb4e2e6beedfb997b071b60014b28ce0b25fb946b1f4abfae9a5e01d1 original: - hackage: primitive-extras-0.8@sha256:fca0310150496867f5b9421fe1541ecda87fae17eae44885a29f9c52dd00c8ff,2963 + hackage: primitive-extras-0.10.1.1 - completed: hackage: text-format-0.3.2@sha256:2a3fc17cf87120fcfdbca62a0da59759755549285841cdc1483081c35fb3d115,1814 pantry-tree: size: 1029 sha256: 2db26ddb77184186e0d5b2b020bdfbeb044c168024767b1fa3691682ca618896 original: - hackage: text-format-0.3.2@sha256:2a3fc17cf87120fcfdbca62a0da59759755549285841cdc1483081c35fb3d115,1814 + hackage: text-format-0.3.2 - completed: hackage: hex-0.2.0@sha256:197d2561d2e216c4ead035b4911dabc6e678ac6257cb71b64e324c822f6f9f5a,726 pantry-tree: size: 197 sha256: 1e5aba0165fb8ffa93d1516a87026a59c245750ca5f2ed42bd53b8328620f98e original: - hackage: hex-0.2.0@sha256:197d2561d2e216c4ead035b4911dabc6e678ac6257cb71b64e324c822f6f9f5a,726 + hackage: hex-0.2.0 - completed: - hackage: quickcheck-state-machine-0.6.0@sha256:3e4f8df0f6b5d415e3c8840dc75034a63e37f56f5f8cfa1035ded16345235ac4,3825 + hackage: quickcheck-state-machine-0.7.1@sha256:575f16ece44b20f204730b7b5d77a1ed91b33f4a961a4e70932fc8d602082b10,6153 pantry-tree: - size: 1926 - sha256: ae502fd7f4c6680294149bed482d1896904c1259d5ae614093da01e0731ec92e + size: 3022 + sha256: edb32e2c7ac3be15e0d110b762990192d993326779f440984e56de0be5e0f714 original: - hackage: quickcheck-state-machine-0.6.0 + hackage: quickcheck-state-machine-0.7.1 - completed: - hackage: servant-multipart-0.11.5@sha256:1633f715b5b53d648a1da69839bdc5046599f4f7244944d4bbf852dba38d8f4b,2319 + hackage: servant-multipart-0.12.1@sha256:4b6a8c3f73d645e212f2a7a476f30a2ab7ed191945a3ff62154ab99d76dea7f0,1951 pantry-tree: - size: 333 - sha256: b3e1fd2ad2e654475be000c2f0ac6f717b5499436fa73eec50ceccddf352dcec + size: 332 + sha256: 80f6033a74da5d7c6aded81c428d740a0bf6bfd49e13ce8cde68158abd5ff49f original: - hackage: servant-multipart-0.11.5@sha256:1633f715b5b53d648a1da69839bdc5046599f4f7244944d4bbf852dba38d8f4b,2319 + hackage: servant-multipart-0.12.1 - completed: name: HaskellNet-SSL version: 0.3.4.2 @@ -646,11 +639,11 @@ packages: git: https://github.com/wireapp/http2 pantry-tree: size: 52771 - sha256: dc6d3868a049d2ed38ef16ca6dd6aeb6b8e8a1e730c664ecdd243ffdb45ee750 - commit: 1ee1ce432d923839dab6782410e91dc17df2a880 + sha256: 71040c20c8e6a766b6b309c03dbc970062b15e450a63e05f8d095a87cdb5082f + commit: aa3501ad58e1abbd196781fac25a84f41ec2a787 original: git: https://github.com/wireapp/http2 - commit: 1ee1ce432d923839dab6782410e91dc17df2a880 + commit: aa3501ad58e1abbd196781fac25a84f41ec2a787 - completed: name: snappy version: 0.2.0.2 @@ -676,12 +669,12 @@ packages: git: https://github.com/vincenthz/hs-certificate commit: a899bda3d7666d25143be7be8f3105fc076703d9 - completed: - hackage: polysemy-1.7.0.0@sha256:c972f33191113e2fe6809ea1cda24a6cabfeed2f115b3be0137dee7c65d08293,5977 + hackage: polysemy-1.7.1.0@sha256:3ead7a332abd70b202920ed3bf2e36866de163f821e643adfdcc9d39867b8033,5977 pantry-tree: size: 4577 - sha256: 78c733f5dde13340e880bbb883dc64af948f6449da3a4025811cdc79c204dfde + sha256: 22f540602a4d5565d4d90bc6084eb4e578f1ed934917a4efd6b01f5b90f49fea original: - hackage: polysemy-1.7.0.0 + hackage: polysemy-1.7.1.0 - completed: hackage: polysemy-plugin-0.4.2.0@sha256:1dbcb892bb866926994dadafeb93e76ae4a6625dc3ae9ca0f4f419ee85cb2f7b,3154 pantry-tree: @@ -690,12 +683,54 @@ packages: original: hackage: polysemy-plugin-0.4.2.0 - completed: - hackage: polysemy-check-0.8.1.0@sha256:5cce3ae162d2f8d8f629397daa28ec5e425f72d357afeb4fe994e102425f2383,2648 + hackage: polysemy-check-0.9.0.0@sha256:f28c23c5cbae246a049d11e06c51ee85212a2b13a069e93598cf8cdd13ad5a18,2665 + pantry-tree: + size: 1086 + sha256: a473605eda27f36717e3f0cbd66651563789107daa9b8d9db59b80cc07ff60d1 + original: + hackage: polysemy-check-0.9.0.0 +- completed: + hackage: kind-generics-0.4.1.0@sha256:15e50867349de627c401af29f56b204dfb2ad2b12e83417132ffca3d5cd02462,1061 + pantry-tree: + size: 390 + sha256: 497a73c5243cd787c06b7b66258fccf6299e6a853fa44f050f72f0bf1967715f + original: + hackage: kind-generics-0.4.1.0 +- completed: + hackage: proto-lens-0.7.1.0@sha256:b151890929e71db5b8c2ad86cd758bcdf1dfcf25f34eb6c9ce19e3d7cd4eae39,2959 + pantry-tree: + size: 1857 + sha256: 2f1199d04d0588805e06faa0bf9a75898584d76243d4f945acbcc0e93913732e + original: + hackage: proto-lens-0.7.1.0 +- completed: + hackage: proto-lens-protoc-0.7.1.0@sha256:b0b92498af74fc4bb770d51f84405d591e73c085a0c1d9952dd3e14ce07b538f,2220 + pantry-tree: + size: 1219 + sha256: 1aaa82cb2823b33c9ea96608cc7ec245e54a0d14de8f18736be03220d8dbe683 + original: + hackage: proto-lens-protoc-0.7.1.0 +- completed: + hackage: proto-lens-runtime-0.7.0.1@sha256:703f327422b2e204f8ea13c5e178edd8ab42ccd01c7a5a89fcb1b37ab474c68a,3038 + pantry-tree: + size: 168 + sha256: 145cb9a15b73d45b07cb3f9f0716256b2ed9e27ac296268ce100a4f0e477e110 + original: + hackage: proto-lens-runtime-0.7.0.1 +- completed: + hackage: proto-lens-setup-0.4.0.5@sha256:ae4514963a6c20ad059bba427cd14b94c6007f614d797ebecae3c37f8bf0fa96,3108 + pantry-tree: + size: 235 + sha256: 14982fbc9ee0c6f9f9a59c2639b647613eb9c2cfa1d5b1b323077a15ae285ccf + original: + hackage: proto-lens-setup-0.4.0.5 +- completed: + hackage: tracing-0.0.7.2@sha256:25a531be1ffe4054085f2855fd5132be54aa2e6b31a730b26e2cb01bd96b22ea,1438 pantry-tree: - size: 1027 - sha256: bc880fb3405307ed251c02358d604979d8014040b78c2ffe6319076431f93509 + size: 672 + sha256: b3059324bf8fea08874dd4f5518105f3edd6e469104242e652698f488a5227d5 original: - hackage: polysemy-check-0.8.1.0 + hackage: tracing-0.0.7.2 - completed: hackage: ormolu-0.1.4.1@sha256:ed404eac6e4eb64da1ca5fb749e0f99907431a9633e6ba34e44d260e7d7728ba,6499 pantry-tree: @@ -711,22 +746,22 @@ packages: original: hackage: ghc-lib-parser-8.10.1.20200412@sha256:b0517bb150a02957d7180f131f5b94abd2a7f58a7d1532a012e71618282339c2,8751 - completed: - hackage: headroom-0.2.1.0@sha256:084b72a071454516bff30c3f50e4f671fb12ee062602693ad5ffcafdea5fab99,8140 + hackage: headroom-0.4.2.0@sha256:ebaf701628054472de745fa57b33ddf1021b99a8e4de5f5b96f21fb296b27652,10873 pantry-tree: - size: 9195 - sha256: 11d2ac77cee54cc1f222e574e4126189fe5b60a47a1aedbafc2ab0de709b29c6 + size: 15450 + sha256: cd772daa4d3ea56ca28764afd60186363bd92cbf69c0ba3c0a9c064507e79ecc original: - hackage: headroom-0.2.1.0 + hackage: headroom-0.4.2.0 - completed: - hackage: implicit-hie-0.1.2.5@sha256:517a98ef72f92f0a1617495222774fed3a751a64b0c06fbfc7b858d7aa5de279,2998 + hackage: implicit-hie-0.1.2.6@sha256:f50a908979a574a881f753c0f9a5224f023f438b30fdefc5b7fa01803b07a280,2998 pantry-tree: size: 844 - sha256: 9bf2645187637b647dfaebf37a45a57e221b3527592ce3b1cfd9faf90339dac3 + sha256: 87e1a41e292526d86b55668bca628cf917056d82001438dc6975e4f35cf5210d original: - hackage: implicit-hie-0.1.2.5 + hackage: implicit-hie-0.1.2.6 snapshots: - completed: - size: 532382 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/14.yaml - sha256: 1ef27e36f38824abafc43224ca612211b3828fa9ffd31ba0fc2867ae2e19ba90 - original: lts-16.14 + size: 586296 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/18.yaml + sha256: 63539429076b7ebbab6daa7656cfb079393bf644971156dc349d7c0453694ac2 + original: lts-18.18 diff --git a/tools/api-simulations/api-simulations.cabal b/tools/api-simulations/api-simulations.cabal index d8e720f3c1d..59a2b2dfa20 100644 --- a/tools/api-simulations/api-simulations.cabal +++ b/tools/api-simulations/api-simulations.cabal @@ -1,10 +1,10 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack -- --- hash: 0bce6d3ef71a3fc2991a10dad9cb794a473111426a2f7d95762ef22bbc353058 +-- hash: cc1ee9817c17b416b041da1872f67634723249762332426dc63b0b1ab43309e8 name: api-simulations version: 0.4.2 @@ -25,7 +25,46 @@ library Paths_api_simulations hs-source-dirs: lib/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 + 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 build-depends: api-bot @@ -49,7 +88,46 @@ executable api-loadtest Paths_api_simulations hs-source-dirs: loadtest/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 + 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 -with-rtsopts=-T build-depends: api-bot @@ -81,7 +159,46 @@ executable api-smoketest Paths_api_simulations hs-source-dirs: smoketest/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 + 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 -with-rtsopts=-T build-depends: api-bot diff --git a/tools/api-simulations/lib/src/Network/Wire/Simulations.hs b/tools/api-simulations/lib/src/Network/Wire/Simulations.hs index 7a34d8280b9..f933ab94149 100644 --- a/tools/api-simulations/lib/src/Network/Wire/Simulations.hs +++ b/tools/api-simulations/lib/src/Network/Wire/Simulations.hs @@ -176,7 +176,7 @@ instance Serialize AssetInfo where AssetInfo k t <$> get mkAssetMsg :: Asset -> SymmetricKeys -> BotMessage -mkAssetMsg a = BotAssetMessage . AssetInfo (a ^. assetKey) (a ^. assetToken) +mkAssetMsg a = BotAssetMessage . AssetInfo (qUnqualified (a ^. assetKey)) (a ^. assetToken) mkTextMsg :: Text -> BotMessage mkTextMsg = BotTextMessage diff --git a/tools/bonanza/bonanza.cabal b/tools/bonanza/bonanza.cabal index d07743e8bc7..6b3221f53e6 100644 --- a/tools/bonanza/bonanza.cabal +++ b/tools/bonanza/bonanza.cabal @@ -1,10 +1,10 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack -- --- hash: d11a5dfdfd8b16afefbb6870c4bc71c097f7f86016ffa65d6fbdc74ece7cb504 +-- hash: e99811a9a954d2a94b4ac9e909d56d22ede51a464f80aefefd5b4e1b8b93b231 name: bonanza version: 3.6.0 @@ -44,7 +44,46 @@ library Paths_bonanza 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 + 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 -funbox-small-strict-fields -fno-warn-unused-do-bind build-depends: aeson >=1.0 @@ -83,7 +122,46 @@ executable bonanza main-is: main/Main.hs other-modules: Paths_bonanza - 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 + 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 -funbox-small-strict-fields -fno-warn-unused-do-bind -threaded -rtsopts -with-rtsopts=-T -with-rtsopts=-N build-depends: base ==4.* @@ -99,7 +177,46 @@ executable kibana-raw main-is: main/KibanaRaw.hs other-modules: Paths_bonanza - 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 + 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 -funbox-small-strict-fields -rtsopts build-depends: aeson >=1.0 @@ -119,7 +236,46 @@ executable kibanana main-is: main/Kibanana.hs other-modules: Paths_bonanza - 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 + 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 -funbox-small-strict-fields -fno-warn-unused-do-bind -threaded -rtsopts -with-rtsopts=-T -with-rtsopts=-N build-depends: async @@ -148,7 +304,46 @@ test-suite bonanza-tests Paths_bonanza hs-source-dirs: test/unit - 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 + 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-depends: QuickCheck diff --git a/tools/convert-to-cabal/shell.nix b/tools/convert-to-cabal/shell.nix index 87266663a03..c708398b849 100644 --- a/tools/convert-to-cabal/shell.nix +++ b/tools/convert-to-cabal/shell.nix @@ -13,7 +13,7 @@ let "stack2cabal" = super.callCabal2nix "stack2cabal" source { }; }; - haskellPackages = pkgs.haskell.packages.ghc884.override { + haskellPackages = pkgs.haskell.packages.ghc8107.override { overrides = overlay; }; diff --git a/tools/db/auto-whitelist/auto-whitelist.cabal b/tools/db/auto-whitelist/auto-whitelist.cabal index aca9fef9eab..695b541cf3e 100644 --- a/tools/db/auto-whitelist/auto-whitelist.cabal +++ b/tools/db/auto-whitelist/auto-whitelist.cabal @@ -1,10 +1,10 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack -- --- hash: a44f3136d459b6192979fc5f06b79873931418960cec00388852fba77d4d0f47 +-- hash: aecd5a2bbe1504d3601577aed1719da584856f3d5f53327650f3c80331619269 name: auto-whitelist version: 1.0.0 @@ -24,7 +24,46 @@ executable auto-whitelist Paths_auto_whitelist 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 + 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 -funbox-strict-fields -threaded -with-rtsopts=-N -with-rtsopts=-T -rtsopts build-depends: base diff --git a/tools/db/billing-team-member-backfill/billing-team-member-backfill.cabal b/tools/db/billing-team-member-backfill/billing-team-member-backfill.cabal index 18b61ba03fa..cec990a25c0 100644 --- a/tools/db/billing-team-member-backfill/billing-team-member-backfill.cabal +++ b/tools/db/billing-team-member-backfill/billing-team-member-backfill.cabal @@ -1,10 +1,10 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack -- --- hash: f4b64220a67932d0f5b25d2a5da2c18ee914d31f0b1d9c14b1b43c11ebb692c8 +-- hash: ada20e0991745d0c8999668355177fca0aef12891245e599d89f28228f0961d4 name: billing-team-member-backfill version: 1.0.0 @@ -24,7 +24,46 @@ executable billing-team-member-backfill Paths_billing_team_member_backfill 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 + 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 -funbox-strict-fields -threaded -with-rtsopts=-N -with-rtsopts=-T -rtsopts build-depends: base diff --git a/tools/db/find-undead/find-undead.cabal b/tools/db/find-undead/find-undead.cabal index 73b6442e470..3882556cc48 100644 --- a/tools/db/find-undead/find-undead.cabal +++ b/tools/db/find-undead/find-undead.cabal @@ -1,10 +1,10 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack -- --- hash: 803cec639d33ee7123c779f5eedc7c78efdda2ae46ab9ecfc58e088e168b8ebc +-- hash: 30202a4d538697375b0b0dc3d4789ad278c7b41e40169f1b41c538410d03d3da name: find-undead version: 1.0.0 @@ -24,7 +24,46 @@ executable find-undead Paths_find_undead 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 + 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 -funbox-strict-fields -threaded -with-rtsopts=-N -with-rtsopts=-T -rtsopts build-depends: aeson diff --git a/tools/db/migrate-sso-feature-flag/migrate-sso-feature-flag.cabal b/tools/db/migrate-sso-feature-flag/migrate-sso-feature-flag.cabal index dc80fff1e7f..df88ba36831 100644 --- a/tools/db/migrate-sso-feature-flag/migrate-sso-feature-flag.cabal +++ b/tools/db/migrate-sso-feature-flag/migrate-sso-feature-flag.cabal @@ -1,10 +1,10 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack -- --- hash: 88d2d668ec329351cd3ab3108eab05b3db51898dedd0f6f9b85be620f4f1e4d5 +-- hash: 6a64c18d59c109cea4e58b9161d589c395fa1b34ba2705060aebc4926ee1f618 name: migrate-sso-feature-flag version: 1.0.0 @@ -24,7 +24,46 @@ executable migrate-sso-feature-flag Paths_migrate_sso_feature_flag 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 + 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 -funbox-strict-fields -threaded -with-rtsopts=-N -with-rtsopts=-T -rtsopts build-depends: base diff --git a/tools/db/move-team/move-team.cabal b/tools/db/move-team/move-team.cabal index 8b3fb1e66c5..70b49422b5f 100644 --- a/tools/db/move-team/move-team.cabal +++ b/tools/db/move-team/move-team.cabal @@ -1,10 +1,10 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack -- --- hash: 6f97fa57af68acb9606816e6048ebe009ec9c0f01a971d39ae9dbc5e2061346d +-- hash: 2168cecbb403740519009eb790938bbfec816c047f81bc1ec44d6157ff798516 name: move-team version: 1.0.0 @@ -28,7 +28,46 @@ library Paths_move_team 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 + 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 -funbox-strict-fields -threaded -with-rtsopts=-N -with-rtsopts=-T -rtsopts build-depends: aeson @@ -63,7 +102,46 @@ executable move-team Paths_move_team hs-source-dirs: move-team - 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 + 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 -funbox-strict-fields -threaded -with-rtsopts=-N -with-rtsopts=-T -rtsopts build-depends: aeson @@ -99,7 +177,46 @@ executable move-team-generate Paths_move_team hs-source-dirs: move-team-generate - 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 + 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 -funbox-strict-fields -threaded -with-rtsopts=-N -with-rtsopts=-T -rtsopts build-depends: aeson diff --git a/tools/db/move-team/src/Schema.hs b/tools/db/move-team/src/Schema.hs index 1958fb705b1..6706e6ebee0 100644 --- a/tools/db/move-team/src/Schema.hs +++ b/tools/db/move-team/src/Schema.hs @@ -40,7 +40,7 @@ import Wire.API.User.Password (PasswordResetKey) type RowBrigClients = (Maybe UUID, Maybe Text, Maybe Int32, Maybe Text, Maybe IP, Maybe Text, Maybe Double, Maybe Double, Maybe Text, Maybe UTCTime, Maybe Int32) -selectBrigClients :: PrepQuery R (Identity ([UserId])) RowBrigClients +selectBrigClients :: PrepQuery R (Identity [UserId]) RowBrigClients selectBrigClients = "SELECT user, client, class, cookie, ip, label, lat, lon, model, tstamp, type FROM clients WHERE user in ?" readBrigClients :: Env -> [UserId] -> ConduitM () [RowBrigClients] IO () @@ -57,7 +57,7 @@ readBrigClientsAll Env {..} = paginateC selectBrigClientsAll (paramsP LocalQuorum () envPageSize) x5 exportBrigClientsFull :: Env -> FilePath -> IO () -exportBrigClientsFull env@Env {..} path = do +exportBrigClientsFull env path = do putStrLn $ "Exporting " <> "brig.clients" <> " to " <> path withBinaryFile path WriteMode $ \handle -> runConduit $ @@ -74,7 +74,7 @@ importBrigClients Env {..} path = do if exists then do putStrLn $ "Importing " <> path <> " to " <> "brig.clients" - withBinaryFile path ReadMode $ \handle -> do + withBinaryFile path ReadMode $ \handle -> runConduit $ sourceJsonLines handle .| transPipe (runClient envBrig) (sinkTableRows insertBrigClients) @@ -86,7 +86,7 @@ importBrigClients Env {..} path = do type RowBrigConnection = (Maybe UUID, Maybe UUID, Maybe UUID, Maybe UTCTime, Maybe Text, Maybe Int32) -selectBrigConnection :: PrepQuery R (Identity ([UserId])) RowBrigConnection +selectBrigConnection :: PrepQuery R (Identity [UserId]) RowBrigConnection selectBrigConnection = "SELECT left, right, conv, last_update, message, status FROM connection WHERE left in ?" readBrigConnection :: Env -> [UserId] -> ConduitM () [RowBrigConnection] IO () @@ -103,7 +103,7 @@ readBrigConnectionAll Env {..} = paginateC selectBrigConnectionAll (paramsP LocalQuorum () envPageSize) x5 exportBrigConnectionFull :: Env -> FilePath -> IO () -exportBrigConnectionFull env@Env {..} path = do +exportBrigConnectionFull env path = do putStrLn $ "Exporting " <> "brig.connection" <> " to " <> path withBinaryFile path WriteMode $ \handle -> runConduit $ @@ -120,7 +120,7 @@ importBrigConnection Env {..} path = do if exists then do putStrLn $ "Importing " <> path <> " to " <> "brig.connection" - withBinaryFile path ReadMode $ \handle -> do + withBinaryFile path ReadMode $ \handle -> runConduit $ sourceJsonLines handle .| transPipe (runClient envBrig) (sinkTableRows insertBrigConnection) @@ -132,7 +132,7 @@ importBrigConnection Env {..} path = do type RowBrigLoginCodes = (Maybe UUID, Maybe Text, Maybe Int32, Maybe UTCTime) -selectBrigLoginCodes :: PrepQuery R (Identity ([UserId])) RowBrigLoginCodes +selectBrigLoginCodes :: PrepQuery R (Identity [UserId]) RowBrigLoginCodes selectBrigLoginCodes = "SELECT user, code, retries, timeout FROM login_codes WHERE user in ?" readBrigLoginCodes :: Env -> [UserId] -> ConduitM () [RowBrigLoginCodes] IO () @@ -149,7 +149,7 @@ readBrigLoginCodesAll Env {..} = paginateC selectBrigLoginCodesAll (paramsP LocalQuorum () envPageSize) x5 exportBrigLoginCodesFull :: Env -> FilePath -> IO () -exportBrigLoginCodesFull env@Env {..} path = do +exportBrigLoginCodesFull env path = do putStrLn $ "Exporting " <> "brig.login_codes" <> " to " <> path withBinaryFile path WriteMode $ \handle -> runConduit $ @@ -166,7 +166,7 @@ importBrigLoginCodes Env {..} path = do if exists then do putStrLn $ "Importing " <> path <> " to " <> "brig.login_codes" - withBinaryFile path ReadMode $ \handle -> do + withBinaryFile path ReadMode $ \handle -> runConduit $ sourceJsonLines handle .| transPipe (runClient envBrig) (sinkTableRows insertBrigLoginCodes) @@ -178,7 +178,7 @@ importBrigLoginCodes Env {..} path = do type RowBrigPasswordReset = (Maybe Ascii, Maybe Ascii, Maybe Int32, Maybe UTCTime, Maybe UUID) -selectBrigPasswordReset :: PrepQuery R (Identity ([PasswordResetKey])) RowBrigPasswordReset +selectBrigPasswordReset :: PrepQuery R (Identity [PasswordResetKey]) RowBrigPasswordReset selectBrigPasswordReset = "SELECT key, code, retries, timeout, user FROM password_reset WHERE key in ?" readBrigPasswordReset :: Env -> [PasswordResetKey] -> ConduitM () [RowBrigPasswordReset] IO () @@ -195,7 +195,7 @@ readBrigPasswordResetAll Env {..} = paginateC selectBrigPasswordResetAll (paramsP LocalQuorum () envPageSize) x5 exportBrigPasswordResetFull :: Env -> FilePath -> IO () -exportBrigPasswordResetFull env@Env {..} path = do +exportBrigPasswordResetFull env path = do putStrLn $ "Exporting " <> "brig.password_reset" <> " to " <> path withBinaryFile path WriteMode $ \handle -> runConduit $ @@ -212,7 +212,7 @@ importBrigPasswordReset Env {..} path = do if exists then do putStrLn $ "Importing " <> path <> " to " <> "brig.password_reset" - withBinaryFile path ReadMode $ \handle -> do + withBinaryFile path ReadMode $ \handle -> runConduit $ sourceJsonLines handle .| transPipe (runClient envBrig) (sinkTableRows insertBrigPasswordReset) @@ -224,7 +224,7 @@ importBrigPasswordReset Env {..} path = do type RowBrigPrekeys = (Maybe UUID, Maybe Text, Maybe Int32, Maybe Text) -selectBrigPrekeys :: PrepQuery R (Identity ([UserId])) RowBrigPrekeys +selectBrigPrekeys :: PrepQuery R (Identity [UserId]) RowBrigPrekeys selectBrigPrekeys = "SELECT user, client, key, data FROM prekeys WHERE user in ?" readBrigPrekeys :: Env -> [UserId] -> ConduitM () [RowBrigPrekeys] IO () @@ -241,7 +241,7 @@ readBrigPrekeysAll Env {..} = paginateC selectBrigPrekeysAll (paramsP LocalQuorum () envPageSize) x5 exportBrigPrekeysFull :: Env -> FilePath -> IO () -exportBrigPrekeysFull env@Env {..} path = do +exportBrigPrekeysFull env path = do putStrLn $ "Exporting " <> "brig.prekeys" <> " to " <> path withBinaryFile path WriteMode $ \handle -> runConduit $ @@ -258,7 +258,7 @@ importBrigPrekeys Env {..} path = do if exists then do putStrLn $ "Importing " <> path <> " to " <> "brig.prekeys" - withBinaryFile path ReadMode $ \handle -> do + withBinaryFile path ReadMode $ \handle -> runConduit $ sourceJsonLines handle .| transPipe (runClient envBrig) (sinkTableRows insertBrigPrekeys) @@ -270,7 +270,7 @@ importBrigPrekeys Env {..} path = do type RowBrigProperties = (Maybe UUID, Maybe Ascii, Maybe Blob) -selectBrigProperties :: PrepQuery R (Identity ([UserId])) RowBrigProperties +selectBrigProperties :: PrepQuery R (Identity [UserId]) RowBrigProperties selectBrigProperties = "SELECT user, key, value FROM properties WHERE user in ?" readBrigProperties :: Env -> [UserId] -> ConduitM () [RowBrigProperties] IO () @@ -287,7 +287,7 @@ readBrigPropertiesAll Env {..} = paginateC selectBrigPropertiesAll (paramsP LocalQuorum () envPageSize) x5 exportBrigPropertiesFull :: Env -> FilePath -> IO () -exportBrigPropertiesFull env@Env {..} path = do +exportBrigPropertiesFull env path = do putStrLn $ "Exporting " <> "brig.properties" <> " to " <> path withBinaryFile path WriteMode $ \handle -> runConduit $ @@ -304,7 +304,7 @@ importBrigProperties Env {..} path = do if exists then do putStrLn $ "Importing " <> path <> " to " <> "brig.properties" - withBinaryFile path ReadMode $ \handle -> do + withBinaryFile path ReadMode $ \handle -> runConduit $ sourceJsonLines handle .| transPipe (runClient envBrig) (sinkTableRows insertBrigProperties) @@ -316,7 +316,7 @@ importBrigProperties Env {..} path = do type RowBrigRichInfo = (Maybe UUID, Maybe Blob) -selectBrigRichInfo :: PrepQuery R (Identity ([UserId])) RowBrigRichInfo +selectBrigRichInfo :: PrepQuery R (Identity [UserId]) RowBrigRichInfo selectBrigRichInfo = "SELECT user, json FROM rich_info WHERE user in ?" readBrigRichInfo :: Env -> [UserId] -> ConduitM () [RowBrigRichInfo] IO () @@ -333,7 +333,7 @@ readBrigRichInfoAll Env {..} = paginateC selectBrigRichInfoAll (paramsP LocalQuorum () envPageSize) x5 exportBrigRichInfoFull :: Env -> FilePath -> IO () -exportBrigRichInfoFull env@Env {..} path = do +exportBrigRichInfoFull env path = do putStrLn $ "Exporting " <> "brig.rich_info" <> " to " <> path withBinaryFile path WriteMode $ \handle -> runConduit $ @@ -350,7 +350,7 @@ importBrigRichInfo Env {..} path = do if exists then do putStrLn $ "Importing " <> path <> " to " <> "brig.rich_info" - withBinaryFile path ReadMode $ \handle -> do + withBinaryFile path ReadMode $ \handle -> runConduit $ sourceJsonLines handle .| transPipe (runClient envBrig) (sinkTableRows insertBrigRichInfo) @@ -362,7 +362,7 @@ importBrigRichInfo Env {..} path = do type RowBrigUser = (Maybe UUID, Maybe [Float], Maybe Int32, Maybe Bool, Maybe [AssetIgnoreData], Maybe Ascii, Maybe Text, Maybe UTCTime, Maybe Text, Maybe Ascii, Maybe Int32, Maybe Text, Maybe Blob, Maybe Text, Maybe [Blob], Maybe UUID, Maybe Bool, Maybe UUID, Maybe Text, Maybe Int32, Maybe UUID) -selectBrigUser :: PrepQuery R (Identity ([UserId])) RowBrigUser +selectBrigUser :: PrepQuery R (Identity [UserId]) RowBrigUser selectBrigUser = "SELECT id, accent, accent_id, activated, assets, country, email, expires, handle, language, managed_by, name, password, phone, picture, provider, searchable, service, sso_id, status, team FROM user WHERE id in ?" readBrigUser :: Env -> [UserId] -> ConduitM () [RowBrigUser] IO () @@ -379,7 +379,7 @@ readBrigUserAll Env {..} = paginateC selectBrigUserAll (paramsP LocalQuorum () envPageSize) x5 exportBrigUserFull :: Env -> FilePath -> IO () -exportBrigUserFull env@Env {..} path = do +exportBrigUserFull env path = do putStrLn $ "Exporting " <> "brig.user" <> " to " <> path withBinaryFile path WriteMode $ \handle -> runConduit $ @@ -396,7 +396,7 @@ importBrigUser Env {..} path = do if exists then do putStrLn $ "Importing " <> path <> " to " <> "brig.user" - withBinaryFile path ReadMode $ \handle -> do + withBinaryFile path ReadMode $ \handle -> runConduit $ sourceJsonLines handle .| transPipe (runClient envBrig) (sinkTableRows insertBrigUser) @@ -408,7 +408,7 @@ importBrigUser Env {..} path = do type RowBrigUserHandle = (Maybe Text, Maybe UUID) -selectBrigUserHandle :: PrepQuery R (Identity ([Handle])) RowBrigUserHandle +selectBrigUserHandle :: PrepQuery R (Identity [Handle]) RowBrigUserHandle selectBrigUserHandle = "SELECT handle, user FROM user_handle WHERE handle in ?" readBrigUserHandle :: Env -> [Handle] -> ConduitM () [RowBrigUserHandle] IO () @@ -425,7 +425,7 @@ readBrigUserHandleAll Env {..} = paginateC selectBrigUserHandleAll (paramsP LocalQuorum () envPageSize) x5 exportBrigUserHandleFull :: Env -> FilePath -> IO () -exportBrigUserHandleFull env@Env {..} path = do +exportBrigUserHandleFull env path = do putStrLn $ "Exporting " <> "brig.user_handle" <> " to " <> path withBinaryFile path WriteMode $ \handle -> runConduit $ @@ -442,7 +442,7 @@ importBrigUserHandle Env {..} path = do if exists then do putStrLn $ "Importing " <> path <> " to " <> "brig.user_handle" - withBinaryFile path ReadMode $ \handle -> do + withBinaryFile path ReadMode $ \handle -> runConduit $ sourceJsonLines handle .| transPipe (runClient envBrig) (sinkTableRows insertBrigUserHandle) @@ -454,7 +454,7 @@ importBrigUserHandle Env {..} path = do type RowBrigUserKeys = (Maybe Text, Maybe UUID) -selectBrigUserKeys :: PrepQuery R (Identity ([Int32])) RowBrigUserKeys +selectBrigUserKeys :: PrepQuery R (Identity [Int32]) RowBrigUserKeys selectBrigUserKeys = "SELECT key, user FROM user_keys WHERE key in ?" readBrigUserKeys :: Env -> [Int32] -> ConduitM () [RowBrigUserKeys] IO () @@ -471,7 +471,7 @@ readBrigUserKeysAll Env {..} = paginateC selectBrigUserKeysAll (paramsP LocalQuorum () envPageSize) x5 exportBrigUserKeysFull :: Env -> FilePath -> IO () -exportBrigUserKeysFull env@Env {..} path = do +exportBrigUserKeysFull env path = do putStrLn $ "Exporting " <> "brig.user_keys" <> " to " <> path withBinaryFile path WriteMode $ \handle -> runConduit $ @@ -488,7 +488,7 @@ importBrigUserKeys Env {..} path = do if exists then do putStrLn $ "Importing " <> path <> " to " <> "brig.user_keys" - withBinaryFile path ReadMode $ \handle -> do + withBinaryFile path ReadMode $ \handle -> runConduit $ sourceJsonLines handle .| transPipe (runClient envBrig) (sinkTableRows insertBrigUserKeys) @@ -500,7 +500,7 @@ importBrigUserKeys Env {..} path = do type RowBrigUserKeysHash = (Maybe Blob, Maybe Int32, Maybe UUID) -selectBrigUserKeysHash :: PrepQuery R (Identity ([Int32])) RowBrigUserKeysHash +selectBrigUserKeysHash :: PrepQuery R (Identity [Int32]) RowBrigUserKeysHash selectBrigUserKeysHash = "SELECT key, key_type, user FROM user_keys_hash WHERE key in ?" readBrigUserKeysHash :: Env -> [Int32] -> ConduitM () [RowBrigUserKeysHash] IO () @@ -517,7 +517,7 @@ readBrigUserKeysHashAll Env {..} = paginateC selectBrigUserKeysHashAll (paramsP LocalQuorum () envPageSize) x5 exportBrigUserKeysHashFull :: Env -> FilePath -> IO () -exportBrigUserKeysHashFull env@Env {..} path = do +exportBrigUserKeysHashFull env path = do putStrLn $ "Exporting " <> "brig.user_keys_hash" <> " to " <> path withBinaryFile path WriteMode $ \handle -> runConduit $ @@ -534,7 +534,7 @@ importBrigUserKeysHash Env {..} path = do if exists then do putStrLn $ "Importing " <> path <> " to " <> "brig.user_keys_hash" - withBinaryFile path ReadMode $ \handle -> do + withBinaryFile path ReadMode $ \handle -> runConduit $ sourceJsonLines handle .| transPipe (runClient envBrig) (sinkTableRows insertBrigUserKeysHash) @@ -546,7 +546,7 @@ importBrigUserKeysHash Env {..} path = do type RowGalleyBillingTeamMember = (Maybe UUID, Maybe UUID) -selectGalleyBillingTeamMember :: PrepQuery R (Identity (TeamId)) RowGalleyBillingTeamMember +selectGalleyBillingTeamMember :: PrepQuery R (Identity TeamId) RowGalleyBillingTeamMember selectGalleyBillingTeamMember = "SELECT team, user FROM billing_team_member WHERE team = ?" readGalleyBillingTeamMember :: Env -> TeamId -> ConduitM () [RowGalleyBillingTeamMember] IO () @@ -563,7 +563,7 @@ readGalleyBillingTeamMemberAll Env {..} = paginateC selectGalleyBillingTeamMemberAll (paramsP LocalQuorum () envPageSize) x5 exportGalleyBillingTeamMemberFull :: Env -> FilePath -> IO () -exportGalleyBillingTeamMemberFull env@Env {..} path = do +exportGalleyBillingTeamMemberFull env path = do putStrLn $ "Exporting " <> "galley.billing_team_member" <> " to " <> path withBinaryFile path WriteMode $ \handle -> runConduit $ @@ -580,7 +580,7 @@ importGalleyBillingTeamMember Env {..} path = do if exists then do putStrLn $ "Importing " <> path <> " to " <> "galley.billing_team_member" - withBinaryFile path ReadMode $ \handle -> do + withBinaryFile path ReadMode $ \handle -> runConduit $ sourceJsonLines handle .| transPipe (runClient envGalley) (sinkTableRows insertGalleyBillingTeamMember) @@ -592,7 +592,7 @@ importGalleyBillingTeamMember Env {..} path = do type RowGalleyClients = (Maybe UUID, Maybe (Cassandra.Set Text)) -selectGalleyClients :: PrepQuery R (Identity ([UserId])) RowGalleyClients +selectGalleyClients :: PrepQuery R (Identity [UserId]) RowGalleyClients selectGalleyClients = "SELECT user, clients FROM clients WHERE user in ?" readGalleyClients :: Env -> [UserId] -> ConduitM () [RowGalleyClients] IO () @@ -609,7 +609,7 @@ readGalleyClientsAll Env {..} = paginateC selectGalleyClientsAll (paramsP LocalQuorum () envPageSize) x5 exportGalleyClientsFull :: Env -> FilePath -> IO () -exportGalleyClientsFull env@Env {..} path = do +exportGalleyClientsFull env path = do putStrLn $ "Exporting " <> "galley.clients" <> " to " <> path withBinaryFile path WriteMode $ \handle -> runConduit $ @@ -626,7 +626,7 @@ importGalleyClients Env {..} path = do if exists then do putStrLn $ "Importing " <> path <> " to " <> "galley.clients" - withBinaryFile path ReadMode $ \handle -> do + withBinaryFile path ReadMode $ \handle -> runConduit $ sourceJsonLines handle .| transPipe (runClient envGalley) (sinkTableRows insertGalleyClients) @@ -638,7 +638,7 @@ importGalleyClients Env {..} path = do type RowGalleyConversation = (Maybe UUID, Maybe (Cassandra.Set Int32), Maybe Int32, Maybe UUID, Maybe Bool, Maybe Int64, Maybe Text, Maybe Int32, Maybe UUID, Maybe Int32) -selectGalleyConversation :: PrepQuery R (Identity ([ConvId])) RowGalleyConversation +selectGalleyConversation :: PrepQuery R (Identity [ConvId]) RowGalleyConversation selectGalleyConversation = "SELECT conv, access, access_role, creator, deleted, message_timer, name, receipt_mode, team, type FROM conversation WHERE conv in ?" readGalleyConversation :: Env -> [ConvId] -> ConduitM () [RowGalleyConversation] IO () @@ -655,7 +655,7 @@ readGalleyConversationAll Env {..} = paginateC selectGalleyConversationAll (paramsP LocalQuorum () envPageSize) x5 exportGalleyConversationFull :: Env -> FilePath -> IO () -exportGalleyConversationFull env@Env {..} path = do +exportGalleyConversationFull env path = do putStrLn $ "Exporting " <> "galley.conversation" <> " to " <> path withBinaryFile path WriteMode $ \handle -> runConduit $ @@ -672,7 +672,7 @@ importGalleyConversation Env {..} path = do if exists then do putStrLn $ "Importing " <> path <> " to " <> "galley.conversation" - withBinaryFile path ReadMode $ \handle -> do + withBinaryFile path ReadMode $ \handle -> runConduit $ sourceJsonLines handle .| transPipe (runClient envGalley) (sinkTableRows insertGalleyConversation) @@ -684,7 +684,7 @@ importGalleyConversation Env {..} path = do type RowGalleyMember = (Maybe UUID, Maybe UUID, Maybe Text, Maybe Bool, Maybe Text, Maybe Bool, Maybe Text, Maybe Bool, Maybe Text, Maybe Int32, Maybe UUID, Maybe UUID, Maybe Int32, Maybe Text, Maybe UUID) -selectGalleyMember :: PrepQuery R (Identity ([ConvId])) RowGalleyMember +selectGalleyMember :: PrepQuery R (Identity [ConvId]) RowGalleyMember selectGalleyMember = "SELECT conv, user, conversation_role, hidden, hidden_ref, otr_archived, otr_archived_ref, otr_muted, otr_muted_ref, otr_muted_status, provider, service, status, user_remote_domain, user_remote_id FROM member WHERE conv in ?" readGalleyMember :: Env -> [ConvId] -> ConduitM () [RowGalleyMember] IO () @@ -701,7 +701,7 @@ readGalleyMemberAll Env {..} = paginateC selectGalleyMemberAll (paramsP LocalQuorum () envPageSize) x5 exportGalleyMemberFull :: Env -> FilePath -> IO () -exportGalleyMemberFull env@Env {..} path = do +exportGalleyMemberFull env path = do putStrLn $ "Exporting " <> "galley.member" <> " to " <> path withBinaryFile path WriteMode $ \handle -> runConduit $ @@ -718,7 +718,7 @@ importGalleyMember Env {..} path = do if exists then do putStrLn $ "Importing " <> path <> " to " <> "galley.member" - withBinaryFile path ReadMode $ \handle -> do + withBinaryFile path ReadMode $ \handle -> runConduit $ sourceJsonLines handle .| transPipe (runClient envGalley) (sinkTableRows insertGalleyMember) @@ -730,7 +730,7 @@ importGalleyMember Env {..} path = do type RowGalleyTeam = (Maybe UUID, Maybe Bool, Maybe UUID, Maybe Bool, Maybe Text, Maybe Text, Maybe Text, Maybe Int32, Maybe Int32) -selectGalleyTeam :: PrepQuery R (Identity (TeamId)) RowGalleyTeam +selectGalleyTeam :: PrepQuery R (Identity TeamId) RowGalleyTeam selectGalleyTeam = "SELECT team, binding, creator, deleted, icon, icon_key, name, search_visibility, status FROM team WHERE team = ?" readGalleyTeam :: Env -> TeamId -> ConduitM () [RowGalleyTeam] IO () @@ -747,7 +747,7 @@ readGalleyTeamAll Env {..} = paginateC selectGalleyTeamAll (paramsP LocalQuorum () envPageSize) x5 exportGalleyTeamFull :: Env -> FilePath -> IO () -exportGalleyTeamFull env@Env {..} path = do +exportGalleyTeamFull env path = do putStrLn $ "Exporting " <> "galley.team" <> " to " <> path withBinaryFile path WriteMode $ \handle -> runConduit $ @@ -764,7 +764,7 @@ importGalleyTeam Env {..} path = do if exists then do putStrLn $ "Importing " <> path <> " to " <> "galley.team" - withBinaryFile path ReadMode $ \handle -> do + withBinaryFile path ReadMode $ \handle -> runConduit $ sourceJsonLines handle .| transPipe (runClient envGalley) (sinkTableRows insertGalleyTeam) @@ -776,7 +776,7 @@ importGalleyTeam Env {..} path = do type RowGalleyTeamConv = (Maybe UUID, Maybe UUID, Maybe Bool) -selectGalleyTeamConv :: PrepQuery R (Identity (TeamId)) RowGalleyTeamConv +selectGalleyTeamConv :: PrepQuery R (Identity TeamId) RowGalleyTeamConv selectGalleyTeamConv = "SELECT team, conv, managed FROM team_conv WHERE team = ?" readGalleyTeamConv :: Env -> TeamId -> ConduitM () [RowGalleyTeamConv] IO () @@ -793,7 +793,7 @@ readGalleyTeamConvAll Env {..} = paginateC selectGalleyTeamConvAll (paramsP LocalQuorum () envPageSize) x5 exportGalleyTeamConvFull :: Env -> FilePath -> IO () -exportGalleyTeamConvFull env@Env {..} path = do +exportGalleyTeamConvFull env path = do putStrLn $ "Exporting " <> "galley.team_conv" <> " to " <> path withBinaryFile path WriteMode $ \handle -> runConduit $ @@ -810,7 +810,7 @@ importGalleyTeamConv Env {..} path = do if exists then do putStrLn $ "Importing " <> path <> " to " <> "galley.team_conv" - withBinaryFile path ReadMode $ \handle -> do + withBinaryFile path ReadMode $ \handle -> runConduit $ sourceJsonLines handle .| transPipe (runClient envGalley) (sinkTableRows insertGalleyTeamConv) @@ -822,7 +822,7 @@ importGalleyTeamConv Env {..} path = do type RowGalleyTeamFeatures = (Maybe UUID, Maybe Int32, Maybe Int32, Maybe Int32, Maybe Int32, Maybe Int32, Maybe Int32, Maybe Int32, Maybe Int32) -selectGalleyTeamFeatures :: PrepQuery R (Identity (TeamId)) RowGalleyTeamFeatures +selectGalleyTeamFeatures :: PrepQuery R (Identity TeamId) RowGalleyTeamFeatures selectGalleyTeamFeatures = "SELECT team_id, app_lock_enforce, app_lock_inactivity_timeout_secs, app_lock_status, digital_signatures, legalhold_status, search_visibility_status, sso_status, validate_saml_emails FROM team_features WHERE team_id = ?" readGalleyTeamFeatures :: Env -> TeamId -> ConduitM () [RowGalleyTeamFeatures] IO () @@ -839,7 +839,7 @@ readGalleyTeamFeaturesAll Env {..} = paginateC selectGalleyTeamFeaturesAll (paramsP LocalQuorum () envPageSize) x5 exportGalleyTeamFeaturesFull :: Env -> FilePath -> IO () -exportGalleyTeamFeaturesFull env@Env {..} path = do +exportGalleyTeamFeaturesFull env path = do putStrLn $ "Exporting " <> "galley.team_features" <> " to " <> path withBinaryFile path WriteMode $ \handle -> runConduit $ @@ -856,7 +856,7 @@ importGalleyTeamFeatures Env {..} path = do if exists then do putStrLn $ "Importing " <> path <> " to " <> "galley.team_features" - withBinaryFile path ReadMode $ \handle -> do + withBinaryFile path ReadMode $ \handle -> runConduit $ sourceJsonLines handle .| transPipe (runClient envGalley) (sinkTableRows insertGalleyTeamFeatures) @@ -868,7 +868,7 @@ importGalleyTeamFeatures Env {..} path = do type RowGalleyTeamMember = (Maybe UUID, Maybe UUID, Maybe UTCTime, Maybe UUID, Maybe Int32, Maybe Permissions) -selectGalleyTeamMember :: PrepQuery R (Identity (TeamId)) RowGalleyTeamMember +selectGalleyTeamMember :: PrepQuery R (Identity TeamId) RowGalleyTeamMember selectGalleyTeamMember = "SELECT team, user, invited_at, invited_by, legalhold_status, perms FROM team_member WHERE team = ?" readGalleyTeamMember :: Env -> TeamId -> ConduitM () [RowGalleyTeamMember] IO () @@ -885,7 +885,7 @@ readGalleyTeamMemberAll Env {..} = paginateC selectGalleyTeamMemberAll (paramsP LocalQuorum () envPageSize) x5 exportGalleyTeamMemberFull :: Env -> FilePath -> IO () -exportGalleyTeamMemberFull env@Env {..} path = do +exportGalleyTeamMemberFull env path = do putStrLn $ "Exporting " <> "galley.team_member" <> " to " <> path withBinaryFile path WriteMode $ \handle -> runConduit $ @@ -902,7 +902,7 @@ importGalleyTeamMember Env {..} path = do if exists then do putStrLn $ "Importing " <> path <> " to " <> "galley.team_member" - withBinaryFile path ReadMode $ \handle -> do + withBinaryFile path ReadMode $ \handle -> runConduit $ sourceJsonLines handle .| transPipe (runClient envGalley) (sinkTableRows insertGalleyTeamMember) @@ -914,7 +914,7 @@ importGalleyTeamMember Env {..} path = do type RowGalleyTeamNotifications = (Maybe UUID, Maybe TimeUuid, Maybe Blob) -selectGalleyTeamNotifications :: PrepQuery R (Identity (TeamId)) RowGalleyTeamNotifications +selectGalleyTeamNotifications :: PrepQuery R (Identity TeamId) RowGalleyTeamNotifications selectGalleyTeamNotifications = "SELECT team, id, payload FROM team_notifications WHERE team = ?" readGalleyTeamNotifications :: Env -> TeamId -> ConduitM () [RowGalleyTeamNotifications] IO () @@ -931,7 +931,7 @@ readGalleyTeamNotificationsAll Env {..} = paginateC selectGalleyTeamNotificationsAll (paramsP LocalQuorum () envPageSize) x5 exportGalleyTeamNotificationsFull :: Env -> FilePath -> IO () -exportGalleyTeamNotificationsFull env@Env {..} path = do +exportGalleyTeamNotificationsFull env path = do putStrLn $ "Exporting " <> "galley.team_notifications" <> " to " <> path withBinaryFile path WriteMode $ \handle -> runConduit $ @@ -948,7 +948,7 @@ importGalleyTeamNotifications Env {..} path = do if exists then do putStrLn $ "Importing " <> path <> " to " <> "galley.team_notifications" - withBinaryFile path ReadMode $ \handle -> do + withBinaryFile path ReadMode $ \handle -> runConduit $ sourceJsonLines handle .| transPipe (runClient envGalley) (sinkTableRows insertGalleyTeamNotifications) @@ -960,7 +960,7 @@ importGalleyTeamNotifications Env {..} path = do type RowGalleyUser = (Maybe UUID, Maybe UUID, Maybe Text, Maybe UUID) -selectGalleyUser :: PrepQuery R (Identity ([UserId])) RowGalleyUser +selectGalleyUser :: PrepQuery R (Identity [UserId]) RowGalleyUser selectGalleyUser = "SELECT user, conv, conv_remote_domain, conv_remote_id FROM user WHERE user in ?" readGalleyUser :: Env -> [UserId] -> ConduitM () [RowGalleyUser] IO () @@ -977,7 +977,7 @@ readGalleyUserAll Env {..} = paginateC selectGalleyUserAll (paramsP LocalQuorum () envPageSize) x5 exportGalleyUserFull :: Env -> FilePath -> IO () -exportGalleyUserFull env@Env {..} path = do +exportGalleyUserFull env path = do putStrLn $ "Exporting " <> "galley.user" <> " to " <> path withBinaryFile path WriteMode $ \handle -> runConduit $ @@ -994,7 +994,7 @@ importGalleyUser Env {..} path = do if exists then do putStrLn $ "Importing " <> path <> " to " <> "galley.user" - withBinaryFile path ReadMode $ \handle -> do + withBinaryFile path ReadMode $ \handle -> runConduit $ sourceJsonLines handle .| transPipe (runClient envGalley) (sinkTableRows insertGalleyUser) @@ -1006,7 +1006,7 @@ importGalleyUser Env {..} path = do type RowGalleyUserTeam = (Maybe UUID, Maybe UUID) -selectGalleyUserTeam :: PrepQuery R (Identity ([UserId])) RowGalleyUserTeam +selectGalleyUserTeam :: PrepQuery R (Identity [UserId]) RowGalleyUserTeam selectGalleyUserTeam = "SELECT user, team FROM user_team WHERE user in ?" readGalleyUserTeam :: Env -> [UserId] -> ConduitM () [RowGalleyUserTeam] IO () @@ -1023,7 +1023,7 @@ readGalleyUserTeamAll Env {..} = paginateC selectGalleyUserTeamAll (paramsP LocalQuorum () envPageSize) x5 exportGalleyUserTeamFull :: Env -> FilePath -> IO () -exportGalleyUserTeamFull env@Env {..} path = do +exportGalleyUserTeamFull env path = do putStrLn $ "Exporting " <> "galley.user_team" <> " to " <> path withBinaryFile path WriteMode $ \handle -> runConduit $ @@ -1040,7 +1040,7 @@ importGalleyUserTeam Env {..} path = do if exists then do putStrLn $ "Importing " <> path <> " to " <> "galley.user_team" - withBinaryFile path ReadMode $ \handle -> do + withBinaryFile path ReadMode $ \handle -> runConduit $ sourceJsonLines handle .| transPipe (runClient envGalley) (sinkTableRows insertGalleyUserTeam) @@ -1052,7 +1052,7 @@ importGalleyUserTeam Env {..} path = do type RowGundeckNotifications = (Maybe UUID, Maybe TimeUuid, Maybe (Cassandra.Set Text), Maybe Blob) -selectGundeckNotifications :: PrepQuery R (Identity ([UserId])) RowGundeckNotifications +selectGundeckNotifications :: PrepQuery R (Identity [UserId]) RowGundeckNotifications selectGundeckNotifications = "SELECT user, id, clients, payload FROM notifications WHERE user in ?" readGundeckNotifications :: Env -> [UserId] -> ConduitM () [RowGundeckNotifications] IO () @@ -1069,7 +1069,7 @@ readGundeckNotificationsAll Env {..} = paginateC selectGundeckNotificationsAll (paramsP LocalQuorum () envPageSize) x5 exportGundeckNotificationsFull :: Env -> FilePath -> IO () -exportGundeckNotificationsFull env@Env {..} path = do +exportGundeckNotificationsFull env path = do putStrLn $ "Exporting " <> "gundeck.notifications" <> " to " <> path withBinaryFile path WriteMode $ \handle -> runConduit $ @@ -1086,7 +1086,7 @@ importGundeckNotifications Env {..} path = do if exists then do putStrLn $ "Importing " <> path <> " to " <> "gundeck.notifications" - withBinaryFile path ReadMode $ \handle -> do + withBinaryFile path ReadMode $ \handle -> runConduit $ sourceJsonLines handle .| transPipe (runClient envGundeck) (sinkTableRows insertGundeckNotifications) @@ -1098,7 +1098,7 @@ importGundeckNotifications Env {..} path = do type RowSparScimExternal = (Maybe UUID, Maybe Text, Maybe UUID) -selectSparScimExternal :: PrepQuery R (Identity (TeamId)) RowSparScimExternal +selectSparScimExternal :: PrepQuery R (Identity TeamId) RowSparScimExternal selectSparScimExternal = "SELECT team, external_id, user FROM scim_external WHERE team = ?" readSparScimExternal :: Env -> TeamId -> ConduitM () [RowSparScimExternal] IO () @@ -1115,7 +1115,7 @@ readSparScimExternalAll Env {..} = paginateC selectSparScimExternalAll (paramsP LocalQuorum () envPageSize) x5 exportSparScimExternalFull :: Env -> FilePath -> IO () -exportSparScimExternalFull env@Env {..} path = do +exportSparScimExternalFull env path = do putStrLn $ "Exporting " <> "spar.scim_external" <> " to " <> path withBinaryFile path WriteMode $ \handle -> runConduit $ @@ -1132,7 +1132,7 @@ importSparScimExternal Env {..} path = do if exists then do putStrLn $ "Importing " <> path <> " to " <> "spar.scim_external" - withBinaryFile path ReadMode $ \handle -> do + withBinaryFile path ReadMode $ \handle -> runConduit $ sourceJsonLines handle .| transPipe (runClient envSpar) (sinkTableRows insertSparScimExternal) @@ -1144,7 +1144,7 @@ importSparScimExternal Env {..} path = do type RowSparScimUserTimes = (Maybe UUID, Maybe UTCTime, Maybe UTCTime) -selectSparScimUserTimes :: PrepQuery R (Identity ([UserId])) RowSparScimUserTimes +selectSparScimUserTimes :: PrepQuery R (Identity [UserId]) RowSparScimUserTimes selectSparScimUserTimes = "SELECT uid, created_at, last_updated_at FROM scim_user_times WHERE uid in ?" readSparScimUserTimes :: Env -> [UserId] -> ConduitM () [RowSparScimUserTimes] IO () @@ -1161,7 +1161,7 @@ readSparScimUserTimesAll Env {..} = paginateC selectSparScimUserTimesAll (paramsP LocalQuorum () envPageSize) x5 exportSparScimUserTimesFull :: Env -> FilePath -> IO () -exportSparScimUserTimesFull env@Env {..} path = do +exportSparScimUserTimesFull env path = do putStrLn $ "Exporting " <> "spar.scim_user_times" <> " to " <> path withBinaryFile path WriteMode $ \handle -> runConduit $ @@ -1178,7 +1178,7 @@ importSparScimUserTimes Env {..} path = do if exists then do putStrLn $ "Importing " <> path <> " to " <> "spar.scim_user_times" - withBinaryFile path ReadMode $ \handle -> do + withBinaryFile path ReadMode $ \handle -> runConduit $ sourceJsonLines handle .| transPipe (runClient envSpar) (sinkTableRows insertSparScimUserTimes) @@ -1190,7 +1190,7 @@ importSparScimUserTimes Env {..} path = do type RowSparUser = (Maybe Text, Maybe Text, Maybe UUID) -selectSparUser :: PrepQuery R (Identity ([Text])) RowSparUser +selectSparUser :: PrepQuery R (Identity [Text]) RowSparUser selectSparUser = "SELECT issuer, sso_id, uid FROM user WHERE issuer in ?" readSparUser :: Env -> [Text] -> ConduitM () [RowSparUser] IO () @@ -1207,7 +1207,7 @@ readSparUserAll Env {..} = paginateC selectSparUserAll (paramsP LocalQuorum () envPageSize) x5 exportSparUserFull :: Env -> FilePath -> IO () -exportSparUserFull env@Env {..} path = do +exportSparUserFull env path = do putStrLn $ "Exporting " <> "spar.user" <> " to " <> path withBinaryFile path WriteMode $ \handle -> runConduit $ @@ -1224,7 +1224,7 @@ importSparUser Env {..} path = do if exists then do putStrLn $ "Importing " <> path <> " to " <> "spar.user" - withBinaryFile path ReadMode $ \handle -> do + withBinaryFile path ReadMode $ \handle -> runConduit $ sourceJsonLines handle .| transPipe (runClient envSpar) (sinkTableRows insertSparUser) diff --git a/tools/db/repair-handles/repair-handles.cabal b/tools/db/repair-handles/repair-handles.cabal index a5b8fd26193..105feb83981 100644 --- a/tools/db/repair-handles/repair-handles.cabal +++ b/tools/db/repair-handles/repair-handles.cabal @@ -1,10 +1,10 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack -- --- hash: abd13346fea0b0196ba60cf22bfa4c3b8b06b83ef7cc88c1d32c276e695b8f3c +-- hash: c8ad3a3ca71a54e03d9bb6572dad0629da8c5940cfe20febf7cf1971d549f042 name: repair-handles version: 1.0.0 @@ -26,7 +26,46 @@ executable repair-handles hs-source-dirs: repair-handles 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 + 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 build-depends: base diff --git a/tools/db/service-backfill/service-backfill.cabal b/tools/db/service-backfill/service-backfill.cabal index 3bc5aa2cd0d..4a1ed2deb16 100644 --- a/tools/db/service-backfill/service-backfill.cabal +++ b/tools/db/service-backfill/service-backfill.cabal @@ -1,10 +1,10 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack -- --- hash: 7e34405c46813f3294b0ecb9bf520e7b75d83db1c83cbcf779de12f46c7957b5 +-- hash: d72d11c1f8954ebb055cecdaed92fb6e31c1b534a8083b486f14bbcf5849e0ba name: service-backfill version: 1.0.0 @@ -24,7 +24,46 @@ executable service-backfill Paths_service_backfill 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 + 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 -funbox-strict-fields -threaded -with-rtsopts=-N -with-rtsopts=-T -rtsopts build-depends: base diff --git a/tools/makedeb/makedeb.cabal b/tools/makedeb/makedeb.cabal index 0adc3c7da9d..5f2263addb8 100644 --- a/tools/makedeb/makedeb.cabal +++ b/tools/makedeb/makedeb.cabal @@ -1,10 +1,10 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack -- --- hash: 7fe255326cb9428aeec3221e074cd2eec369cad640361ae18e967e7f095fd0a8 +-- hash: 80100f7bcc806d6eef6f942564fb7afa966abe1df367224e68b29a904fbe3cf2 name: makedeb version: 0.3.0 @@ -27,7 +27,46 @@ library Paths_makedeb 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 + 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 build-depends: base >=4.6 && <5.0 @@ -43,7 +82,46 @@ executable makedeb main-is: src/Main.hs other-modules: Paths_makedeb - 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 + 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 build-depends: base diff --git a/tools/nginz_disco/Dockerfile b/tools/nginz_disco/Dockerfile index 9d15426f594..67c5a5b1ee4 100644 --- a/tools/nginz_disco/Dockerfile +++ b/tools/nginz_disco/Dockerfile @@ -1,4 +1,4 @@ -FROM alpine:3.12.3 +FROM alpine:3.15.0 RUN apk add --no-cache curl bash openssl bind-tools diff --git a/tools/nginz_disco/README.md b/tools/nginz_disco/README.md index 5571c7a1a38..33fa7f108db 100644 --- a/tools/nginz_disco/README.md +++ b/tools/nginz_disco/README.md @@ -1,6 +1,6 @@ # nginz-disco -Due to nginx not supporting DNS names for its list of upstream servers (unless you pay extra), the nginz-disco container is a simple bash script to do DNS lookups and write the resulting IPs to a file. Nginz reloads on changes to this file. +Due to nginx not supporting DNS names for its list of upstream servers (unless you pay extra), the nginz-disco container is a simple bash script to do DNS lookups and write the resulting IPs to a file. Nginz reloads on changes to this file. -This is useful as a sidecar container to nginz in kubernetes. See also [wire-server-deploy/nginz](https://github.com/wireapp/wire-server-deploy/charts/nginz/)