diff --git a/.github/pull_request_template.md b/.github/pull_request_template.md index eee52d1ebcd..663a3c5ef2f 100644 --- a/.github/pull_request_template.md +++ b/.github/pull_request_template.md @@ -2,6 +2,7 @@ - [ ] The **PR Title** explains the impact of the change. - [ ] The **PR description** provides context as to why the change should occur and what the code contributes to that effect. This could also be a link to a JIRA ticket or a Github issue, if there is one. + - [ ] If this PR changes development workflow or dependencies, they have been A) automated and B) documented under docs/developer/. All efforts have been taken to minimize development setup breakage or slowdown for co-workers. - [ ] If HTTP endpoint paths have been added or renamed, the **endpoint / config-flag checklist** (see Wire-employee only backend [wiki page](https://github.com/zinfra/backend-wiki/wiki/Checklists)) has been followed. - [ ] If a cassandra schema migration has been added, I ran **`make git-add-cassandra-schema`** to update the cassandra schema documentation. - [ ] **changelog.d** contains the following bits of information ([details](https://github.com/wireapp/wire-server/blob/develop/docs/developer/changelog.md)): diff --git a/CHANGELOG.md b/CHANGELOG.md index dcc5938707f..9be2efc0674 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,42 @@ +# [2022-03-01] + +## Release notes + + +* Upgrade webapp version to 2022-02-22-production.0-v0.29.2-0-abb34f5 (#2148) + + +## API changes + + +* The `api-version` endpoint now returns additional information about the backend: + + - whether federation is supported (field `federation`); + - the federation domain (field `domain`). + + Note that the federation domain is always set, even if federation is disabled. (#2146) + +* Add MLS key package API (#2102) + + +## Internal changes + + +* Bump aeson to v2.0.3.0 and update amazonka fork from upstream repository. (#2153, #2157, #2163) + +* Add schema-profunctor instances for `QueuedNotification` and `QueuedNotificationList` (#2161) + +* Dockerfile.builder: Add cabal update (#2168) + + +## Federation changes + + +* Make restrictions on federated user search configurable by domain: `NoSearch`, `ExactHandleSearch` and `FullSearch`. + Details about the configuration are described in [config-options.md](docs/reference/config-options.md). + There are sane defaults (*deny to find any users as long as there is no other configuration for the domain*), so no measures have to be taken by on-premise customers (unless the default is not the desired behavior). (#2087) + + # [2022-02-21] ## Release notes diff --git a/Makefile b/Makefile index 4ea6e2e0e7f..2ae697e195b 100644 --- a/Makefile +++ b/Makefile @@ -43,6 +43,7 @@ init: .PHONY: install install: init ifeq ($(WIRE_BUILD_WITH_CABAL), 1) + cabal update cabal build all ./hack/bin/cabal-run-all-tests.sh ./hack/bin/cabal-install-artefacts.sh all diff --git a/build/ubuntu/Dockerfile.builder b/build/ubuntu/Dockerfile.builder index f6f83ba48e5..8dc7014ec50 100644 --- a/build/ubuntu/Dockerfile.builder +++ b/build/ubuntu/Dockerfile.builder @@ -22,6 +22,7 @@ RUN set -x && \ stack build haskell-src-exts && \ stack build --pedantic --test --no-run-tests --bench --no-run-benchmarks --dependencies-only -j${THREADS} && \ stack install ormolu && \ + cabal update && \ cabal build all --dependencies-only ${CABAL_BUILD_ARGS} && \ 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 index 85531bd85fe..0a308ed5f6f 100644 --- a/build/ubuntu/Dockerfile.deps +++ b/build/ubuntu/Dockerfile.deps @@ -3,18 +3,27 @@ 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 && \ + apt-get install -y cargo file libsodium-dev git pkg-config make && \ cd /tmp && \ git clone https://github.com/wireapp/cryptobox-c.git && \ cd cryptobox-c && \ export SODIUM_USE_PKG_CONFIG=1 && \ cargo build --release +# compile core-crypto cli tool +RUN cd /tmp && \ + git clone -b cli https://github.com/wireapp/core-crypto && \ + cd core-crypto/cli && \ + 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 +# FUTUREWORK: only copy crypto-cli executable if we are building an integration test image +COPY --from=cryptobox-builder /tmp/core-crypto/target/release/crypto-cli /usr/bin + RUN export DEBIAN_FRONTEND=noninteractive && \ apt-get update && \ apt-get install -y \ diff --git a/cabal.project b/cabal.project index 09c5a8a6a80..c056574389e 100644 --- a/cabal.project +++ b/cabal.project @@ -64,11 +64,6 @@ source-repository-package tag: 2e3282e5fb27ba8d989c271a0a989823fad7ec43 subdir: wai-middleware-prometheus -source-repository-package - type: git - location: https://github.com/haskell-servant/servant-swagger - tag: bb0a84faa073fa9530f60337610d7da3d5b9393c - source-repository-package type: git location: https://github.com/haskell-servant/servant.git @@ -97,20 +92,22 @@ source-repository-package source-repository-package type: git location: https://github.com/wireapp/amazonka - tag: 412172d8c28906591f01576a78792de7c34cc3eb - subdir: amazonka - amazonka-cloudfront - amazonka-dynamodb - amazonka-s3 - amazonka-ses - amazonka-sns - amazonka-sqs - core + tag: 7ced54b0396296307b9871d293cc0ac161e5743d + subdir: lib/amazonka + lib/amazonka-core + lib/services/amazonka-cloudfront + lib/services/amazonka-dynamodb + lib/services/amazonka-s3 + lib/services/amazonka-ses + lib/services/amazonka-sns + lib/services/amazonka-sqs + lib/services/amazonka-sso + lib/services/amazonka-sts source-repository-package type: git location: https://github.com/wireapp/bloodhound - tag: 92de9aa632d590f288a353d03591c38ba72b3cb3 + tag: d444579f808115ddb0f20a1fe169fafad24f5165 source-repository-package type: git @@ -125,7 +122,7 @@ source-repository-package source-repository-package type: git location: https://github.com/wireapp/hsaml2 - tag: b652ec6e69d1647e827cbee0fa290605ac09dc63 + tag: ef7b1de45ab0ea3a0a333b335579a02d8f88340c source-repository-package type: git @@ -156,6 +153,11 @@ source-repository-package location: https://github.com/wireapp/snappy tag: b0e5c08af48911caecffa4fa6a3e74872018b258 +source-repository-package + type: git + location: https://gitlab.com/axeman/swagger + tag: e2d3f5b5274b8d8d301b5377b0af4319cea73f9e + source-repository-package type: git location: https://gitlab.com/twittner/wai-routing @@ -167,7 +169,7 @@ allow-newer: * -- Changes by ./tools/convert-to-cabal/generate.sh tests: True - +benchmarks: True package api-bot ghc-options: -Werror diff --git a/cabal.project.freeze b/cabal.project.freeze index eac24bfbdc7..ad4f6d15047 100644 --- a/cabal.project.freeze +++ b/cabal.project.freeze @@ -72,7 +72,7 @@ constraints: any.AC-Angle ==1.0, any.NineP ==0.0.2.1, any.NumInstances ==1.4, any.ObjectName ==1.1.0.2, - any.OneTuple ==0.2.2.1, + any.OneTuple ==0.3.1, any.Only ==0.1, any.OpenAL ==1.7.0.5, any.OpenGL ==3.0.3.0, @@ -114,7 +114,7 @@ constraints: any.AC-Angle ==1.0, any.adler32 ==0.1.2.0, any.aern2-mp ==0.2.8.0, any.aern2-real ==0.2.8.0, - any.aeson ==1.4.7.1, + any.aeson ==2.0.3.0, any.aeson-attoparsec ==0.0.0, any.aeson-better-errors ==0.9.1.0, any.aeson-casing ==0.2.0.0, @@ -223,7 +223,6 @@ constraints: any.AC-Angle ==1.0, any.amazonka-ssm ==1.6.1, any.amazonka-stepfunctions ==1.6.1, any.amazonka-storagegateway ==1.6.1, - any.amazonka-sts ==1.6.1, any.amazonka-support ==1.6.1, any.amazonka-swf ==1.6.1, any.amazonka-test ==1.6.1, @@ -276,7 +275,7 @@ constraints: any.AC-Angle ==1.0, any.atom-basic ==0.2.5, any.atomic-primops ==0.8.4, any.atomic-write ==0.2.0.7, - any.attoparsec ==0.13.2.5, + any.attoparsec ==0.14.4, any.attoparsec-base64 ==0.0.0, any.attoparsec-binary ==0.2, any.attoparsec-expr ==0.1.1.2, @@ -404,6 +403,7 @@ constraints: any.AC-Angle ==1.0, any.byteorder ==1.0.4, any.bytes ==0.17.1, any.byteset ==0.1.1.0, + any.bytestring-arbitrary ==0.1.3, any.bytestring-builder ==0.10.8.2.0, any.bytestring-conversion ==0.3.1, any.bytestring-lexing ==0.5.0.8, @@ -678,7 +678,7 @@ constraints: any.AC-Angle ==1.0, 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-aeson ==0.2.8, any.deriving-compat ==0.5.10, any.derulo ==1.0.10, any.dhall ==1.39.0, @@ -1057,7 +1057,7 @@ constraints: any.AC-Angle ==1.0, 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 ==1.4.0.2, any.hashable-time ==0.2.1, any.hashids ==1.0.2.4, any.hashing ==0.1.0.1, @@ -1143,7 +1143,7 @@ constraints: any.AC-Angle ==1.0, any.hmpfr ==0.4.4, any.hnock ==0.4.0, any.hoauth2 ==1.16.0, - any.hoogle ==5.0.18.2, + any.hoogle ==5.0.18.3, any.hopenpgp-tools ==0.23.6, any.hopenssl ==2.2.4, any.hopfli ==0.2.2.1, @@ -1210,7 +1210,7 @@ constraints: any.AC-Angle ==1.0, 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.2, + any.http-api-data ==0.4.3, any.http-client-overrides ==0.1.1.0, any.http-common ==0.8.3.4, any.http-date ==0.0.11, @@ -1415,7 +1415,7 @@ constraints: any.AC-Angle ==1.0, any.leancheck-instances ==0.0.4, any.leapseconds-announced ==2017.1.0.1, any.learn-physics ==0.6.5, - any.lens ==4.19.2, + any.lens ==5.0.1, any.lens-action ==0.2.6, any.lens-aeson ==1.1.3, any.lens-csv ==0.1.1.0, @@ -1534,7 +1534,7 @@ constraints: any.AC-Angle ==1.0, any.metrics ==0.4.1.1, any.mfsolve ==0.3.2.0, any.microlens ==0.4.12.0, - any.microlens-aeson ==2.3.1, + any.microlens-aeson ==2.4.1, any.microlens-contra ==0.1.0.2, any.microlens-ghc ==0.4.13.1, any.microlens-mtl ==0.2.0.1, @@ -1731,9 +1731,9 @@ constraints: any.AC-Angle ==1.0, any.operational ==0.2.4.1, any.operational-class ==0.3.0.0, 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-core ==0.4, + any.optics-extra ==0.4, + any.optics-th ==0.4, any.optics-vl ==0.2.1, any.optional-args ==1.0.2, any.options ==1.2.1.1, @@ -1941,7 +1941,7 @@ constraints: any.AC-Angle ==1.0, 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-instances ==0.3.27, any.quickcheck-io ==0.2.0, any.quickcheck-simple ==0.1.1.1, any.quickcheck-special ==0.1.0.6, @@ -2109,7 +2109,7 @@ constraints: any.AC-Angle ==1.0, 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 ==1.2.0.1, any.semialign-indexed ==1.1, any.semialign-optics ==1.1, any.semigroupoid-extras ==5, @@ -2149,6 +2149,7 @@ constraints: any.AC-Angle ==1.0, any.servant-openapi3 ==2.0.1.2, any.servant-pipes ==0.15.3, any.servant-rawm ==1.0.0.0, + any.servant-swagger ==1.1.10, any.servant-swagger-ui ==0.3.5.3.52.5, any.servant-swagger-ui-core ==0.3.5, any.serverless-haskell ==0.12.6, @@ -2163,7 +2164,7 @@ constraints: any.AC-Angle ==1.0, 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.shakespeare ==2.0.25.1, any.shared-memory ==0.2.0.0, any.shell-conduit ==5.0.0, any.shell-escape ==0.2.0, @@ -2250,7 +2251,7 @@ constraints: any.AC-Angle ==1.0, any.squeal-postgresql ==0.7.0.1, any.squeather ==0.8.0.0, any.srcloc ==0.6, - any.stache ==2.3.0, + any.stache ==2.3.1, any.stack ==2.7.3, any.stack-templatizer ==0.1.0.2, any.stackcollapse-ghc ==0.0.1.3, @@ -2315,8 +2316,7 @@ constraints: any.AC-Angle ==1.0, any.sundown ==0.6, any.superbuffer ==0.3.1.1, any.svg-tree ==0.6.2.4, - any.swagger ==0.3.0, - any.swagger2 ==2.6, + any.swagger2 ==2.8.2, any.sweet-egison ==0.1.1.3, any.swish ==0.10.0.8, any.syb ==0.7.2.1, @@ -2408,7 +2408,7 @@ constraints: any.AC-Angle ==1.0, 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-short ==0.1.5, any.text-show ==3.9.2, any.text-show-instances ==3.8.4, any.text-zipper ==0.11, @@ -2449,7 +2449,7 @@ constraints: any.AC-Angle ==1.0, any.thyme ==0.3.5.5, any.tidal ==1.7.8, any.tile ==0.3.0.0, - any.time-compat ==1.9.5, + any.time-compat ==1.9.6.1, any.time-lens ==0.4.0.2, time-locale-compat -old-locale, any.time-locale-compat ==0.1.1.5, diff --git a/charts/brig/templates/configmap.yaml b/charts/brig/templates/configmap.yaml index 9f19a4056df..bbaa7171afb 100644 --- a/charts/brig/templates/configmap.yaml +++ b/charts/brig/templates/configmap.yaml @@ -212,6 +212,9 @@ data: setPropertyMaxValueLen: {{ .setPropertyMaxValueLen }} setDeleteThrottleMillis: {{ .setDeleteThrottleMillis }} setFederationDomain: {{ .setFederationDomain }} + {{- if .setFederationDomainConfigs }} + setFederationDomainConfigs: {{ toYaml .setFederationDomainConfigs | nindent 8 }} + {{- end }} {{- if .setSearchSameTeamOnly }} setSearchSameTeamOnly: {{ .setSearchSameTeamOnly }} {{- end }} diff --git a/charts/cargohold/templates/tests/cargohold-integration.yaml b/charts/cargohold/templates/tests/cargohold-integration.yaml index 3a4d1ed94b7..6decd33e477 100644 --- a/charts/cargohold/templates/tests/cargohold-integration.yaml +++ b/charts/cargohold/templates/tests/cargohold-integration.yaml @@ -23,11 +23,17 @@ spec: - name: "cargohold-config" mountPath: "/etc/wire/cargohold/conf" env: - # these dummy values are necessary for Amazonka's "Discover" + # these values are necessary for Amazonka's "Discover" - name: AWS_ACCESS_KEY_ID - value: "dummy" + valueFrom: + secretKeyRef: + name: cargohold + key: awsKeyId - name: AWS_SECRET_ACCESS_KEY - value: "dummy" + valueFrom: + secretKeyRef: + name: cargohold + key: awsSecretKey - name: AWS_REGION - value: "eu-west-1" + value: "{{ .Values.config.aws.region }}" restartPolicy: Never diff --git a/charts/nginz/values.yaml b/charts/nginz/values.yaml index 877b63c11f6..68306c486a8 100644 --- a/charts/nginz/values.yaml +++ b/charts/nginz/values.yaml @@ -123,6 +123,9 @@ nginx_conf: - path: /clients envs: - all + - path: /mls/key-packages + envs: + - all - path: /properties envs: - all diff --git a/charts/webapp/values.yaml b/charts/webapp/values.yaml index fe3cdbf7dec..366d4c246b0 100644 --- a/charts/webapp/values.yaml +++ b/charts/webapp/values.yaml @@ -9,7 +9,7 @@ resources: cpu: "1" image: repository: quay.io/wire/webapp - tag: "2022-02-08-production.0-v0.29.2-0-4d437bb" + tag: "2022-02-22-production.0-v0.29.2-0-abb34f5" service: https: externalPort: 443 diff --git a/deploy/services-demo/conf/nginz/nginx.conf b/deploy/services-demo/conf/nginz/nginx.conf index 0b86eb2c1bf..d7a3a6f4139 100644 --- a/deploy/services-demo/conf/nginz/nginx.conf +++ b/deploy/services-demo/conf/nginz/nginx.conf @@ -266,6 +266,11 @@ http { proxy_pass http://brig; } + location /mls/key-packages { + include common_response_with_zauth.conf; + proxy_pass http://brig; + } + location /properties { include common_response_with_zauth.conf; proxy_pass http://brig; diff --git a/dev-packages.nix b/dev-packages.nix index 21e897d1d91..8de34bf68d1 100644 --- a/dev-packages.nix +++ b/dev-packages.nix @@ -184,6 +184,7 @@ in pkgs.yq pkgs.rsync pkgs.netcat + pkgs.crypto_cli # To actually run buildah on nixos, I had to follow this: https://gist.github.com/alexhrescale/474d55635154e6b2cd6362c3bb403faf pkgs.buildah diff --git a/docs/reference/cassandra-schema.cql b/docs/reference/cassandra-schema.cql index ac4a6ce6461..3f7e7e17639 100644 --- a/docs/reference/cassandra-schema.cql +++ b/docs/reference/cassandra-schema.cql @@ -743,16 +743,17 @@ CREATE TABLE brig_test.user_cookies ( AND read_repair_chance = 0.0 AND speculative_retry = '99PERCENTILE'; -CREATE TABLE brig_test.service_whitelist ( - team uuid, - provider uuid, - service uuid, - PRIMARY KEY (team, provider, service) -) WITH CLUSTERING ORDER BY (provider ASC, service ASC) - AND bloom_filter_fp_chance = 0.01 +CREATE TABLE brig_test.mls_key_packages ( + user uuid, + client text, + ref blob, + data blob, + PRIMARY KEY ((user, client), ref) +) WITH CLUSTERING ORDER BY (ref ASC) + AND bloom_filter_fp_chance = 0.1 AND caching = {'keys': 'ALL', 'rows_per_partition': 'NONE'} AND comment = '' - AND compaction = {'class': 'org.apache.cassandra.db.compaction.SizeTieredCompactionStrategy', 'max_threshold': '32', 'min_threshold': '4'} + AND compaction = {'class': 'org.apache.cassandra.db.compaction.LeveledCompactionStrategy'} AND compression = {'chunk_length_in_kb': '64', 'class': 'org.apache.cassandra.io.compress.LZ4Compressor'} AND crc_check_chance = 1.0 AND dclocal_read_repair_chance = 0.1 @@ -893,6 +894,27 @@ CREATE TABLE brig_test.invitation_info ( AND read_repair_chance = 0.0 AND speculative_retry = '99PERCENTILE'; +CREATE TABLE brig_test.service_whitelist ( + team uuid, + provider uuid, + service uuid, + PRIMARY KEY (team, provider, service) +) WITH CLUSTERING ORDER BY (provider ASC, service ASC) + AND bloom_filter_fp_chance = 0.01 + AND caching = {'keys': 'ALL', 'rows_per_partition': 'NONE'} + AND comment = '' + AND compaction = {'class': 'org.apache.cassandra.db.compaction.SizeTieredCompactionStrategy', 'max_threshold': '32', 'min_threshold': '4'} + AND compression = {'chunk_length_in_kb': '64', 'class': 'org.apache.cassandra.io.compress.LZ4Compressor'} + AND crc_check_chance = 1.0 + AND dclocal_read_repair_chance = 0.1 + AND default_time_to_live = 0 + AND gc_grace_seconds = 864000 + AND max_index_interval = 2048 + AND memtable_flush_period_in_ms = 0 + AND min_index_interval = 128 + AND read_repair_chance = 0.0 + AND speculative_retry = '99PERCENTILE'; + CREATE TABLE brig_test.provider ( id uuid PRIMARY KEY, descr text, diff --git a/docs/reference/config-options.md b/docs/reference/config-options.md index 0e5e21fe381..649c9c90d12 100644 --- a/docs/reference/config-options.md +++ b/docs/reference/config-options.md @@ -417,3 +417,38 @@ This option is the default user locale to be used if it is not set in the user p optSettings: setDefaultUserLocale: en ``` + +### MLS settings + +#### `setKeyPackageMaximumLifetime` + +This option specifies the maximum accepted lifetime of a key package from the moment it is uploaded, in seconds. For example, when brig is configured as follows: + +``` +# [brig.yaml] +optSettings: + setKeyPackageMaximumLifetime: 1296000 # 15 days +``` + +any key package whose expiry date is set further than 15 days after upload time will be rejected. + + +### Federated domain specific configuration settings +#### Restrict user search + +The lookup and search of users on a wire instance can be configured. This can be done per federated domain. + +```yaml +# [brig.yaml] +optSettings: + setFederationDomainConfigs: + - domain: example.com + search_policy: no_search +``` + +Valid values for `search_policy` are: +- `no_search`: No users are returned by federated searches. +- `exact_handle_search`: Only users where the handle exactly matches are returned. +- `full_search`: Additionally to `exact_handle_search`, users are found by a freetext search on handle and display name. + +If there is no configuration for a domain, it's defaulted to `no_search`. diff --git a/hack/helm_vars/wire-server/values.yaml.gotmpl b/hack/helm_vars/wire-server/values.yaml.gotmpl index ffc2b22184c..c9d769841fb 100644 --- a/hack/helm_vars/wire-server/values.yaml.gotmpl +++ b/hack/helm_vars/wire-server/values.yaml.gotmpl @@ -75,6 +75,11 @@ brig: setMaxTeamSize: 32 setMaxConvSize: 16 setFederationDomain: integration.example.com + setFederationDomainConfigs: + - domain: integration.example.com + search_policy: full_search + - domain: federation-test-helper.{{ .Release.Namespace }}.svc.cluster.local + search_policy: full_search aws: sesEndpoint: http://fake-aws-ses:4569 sqsEndpoint: http://fake-aws-sqs:4568 diff --git a/hack/helmfile.yaml b/hack/helmfile.yaml index e345085bc1d..77bd85420b8 100644 --- a/hack/helmfile.yaml +++ b/hack/helmfile.yaml @@ -110,6 +110,8 @@ releases: value: {{ .Values.federationDomain }} - name: cargohold.config.settings.federationDomain value: {{ .Values.federationDomain }} + - name: brig.config.optSettings.setFederationDomainConfigs[0].domain + value: {{ .Values.federationDomainFed2 }} - name: '{{ .Values.namespace }}-wire-server-2' namespace: '{{ .Values.namespaceFed2 }}' @@ -124,3 +126,5 @@ releases: value: {{ .Values.federationDomainFed2 }} - name: cargohold.config.settings.federationDomain value: {{ .Values.federationDomainFed2 }} + - name: brig.config.optSettings.setFederationDomainConfigs[0].domain + value: {{ .Values.federationDomain }} diff --git a/libs/api-bot/api-bot.cabal b/libs/api-bot/api-bot.cabal index e7d323890ee..4d6aa0227fb 100644 --- a/libs/api-bot/api-bot.cabal +++ b/libs/api-bot/api-bot.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: e1d75e3473601a708c1154cd12e54b8990937ab09168ea17d8359c4573dd5987 +-- hash: 208b12ff1a7bb406c0e9b006b8badb293d9f3fb39750fa4df03a5267cf5d7bfd name: api-bot version: 0.4.2 @@ -80,7 +80,7 @@ library build-depends: HaskellNet >=0.5 , HaskellNet-SSL >=0.3 - , aeson >=0.11 + , aeson >=2.0.1.0 , ansi-terminal >=0.6 , api-client , async >=2.0 diff --git a/libs/api-bot/package.yaml b/libs/api-bot/package.yaml index 78bc45fedaf..92bf878d854 100644 --- a/libs/api-bot/package.yaml +++ b/libs/api-bot/package.yaml @@ -9,7 +9,7 @@ author: Wire Swiss GmbH maintainer: Wire Swiss GmbH license: AGPL-3 dependencies: -- aeson >=0.11 +- aeson >=2.0.1.0 - HaskellNet >=0.5 - HaskellNet-SSL >=0.3 - ansi-terminal >=0.6 diff --git a/libs/api-client/api-client.cabal b/libs/api-client/api-client.cabal index 810e6bd5fc8..88b0fc0af16 100644 --- a/libs/api-client/api-client.cabal +++ b/libs/api-client/api-client.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 55c2d2915aedb6a1fffd5a9cf920729e473ce67d106d456c5f499572967e8034 +-- hash: c5b993207775ad794fae01115aca3500cbdb2ce9458af0185734c9ee5e025814 name: api-client version: 0.4.2 @@ -77,7 +77,7 @@ library 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 + aeson >=2.0.1.0 , async >=2.0 , base >=4.6 && <5 , bilge >=0.21 diff --git a/libs/api-client/package.yaml b/libs/api-client/package.yaml index 3ff9298b3e4..ff7038e373e 100644 --- a/libs/api-client/package.yaml +++ b/libs/api-client/package.yaml @@ -9,7 +9,7 @@ author: Wire Swiss GmbH maintainer: Wire Swiss GmbH license: AGPL-3 dependencies: -- aeson >=0.11 +- aeson >=2.0.1.0 - async >=2.0 - base >=4.6 && <5 - bilge >=0.21 diff --git a/libs/api-client/src/Network/Wire/Client/API/Push.hs b/libs/api-client/src/Network/Wire/Client/API/Push.hs index c89176582b0..fe3d1c99166 100644 --- a/libs/api-client/src/Network/Wire/Client/API/Push.hs +++ b/libs/api-client/src/Network/Wire/Client/API/Push.hs @@ -54,11 +54,11 @@ import Control.Concurrent.Async import Control.Exception (bracket, finally, onException) import Control.Monad.Catch (MonadThrow) import Data.Aeson hiding (Error) +import qualified Data.Aeson.KeyMap as KeyMap import Data.Aeson.Types (Parser) import qualified Data.ByteString.Char8 as C import qualified Data.ByteString.Lazy as L import Data.Default.Class -import qualified Data.HashMap.Strict as M import Data.Id import Data.List.NonEmpty import Data.Text (pack) @@ -271,7 +271,7 @@ parseEvent _ t = fail $ "Unknown event type: " ++ T.unpack t instance FromJSON Event where parseJSON = withObject "event" $ \o -> - case M.lookup "type" o of + case KeyMap.lookup "type" o of Just (String t) -> parseEvent o t Just _ -> fail "Event type is not a string" Nothing -> fail "Missing event type" diff --git a/libs/bilge/bilge.cabal b/libs/bilge/bilge.cabal index 443c91a643d..6a4f75d69fe 100644 --- a/libs/bilge/bilge.cabal +++ b/libs/bilge/bilge.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 35c665e33076366baa18f5cac9e0d715b8d137004bf07f93b69eb9ae99c93195 +-- hash: 57b03ca9ff6cfe827c27bb6a0f6fb21156c8465d090f29d8a7a3d443bb308137 name: bilge version: 0.22.0 @@ -77,7 +77,7 @@ library 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 + aeson >=2.0.1.0 , ansi-terminal >=0.6 , base >=4.7 && <5 , bytestring >=0.9 diff --git a/libs/bilge/package.yaml b/libs/bilge/package.yaml index ef6cfca63ae..db1b7eacc09 100644 --- a/libs/bilge/package.yaml +++ b/libs/bilge/package.yaml @@ -12,7 +12,7 @@ license: AGPL-3 extra-source-files: - README.md dependencies: -- aeson >=0.6 +- aeson >=2.0.1.0 - ansi-terminal >=0.6 - base >=4.7 && <5 - bytestring >=0.9 diff --git a/libs/brig-types/brig-types.cabal b/libs/brig-types/brig-types.cabal index f7dad9b128b..7ceef8d6cea 100644 --- a/libs/brig-types/brig-types.cabal +++ b/libs/brig-types/brig-types.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 7d28adb77d06047d2fb59e1470865a151254230ed48075e7ea0d68d35366147c +-- hash: 8325cabb6835adebe7d0c773eb6059ab230d35b8f8b0b22c5d618f3dc91f66fd name: brig-types version: 1.35.0 @@ -88,7 +88,7 @@ library 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 - , aeson >=0.11 + , aeson >=2.0.1.0 , attoparsec >=0.10 , base ==4.* , bytestring-conversion >=0.2 @@ -97,7 +97,7 @@ library , deriving-swagger2 >=0.1.0 , imports , servant-server >=0.18.2 - , servant-swagger >=1.1.11 + , servant-swagger >=1.1.10 , string-conversions , swagger2 >=2.5 , text >=0.11 @@ -162,7 +162,7 @@ test-suite brig-types-tests 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 - , aeson >=0.11 + , aeson >=2.0.1.0 , attoparsec >=0.10 , base ==4.* , brig-types diff --git a/libs/brig-types/package.yaml b/libs/brig-types/package.yaml index 3e3ff5b73c9..1db199d045c 100644 --- a/libs/brig-types/package.yaml +++ b/libs/brig-types/package.yaml @@ -9,7 +9,7 @@ maintainer: Wire Swiss GmbH copyright: (c) 2017 Wire Swiss GmbH license: AGPL-3 dependencies: -- aeson >=0.11 +- aeson >=2.0.1.0 - attoparsec >=0.10 - base ==4.* - bytestring-conversion >=0.3.1 @@ -32,7 +32,7 @@ library: - cassandra-util - deriving-swagger2 >=0.1.0 - servant-server >=0.18.2 - - servant-swagger >=1.1.11 + - servant-swagger >=1.1.10 - string-conversions tests: brig-types-tests: diff --git a/libs/brig-types/src/Brig/Types/Intra.hs b/libs/brig-types/src/Brig/Types/Intra.hs index 88654161391..0b5982a4c23 100644 --- a/libs/brig-types/src/Brig/Types/Intra.hs +++ b/libs/brig-types/src/Brig/Types/Intra.hs @@ -33,7 +33,7 @@ where import Brig.Types.Connection import Brig.Types.User import Data.Aeson -import qualified Data.HashMap.Strict as M +import qualified Data.Aeson.KeyMap as KeyMap import Data.Id (TeamId, UserId) import Data.Misc (PlainTextPassword (..)) import qualified Data.Text as Text @@ -112,7 +112,7 @@ instance ToJSON UserAccount where toJSON (UserAccount u s) = case toJSON u of Object o -> - Object $ M.insert "status" (toJSON s) o + Object $ KeyMap.insert "status" (toJSON s) o other -> error $ "toJSON UserAccount: not an object: " <> show (encode other) diff --git a/libs/cassandra-util/cassandra-util.cabal b/libs/cassandra-util/cassandra-util.cabal index cc43fe634ae..9b4df221a2f 100644 --- a/libs/cassandra-util/cassandra-util.cabal +++ b/libs/cassandra-util/cassandra-util.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: a517eff209060dd72d3ddfdf3d5af57021c95a989da62cca8c98584144cbb7e3 +-- hash: aaa0bf2f2e8b434044d86eef4704bf30525c4c86315058ba1290f1d34d561c9e name: cassandra-util version: 0.16.5 @@ -71,7 +71,7 @@ library 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 + aeson >=2.0.1.0 , base >=4.6 && <5.0 , conduit , containers diff --git a/libs/cassandra-util/package.yaml b/libs/cassandra-util/package.yaml index cb0241dc840..9e0a8f13ca8 100644 --- a/libs/cassandra-util/package.yaml +++ b/libs/cassandra-util/package.yaml @@ -9,7 +9,7 @@ maintainer: Wire Swiss GmbH copyright: (c) 2017 Wire Swiss GmbH license: AGPL-3 dependencies: -- aeson >=0.7 +- aeson >=2.0.1.0 - base >=4.6 && <5.0 - conduit - containers diff --git a/libs/extended/src/System/Logger/Extended.hs b/libs/extended/src/System/Logger/Extended.hs index bc24e383502..9bf0cdddcf5 100644 --- a/libs/extended/src/System/Logger/Extended.hs +++ b/libs/extended/src/System/Logger/Extended.hs @@ -36,6 +36,7 @@ import Cassandra (MonadClient) import Control.Monad.Catch import Data.Aeson as Aeson import Data.Aeson.Encoding (list, pair, text) +import qualified Data.Aeson.Key as Key import qualified Data.ByteString.Builder as B import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.Map.Lazy as Map @@ -74,12 +75,12 @@ collect = foldr go (Element' mempty []) go (Bytes b) (Element' f m) = Element' f (b : m) go (Field k v) (Element' f m) = - Element' (f <> pair (cs . eval $ k) (text . cs . eval $ v)) m + Element' (f <> pair (Key.fromText . cs . eval $ k) (text . cs . eval $ v)) m jsonRenderer :: Renderer jsonRenderer _sep _dateFormat _logLevel = fromEncoding . elementToEncoding . collect -data StructuredJSONOutput = StructuredJSONOutput {lvl :: Maybe Level, msgs :: [Text], fields :: Map Text [Text]} +data StructuredJSONOutput = StructuredJSONOutput {lvl :: Maybe Level, msgs :: [Text], fields :: Map Key [Text]} -- | Displays all the 'Bytes' segments in a list under key @msgs@ and 'Field' -- segments as key-value pair in a JSON @@ -127,7 +128,7 @@ structuredJSONRenderer _sep _dateFmt _lvlThreshold logElems = in case parseLevel buildMsg of Nothing -> o {msgs = builderToText b : msgs o} Just lvl -> o {lvl = Just lvl} - Field k v -> o {fields = Map.insertWith (<>) (builderToText k) (map builderToText [v]) (fields o)} + Field k v -> o {fields = Map.insertWith (<>) (Key.fromText $ builderToText k) (map builderToText [v]) (fields o)} ) (StructuredJSONOutput Nothing [] mempty) diff --git a/libs/galley-types/galley-types.cabal b/libs/galley-types/galley-types.cabal index ace5070f043..fcd82abf5af 100644 --- a/libs/galley-types/galley-types.cabal +++ b/libs/galley-types/galley-types.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: fa648be72eab493846729545f4f4ec2a9cdc0f69add8e39150054510a9e9ac24 +-- hash: 9cb223453735258513c78908da15528c4b26797a131e07788f0dee41a0c469a4 name: galley-types version: 0.81.0 @@ -76,7 +76,7 @@ library 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 + , aeson >=2.0.1.0 , base ==4.* , bytestring , bytestring-conversion diff --git a/libs/galley-types/package.yaml b/libs/galley-types/package.yaml index d692a08ae4c..66ba6e181e1 100644 --- a/libs/galley-types/package.yaml +++ b/libs/galley-types/package.yaml @@ -14,7 +14,7 @@ dependencies: library: source-dirs: src dependencies: - - aeson >=0.6 + - aeson >=2.0.1.0 - base >=4 && <5 - bytestring - bytestring-conversion diff --git a/libs/gundeck-types/gundeck-types.cabal b/libs/gundeck-types/gundeck-types.cabal index 021a011e806..4a3dc9f6591 100644 --- a/libs/gundeck-types/gundeck-types.cabal +++ b/libs/gundeck-types/gundeck-types.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: dba11fae094eb5ca67d599427dc30c857a0263eb293cf917e14442c7101bdb97 +-- hash: 5e5b9d44e914092fd283c32d8a12768443221b3f7f7e0f41cc1388f17f4ce373 name: gundeck-types version: 1.45.0 @@ -73,7 +73,7 @@ library 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 + aeson >=2.0.1.0 , attoparsec >=0.10 , base ==4.* , bytestring >=0.10 diff --git a/libs/gundeck-types/package.yaml b/libs/gundeck-types/package.yaml index e6092dfa681..3926920e2ba 100644 --- a/libs/gundeck-types/package.yaml +++ b/libs/gundeck-types/package.yaml @@ -9,7 +9,7 @@ maintainer: Wire Swiss GmbH copyright: (c) 2017 Wire Swiss GmbH license: AGPL-3 dependencies: -- aeson >=0.6 +- aeson >=2.0.1.0 - attoparsec >=0.10 - base >=4 && <5 - bytestring >=0.10 diff --git a/libs/gundeck-types/src/Gundeck/Types/Event.hs b/libs/gundeck-types/src/Gundeck/Types/Event.hs index 72c0f3e9ae6..efe8f821a85 100644 --- a/libs/gundeck-types/src/Gundeck/Types/Event.hs +++ b/libs/gundeck-types/src/Gundeck/Types/Event.hs @@ -20,7 +20,7 @@ module Gundeck.Types.Event where import Data.Aeson -import qualified Data.HashMap.Strict as M +import qualified Data.Aeson.KeyMap as KeyMap import Data.Json.Util import Gundeck.Types.Push import Imports @@ -37,7 +37,7 @@ instance ToJSON PushRemove where instance ToJSONObject PushRemove where toJSONObject (PushRemove t) = - M.fromList + KeyMap.fromList [ "type" .= ("user.push-remove" :: Text), "token" .= t ] diff --git a/libs/hscim/hscim.cabal b/libs/hscim/hscim.cabal index 381f3bc0939..c75502af5df 100644 --- a/libs/hscim/hscim.cabal +++ b/libs/hscim/hscim.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: cca3008213a478b2de914ed4e3bb1946613cc6cf4103168bacbe9b002e73764b +-- hash: 492b6e29bec45fc722bb0c706c9bc29c4b8e86fa0bc88cc74e390c09026d2ea8 name: hscim version: 0.3.6 @@ -88,14 +88,14 @@ library TypeSynonymInstances ghc-options: -Wall -Werror build-depends: - aeson >=1.4.5 && <1.5 + aeson >=2 , aeson-qq >=0.8.2 && <0.9 - , attoparsec >=0.13.2 && <0.14 + , attoparsec >=0.13.2 && <0.15 , base >=4.12 && <4.15 , bytestring >=0.10.8 && <0.11 , case-insensitive >=1.2.1.0 && <1.3 , email-validate >=2.3.2 && <2.4 - , hashable >=1.2.7 && <1.4 + , hashable >=1.2.7 && <1.5 , hedgehog >=1.0.1 && <1.1 , hspec >=2.7.1 && <2.8 , hspec-expectations >=0.8.2 && <0.9 @@ -116,7 +116,7 @@ library , servant-client-core >=0.16.2 && <0.19 , servant-server >=0.16.2 && <0.19 , stm >=2.5.0 && <2.6 - , stm-containers >=1.1.0 && <1.2 + , stm-containers >=1.1.0 && <1.3 , string-conversions >=0.4.0 && <0.5 , template-haskell >=2.14.0 && <2.17 , text >=1.2.3 && <1.3 @@ -124,7 +124,7 @@ library , unordered-containers >=0.2.10 && <0.3 , uuid >=1.3.13 && <1.4 , wai >=3.2.2 && <3.3 - , wai-extra >=3.0.28 && <3.1 + , wai-extra >=3.0.28 && <3.2 , warp >=3.2.28 && <3.4 default-language: Haskell2010 @@ -153,14 +153,14 @@ executable hscim-server TypeSynonymInstances ghc-options: -Wall -Werror -threaded -rtsopts -with-rtsopts=-N build-depends: - aeson >=1.4.5 && <1.5 + aeson >=2 , aeson-qq >=0.8.2 && <0.9 - , attoparsec >=0.13.2 && <0.14 + , attoparsec >=0.13.2 && <0.15 , base >=4.12 && <4.15 , bytestring >=0.10.8 && <0.11 , case-insensitive >=1.2.1.0 && <1.3 , email-validate >=2.3.2 && <2.4 - , hashable >=1.2.7 && <1.4 + , hashable >=1.2.7 && <1.5 , hedgehog >=1.0.1 && <1.1 , hscim , hspec >=2.7.1 && <2.8 @@ -182,7 +182,7 @@ executable hscim-server , servant-client-core >=0.16.2 && <0.19 , servant-server >=0.16.2 && <0.19 , stm >=2.5.0 && <2.6 - , stm-containers >=1.1.0 && <1.2 + , stm-containers >=1.1.0 && <1.3 , string-conversions >=0.4.0 && <0.5 , template-haskell >=2.14.0 && <2.17 , text >=1.2.3 && <1.3 @@ -190,7 +190,7 @@ executable hscim-server , unordered-containers >=0.2.10 && <0.3 , uuid >=1.3.13 && <1.4 , wai >=3.2.2 && <3.3 - , wai-extra >=3.0.28 && <3.1 + , wai-extra >=3.0.28 && <3.2 , warp >=3.2.28 && <3.4 default-language: Haskell2010 @@ -236,14 +236,14 @@ test-suite spec build-tool-depends: hspec-discover:hspec-discover build-depends: - aeson >=1.4.5 && <1.5 + aeson >=2 , aeson-qq >=0.8.2 && <0.9 - , attoparsec >=0.13.2 && <0.14 + , attoparsec >=0.13.2 && <0.15 , base >=4.12 && <4.15 , bytestring >=0.10.8 && <0.11 , case-insensitive >=1.2.1.0 && <1.3 , email-validate >=2.3.2 && <2.4 - , hashable >=1.2.7 && <1.4 + , hashable >=1.2.7 && <1.5 , hedgehog >=1.0.1 && <1.1 , hscim , hspec >=2.7.1 && <2.8 @@ -253,6 +253,7 @@ test-suite spec , http-media >=0.8.0 && <0.9 , http-types >=0.12.3 && <0.13 , hw-hspec-hedgehog >=0.1.0 && <0.2 + , indexed-traversable , list-t >=1.0.4 && <1.1 , microlens >=0.4.10 && <0.5 , mmorph >=1.1.3 && <1.2 @@ -265,7 +266,7 @@ test-suite spec , servant-client-core >=0.16.2 && <0.19 , servant-server >=0.16.2 && <0.19 , stm >=2.5.0 && <2.6 - , stm-containers >=1.1.0 && <1.2 + , stm-containers >=1.1.0 && <1.3 , string-conversions >=0.4.0 && <0.5 , template-haskell >=2.14.0 && <2.17 , text >=1.2.3 && <1.3 @@ -273,6 +274,6 @@ test-suite spec , unordered-containers >=0.2.10 && <0.3 , uuid >=1.3.13 && <1.4 , wai >=3.2.2 && <3.3 - , wai-extra >=3.0.28 && <3.1 + , wai-extra >=3.0.28 && <3.2 , warp >=3.2.28 && <3.4 default-language: Haskell2010 diff --git a/libs/hscim/package.yaml b/libs/hscim/package.yaml index 9e4d5911cc7..5b4973bc135 100644 --- a/libs/hscim/package.yaml +++ b/libs/hscim/package.yaml @@ -38,13 +38,13 @@ extra-source-files: - CHANGELOG dependencies: - - aeson >= 1.4.5 && < 1.5 - - attoparsec >= 0.13.2 && < 0.14 + - aeson >= 2 + - attoparsec >= 0.13.2 && < 0.15 - bytestring >= 0.10.8 && < 0.11 - base >= 4.12 && < 4.15 - case-insensitive >= 1.2.1.0 && < 1.3 - scientific >= 0.3.6 && < 0.4 - - hashable >= 1.2.7 && < 1.4 + - hashable >= 1.2.7 && < 1.5 - text >= 1.2.3 && < 1.3 - time >= 1.8.0 && < 1.10 - template-haskell >= 2.14.0 && < 2.17 @@ -60,7 +60,7 @@ dependencies: - hspec-expectations >= 0.8.2 && < 0.9 - http-types >= 0.12.3 && < 0.13 - wai >= 3.2.2 && < 3.3 - - wai-extra >= 3.0.28 && < 3.1 + - wai-extra >= 3.0.28 && < 3.2 - http-api-data >= 0.4.1 && < 0.5 - http-media >= 0.8.0 && < 0.9 - hw-hspec-hedgehog >= 0.1.0 && < 0.2 @@ -72,7 +72,7 @@ dependencies: - servant-client >= 0.16.2 && < 0.19 - servant-client-core >= 0.16.2 && < 0.19 - warp >= 3.2.28 && < 3.4 - - stm-containers >= 1.1.0 && < 1.2 + - stm-containers >= 1.1.0 && < 1.3 - string-conversions >= 0.4.0 && < 0.5 - uuid >= 1.3.13 && < 1.4 - retry >= 0.8.1.0 && < 0.9 @@ -100,3 +100,4 @@ tests: - hspec-discover:hspec-discover dependencies: - hscim + - indexed-traversable diff --git a/libs/hscim/src/Web/Scim/Capabilities/MetaSchema.hs b/libs/hscim/src/Web/Scim/Capabilities/MetaSchema.hs index 9bced57cc65..3f5f0e1cdf4 100644 --- a/libs/hscim/src/Web/Scim/Capabilities/MetaSchema.hs +++ b/libs/hscim/src/Web/Scim/Capabilities/MetaSchema.hs @@ -27,7 +27,7 @@ module Web.Scim.Capabilities.MetaSchema where import Data.Aeson -import qualified Data.HashMap.Lazy as HML +import qualified Data.Aeson.KeyMap as KeyMap import Data.Text (Text) import Data.Typeable (Typeable, cast) import Servant hiding (URI) @@ -56,8 +56,8 @@ data Supported a = Supported instance ToJSON a => ToJSON (Supported a) where toJSON (Supported (ScimBool b) v) = case toJSON v of - (Object o) -> Object $ HML.insert "supported" (Bool b) o - _ -> Object $ HML.fromList [("supported", Bool b)] + (Object o) -> Object $ KeyMap.insert "supported" (Bool b) o + _ -> Object $ KeyMap.fromList [("supported", Bool b)] -- | See module "Test.Schema.MetaSchemaSpec" for golden tests that explain this instance -- better. diff --git a/libs/hscim/src/Web/Scim/Schema/Common.hs b/libs/hscim/src/Web/Scim/Schema/Common.hs index 13f6e198756..4fdbfc3d314 100644 --- a/libs/hscim/src/Web/Scim/Schema/Common.hs +++ b/libs/hscim/src/Web/Scim/Schema/Common.hs @@ -21,9 +21,9 @@ module Web.Scim.Schema.Common where import Data.Aeson +import qualified Data.Aeson.Key as Key +import qualified Data.Aeson.KeyMap as KeyMap import qualified Data.CaseInsensitive as CI -import qualified Data.HashMap.Lazy as HML -import qualified Data.HashMap.Strict as HM import Data.String.Conversions (cs) import Data.Text (pack, unpack) import qualified Network.URI as Network @@ -36,7 +36,7 @@ data WithId id a = WithId instance (ToJSON id, ToJSON a) => ToJSON (WithId id a) where toJSON (WithId i v) = case toJSON v of - (Object o) -> Object (HML.insert "id" (toJSON i) o) + (Object o) -> Object (KeyMap.insert "id" (toJSON i) o) other -> other instance (FromJSON id, FromJSON a) => FromJSON (WithId id a) where @@ -95,11 +95,14 @@ parseOptions = -- (FUTUREWORK: The "recursively" part is a bit of a waste and could be dropped, but we would -- have to spend more effort in making sure it is always called manually in nested parsers.) jsonLower :: Value -> Value -jsonLower (Object o) = Object . HM.fromList . fmap lowerPair . HM.toList $ o +jsonLower (Object o) = Object . KeyMap.fromList . fmap lowerPair . KeyMap.toList $ o where - lowerPair (key, val) = (CI.foldCase key, jsonLower val) + lowerPair (key, val) = (lowerKey key, jsonLower val) jsonLower (Array x) = Array (jsonLower <$> x) jsonLower same@(String _) = same -- (only object attributes, not all texts in the value side of objects!) jsonLower same@(Number _) = same jsonLower same@(Bool _) = same jsonLower same@Null = same + +lowerKey :: Key.Key -> Key.Key +lowerKey = Key.fromText . CI.foldCase . Key.toText diff --git a/libs/hscim/src/Web/Scim/Schema/Meta.hs b/libs/hscim/src/Web/Scim/Schema/Meta.hs index 3f4dc66dd19..ce014e38472 100644 --- a/libs/hscim/src/Web/Scim/Schema/Meta.hs +++ b/libs/hscim/src/Web/Scim/Schema/Meta.hs @@ -18,7 +18,7 @@ module Web.Scim.Schema.Meta where import Data.Aeson -import qualified Data.HashMap.Lazy as HML +import qualified Data.Aeson.KeyMap as KeyMap import Data.Text (Text, pack, unpack) import qualified Data.Text as Text import Data.Time.Clock @@ -77,7 +77,7 @@ data WithMeta a = WithMeta instance (ToJSON a) => ToJSON (WithMeta a) where toJSON (WithMeta m v) = case toJSON v of - (Object o) -> Object (HML.insert "meta" (toJSON m) o) + (Object o) -> Object (KeyMap.insert "meta" (toJSON m) o) other -> other instance (FromJSON a) => FromJSON (WithMeta a) where diff --git a/libs/hscim/src/Web/Scim/Schema/PatchOp.hs b/libs/hscim/src/Web/Scim/Schema/PatchOp.hs index 49ceffae336..7c4fb3b692c 100644 --- a/libs/hscim/src/Web/Scim/Schema/PatchOp.hs +++ b/libs/hscim/src/Web/Scim/Schema/PatchOp.hs @@ -19,16 +19,18 @@ module Web.Scim.Schema.PatchOp where import Control.Applicative import Control.Monad.Except +import qualified Data.Aeson.Key as Key +import qualified Data.Aeson.KeyMap as KeyMap import Data.Aeson.Types (FromJSON (parseJSON), ToJSON (toJSON), Value (String), object, withObject, withText, (.:), (.:?), (.=)) import qualified Data.Aeson.Types as Aeson import Data.Attoparsec.ByteString (Parser, endOfInput, parseOnly) import Data.Bifunctor (first) import qualified Data.CaseInsensitive as CI -import qualified Data.HashMap.Strict as HashMap import Data.Text (Text) import Data.Text.Encoding (encodeUtf8) import Web.Scim.AttrName (AttrName (..)) import Web.Scim.Filter (AttrPath (..), SubAttr (..), ValuePath (..), pAttrPath, pSubAttr, pValuePath, rAttrPath, rSubAttr, rValuePath) +import Web.Scim.Schema.Common (lowerKey) import Web.Scim.Schema.Error import Web.Scim.Schema.Schema (Schema (PatchOp20)) import Web.Scim.Schema.UserTypes (UserTypes (supportedSchemas)) @@ -85,7 +87,7 @@ rPath (IntoValuePath valuePath subAttr) = rValuePath valuePath <> maybe "" rSubA -- can't control what errors FromJSON throws :/ instance UserTypes tag => FromJSON (PatchOp tag) where parseJSON = withObject "PatchOp" $ \v -> do - let o = HashMap.fromList . map (first CI.foldCase) . HashMap.toList $ v + let o = KeyMap.fromList . map (first lowerKey) . KeyMap.toList $ v schemas' :: [Schema] <- o .: "schemas" guard $ PatchOp20 `elem` schemas' operations <- Aeson.explicitParseField (Aeson.listParser $ operationFromJSON (supportedSchemas @tag)) o "operations" @@ -100,7 +102,7 @@ instance ToJSON (PatchOp tag) where operationFromJSON :: [Schema] -> Value -> Aeson.Parser Operation operationFromJSON schemas' = withObject "Operation" $ \v -> do - let o = HashMap.fromList . map (first CI.foldCase) . HashMap.toList $ v + let o = KeyMap.fromList . map (first lowerKey) . KeyMap.toList $ v Operation <$> (o .: "op") <*> (Aeson.explicitParseFieldMaybe (pathFromJSON schemas') o "path") @@ -139,9 +141,9 @@ instance ToJSON Path where class Patchable a where applyOperation :: (MonadError ScimError m) => a -> Operation -> m a -instance Patchable (HashMap.HashMap Text Text) where +instance Patchable (KeyMap.KeyMap Text) where applyOperation theMap (Operation Remove (Just (NormalPath (AttrPath _schema (AttrName attrName) _subAttr))) _) = - pure $ HashMap.delete attrName theMap + pure $ KeyMap.delete (Key.fromText attrName) theMap applyOperation theMap (Operation _AddOrReplace (Just (NormalPath (AttrPath _schema (AttrName attrName) _subAttr))) (Just (String val))) = - pure $ HashMap.insert attrName val theMap + pure $ KeyMap.insert (Key.fromText attrName) val theMap applyOperation _ _ = throwError $ badRequest InvalidValue $ Just "Unsupported operation" diff --git a/libs/hscim/src/Web/Scim/Schema/User.hs b/libs/hscim/src/Web/Scim/Schema/User.hs index 1e2a8c96dc4..4525ccb275f 100644 --- a/libs/hscim/src/Web/Scim/Schema/User.hs +++ b/libs/hscim/src/Web/Scim/Schema/User.hs @@ -74,8 +74,8 @@ where import Control.Monad.Except import Data.Aeson -import qualified Data.CaseInsensitive as CI -import qualified Data.HashMap.Strict as HM +import qualified Data.Aeson.Key as Key +import qualified Data.Aeson.KeyMap as KeyMap import Data.List ((\\)) import Data.Text (Text, pack) import qualified Data.Text as Text @@ -181,7 +181,7 @@ empty schemas userName extra = instance FromJSON (UserExtra tag) => FromJSON (User tag) where parseJSON = withObject "User" $ \obj -> do -- Lowercase all fields - let o = HM.fromList . map (over _1 CI.foldCase) . HM.toList $ obj + let o = KeyMap.fromList . map (over _1 lowerKey) . KeyMap.toList $ obj schemas <- o .:? "schemas" <&> \case Nothing -> [User20] @@ -212,7 +212,7 @@ instance FromJSON (UserExtra tag) => FromJSON (User tag) where instance ToJSON (UserExtra tag) => ToJSON (User tag) where toJSON User {..} = let mainObject = - HM.fromList $ + KeyMap.fromList $ concat [ ["schemas" .= schemas], ["userName" .= userName], @@ -239,8 +239,8 @@ instance ToJSON (UserExtra tag) => ToJSON (User tag) where extraObject = case toJSON extra of Null -> mempty Object x -> x - other -> HM.fromList ["extra" .= other] - in Object (HM.union mainObject extraObject) + other -> KeyMap.fromList ["extra" .= other] + in Object (KeyMap.union mainObject extraObject) where -- Omit a field if it's Nothing optionalField fname = \case @@ -321,7 +321,7 @@ applyUserOperation _ (Operation Replace (Just (IntoValuePath _ _)) _) = do throwError (badRequest InvalidPath (Just "can not lens into multi-valued attributes yet")) applyUserOperation user (Operation Replace Nothing (Just value)) = do case value of - Object hm | null ((AttrName <$> HM.keys hm) \\ ["username", "displayname", "externalid", "active"]) -> do + Object hm | null ((AttrName . Key.toText <$> KeyMap.keys hm) \\ ["username", "displayname", "externalid", "active"]) -> do (u :: User tag) <- resultToScimError $ fromJSON value pure $ user diff --git a/libs/hscim/src/Web/Scim/Test/Util.hs b/libs/hscim/src/Web/Scim/Test/Util.hs index bd2d2d71392..e05dfad1570 100644 --- a/libs/hscim/src/Web/Scim/Test/Util.hs +++ b/libs/hscim/src/Web/Scim/Test/Util.hs @@ -52,13 +52,14 @@ where import qualified Control.Retry as Retry import Data.Aeson +import qualified Data.Aeson.Key as Key +import qualified Data.Aeson.KeyMap as KeyMap import Data.Aeson.QQ import Data.Aeson.Types (JSONPathElement (Key)) import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 import qualified Data.ByteString.Lazy as L -import qualified Data.HashMap.Strict as SMap import Data.Proxy import Data.Text import Data.UUID as UUID @@ -231,16 +232,16 @@ getField (Field a) = a -- Copied from https://hackage.haskell.org/package/aeson-extra-0.4.1.1/docs/src/Data.Aeson.Extra.SingObject.html instance (KnownSymbol s, FromJSON a) => FromJSON (Field s a) where parseJSON = withObject ("Field " <> show key) $ \obj -> - case SMap.lookup key obj of + case KeyMap.lookup key obj of Nothing -> fail $ "key " ++ show key ++ " not present" Just v -> Field <$> parseJSON v Key key where - key = pack $ symbolVal (Proxy :: Proxy s) + key = Key.fromString $ symbolVal (Proxy :: Proxy s) instance (KnownSymbol s, ToJSON a) => ToJSON (Field s a) where toJSON (Field x) = object [key .= x] where - key = pack $ symbolVal (Proxy :: Proxy s) + key = Key.fromString $ symbolVal (Proxy :: Proxy s) ---------------------------------------------------------------------------- -- Tag diff --git a/libs/hscim/test/Test/Schema/PatchOpSpec.hs b/libs/hscim/test/Test/Schema/PatchOpSpec.hs index 78d2598faee..6ddb155e07f 100644 --- a/libs/hscim/test/Test/Schema/PatchOpSpec.hs +++ b/libs/hscim/test/Test/Schema/PatchOpSpec.hs @@ -21,13 +21,12 @@ module Test.Schema.PatchOpSpec where import qualified Data.Aeson as Aeson +import qualified Data.Aeson.KeyMap as KeyMap import Data.Aeson.Types (Result (Error, Success), Value (String), fromJSON, toJSON) import qualified Data.Aeson.Types as Aeson import Data.Attoparsec.ByteString (parseOnly) import Data.Either (isLeft) import Data.Foldable (for_) -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HM import Data.Text (Text) import Data.Text.Encoding (decodeUtf8, encodeUtf8) import HaskellWorks.Hspec.Hedgehog (require) @@ -82,24 +81,24 @@ type PatchTestTag = TestTag () () () () spec :: Spec spec = do - describe "Patchable" $ do + describe "Patchable" $ describe "HashMap Text Text" $ do it "supports `Add` operation" $ do - let theMap :: HashMap Text Text = HM.empty + let theMap = KeyMap.empty @Text operation = Operation Add (Just $ NormalPath (AttrPath Nothing (AttrName "key") Nothing)) $ Just "value" - applyOperation theMap operation `shouldBe` (Right $ HM.singleton "key" "value") + applyOperation theMap operation `shouldBe` Right (KeyMap.singleton "key" "value") it "supports `Replace` operation" $ do - let theMap :: HashMap Text Text = HM.singleton "key" "value1" + let theMap = KeyMap.singleton @Text "key" "value1" operation = Operation Replace (Just $ NormalPath (AttrPath Nothing (AttrName "key") Nothing)) $ Just "value2" - applyOperation theMap operation `shouldBe` (Right $ HM.singleton "key" "value2") + applyOperation theMap operation `shouldBe` Right (KeyMap.singleton "key" "value2") it "supports `Delete` operation" $ do - let theMap :: HashMap Text Text = HM.fromList [("key1", "value1"), ("key2", "value2")] + let theMap = KeyMap.fromList @Text [("key1", "value1"), ("key2", "value2")] operation = Operation Remove (Just $ NormalPath (AttrPath Nothing (AttrName "key1") Nothing)) Nothing - applyOperation theMap operation `shouldBe` (Right $ HM.singleton "key2" "value2") + applyOperation theMap operation `shouldBe` Right (KeyMap.singleton "key2" "value2") it "gracefully rejects invalid/unsupported operations" $ do - let theMap :: HashMap Text Text = HM.fromList [("key1", "value1"), ("key2", "value2")] - key1Path = (AttrPath Nothing (AttrName "key1") Nothing) - key2Path = (AttrPath Nothing (AttrName "key2") Nothing) + let theMap = KeyMap.fromList @Text [("key1", "value1"), ("key2", "value2")] + key1Path = AttrPath Nothing (AttrName "key1") Nothing + key2Path = AttrPath Nothing (AttrName "key2") Nothing invalidOperations = [ Operation Add (Just $ NormalPath key1Path) Nothing, -- Nothing to add Operation Replace (Just $ NormalPath key1Path) Nothing, -- Nothing to replace @@ -108,7 +107,7 @@ spec = do ] mapM_ (\o -> applyOperation theMap o `shouldSatisfy` isLeft) invalidOperations describe "urn:ietf:params:scim:api:messages:2.0:PatchOp" $ do - describe "The body of each request MUST contain the \"schemas\" attribute with the URI value of \"urn:ietf:params:scim:api:messages:2.0:PatchOp\"." $ do + describe "The body of each request MUST contain the \"schemas\" attribute with the URI value of \"urn:ietf:params:scim:api:messages:2.0:PatchOp\"." $ it "rejects an empty schemas list" $ do fromJSON @(PatchOp PatchTestTag) [scim| { @@ -120,7 +119,7 @@ spec = do it "roundtrips Path" $ require $ prop_roundtrip @PatchTestTag it "roundtrips PatchOp" $ require $ prop_roundtrip_PatchOp @PatchTestTag it "case-insensitive" $ require $ mk_prop_caseInsensitive (genSimplePatchOp @PatchTestTag) - it "rejects invalid operations" $ do + it "rejects invalid operations" $ fromJSON @(PatchOp PatchTestTag) [scim| { "schemas": ["urn:ietf:params:scim:api:messages:2.0:PatchOp"], @@ -128,9 +127,9 @@ spec = do }|] `shouldSatisfy` (not . isSuccess) -- TODO(arianvp/akshay): Implement if required - xit "rejects unknown paths" $ do + xit "rejects unknown paths" $ Aeson.parse (pathFromJSON [User20]) (Aeson.String "unknown.field") `shouldSatisfy` (not . isSuccess) - it "rejects invalid paths" $ do + it "rejects invalid paths" $ Aeson.parse (pathFromJSON [User20]) "unknown]field" `shouldSatisfy` (not . isSuccess) describe "Examples from https://tools.ietf.org/html/rfc7644#section-3.5.2 Figure 8" $ do let examples = @@ -140,4 +139,4 @@ spec = do "members[value eq \"2819c223-7f76-453a-919d-413861904646\"]", "members[value eq \"2819c223-7f76-453a-919d-413861904646\"].displayname" ] - for_ examples $ \p -> it ("parses " ++ show p) $ (rPath <$> parseOnly (pPath (supportedSchemas @PatchTestTag)) p) `shouldBe` Right (decodeUtf8 p) + for_ examples $ \p -> it ("parses " ++ show p) $ rPath <$> parseOnly (pPath (supportedSchemas @PatchTestTag)) p `shouldBe` Right (decodeUtf8 p) diff --git a/libs/hscim/test/Test/Schema/UserSpec.hs b/libs/hscim/test/Test/Schema/UserSpec.hs index b28ab428c55..cbe1cddc894 100644 --- a/libs/hscim/test/Test/Schema/UserSpec.hs +++ b/libs/hscim/test/Test/Schema/UserSpec.hs @@ -25,10 +25,9 @@ module Test.Schema.UserSpec where import Data.Aeson -import qualified Data.CaseInsensitive as CI +import qualified Data.Aeson.KeyMap as KeyMap import Data.Either (isLeft, isRight) import Data.Foldable (for_) -import qualified Data.HashMap.Strict as HM import Data.Text (Text) import HaskellWorks.Hspec.Hedgehog (require) import Hedgehog @@ -41,7 +40,7 @@ import Test.Schema.Util (genUri, mk_prop_caseInsensitive) import Text.Email.Validate (emailAddress) import qualified Web.Scim.Class.User as UserClass import Web.Scim.Filter (AttrPath (..)) -import Web.Scim.Schema.Common (ScimBool (ScimBool), URI (..), WithId (..)) +import Web.Scim.Schema.Common (ScimBool (ScimBool), URI (..), WithId (..), lowerKey) import qualified Web.Scim.Schema.ListResponse as ListResponse import Web.Scim.Schema.Meta (ETag (Strong, Weak), Meta (..), WithMeta (..)) import Web.Scim.Schema.PatchOp (Op (..), Operation (..), PatchOp (..), Patchable (..), Path (..)) @@ -65,14 +64,14 @@ prop_roundtrip = property $ do type PatchTag = TestTag Text () () UserExtraPatch -type UserExtraPatch = HM.HashMap Text Text +type UserExtraPatch = KeyMap.KeyMap Text spec :: Spec spec = do describe "applyPatch" $ do it "only applies patch for supported fields" $ do let schemas' = [] - let extras = HM.empty + let extras = KeyMap.empty let user :: User PatchTag = User.empty schemas' "hello" extras for_ [ ("username", String "lol"), @@ -86,7 +85,7 @@ spec = do User.applyPatch user patchOp `shouldSatisfy` isRight it "does not support multi-value attributes" $ do let schemas' = [] - let extras = HM.empty + let extras = KeyMap.empty let user :: User PatchTag = User.empty schemas' "hello" extras for_ [ ("schemas", toJSON @[Schema] mempty), @@ -113,12 +112,12 @@ spec = do User.applyPatch user patchOp `shouldSatisfy` isLeft it "applies patch to `extra`" $ do let schemas' = [] - let extras = HM.empty + let extras = KeyMap.empty let user :: User PatchTag = User.empty schemas' "hello" extras let Right programmingLanguagePath = PatchOp.parsePath (User.supportedSchemas @PatchTag) "urn:hscim:test:programmingLanguage" let operation = Operation Replace (Just programmingLanguagePath) (Just (toJSON @Text "haskell")) let patchOp = PatchOp [operation] - User.extra <$> (User.applyPatch user patchOp) `shouldBe` Right (HM.singleton "programmingLanguage" "haskell") + User.extra <$> (User.applyPatch user patchOp) `shouldBe` Right (KeyMap.singleton "programmingLanguage" "haskell") describe "JSON serialization" $ do it "handles all fields" $ do require prop_roundtrip @@ -444,7 +443,7 @@ instance FromJSON UserExtraTest where Nothing -> pure UserExtraEmpty Just (lowercase -> o2) -> UserExtraObject <$> o2 .: "test" where - lowercase = HM.fromList . map (over _1 CI.foldCase) . HM.toList + lowercase = KeyMap.fromList . map (over _1 lowerKey) . KeyMap.toList instance ToJSON UserExtraTest where toJSON UserExtraEmpty = object [] diff --git a/libs/hscim/test/Test/Schema/Util.hs b/libs/hscim/test/Test/Schema/Util.hs index 47a533d0c27..63c13b78e70 100644 --- a/libs/hscim/test/Test/Schema/Util.hs +++ b/libs/hscim/test/Test/Schema/Util.hs @@ -25,10 +25,13 @@ module Test.Schema.Util where import Data.Aeson -import qualified Data.HashMap.Strict as HM +import qualified Data.Aeson.Key as Key +import Data.Aeson.KeyMap as KeyMap +import Data.Foldable.WithIndex (ifoldl') import Data.Text (Text, toCaseFold, toLower, toUpper) import Hedgehog import Hedgehog.Gen as Gen +import Lens.Micro (over) import Network.URI.Static import Web.Scim.Schema.Common (URI (..)) @@ -47,9 +50,12 @@ mk_prop_caseInsensitive gen = property $ do where withCasing :: (Text -> Text) -> Value -> Value withCasing toCasing = \case - Object obj -> Object $ HM.foldlWithKey' (\u k v -> HM.insert (toCasing k) (withCasing toCasing v) u) HM.empty obj + Object obj -> Object $ ifoldl' (\k u v -> KeyMap.insert (over keyTextL toCasing k) (withCasing toCasing v) u) KeyMap.empty obj Array arr -> Array $ withCasing toCasing <$> arr same@(Number _) -> same same@(String _) -> same same@(Bool _) -> same same@Null -> same + +keyTextL :: Functor f => (Text -> f Text) -> Key -> f Key +keyTextL f key = fmap Key.fromText (f (Key.toText key)) diff --git a/libs/ropes/package.yaml b/libs/ropes/package.yaml index 9fe51a38257..41be6c98102 100644 --- a/libs/ropes/package.yaml +++ b/libs/ropes/package.yaml @@ -15,7 +15,7 @@ dependencies: library: source-dirs: src dependencies: - - aeson >=0.6 + - aeson >=2.0.1.0 - base ==4.* - http-client >=0.5 - http-types >=0.7 diff --git a/libs/ropes/ropes.cabal b/libs/ropes/ropes.cabal index 58b7ae927f0..51c228d4b02 100644 --- a/libs/ropes/ropes.cabal +++ b/libs/ropes/ropes.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 037e046804ad490d6ca65048cb0f7809f2b15ff57a4b513a64cf34153a2a7342 +-- hash: 8ecd96e484d77945f2e5e3bf9e52fbe5847ee47bdfa13e7ecb07c186db73e04c name: ropes version: 0.4.20 @@ -67,7 +67,7 @@ library 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 + aeson >=2.0.1.0 , base ==4.* , bytestring >=0.9 , errors >=2.0 diff --git a/libs/schema-profunctor/README.md b/libs/schema-profunctor/README.md index 9f1421f77d4..8ab55d096ef 100644 --- a/libs/schema-profunctor/README.md +++ b/libs/schema-profunctor/README.md @@ -421,9 +421,9 @@ techniques of the previous two examples: ```haskell userSchema' :: ValueSchema NamedSwaggerDoc User userSchema' = object "User" $ User - <$> field "name" schema - <*> optField "handle" (maybeWithDefault Aeson.Null schema) - <*> opt (field "expire" schema) + <$> userName .= field "name" schema + <*> userHandle .= optField "handle" (maybeWithDefault Aeson.Null schema) + <*> userExpire .= opt (field "expire" schema) ``` Two things to note here: diff --git a/libs/schema-profunctor/package.yaml b/libs/schema-profunctor/package.yaml index dcaf19c7866..21b1b3d63c9 100644 --- a/libs/schema-profunctor/package.yaml +++ b/libs/schema-profunctor/package.yaml @@ -13,13 +13,13 @@ library: source-dirs: src dependencies: - base >=4 && < 5 - - aeson >= 1.0 && < 1.6 + - aeson >= 2.0.1.0 && < 2.1 - bifunctors - comonad - imports - lens - profunctors - - swagger2 >=2 && < 2.7 + - swagger2 >=2 && < 2.9 - text - transformers - vector diff --git a/libs/schema-profunctor/schema-profunctor.cabal b/libs/schema-profunctor/schema-profunctor.cabal index a3c1e5841a9..13c89f43896 100644 --- a/libs/schema-profunctor/schema-profunctor.cabal +++ b/libs/schema-profunctor/schema-profunctor.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 83646796a68e282b2b169035619c5d5ca2c53e12d08311ae712682f24cd90658 +-- hash: fa464d91df7452e4c1891d1d922b9998bdff09e33af3b55625efa52adb24aaff name: schema-profunctor version: 0.1.0 @@ -66,7 +66,7 @@ library 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 + aeson >=2.0.1.0 && <2.1 , base ==4.* , bifunctors , comonad @@ -74,7 +74,7 @@ library , imports , lens , profunctors - , swagger2 >=2 && <2.7 + , swagger2 >=2 && <2.9 , text , transformers , vector diff --git a/libs/schema-profunctor/src/Data/Schema.hs b/libs/schema-profunctor/src/Data/Schema.hs index 63af0cd2410..e654985d7e6 100644 --- a/libs/schema-profunctor/src/Data/Schema.hs +++ b/libs/schema-profunctor/src/Data/Schema.hs @@ -88,6 +88,7 @@ import Control.Comonad import Control.Lens hiding (element, enum, set, (.=)) import qualified Control.Lens as Lens import Control.Monad.Trans.Cont +import qualified Data.Aeson.Key as Key import qualified Data.Aeson.Types as A import Data.Bifunctor.Joker import Data.List.NonEmpty (NonEmpty) @@ -279,11 +280,11 @@ class Functor f => FieldFunctor doc f where mkDocF :: doc -> doc instance FieldFunctor doc Identity where - parseFieldF f obj key = Identity <$> A.explicitParseField f obj key + parseFieldF f obj key = Identity <$> A.explicitParseField f obj (Key.fromText key) mkDocF = id instance HasOpt doc => FieldFunctor doc Maybe where - parseFieldF = A.explicitParseFieldMaybe + parseFieldF f obj key = A.explicitParseFieldMaybe f obj (Key.fromText key) mkDocF = mkOpt -- | A schema for a one-field JSON object. @@ -335,7 +336,7 @@ fieldOverF l name sch = SchemaP (SchemaDoc s) (SchemaIn r) (SchemaOut w) w x = do v <- schemaOut sch x - pure [name A..= v] + pure [Key.fromText name A..= v] s = mkDocF @doc @f (mkField name (schemaDoc sch)) diff --git a/libs/types-common-aws/package.yaml b/libs/types-common-aws/package.yaml index 9a4ea33990f..db9fd5c09f3 100644 --- a/libs/types-common-aws/package.yaml +++ b/libs/types-common-aws/package.yaml @@ -19,6 +19,7 @@ dependencies: - proto-lens - lens >=4.10 - monad-control +- resourcet - safe >=0.3 - tasty - tasty-hunit diff --git a/libs/types-common-aws/src/Util/Test/SQS.hs b/libs/types-common-aws/src/Util/Test/SQS.hs index e1b00cb89a9..a0c86086bd5 100644 --- a/libs/types-common-aws/src/Util/Test/SQS.hs +++ b/libs/types-common-aws/src/Util/Test/SQS.hs @@ -25,18 +25,19 @@ module Util.Test.SQS where +import qualified Amazonka as AWS +import qualified Amazonka.SQS as SQS +import qualified Amazonka.SQS.Lens as SQS import Control.Exception (asyncExceptionFromException) import Control.Lens hiding ((.=)) import Control.Monad.Catch hiding (bracket) -import Control.Monad.Trans.Control import qualified Data.ByteString.Base64 as B64 import Data.ProtoLens import qualified Data.Text.Encoding as Text import Imports -import qualified Network.AWS as AWS -import qualified Network.AWS.SQS as SQS import Safe (headDef) import Test.Tasty.HUnit +import UnliftIO.Resource (MonadResource, ResourceT) ----------------------------------------------------------------------------- -- Assertions @@ -50,59 +51,57 @@ assertNoMessages url env = do ----------------------------------------------------------------------------- -- Queue operations -purgeQueue :: AWS.MonadAWS m => Text -> m () +purgeQueue :: (Monad m, MonadReader AWS.Env m, MonadResource m) => Text -> m () purgeQueue = void . readAndDeleteAllUntilEmpty -- Note that Amazon's purge queue is a bit incovenient for testing purposes because -- it may be delayed in ~60 seconds which causes messages that are published later -- to be (unintentionally) deleted which is why we have our own for testing purposes -readAndDeleteAllUntilEmpty :: AWS.MonadAWS m => Text -> m [SQS.Message] +readAndDeleteAllUntilEmpty :: (Monad m, MonadReader AWS.Env m, MonadResource m) => Text -> m [SQS.Message] readAndDeleteAllUntilEmpty url = do - firstBatch <- view SQS.rmrsMessages <$> AWS.send (receive 1 url) - allMsgs <- readUntilEmpty firstBatch firstBatch - return allMsgs + firstBatch <- fromMaybe [] . view SQS.receiveMessageResponse_messages <$> sendEnv (receive 1 url) + readUntilEmpty firstBatch firstBatch where readUntilEmpty acc [] = return acc readUntilEmpty acc msgs = do forM_ msgs $ deleteMessage url - newMsgs <- view SQS.rmrsMessages <$> AWS.send (receive 1 url) + newMsgs <- fromMaybe [] . view SQS.receiveMessageResponse_messages <$> sendEnv (receive 1 url) forM_ newMsgs $ deleteMessage url readUntilEmpty (acc ++ newMsgs) newMsgs -deleteMessage :: AWS.MonadAWS m => Text -> SQS.Message -> m () +deleteMessage :: (Monad m, MonadReader AWS.Env m, MonadResource m) => Text -> SQS.Message -> m () deleteMessage url m = do for_ - (m ^. SQS.mReceiptHandle) - (void . AWS.send . SQS.deleteMessage url) + (m ^. SQS.message_receiptHandle) + (void . sendEnv . SQS.newDeleteMessage url) ----------------------------------------------------------------------------- -- Generic AWS execution helpers execute :: - (AWS.HasEnv r, MonadIO m, MonadThrow m, MonadBaseControl IO m) => - r -> - AWS.AWS a -> - m a -execute env act = liftIO . AWS.runResourceT $ AWS.runAWS env act + AWS.Env -> + ReaderT AWS.Env (ResourceT IO) a -> + IO a +execute env = AWS.runResourceT . flip runReaderT env ----------------------------------------------------------------------------- -- Internal. Most of these functions _can_ be used outside of this function -- but probably do not need to receive :: Int -> Text -> SQS.ReceiveMessage receive n url = - SQS.receiveMessage url - & set SQS.rmWaitTimeSeconds (Just 1) - . set SQS.rmMaxNumberOfMessages (Just n) - . set SQS.rmVisibilityTimeout (Just 1) + SQS.newReceiveMessage url + & set SQS.receiveMessage_waitTimeSeconds (Just 1) + . set SQS.receiveMessage_maxNumberOfMessages (Just n) + . set SQS.receiveMessage_visibilityTimeout (Just 1) -fetchMessage :: (MonadIO m, AWS.MonadAWS m, Message a) => Text -> String -> (String -> Maybe a -> IO ()) -> m () +fetchMessage :: (MonadIO m, Message a, MonadReader AWS.Env m, MonadResource m) => Text -> String -> (String -> Maybe a -> IO ()) -> m () fetchMessage url label callback = do - msgs <- view SQS.rmrsMessages <$> AWS.send (receive 1 url) + msgs <- fromMaybe [] . view SQS.receiveMessageResponse_messages <$> sendEnv (receive 1 url) events <- mapM (parseDeleteMessage url) msgs liftIO $ callback label (headDef Nothing events) -parseDeleteMessage :: (AWS.MonadAWS m, Message a) => Text -> SQS.Message -> m (Maybe a) +parseDeleteMessage :: (Monad m, Message a, MonadIO m, MonadReader AWS.Env m, MonadResource m) => Text -> SQS.Message -> m (Maybe a) parseDeleteMessage url m = do - evt <- case (>>= decodeMessage) . B64.decode . Text.encodeUtf8 <$> (m ^. SQS.mBody) of + evt <- case (>>= decodeMessage) . B64.decode . Text.encodeUtf8 <$> (m ^. SQS.message_body) of Just (Right e) -> return (Just e) _ -> do liftIO $ print ("Failed to parse SQS message or event" :: String) @@ -110,11 +109,12 @@ parseDeleteMessage url m = do deleteMessage url m return evt -queueMessage :: (AWS.MonadAWS m, Message a) => Text -> a -> m () -queueMessage url e = void $ AWS.send req +queueMessage :: (MonadReader AWS.Env m, Message a, MonadResource m) => Text -> a -> m () +queueMessage url e = do + void $ sendEnv req where event = Text.decodeLatin1 $ B64.encode $ encodeMessage e - req = SQS.sendMessage url event + req = SQS.newSendMessage url event newtype MatchFailure a = MatchFailure {mFailure :: (a, SomeException)} @@ -122,7 +122,7 @@ newtype MatchFailure a = MatchFailure {mFailure :: (a, SomeException)} -- match during the timeout, it asserts with the given label -- Matched matches are consumed while unmatched ones are republished to the queue tryMatch :: - (AWS.MonadAWS m, Show a, Message a) => + (Show a, Message a, MonadReader AWS.Env m, MonadResource m, MonadThrow m, MonadCatch m) => String -> Int -> Text -> @@ -147,3 +147,6 @@ tryMatch label tries url callback = go tries `catchAll` \ex -> case asyncExceptionFromException ex of Just x -> throwM (x :: SomeAsyncException) Nothing -> return . Left $ MatchFailure (e, ex) + +sendEnv :: (MonadReader AWS.Env m, MonadResource m, AWS.AWSRequest a) => a -> m (AWS.AWSResponse a) +sendEnv x = flip AWS.send x =<< ask diff --git a/libs/types-common-aws/types-common-aws.cabal b/libs/types-common-aws/types-common-aws.cabal index 9c3ca1dd1b3..652daf300aa 100644 --- a/libs/types-common-aws/types-common-aws.cabal +++ b/libs/types-common-aws/types-common-aws.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 4b83070073d35300a38f4eeaac64a4d3ad4822df651b881a6a8eea293aa4dfcf +-- hash: b83bb5e2ebe7499bdd426bff59d23e2c08935fc24e6f182114fd5ef296f19928 name: types-common-aws version: 0.16.0 @@ -87,6 +87,7 @@ library , lens >=4.10 , monad-control , proto-lens + , resourcet , safe >=0.3 , tasty , tasty-hunit diff --git a/libs/types-common/package.yaml b/libs/types-common/package.yaml index 47f4d93f71a..91122eead73 100644 --- a/libs/types-common/package.yaml +++ b/libs/types-common/package.yaml @@ -15,11 +15,13 @@ library: source-dirs: src ghc-prof-options: -fprof-auto-exported dependencies: - - aeson >=1.0 + - aeson >=2.0.1.0 - attoparsec >=0.11 + - attoparsec-iso8601 - base16-bytestring >=0.1 - base ==4.* - base64-bytestring >=1.0 + - binary - bytestring >=0.10 - bytestring-conversion >=0.2 - cassandra-util diff --git a/libs/types-common/src/Data/Domain.hs b/libs/types-common/src/Data/Domain.hs index 5a5d346a8bb..6a00203b329 100644 --- a/libs/types-common/src/Data/Domain.hs +++ b/libs/types-common/src/Data/Domain.hs @@ -26,6 +26,7 @@ import Data.Aeson.Types (toJSONKeyText) import Data.Attoparsec.ByteString (()) import qualified Data.Attoparsec.ByteString.Char8 as Atto import Data.Bifunctor (Bifunctor (first)) +import Data.Binary import qualified Data.ByteString as BS import qualified Data.ByteString.Builder as Builder import qualified Data.ByteString.Char8 as BS.Char8 @@ -63,7 +64,7 @@ import Util.Attoparsec (takeUpToWhile) -- The domain will be normalized to lowercase when parsed. newtype Domain = Domain {_domainText :: Text} deriving stock (Eq, Ord, Generic, Show) - deriving newtype (S.ToParamSchema) + deriving newtype (S.ToParamSchema, Binary) deriving (FromJSON, ToJSON, S.ToSchema) via Schema Domain instance ToSchema Domain where diff --git a/libs/types-common/src/Data/Id.hs b/libs/types-common/src/Data/Id.hs index 229dc77c2d7..b587f102d15 100644 --- a/libs/types-common/src/Data/Id.hs +++ b/libs/types-common/src/Data/Id.hs @@ -57,9 +57,11 @@ import Control.Lens ((?~)) import Data.Aeson (FromJSON (..), ToJSON (..)) import qualified Data.Aeson as A import qualified Data.Aeson.Encoding as A +import qualified Data.Aeson.Key as Key import qualified Data.Aeson.Types as A import Data.Attoparsec.ByteString (()) import qualified Data.Attoparsec.ByteString.Char8 as Atto +import Data.Binary import Data.ByteString.Builder (byteString) import Data.ByteString.Conversion import qualified Data.ByteString.Lazy as L @@ -143,7 +145,7 @@ newtype Id a = Id { toUUID :: UUID } deriving stock (Eq, Ord, Generic) - deriving newtype (Hashable, NFData, ToParamSchema) + deriving newtype (Hashable, NFData, ToParamSchema, Binary) deriving (ToJSON, FromJSON, S.ToSchema) via Schema (Id a) instance ToSchema (Id a) where @@ -202,7 +204,7 @@ instance ToHttpApiData (Id a) where toUrlPiece = toUrlPiece . show instance A.ToJSONKey (Id a) where - toJSONKey = A.ToJSONKeyText idToText (A.text . idToText) + toJSONKey = A.ToJSONKeyText (Key.fromText . idToText) (A.text . idToText) instance A.FromJSONKey (Id a) where fromJSONKey = A.FromJSONKeyTextParser idFromText @@ -281,7 +283,7 @@ newtype ClientId = ClientId { client :: Text } deriving (Eq, Ord, Show, ToByteString, Hashable, NFData, A.ToJSONKey, Generic) - deriving newtype (ToParamSchema, FromHttpApiData, ToHttpApiData) + deriving newtype (ToParamSchema, FromHttpApiData, ToHttpApiData, Binary) deriving (FromJSON, ToJSON, S.ToSchema) via Schema ClientId instance ToSchema ClientId where diff --git a/libs/types-common/src/Data/Json/Util.hs b/libs/types-common/src/Data/Json/Util.hs index 20116936bf1..c62f90bff49 100644 --- a/libs/types-common/src/Data/Json/Util.hs +++ b/libs/types-common/src/Data/Json/Util.hs @@ -29,6 +29,8 @@ module Data.Json.Util -- * UTCTimeMillis UTCTimeMillis, + utcTimeTextSchema, + utcTimeSchema, toUTCTimeMillis, fromUTCTimeMillis, showUTCTimeMillis, @@ -39,6 +41,7 @@ module Data.Json.Util fromBase64TextLenient, fromBase64Text, toBase64Text, + base64Schema, ) where @@ -47,6 +50,8 @@ import Control.Lens (coerced, (%~), (?~)) import Data.Aeson (FromJSON (..), ToJSON (..)) import qualified Data.Aeson as A import qualified Data.Aeson.Types as A +import qualified Data.Attoparsec.Text as Atto +import qualified Data.Attoparsec.Time as Atto import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Base64.Lazy as B64L import qualified Data.ByteString.Builder as BB @@ -57,7 +62,7 @@ import Data.Fixed import Data.Schema import Data.String.Conversions (cs) import qualified Data.Swagger as S -import Data.Text (pack) +import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import qualified Data.Text.Encoding.Error as Text import Data.Time.Clock @@ -94,23 +99,28 @@ newtype UTCTimeMillis = UTCTimeMillis {fromUTCTimeMillis :: UTCTime} deriving (FromJSON, ToJSON, S.ToSchema) via Schema UTCTimeMillis instance ToSchema UTCTimeMillis where - schema = - UTCTimeMillis <$> showUTCTimeMillis - .= mkSchema swagger parseJSON (pure . A.String . pack) - where - swagger = - S.NamedSchema (Just "UTCTimeMillis") <$> mempty - & S.schema . S.type_ ?~ S.SwaggerString - & S.schema . S.format ?~ "yyyy-mm-ddThh:MM:ss.qqq" - & S.schema . S.example ?~ "2021-05-12T10:52:02.671Z" + schema = UTCTimeMillis <$> showUTCTimeMillis .= utcTimeTextSchema + +utcTimeTextSchema :: ValueSchemaP NamedSwaggerDoc Text UTCTime +utcTimeTextSchema = + parsedText "UTCTime" (Atto.parseOnly (Atto.utcTime <* Atto.endOfInput)) + & doc . S.schema + %~ (S.format ?~ "yyyy-mm-ddThh:MM:ss.qqq") + . (S.example ?~ "2021-05-12T10:52:02.671Z") + +utcTimeSchema :: ValueSchema NamedSwaggerDoc UTCTime +utcTimeSchema = showUTCTime .= utcTimeTextSchema {-# INLINE toUTCTimeMillis #-} toUTCTimeMillis :: HasCallStack => UTCTime -> UTCTimeMillis toUTCTimeMillis = UTCTimeMillis . (TL.seconds . coerced @Pico @_ @Integer %~ (* 1e9) . (`div` 1e9)) {-# INLINE showUTCTimeMillis #-} -showUTCTimeMillis :: UTCTimeMillis -> String -showUTCTimeMillis (UTCTimeMillis t) = formatTime defaultTimeLocale "%FT%T.%03qZ" t +showUTCTimeMillis :: UTCTimeMillis -> Text +showUTCTimeMillis = Text.pack . formatTime defaultTimeLocale "%FT%T.%03qZ" . fromUTCTimeMillis + +showUTCTime :: UTCTime -> Text +showUTCTime = Text.pack . formatTime defaultTimeLocale "%FT%T%QZ" readUTCTimeMillis :: String -> Maybe UTCTimeMillis readUTCTimeMillis = fmap toUTCTimeMillis . parseTimeM True defaultTimeLocale formatUTCTimeMillis @@ -119,7 +129,7 @@ formatUTCTimeMillis :: String formatUTCTimeMillis = "%FT%T%QZ" instance Show UTCTimeMillis where - showsPrec d = showParen (d > 10) . showString . showUTCTimeMillis + showsPrec d = showParen (d > 10) . showString . Text.unpack . showUTCTimeMillis instance BS.ToByteString UTCTimeMillis where builder = BB.byteString . cs . show @@ -195,6 +205,9 @@ instance IsString Base64ByteString where instance Arbitrary Base64ByteString where arbitrary = Base64ByteString <$> arbitrary +base64Schema :: ValueSchema SwaggerDoc Base64ByteString +base64Schema = mkSchema mempty A.parseJSON (pure . A.toJSON) + -------------------------------------------------------------------------------- -- Utilities diff --git a/libs/types-common/src/Data/Qualified.hs b/libs/types-common/src/Data/Qualified.hs index 4621312a472..12180988f61 100644 --- a/libs/types-common/src/Data/Qualified.hs +++ b/libs/types-common/src/Data/Qualified.hs @@ -42,6 +42,8 @@ module Data.Qualified bucketQualified, bucketRemote, deprecatedSchema, + qualifiedSchema, + qualifiedObjectSchema, ) where @@ -167,9 +169,17 @@ qualifiedSchema :: ValueSchema NamedSwaggerDoc (Qualified a) qualifiedSchema name fieldName sch = object ("Qualified_" <> name) $ - Qualified - <$> qUnqualified .= field fieldName sch - <*> qDomain .= field "domain" schema + qualifiedObjectSchema fieldName sch + +qualifiedObjectSchema :: + HasSchemaRef d => + Text -> + ValueSchema d a -> + ObjectSchema SwaggerDoc (Qualified a) +qualifiedObjectSchema fieldName sch = + flip Qualified + <$> qDomain .= field "domain" schema + <*> qUnqualified .= field fieldName sch instance KnownIdTag t => ToSchema (Qualified (Id t)) where schema = qualifiedSchema (idTagName (idTagValue @t) <> "Id") "id" schema diff --git a/libs/types-common/types-common.cabal b/libs/types-common/types-common.cabal index 03402763a91..013cf3302a3 100644 --- a/libs/types-common/types-common.cabal +++ b/libs/types-common/types-common.cabal @@ -3,8 +3,6 @@ cabal-version: 1.12 -- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack --- --- hash: 00836419e46c5f3ba70a9a8c3048fe32fb28f3d7176f97a681722bfb63807bd3 name: types-common version: 0.16.0 @@ -89,11 +87,13 @@ library ghc-prof-options: -fprof-auto-exported build-depends: QuickCheck >=2.9 - , aeson >=1.0 + , aeson >=2.0.1.0 , attoparsec >=0.11 + , attoparsec-iso8601 , base ==4.* , base16-bytestring >=0.1 , base64-bytestring >=1.0 + , binary , bytestring >=0.10 , bytestring-conversion >=0.2 , cassandra-util diff --git a/libs/wai-utilities/package.yaml b/libs/wai-utilities/package.yaml index 537f0a6dc42..111b6d70650 100644 --- a/libs/wai-utilities/package.yaml +++ b/libs/wai-utilities/package.yaml @@ -10,7 +10,7 @@ maintainer: Wire Swiss GmbH copyright: (c) 2017 Wire Swiss GmbH license: AGPL-3 dependencies: -- aeson >=0.6 +- aeson >=2.0.1.0 - async >=2.0 - base >=4.6 && <5.0 - bytestring >=0.10 diff --git a/libs/wai-utilities/wai-utilities.cabal b/libs/wai-utilities/wai-utilities.cabal index 8b0d7a76ba4..27c7da4ed01 100644 --- a/libs/wai-utilities/wai-utilities.cabal +++ b/libs/wai-utilities/wai-utilities.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 52a60b4f6f7985a3b05c720cb7f00a1034117a09c5d39bbf1d9bb4f0828b86c8 +-- hash: f032f8354316816e361796a0e1b2d5da703e8d447d4b12f9e6cab7be5e252e6f name: wai-utilities version: 0.16.1 @@ -73,7 +73,7 @@ library 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 + aeson >=2.0.1.0 , async >=2.0 , base >=4.6 && <5.0 , bytestring >=0.10 diff --git a/libs/wire-api-federation/package.yaml b/libs/wire-api-federation/package.yaml index 8fb6f5d3003..c46fac77be4 100644 --- a/libs/wire-api-federation/package.yaml +++ b/libs/wire-api-federation/package.yaml @@ -11,7 +11,7 @@ copyright: (c) 2020 Wire Swiss GmbH license: AGPL-3 dependencies: - QuickCheck >=2.13 -- aeson >=1.4 +- aeson >=2.0.1.0 - async - base >=4.6 && <5.0 - bytestring 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 08b134a13b6..e62c40d73bf 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 @@ -43,6 +43,16 @@ instance ToJSON SearchRequest instance FromJSON SearchRequest +data SearchResponse = SearchResponse + { contacts :: [Contact], + searchPolicy :: FederatedUserSearchPolicy + } + deriving (Show, Generic, Typeable) + +instance ToJSON SearchResponse + +instance FromJSON SearchResponse + -- | For conventions see /docs/developer/federation-api-conventions.md -- -- Maybe this module should be called Brig @@ -54,7 +64,7 @@ type BrigApi = :<|> 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 "search-users" SearchRequest SearchResponse :<|> FedEndpoint "get-user-clients" GetUserClients (UserMap (Set PubClient)) :<|> FedEndpoint "send-connection-action" NewConnectionRequest NewConnectionResponse :<|> FedEndpoint "on-user-deleted-connections" UserDeletedConnectionsNotification EmptyResponse diff --git a/libs/wire-api-federation/wire-api-federation.cabal b/libs/wire-api-federation/wire-api-federation.cabal index aa0dc39024a..0c2cc1db7f5 100644 --- a/libs/wire-api-federation/wire-api-federation.cabal +++ b/libs/wire-api-federation/wire-api-federation.cabal @@ -76,7 +76,7 @@ library ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path build-depends: QuickCheck >=2.13 - , aeson >=1.4 + , aeson >=2.0.1.0 , async , base >=4.6 && <5.0 , bytestring @@ -173,7 +173,7 @@ test-suite spec build-depends: HUnit , QuickCheck >=2.13 - , aeson >=1.4 + , aeson >=2.0.1.0 , aeson-pretty , async , base >=4.6 && <5.0 diff --git a/libs/wire-api/package.yaml b/libs/wire-api/package.yaml index 8a369f82054..02215683ab3 100644 --- a/libs/wire-api/package.yaml +++ b/libs/wire-api/package.yaml @@ -10,7 +10,7 @@ copyright: (c) 2020 Wire Swiss GmbH license: AGPL-3 dependencies: -- aeson >=0.6 +- aeson >=2.0.1.0 - case-insensitive - containers >=0.5 - filepath @@ -29,6 +29,7 @@ library: - attoparsec >=0.10 - base64-bytestring >=1.0 - binary + - binary-parsers - bytestring >=0.9 - bytestring-conversion >=0.2 - cassandra-util @@ -36,6 +37,7 @@ library: - cereal - comonad - conduit + - constraints - cookie - cryptonite - currency-codes >=2.0 @@ -112,6 +114,7 @@ tests: - cassava - currency-codes - directory + - hex - iso3166-country-codes - iso639 - lens diff --git a/libs/wire-api/src/Wire/API/Arbitrary.hs b/libs/wire-api/src/Wire/API/Arbitrary.hs index d40e1212b1c..9974d5f90bd 100644 --- a/libs/wire-api/src/Wire/API/Arbitrary.hs +++ b/libs/wire-api/src/Wire/API/Arbitrary.hs @@ -31,10 +31,8 @@ module Wire.API.Arbitrary where import qualified Codec.MIME.Type as MIME -import qualified Data.Aeson as Aeson import Data.Coerce (coerce) 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.List.NonEmpty (NonEmpty (..)) @@ -46,7 +44,7 @@ import qualified Generic.Random as Generic import Imports import Test.QuickCheck.Arbitrary (Arbitrary (arbitrary)) import qualified Test.QuickCheck.Arbitrary as QC -import Test.QuickCheck.Gen (Gen (MkGen), oneof) +import Test.QuickCheck.Gen (Gen (MkGen)) import Test.QuickCheck.Instances () import Test.QuickCheck.Random @@ -114,23 +112,6 @@ deriving stock instance Bounded ISO639_1 deriving via (GenericUniform CountryCode) instance Arbitrary CountryCode -instance Arbitrary Aeson.Value where - arbitrary = oneof [genBaseCase, genObject, genArray] - where - genObject = - Aeson.Object . HashMap.fromList - <$> listOf' (liftA2 (,) arbitrary genBaseCase) - genArray = - Aeson.Array . foldMap pure - <$> listOf' genBaseCase - genBaseCase = - oneof - [ pure Aeson.Null, - Aeson.String <$> arbitrary, - Aeson.Number <$> arbitrary, - Aeson.Bool <$> arbitrary - ] - -- | Use Arbitrary instance to generate an example to be used in swagger where -- we cannot rely on swagger-ui to generate nice examples. So far, this is only -- required for maps as swagger2 doesn't have a good way to specify the type of diff --git a/libs/wire-api/src/Wire/API/ErrorDescription.hs b/libs/wire-api/src/Wire/API/ErrorDescription.hs index ef4d77d4b6e..49870a480ff 100644 --- a/libs/wire-api/src/Wire/API/ErrorDescription.hs +++ b/libs/wire-api/src/Wire/API/ErrorDescription.hs @@ -376,3 +376,14 @@ type InvalidAction = ErrorDescription 403 "invalid-actions" "The specified actio type PasswordAuthenticationFailed = ErrorDescription 403 "password-authentication-failed" "Password authentication failed." type CodeAuthenticationFailed = ErrorDescription 403 "code-authentication-failed" "Code authentication failed." + +type MLSProtocolError = ErrorDescription 400 "mls-protocol-error" "MLS protocol error" + +mlsProtocolError :: Text -> MLSProtocolError +mlsProtocolError = ErrorDescription + +type MLSIdentityMismatch = + ErrorDescription + 403 + "mls-identity-mismatch" + "Prekey credential does not match qualified client ID" diff --git a/libs/wire-api/src/Wire/API/Event/Conversation.hs b/libs/wire-api/src/Wire/API/Event/Conversation.hs index b87b9369ee0..66a1b7e946b 100644 --- a/libs/wire-api/src/Wire/API/Event/Conversation.hs +++ b/libs/wire-api/src/Wire/API/Event/Conversation.hs @@ -85,7 +85,7 @@ import Control.Arrow ((&&&)) import Control.Lens (makePrisms, (?~), _1) import Data.Aeson (FromJSON (..), ToJSON (..)) import qualified Data.Aeson as A -import qualified Data.HashMap.Strict as HashMap +import qualified Data.Aeson.KeyMap as KeyMap import Data.Id import Data.Json.Util (ToJSONObject (toJSONObject), UTCTimeMillis (fromUTCTimeMillis), toUTCTimeMillis) import Data.Qualified @@ -551,7 +551,7 @@ eventObjectSchema = instance ToJSONObject Event where toJSONObject = - HashMap.fromList + KeyMap.fromList . fromMaybe [] . schemaOut eventObjectSchema diff --git a/libs/wire-api/src/Wire/API/Event/FeatureConfig.hs b/libs/wire-api/src/Wire/API/Event/FeatureConfig.hs index 6a3a9752fde..c18e59c00d7 100644 --- a/libs/wire-api/src/Wire/API/Event/FeatureConfig.hs +++ b/libs/wire-api/src/Wire/API/Event/FeatureConfig.hs @@ -25,7 +25,7 @@ where import Control.Arrow ((&&&)) import Control.Lens (makePrisms, _1) import Data.Aeson (FromJSON (..), ToJSON (..)) -import qualified Data.HashMap.Strict as HashMap +import qualified Data.Aeson.KeyMap as KeyMap import Data.Json.Util (ToJSONObject (..)) import Data.Schema import qualified Data.Swagger as S @@ -93,7 +93,7 @@ instance ToSchema Event where instance ToJSONObject Event where toJSONObject = - HashMap.fromList + KeyMap.fromList . fromMaybe [] . schemaOut eventObjectSchema diff --git a/libs/wire-api/src/Wire/API/Event/Team.hs b/libs/wire-api/src/Wire/API/Event/Team.hs index 22b48eef5ca..e18cde53a04 100644 --- a/libs/wire-api/src/Wire/API/Event/Team.hs +++ b/libs/wire-api/src/Wire/API/Event/Team.hs @@ -46,8 +46,8 @@ where import Control.Lens (makeLenses) import Data.Aeson +import qualified Data.Aeson.KeyMap as KeyMap import Data.Aeson.Types (Parser) -import qualified Data.HashMap.Strict as HashMap import Data.Id (ConvId, TeamId, UserId) import Data.Json.Util import qualified Data.Swagger.Build.Api as Doc @@ -122,7 +122,7 @@ instance ToJSON Event where instance ToJSONObject Event where toJSONObject e = - HashMap.fromList + KeyMap.fromList [ "type" .= _eventType e, "team" .= _eventTeam e, "time" .= _eventTime e, diff --git a/libs/wire-api/src/Wire/API/MLS/CipherSuite.hs b/libs/wire-api/src/Wire/API/MLS/CipherSuite.hs new file mode 100644 index 00000000000..161edf3119c --- /dev/null +++ b/libs/wire-api/src/Wire/API/MLS/CipherSuite.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneKindSignatures #-} + +-- 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.MLS.CipherSuite where + +import Crypto.Error +import Crypto.Hash.Algorithms +import qualified Crypto.KDF.HKDF as HKDF +import qualified Crypto.PubKey.Ed25519 as Ed25519 +import Data.Word +import Imports +import Wire.API.Arbitrary +import Wire.API.MLS.Serialisation + +newtype CipherSuite = CipherSuite {cipherSuiteNumber :: Word16} + deriving stock (Eq, Show) + deriving newtype (ParseMLS, Arbitrary) + +data CipherSuiteTag = MLS_128_DHKEMX25519_AES128GCM_SHA256_Ed25519 + deriving stock (Bounded, Enum, Eq, Show) + +-- | See https://messaginglayersecurity.rocks/mls-protocol/draft-ietf-mls-protocol.html#table-5. +cipherSuiteTag :: CipherSuite -> Maybe CipherSuiteTag +cipherSuiteTag (CipherSuite n) = case n of + 1 -> pure MLS_128_DHKEMX25519_AES128GCM_SHA256_Ed25519 + _ -> Nothing + +csHash :: CipherSuiteTag -> ByteString -> ByteString -> ByteString +csHash MLS_128_DHKEMX25519_AES128GCM_SHA256_Ed25519 ctx value = + HKDF.expand (HKDF.extract @SHA256 (mempty :: ByteString) value) ctx 16 + +csVerifySignature :: CipherSuiteTag -> ByteString -> ByteString -> ByteString -> Bool +csVerifySignature MLS_128_DHKEMX25519_AES128GCM_SHA256_Ed25519 pub x sig = fromMaybe False . maybeCryptoError $ do + pub' <- Ed25519.publicKey pub + sig' <- Ed25519.signature sig + pure $ Ed25519.verify pub' x sig' diff --git a/libs/wire-api/src/Wire/API/MLS/Credential.hs b/libs/wire-api/src/Wire/API/MLS/Credential.hs new file mode 100644 index 00000000000..2922ca76e40 --- /dev/null +++ b/libs/wire-api/src/Wire/API/MLS/Credential.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Wire.API.MLS.Credential where + +import Data.Binary +import Data.Binary.Get +import Data.Binary.Parser +import Data.Binary.Parser.Char8 +import Data.Domain +import Data.Id +import Data.Qualified +import qualified Data.Text as T +import Data.UUID +import Imports +import Wire.API.Arbitrary +import Wire.API.MLS.Serialisation + +-- | An MLS credential. +-- +-- Only the @BasicCredential@ type is supported. +data Credential = BasicCredential + { bcIdentity :: ByteString, + bcSignatureScheme :: SignatureScheme, + bcSignatureKey :: ByteString + } + deriving stock (Eq, Show, Generic) + deriving (Arbitrary) via GenericUniform Credential + +data CredentialTag = ReservedCredentialTag | BasicCredentialTag + deriving stock (Enum, Bounded, Show) + deriving (ParseMLS) via (EnumMLS Word16 CredentialTag) + +instance ParseMLS Credential where + parseMLS = do + tag <- parseMLS + case tag of + BasicCredentialTag -> + BasicCredential + <$> parseMLSBytes @Word16 + <*> parseMLS + <*> parseMLSBytes @Word16 + ReservedCredentialTag -> + fail "Unexpected credential type" + +credentialTag :: Credential -> CredentialTag +credentialTag (BasicCredential _ _ _) = BasicCredentialTag + +-- | A TLS signature scheme. +-- +-- See . +newtype SignatureScheme = SignatureScheme {signatureSchemeNumber :: Word16} + deriving stock (Eq, Show) + deriving newtype (ParseMLS, Arbitrary) + +data ClientIdentity = ClientIdentity + { ciDomain :: Domain, + ciUser :: UserId, + ciClient :: ClientId + } + deriving stock (Eq, Show, Generic) + +instance ParseMLS ClientIdentity where + parseMLS = do + uid <- + maybe (fail "Invalid UUID") (pure . Id) + =<< fmap fromASCIIBytes (getByteString 36) + char ':' + cid <- newClientId <$> hexadecimal + char '@' + dom <- + either fail pure + =<< fmap (mkDomain . T.pack) (many' anyChar) + pure $ ClientIdentity dom uid cid + +mkClientIdentity :: Qualified UserId -> ClientId -> ClientIdentity +mkClientIdentity (Qualified uid domain) cid = ClientIdentity domain uid cid + +instance Binary ClientIdentity diff --git a/libs/wire-api/src/Wire/API/MLS/KeyPackage.hs b/libs/wire-api/src/Wire/API/MLS/KeyPackage.hs new file mode 100644 index 00000000000..6c1958f2817 --- /dev/null +++ b/libs/wire-api/src/Wire/API/MLS/KeyPackage.hs @@ -0,0 +1,275 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneKindSignatures #-} + +-- 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.MLS.KeyPackage + ( -- * API types + KeyPackageUpload (..), + KeyPackageBundle (..), + KeyPackageBundleEntry (..), + KeyPackageCount (..), + KeyPackageData (..), + KeyPackage (..), + KeyPackageTBS (..), + KeyPackageRef (..), + + -- * Key package types + Timestamp (..), + ProtocolVersion (..), + ProtocolVersionTag (..), + pvTag, + Extension (..), + + -- * Extensions + decodeExtension, + parseExtension, + ExtensionTag (..), + ReservedExtensionTagSym0, + CapabilitiesExtensionTagSym0, + LifetimeExtensionTagSym0, + SExtensionTag (..), + SomeExtension (..), + Capabilities (..), + Lifetime (..), + + -- * Utilities + tsPOSIX, + kpRef, + kpSigOffset, + ) +where + +import Control.Applicative +import Control.Error.Util +import Control.Lens hiding (set, (.=)) +import Data.Aeson (FromJSON, ToJSON) +import Data.Binary +import Data.Binary.Get +import qualified Data.ByteString.Lazy as LBS +import Data.Id +import Data.Json.Util +import Data.Qualified +import Data.Schema +import Data.Singletons +import Data.Singletons.TH +import qualified Data.Swagger as S +import Data.Time.Clock.POSIX +import Imports +import Wire.API.Arbitrary +import Wire.API.MLS.CipherSuite +import Wire.API.MLS.Credential +import Wire.API.MLS.Serialisation + +data KeyPackageUpload = KeyPackageUpload + {kpuKeyPackages :: [KeyPackageData]} + deriving (FromJSON, ToJSON, S.ToSchema) via Schema KeyPackageUpload + +instance ToSchema KeyPackageUpload where + schema = + object "KeyPackageUpload" $ + KeyPackageUpload + <$> kpuKeyPackages .= field "key_packages" (array schema) + +newtype KeyPackageData = KeyPackageData {kpData :: LByteString} + deriving stock (Eq, Ord, Show) + +instance ToSchema KeyPackageData where + schema = + (S.schema . S.example ?~ "a2V5IHBhY2thZ2UgZGF0YQo=") + ( KeyPackageData <$> kpData + .= named "KeyPackage" (Base64ByteString .= fmap fromBase64ByteString base64Schema) + ) + +data KeyPackageBundleEntry = KeyPackageBundleEntry + { kpbeUser :: Qualified UserId, + kpbeClient :: ClientId, + kpbeKeyPackage :: KeyPackageData + } + deriving stock (Eq, Ord) + +instance ToSchema KeyPackageBundleEntry where + schema = + object "KeyPackageBundleEntry" $ + KeyPackageBundleEntry + <$> kpbeUser .= qualifiedObjectSchema "user" schema + <*> kpbeClient .= field "client" schema + <*> kpbeKeyPackage .= field "key_package" schema + +newtype KeyPackageBundle = KeyPackageBundle {kpbEntries :: Set KeyPackageBundleEntry} + deriving (FromJSON, ToJSON, S.ToSchema) via Schema KeyPackageBundle + +instance ToSchema KeyPackageBundle where + schema = + object "KeyPackageBundle" $ + KeyPackageBundle + <$> kpbEntries .= field "key_packages" (set schema) + +newtype KeyPackageCount = KeyPackageCount {unKeyPackageCount :: Int} + deriving newtype (Eq, Ord, Num, Show) + deriving (FromJSON, ToJSON, S.ToSchema) via Schema KeyPackageCount + +instance ToSchema KeyPackageCount where + schema = + object "OwnKeyPackages" $ + KeyPackageCount <$> unKeyPackageCount .= field "count" schema + +-------------------------------------------------------------------------------- + +newtype ProtocolVersion = ProtocolVersion {pvNumber :: Word8} + deriving newtype (Eq, Ord, Show, Binary, Arbitrary) + deriving (ParseMLS) via (BinaryMLS ProtocolVersion) + +data ProtocolVersionTag = ProtocolMLS10 | ProtocolMLSDraft11 + deriving stock (Bounded, Enum, Eq, Show, Generic) + deriving (Arbitrary) via GenericUniform ProtocolVersionTag + +pvTag :: ProtocolVersion -> Maybe ProtocolVersionTag +pvTag (ProtocolVersion v) = case v of + 1 -> pure ProtocolMLS10 + 200 -> pure ProtocolMLSDraft11 + _ -> Nothing + +data Extension = Extension + { extType :: Word16, + extData :: ByteString + } + deriving stock (Eq, Show, Generic) + deriving (Arbitrary) via GenericUniform Extension + +instance ParseMLS Extension where + parseMLS = Extension <$> parseMLS <*> parseMLSBytes @Word32 + +data ExtensionTag + = ReservedExtensionTag + | CapabilitiesExtensionTag + | LifetimeExtensionTag + deriving (Bounded, Enum) + +$(genSingletons [''ExtensionTag]) + +type family ExtensionType (t :: ExtensionTag) :: * where + ExtensionType 'ReservedExtensionTag = () + ExtensionType 'CapabilitiesExtensionTag = Capabilities + ExtensionType 'LifetimeExtensionTag = Lifetime + +parseExtension :: Sing t -> Get (ExtensionType t) +parseExtension SReservedExtensionTag = pure () +parseExtension SCapabilitiesExtensionTag = parseMLS +parseExtension SLifetimeExtensionTag = parseMLS + +data SomeExtension where + SomeExtension :: Sing t -> ExtensionType t -> SomeExtension + +instance Eq SomeExtension where + SomeExtension SCapabilitiesExtensionTag caps1 == SomeExtension SCapabilitiesExtensionTag caps2 = caps1 == caps2 + SomeExtension SLifetimeExtensionTag lt1 == SomeExtension SLifetimeExtensionTag lt2 = lt1 == lt2 + _ == _ = False + +instance Show SomeExtension where + show (SomeExtension SReservedExtensionTag _) = show () + show (SomeExtension SCapabilitiesExtensionTag caps) = show caps + show (SomeExtension SLifetimeExtensionTag lt) = show lt + +decodeExtension :: Extension -> Maybe SomeExtension +decodeExtension e = do + t <- safeToEnum (fromIntegral (extType e)) + hush $ + withSomeSing t $ \st -> + decodeMLSWith' (SomeExtension st <$> parseExtension st) (extData e) + +data Capabilities = Capabilities + { capVersions :: [ProtocolVersion], + capCiphersuites :: [CipherSuite], + capExtensions :: [Word16], + capProposals :: [Word16] + } + deriving stock (Eq, Show, Generic) + deriving (Arbitrary) via (GenericUniform Capabilities) + +instance ParseMLS Capabilities where + parseMLS = + Capabilities + <$> parseMLSVector @Word8 parseMLS + <*> parseMLSVector @Word8 parseMLS + <*> parseMLSVector @Word8 parseMLS + <*> parseMLSVector @Word8 parseMLS + +-- | Seconds since the UNIX epoch. +newtype Timestamp = Timestamp {timestampSeconds :: Word64} + deriving newtype (Eq, Show, Arbitrary, ParseMLS) + +tsPOSIX :: Timestamp -> POSIXTime +tsPOSIX = fromIntegral . timestampSeconds + +data Lifetime = Lifetime + { ltNotBefore :: Timestamp, + ltNotAfter :: Timestamp + } + deriving stock (Eq, Show, Generic) + deriving (Arbitrary) via GenericUniform Lifetime + +instance ParseMLS Lifetime where + parseMLS = Lifetime <$> parseMLS <*> parseMLS + +data KeyPackageTBS = KeyPackageTBS + { kpProtocolVersion :: ProtocolVersion, + kpCipherSuite :: CipherSuite, + kpInitKey :: ByteString, + kpCredential :: Credential, + kpExtensions :: [Extension] + } + deriving stock (Show, Generic) + deriving (Arbitrary) via GenericUniform KeyPackageTBS + +instance ParseMLS KeyPackageTBS where + parseMLS = + KeyPackageTBS + <$> parseMLS + <*> parseMLS + <*> parseMLSBytes @Word16 + <*> parseMLS + <*> parseMLSVector @Word32 parseMLS + +data KeyPackage = KeyPackage + { kpTBS :: KeyPackageTBS, + kpSignature :: ByteString + } + deriving (Show) + +newtype KeyPackageRef = KeyPackageRef {unKeyPackageRef :: ByteString} + deriving stock (Show) + +kpRef :: CipherSuiteTag -> KeyPackageData -> KeyPackageRef +kpRef cs = + KeyPackageRef + . csHash cs "MLS 1.0 KeyPackage Reference" + . LBS.toStrict + . kpData + +instance ParseMLS KeyPackage where + parseMLS = fst <$> kpSigOffset + +-- | Parse a key package, and also return the offset of the signature. This can +-- be used to reconstruct the signed data. +kpSigOffset :: Get (KeyPackage, Int64) +kpSigOffset = do + kp <- parseMLS + off <- bytesRead + sig <- parseMLSBytes @Word16 + pure (KeyPackage kp sig, off) diff --git a/libs/wire-api/src/Wire/API/MLS/Proposal.hs b/libs/wire-api/src/Wire/API/MLS/Proposal.hs new file mode 100644 index 00000000000..abfc1553ebb --- /dev/null +++ b/libs/wire-api/src/Wire/API/MLS/Proposal.hs @@ -0,0 +1,37 @@ +-- 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.MLS.Proposal where + +import Data.Binary +import Imports +import Wire.API.Arbitrary +import Wire.API.MLS.Serialisation + +data ProposalType + = AddProposal + | UpdateProposal + | RemoveProposal + | PreSharedKeyProposal + | ReInitProposal + | ExternalInitProposal + | AppAckProposal + | GroupContextExtensionsProposal + | ExternalProposal + deriving stock (Bounded, Enum, Eq, Generic, Show) + deriving (ParseMLS) via (EnumMLS Word16 ProposalType) + deriving (Arbitrary) via GenericUniform ProposalType diff --git a/libs/wire-api/src/Wire/API/MLS/Serialisation.hs b/libs/wire-api/src/Wire/API/MLS/Serialisation.hs new file mode 100644 index 00000000000..f773e8fa2e3 --- /dev/null +++ b/libs/wire-api/src/Wire/API/MLS/Serialisation.hs @@ -0,0 +1,107 @@ +-- 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.MLS.Serialisation + ( ParseMLS (..), + parseMLSVector, + parseMLSBytes, + BinaryMLS (..), + EnumMLS (..), + safeToEnum, + decodeMLS, + decodeMLS', + decodeMLSWith, + decodeMLSWith', + ) +where + +import Control.Applicative +import Data.Binary +import Data.Binary.Get +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Text as T +import Imports + +-- | Parse a value encoded using the "TLS presentation" format. +class ParseMLS a where + parseMLS :: Get a + +parseMLSVector :: forall w a. (Binary w, Integral w) => Get a -> Get [a] +parseMLSVector getItem = do + len <- get @w + if len == 0 + then pure [] + else isolate (fromIntegral len) $ go (fromIntegral len) + where + go :: Int64 -> Get [a] + go endPos = do + x <- getItem + pos <- bytesRead + (:) <$> pure x <*> if pos < endPos then go endPos else pure [] + +parseMLSBytes :: forall w. (Binary w, Integral w) => Get ByteString +parseMLSBytes = do + len <- fromIntegral <$> get @w + getByteString len + +instance ParseMLS Word8 where parseMLS = get + +instance ParseMLS Word16 where parseMLS = get + +instance ParseMLS Word32 where parseMLS = get + +instance ParseMLS Word64 where parseMLS = get + +-- | A wrapper to generate a 'ParseMLS' instance given a 'Binary' instance. +newtype BinaryMLS a = BinaryMLS a + +instance Binary a => ParseMLS (BinaryMLS a) where + parseMLS = BinaryMLS <$> get + +-- | A wrapper to generate a 'Binary' instance for an enumerated type. +newtype EnumMLS w a = EnumMLS {unEnumMLS :: a} + +safeToEnum :: forall a f. (Bounded a, Enum a, MonadFail f) => Int -> f a +safeToEnum n + | n >= fromEnum @a minBound && n <= fromEnum @a maxBound = + pure (toEnum n) + | otherwise = + fail "Out of bound enumeration" + +instance (Binary w, Integral w, Bounded a, Enum a) => ParseMLS (EnumMLS w a) where + parseMLS = do + n <- fromIntegral <$> get @w + EnumMLS <$> safeToEnum n + +-- | Decode an MLS value from a lazy bytestring. Return an error message in case of failure. +decodeMLS :: ParseMLS a => LByteString -> Either Text a +decodeMLS = decodeMLSWith parseMLS + +decodeMLS' :: ParseMLS a => ByteString -> Either Text a +decodeMLS' = decodeMLS . LBS.fromStrict + +-- | Decode an MLS value from a lazy bytestring given a custom parser. +-- Return an error message in case of failure. +decodeMLSWith :: Get a -> LByteString -> Either Text a +decodeMLSWith p b = case runGetOrFail p b of + Left (_, _, msg) -> Left (T.pack msg) + Right (remainder, pos, x) + | LBS.null remainder -> Right x + | otherwise -> Left $ "Trailing data at position " <> T.pack (show pos) + +decodeMLSWith' :: Get a -> ByteString -> Either Text a +decodeMLSWith' p = decodeMLSWith p . LBS.fromStrict diff --git a/libs/wire-api/src/Wire/API/MLS/Servant.hs b/libs/wire-api/src/Wire/API/MLS/Servant.hs new file mode 100644 index 00000000000..1f4ffb6c594 --- /dev/null +++ b/libs/wire-api/src/Wire/API/MLS/Servant.hs @@ -0,0 +1,37 @@ +-- 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.MLS.Servant (MLS, mimeUnrenderMLSWith) where + +import Data.Bifunctor +import Data.Binary +import qualified Data.Text as T +import Imports +import Network.HTTP.Media ((//)) +import Servant.API hiding (Get) +import Wire.API.MLS.Serialisation + +data MLS + +instance Accept MLS where + contentType _ = "message" // "mls" + +instance {-# OVERLAPPABLE #-} ParseMLS a => MimeUnrender MLS a where + mimeUnrender _ = mimeUnrenderMLSWith parseMLS + +mimeUnrenderMLSWith :: Get a -> LByteString -> Either String a +mimeUnrenderMLSWith p = first T.unpack . decodeMLSWith p diff --git a/libs/wire-api/src/Wire/API/Notification.hs b/libs/wire-api/src/Wire/API/Notification.hs index eb0a31c6d8d..d46ed7bfe43 100644 --- a/libs/wire-api/src/Wire/API/Notification.hs +++ b/libs/wire-api/src/Wire/API/Notification.hs @@ -41,11 +41,13 @@ module Wire.API.Notification where import Control.Lens (makeLenses) -import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON), (.!=), (.:), (.:?), (.=)) -import qualified Data.Aeson as JSON +import Data.Aeson (FromJSON (..), ToJSON (..)) +import qualified Data.Aeson.Types as Aeson import Data.Id -import Data.Json.Util ((#)) -import Data.List1 +import Data.Json.Util +import Data.List.NonEmpty (NonEmpty) +import Data.Schema +import qualified Data.Swagger as S import qualified Data.Swagger.Build.Api as Doc import Data.Time.Clock (UTCTime) import Imports @@ -56,7 +58,7 @@ type NotificationId = Id QueuedNotification -- FUTUREWORK: -- This definition is very opaque, but we know some of the structure already -- (e.g. visible in 'modelEvent'). Can we specify it in a better way? -type Event = JSON.Object +type Event = Aeson.Object modelEvent :: Doc.Model modelEvent = Doc.defineModel "NotificationEvent" $ do @@ -69,14 +71,22 @@ modelEvent = Doc.defineModel "NotificationEvent" $ do data QueuedNotification = QueuedNotification { _queuedNotificationId :: NotificationId, - _queuedNotificationPayload :: List1 Event + _queuedNotificationPayload :: NonEmpty Event } deriving stock (Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform QueuedNotification) + deriving (ToJSON, FromJSON, S.ToSchema) via (Schema QueuedNotification) -queuedNotification :: NotificationId -> List1 Event -> QueuedNotification +queuedNotification :: NotificationId -> NonEmpty Event -> QueuedNotification queuedNotification = QueuedNotification +instance ToSchema QueuedNotification where + schema = + object "QueuedNotification" $ + QueuedNotification + <$> _queuedNotificationId .= field "id" schema + <*> _queuedNotificationPayload .= field "payload" (nonEmptyArray jsonObject) + makeLenses ''QueuedNotification modelNotification :: Doc.Model @@ -87,19 +97,6 @@ modelNotification = Doc.defineModel "Notification" $ do Doc.property "payload" (Doc.array (Doc.ref modelEvent)) $ Doc.description "List of events" -instance ToJSON QueuedNotification where - toJSON (QueuedNotification i p) = - JSON.object - [ "id" .= i, - "payload" .= p - ] - -instance FromJSON QueuedNotification where - parseJSON = JSON.withObject "QueuedNotification" $ \o -> - QueuedNotification - <$> o .: "id" - <*> o .: "payload" - data QueuedNotificationList = QueuedNotificationList { _queuedNotifications :: [QueuedNotification], _queuedHasMore :: Bool, @@ -107,12 +104,11 @@ data QueuedNotificationList = QueuedNotificationList } deriving stock (Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform QueuedNotificationList) + deriving (ToJSON, FromJSON, S.ToSchema) via (Schema QueuedNotificationList) queuedNotificationList :: [QueuedNotification] -> Bool -> Maybe UTCTime -> QueuedNotificationList queuedNotificationList = QueuedNotificationList -makeLenses ''QueuedNotificationList - modelNotificationList :: Doc.Model modelNotificationList = Doc.defineModel "NotificationList" $ do Doc.description "Zero or more notifications" @@ -121,18 +117,12 @@ modelNotificationList = Doc.defineModel "NotificationList" $ do Doc.property "has_more" Doc.bool' $ Doc.description "Whether there are still more notifications." -instance ToJSON QueuedNotificationList where - toJSON (QueuedNotificationList ns more t) = - JSON.object - ( "notifications" .= ns - # "has_more" .= more - # "time" .= t - # [] - ) - -instance FromJSON QueuedNotificationList where - parseJSON = JSON.withObject "QueuedNotificationList" $ \o -> - QueuedNotificationList - <$> o .: "notifications" - <*> o .:? "has_more" .!= False - <*> o .:? "time" +instance ToSchema QueuedNotificationList where + schema = + object "QueuedNotificationList" $ + QueuedNotificationList + <$> _queuedNotifications .= field "notifications" (array schema) + <*> _queuedHasMore .= fmap (fromMaybe False) (optField "has_more" schema) + <*> _queuedTime .= maybe_ (optField "time" utcTimeSchema) + +makeLenses ''QueuedNotificationList diff --git a/libs/wire-api/src/Wire/API/Properties.hs b/libs/wire-api/src/Wire/API/Properties.hs index 38acd2f5d50..d7d05cac424 100644 --- a/libs/wire-api/src/Wire/API/Properties.hs +++ b/libs/wire-api/src/Wire/API/Properties.hs @@ -29,6 +29,7 @@ module Wire.API.Properties where import Data.Aeson +import qualified Data.Aeson.Key as Key import Data.ByteString.Conversion import Data.Hashable (Hashable) import qualified Data.Swagger.Build.Api as Doc @@ -46,7 +47,7 @@ modelPropertyDictionary = Doc.description "A JSON object with properties as attribute/value pairs." instance ToJSON PropertyKeysAndValues where - toJSON (PropertyKeysAndValues kvs) = object [toText k .= v | (PropertyKey k, v) <- kvs] + toJSON (PropertyKeysAndValues kvs) = object [Key.fromText (toText k) .= v | (PropertyKey k, v) <- kvs] newtype PropertyKey = PropertyKey {propertyKeyName :: AsciiPrintable} diff --git a/libs/wire-api/src/Wire/API/Routes/MultiVerb.hs b/libs/wire-api/src/Wire/API/Routes/MultiVerb.hs index 80d4a70b4d6..d0af4c19771 100644 --- a/libs/wire-api/src/Wire/API/Routes/MultiVerb.hs +++ b/libs/wire-api/src/Wire/API/Routes/MultiVerb.hs @@ -21,6 +21,7 @@ module Wire.API.Routes.MultiVerb ( -- * MultiVerb types MultiVerb, + MultiVerb1, Respond, RespondAs, RespondEmpty, @@ -476,6 +477,9 @@ combineSwaggerSchema s1 s2 -- the handler return type. data MultiVerb (method :: StdMethod) cs (as :: [*]) (r :: *) +-- | A 'MultiVerb' endpoint with a single response. +type MultiVerb1 m cs a = MultiVerb m cs '[a] (ResponseType a) + -- | This class is used to convert a handler return type to a union type -- including all possible responses of a 'MultiVerb' endpoint. -- diff --git a/libs/wire-api/src/Wire/API/Routes/Named.hs b/libs/wire-api/src/Wire/API/Routes/Named.hs index ea2fa27b195..9688ef75f1f 100644 --- a/libs/wire-api/src/Wire/API/Routes/Named.hs +++ b/libs/wire-api/src/Wire/API/Routes/Named.hs @@ -19,8 +19,9 @@ module Wire.API.Routes.Named where import Data.Metrics.Servant import Data.Proxy +import GHC.TypeLits import Imports -import Servant.Server +import Servant import Servant.Swagger newtype Named named x = Named {unnamed :: x} @@ -38,3 +39,30 @@ instance HasServer api ctx => HasServer (Named name api) ctx where instance RoutesToPaths api => RoutesToPaths (Named name api) where getRoutes = getRoutes @api + +type family FindName n (api :: *) :: (n, *) where + FindName n (Named name api) = '(name, api) + FindName n (x :> api) = AddPrefix x (FindName n api) + FindName n api = '(TypeError ('Text "Named combinator not found"), api) + +type family AddPrefix x napi where + AddPrefix x '(name, api) = '(name, x :> api) + +type family LiftNamed' napi where + LiftNamed' '(name, api) = Named name api + +type family Flatten api where + Flatten (x :> api) = Flatten1 x (Flatten api) + Flatten api = api + +type family Flatten1 x api where + Flatten1 x (api1 :<|> api2) = Flatten1 x api1 :<|> Flatten1 x api2 + Flatten1 x api = x :> api + +type family LiftFlatNamed n api where + LiftFlatNamed n (api1 :<|> api2) = LiftFlatNamed n api1 :<|> LiftFlatNamed n api2 + LiftFlatNamed n api = LiftNamed' (FindName n api) + +type LiftNamedOfKind n api = LiftFlatNamed n (Flatten api) + +type LiftNamed api = LiftNamedOfKind Symbol api diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs b/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs index 9859e947211..9181305a437 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs @@ -36,9 +36,11 @@ import Servant.Swagger (HasSwagger (toSwagger)) import Servant.Swagger.Internal.Orphans () import Wire.API.Connection import Wire.API.ErrorDescription +import Wire.API.MLS.KeyPackage +import Wire.API.MLS.Servant import Wire.API.Routes.MultiVerb import Wire.API.Routes.Named -import Wire.API.Routes.Public (ZConn, ZUser) +import Wire.API.Routes.Public import Wire.API.Routes.Public.Util import Wire.API.Routes.QualifiedCapture import Wire.API.User @@ -675,7 +677,48 @@ type ConnectionAPI = :> Get '[Servant.JSON] (SearchResult Contact) ) -type BrigAPI = UserAPI :<|> SelfAPI :<|> ClientAPI :<|> PrekeyAPI :<|> UserClientAPI :<|> ConnectionAPI +type MLSKeyPackageAPI = + "key-packages" + :> ( Named + "mls-key-packages-upload" + ( "self" + :> Summary "Upload a fresh batch of key packages" + :> Description "The request body should be a json object containing a list of base64-encoded key packages." + :> CanThrow MLSProtocolError + :> CanThrow MLSIdentityMismatch + :> CaptureClientId "client" + :> ReqBody '[JSON] KeyPackageUpload + :> MultiVerb 'POST '[JSON, MLS] '[RespondEmpty 201 "Key packages uploaded"] () + ) + :<|> ( Named + "mls-key-packages-claim" + ( "claim" + :> Summary "Claim one key package for each client of the given user" + :> QualifiedCaptureUserId "user" + :> MultiVerb1 'POST '[JSON] (Respond 200 "Claimed key packages" KeyPackageBundle) + ) + ) + :<|> ( Named + "mls-key-packages-count" + ( "self" + :> CaptureClientId "client" + :> "count" + :> Summary "Return the number of unused key packages for the given client" + :> MultiVerb1 'GET '[JSON] (Respond 200 "Number of key packages" KeyPackageCount) + ) + ) + ) + +type MLSAPI = LiftNamed (ZLocalUser :> "mls" :> MLSKeyPackageAPI) + +type BrigAPI = + UserAPI + :<|> SelfAPI + :<|> ClientAPI + :<|> PrekeyAPI + :<|> UserClientAPI + :<|> ConnectionAPI + :<|> MLSAPI brigSwagger :: Swagger brigSwagger = toSwagger (Proxy @BrigAPI) diff --git a/libs/wire-api/src/Wire/API/Routes/Version.hs b/libs/wire-api/src/Wire/API/Routes/Version.hs index acd525dc336..03cd25604e8 100644 --- a/libs/wire-api/src/Wire/API/Routes/Version.hs +++ b/libs/wire-api/src/Wire/API/Routes/Version.hs @@ -15,11 +15,24 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Wire.API.Routes.Version where +module Wire.API.Routes.Version + ( -- * API version endpoint + VersionAPI, + VersionInfo (..), + versionSwagger, + + -- * Version + Version (..), + supportedVersions, + readVersionNumber, + mkVersion, + ) +where import Control.Lens ((?~)) import Data.Aeson (FromJSON, ToJSON (..)) import qualified Data.Aeson as Aeson +import Data.Domain import Data.Schema import qualified Data.Swagger as S import qualified Data.Text as Text @@ -56,13 +69,28 @@ mkVersion n = case Aeson.fromJSON (Aeson.Number (fromIntegral n)) of supportedVersions :: [Version] supportedVersions = [minBound .. maxBound] -newtype VersionInfo = VersionInfo {vinfoSupported :: [Version]} +data VersionInfo = VersionInfo + { vinfoSupported :: [Version], + vinfoFederation :: Bool, + vinfoDomain :: Domain + } deriving (FromJSON, ToJSON, S.ToSchema) via (Schema VersionInfo) instance ToSchema VersionInfo where schema = - (S.schema . S.example ?~ toJSON (VersionInfo supportedVersions)) - (VersionInfo <$> vinfoSupported .= vinfoSchema schema) + objectWithDocModifier "VersionInfo" (S.schema . S.example ?~ toJSON example) $ + VersionInfo + <$> vinfoSupported .= vinfoObjectSchema schema + <*> vinfoFederation .= field "federation" schema + <*> vinfoDomain .= field "domain" schema + where + example :: VersionInfo + example = + VersionInfo + { vinfoSupported = supportedVersions, + vinfoFederation = False, + vinfoDomain = Domain "example.com" + } type VersionAPI = Named @@ -71,10 +99,5 @@ type VersionAPI = :> Get '[JSON] VersionInfo ) -versionAPI :: Applicative m => ServerT VersionAPI m -versionAPI = - Named @"get-version" $ - pure . VersionInfo $ supportedVersions - versionSwagger :: S.Swagger versionSwagger = toSwagger (Proxy @VersionAPI) diff --git a/libs/wire-api/src/Wire/API/Team/Export.hs b/libs/wire-api/src/Wire/API/Team/Export.hs index 1391f86b277..4cffed4cf25 100644 --- a/libs/wire-api/src/Wire/API/Team/Export.hs +++ b/libs/wire-api/src/Wire/API/Team/Export.hs @@ -98,7 +98,7 @@ allowEmpty p str = Just <$> p str parseByteString :: forall a. FromByteString a => ByteString -> Parser a parseByteString bstr = - case parseOnly (parser @a) (unquoted bstr) of + case parseOnly (parser @a) (cs (unquoted bstr)) of Left err -> fail err Right thing -> pure thing diff --git a/libs/wire-api/src/Wire/API/User.hs b/libs/wire-api/src/Wire/API/User.hs index be3dd749a2d..f097607fd71 100644 --- a/libs/wire-api/src/Wire/API/User.hs +++ b/libs/wire-api/src/Wire/API/User.hs @@ -109,6 +109,7 @@ import Control.Applicative import Control.Error.Safe (rightMay) import Control.Lens (over, view, (.~), (?~)) import Data.Aeson (FromJSON (..), ToJSON (..)) +import qualified Data.Aeson.KeyMap as KeyMap import qualified Data.Aeson.Types as A import Data.ByteString.Conversion import qualified Data.CaseInsensitive as CI @@ -116,7 +117,6 @@ import qualified Data.Code as Code import qualified Data.Currency as Currency import Data.Domain (Domain (Domain)) import Data.Handle (Handle) -import qualified Data.HashMap.Strict as HashMap import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap import Data.Id import Data.Json.Util (UTCTimeMillis, (#)) @@ -786,7 +786,7 @@ newtype InvitationCode = InvitationCode -- FUTUREWORK: Why is the SSO ID passed separately? parseIdentity :: Maybe UserSSOId -> A.Object -> A.Parser (Maybe UserIdentity) parseIdentity ssoid o = - if isJust (HashMap.lookup "email" o <|> HashMap.lookup "phone" o) || isJust ssoid + if isJust (KeyMap.lookup "email" o <|> KeyMap.lookup "phone" o) || isJust ssoid then Just <$> parseJSON (A.Object o) else pure Nothing diff --git a/libs/wire-api/src/Wire/API/User/Client.hs b/libs/wire-api/src/Wire/API/User/Client.hs index 5c6b54e6e58..76a9543db2e 100644 --- a/libs/wire-api/src/Wire/API/User/Client.hs +++ b/libs/wire-api/src/Wire/API/User/Client.hs @@ -78,10 +78,11 @@ import Control.Applicative import Control.Lens (over, view, (?~), (^.)) import Data.Aeson (FromJSON (..), ToJSON (..)) import qualified Data.Aeson as A +import qualified Data.Aeson.Key as Key +import qualified Data.Aeson.KeyMap as KeyMap import Data.Bifunctor (second) import Data.Coerce import Data.Domain (Domain) -import qualified Data.HashMap.Strict as HashMap import Data.Id import Data.Json.Util import qualified Data.Map.Strict as Map @@ -346,9 +347,9 @@ instance ToJSON UserClientsFull where instance FromJSON UserClientsFull where parseJSON = - A.withObject "UserClientsFull" (fmap UserClientsFull . foldrM fn Map.empty . HashMap.toList) + A.withObject "UserClientsFull" (fmap UserClientsFull . foldrM fn Map.empty . KeyMap.toList) where - fn (k, v) m = Map.insert <$> parseJSON (A.String k) <*> parseJSON v <*> pure m + fn (k, v) m = Map.insert <$> parseJSON (A.String $ Key.toText k) <*> parseJSON v <*> pure m instance Arbitrary UserClientsFull where arbitrary = UserClientsFull <$> mapOf' arbitrary (setOf' arbitrary) diff --git a/libs/wire-api/src/Wire/API/User/RichInfo.hs b/libs/wire-api/src/Wire/API/User/RichInfo.hs index 350c878715e..7eb1b9e448f 100644 --- a/libs/wire-api/src/Wire/API/User/RichInfo.hs +++ b/libs/wire-api/src/Wire/API/User/RichInfo.hs @@ -47,13 +47,12 @@ module Wire.API.User.RichInfo where import Data.Aeson +import qualified Data.Aeson.Key as Key +import qualified Data.Aeson.KeyMap as KeyMap import qualified Data.Aeson.Types as Aeson import Data.Bifunctor import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI -import qualified Data.HashMap.Strict as HM -import qualified Data.HashMap.Strict as HashMap -import Data.Hashable (Hashable) import Data.List.Extra (nubOrdOn) import qualified Data.Map as Map import Data.String.Conversions (cs) @@ -160,7 +159,7 @@ modelRichInfo = Doc.defineModel "RichInfo" $ do instance ToJSON RichInfoMapAndList where toJSON u = object - [ richInfoAssocListURN + [ Key.fromText richInfoAssocListURN .= object [ "richInfo" .= object @@ -168,33 +167,33 @@ instance ToJSON RichInfoMapAndList where "version" .= (0 :: Int) ] ], - richInfoMapURN .= Map.mapKeys CI.original (richInfoMap u) + Key.fromText richInfoMapURN .= Map.mapKeys CI.original (richInfoMap u) ] instance FromJSON RichInfoMapAndList where parseJSON = withObject "RichInfo" $ \o -> - let objWithCIKeys = hmMapKeys CI.mk o + let objWithCIKeys = mapKeys CI.mk (KeyMap.toMapText o) in normalizeRichInfoMapAndList <$> ( RichInfoMapAndList <$> extractMap objWithCIKeys <*> extractAssocList objWithCIKeys ) where - extractMap :: HashMap (CI Text) Value -> Aeson.Parser (Map (CI Text) Text) + extractMap :: Map (CI Text) Value -> Aeson.Parser (Map (CI Text) Text) extractMap o = - case HM.lookup (CI.mk richInfoMapURN) o of + case Map.lookup (CI.mk richInfoMapURN) o of Nothing -> pure mempty Just innerObj -> do Map.mapKeys CI.mk <$> parseJSON innerObj - extractAssocList :: HashMap (CI Text) Value -> Aeson.Parser [RichField] + extractAssocList :: Map (CI Text) Value -> Aeson.Parser [RichField] extractAssocList o = - case HM.lookup (CI.mk richInfoAssocListURN) o of + case Map.lookup (CI.mk richInfoAssocListURN) o of Nothing -> pure [] Just (Object innerObj) -> do - richInfo <- lookupOrFail "richinfo" $ hmMapKeys CI.mk innerObj + richInfo <- lookupOrFail "richinfo" $ mapKeys CI.mk (KeyMap.toMapText innerObj) case richInfo of Object richinfoObj -> do richInfoAssocListFromObject richinfoObj @@ -202,11 +201,11 @@ instance FromJSON RichInfoMapAndList where v -> Aeson.typeMismatch "Object or Array" v Just v -> Aeson.typeMismatch "Object" v - hmMapKeys :: (Eq k2, Hashable k2) => (k1 -> k2) -> HashMap k1 v -> HashMap k2 v - hmMapKeys f = HashMap.fromList . map (Data.Bifunctor.first f) . HashMap.toList + mapKeys :: (Eq k2, Ord k2) => (k1 -> k2) -> Map k1 v -> Map k2 v + mapKeys f = Map.fromList . map (Data.Bifunctor.first f) . Map.toList - lookupOrFail :: (MonadFail m, Show k, Eq k, Hashable k) => k -> HashMap k v -> m v - lookupOrFail key theMap = case HM.lookup key theMap of + lookupOrFail :: (MonadFail m, Show k, Eq k, Ord k) => k -> Map k v -> m v + lookupOrFail key theMap = case Map.lookup key theMap of Nothing -> fail $ "key '" ++ show key ++ "' not found" Just v -> return v diff --git a/libs/wire-api/src/Wire/API/User/Search.hs b/libs/wire-api/src/Wire/API/User/Search.hs index 152500a8e3a..8f3c00d3a78 100644 --- a/libs/wire-api/src/Wire/API/User/Search.hs +++ b/libs/wire-api/src/Wire/API/User/Search.hs @@ -25,6 +25,7 @@ module Wire.API.User.Search RoleFilter (..), TeamUserSearchSortOrder (..), TeamUserSearchSortBy (..), + FederatedUserSearchPolicy (..), -- * Swagger modelSearchResult, @@ -33,19 +34,18 @@ module Wire.API.User.Search ) where -import Control.Lens (over, (.~), (?~)) -import Data.Aeson +import Control.Lens (makePrisms, (?~)) +import Data.Aeson hiding (object, (.=)) +import qualified Data.Aeson as Aeson import Data.Attoparsec.ByteString (sepBy) import Data.Attoparsec.ByteString.Char8 (char, string) import Data.ByteString.Conversion (FromByteString (..), ToByteString (..)) -import qualified Data.HashMap.Strict.InsOrd as InsOrdHasMap import Data.Id (TeamId, UserId) import Data.Json.Util (UTCTimeMillis) -import Data.Proxy (Proxy (..)) import Data.Qualified -import Data.Swagger hiding (Contact) +import Data.Schema +import qualified Data.Swagger as S import qualified Data.Swagger.Build.Api as Doc -import Deriving.Swagger import Imports import Wire.API.Arbitrary (Arbitrary, GenericUniform (..)) import Wire.API.Team.Role (Role) @@ -59,7 +59,8 @@ data SearchResult a = SearchResult { searchFound :: Int, searchReturned :: Int, searchTook :: Int, - searchResults :: [a] + searchResults :: [a], + searchPolicy :: FederatedUserSearchPolicy } deriving stock (Eq, Show, Generic, Functor) deriving (Arbitrary) via (GenericUniform (SearchResult a)) @@ -72,22 +73,21 @@ instance Traversable SearchResult where newResults <- traverse f (searchResults r) pure $ r {searchResults = newResults} -instance ToSchema (SearchResult Contact) where - declareNamedSchema _ = do - intSchema <- declareSchema (Proxy @Int) - contacts <- declareSchema (Proxy @[Contact]) - pure $ - NamedSchema (Just "SearchResult") $ - mempty - & type_ ?~ SwaggerObject - & properties - .~ InsOrdHasMap.fromList - [ ("found", Inline (intSchema & description ?~ "Total number of hits")), - ("returned", Inline (intSchema & description ?~ "Total number of hits returned")), - ("took", Inline (intSchema & description ?~ "Search time in ms")), - ("documents", Inline (contacts & description ?~ "List of contacts found")) - ] - & required .~ ["found", "returned", "took", "documents"] +instance ToSchema a => ToSchema (SearchResult a) where + schema = + object "SearchResult" $ + SearchResult + <$> searchFound .= fieldWithDocModifier "found" (S.description ?~ "Total number of hits") schema + <*> searchReturned .= fieldWithDocModifier "returned" (S.description ?~ "Total number of hits returned") schema + <*> searchTook .= fieldWithDocModifier "took" (S.description ?~ "Search time in ms") schema + <*> searchResults .= fieldWithDocModifier "documents" (S.description ?~ "List of contacts found") (array schema) + <*> searchPolicy .= fieldWithDocModifier "search_policy" (S.description ?~ "Search policy that was applied when searching for users") schema + +deriving via (Schema (SearchResult Contact)) instance ToJSON (SearchResult Contact) + +deriving via (Schema (SearchResult Contact)) instance FromJSON (SearchResult Contact) + +deriving via (Schema (SearchResult Contact)) instance S.ToSchema (SearchResult Contact) modelSearchResult :: Doc.Model -> Doc.Model modelSearchResult modelContact = Doc.defineModel "SearchResult" $ do @@ -101,28 +101,28 @@ modelSearchResult modelContact = Doc.defineModel "SearchResult" $ do Doc.property "documents" (Doc.array (Doc.ref modelContact)) $ Doc.description "List of contacts found" -instance ToJSON a => ToJSON (SearchResult a) where +instance ToJSON (SearchResult TeamContact) where toJSON r = - object - [ "found" .= searchFound r, - "returned" .= searchReturned r, - "took" .= searchTook r, - "documents" .= searchResults r + Aeson.object + [ "found" Aeson..= searchFound r, + "returned" Aeson..= searchReturned r, + "took" Aeson..= searchTook r, + "documents" Aeson..= searchResults r, + "search_policy" Aeson..= searchPolicy r ] -instance FromJSON a => FromJSON (SearchResult a) where +instance FromJSON (SearchResult TeamContact) where parseJSON = withObject "SearchResult" $ \o -> SearchResult <$> o .: "found" <*> o .: "returned" <*> o .: "took" <*> o .: "documents" + <*> o .: "search_policy" -------------------------------------------------------------------------------- -- Contact -type ContactLabelMappings = '["color_id" ':-> "accent_id"] - -- | Returned by 'searchIndex' under @/contacts/search@. -- This is a subset of 'User' and json instances should reflect that. data Contact = Contact @@ -134,19 +134,7 @@ data Contact = Contact } deriving stock (Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform Contact) - -instance ToSchema Contact where - declareNamedSchema _ = do - genericSchema <- - genericDeclareNamedSchema - ( swaggerOptions - @'[FieldLabelModifier (StripPrefix "contact", CamelToSnake, LabelMappings ContactLabelMappings)] - ) - (Proxy @Contact) - idSchema <- declareSchemaRef (Proxy @UserId) - pure $ - genericSchema - & over (schema . properties) (InsOrdHasMap.insert "id" idSchema) + deriving (ToJSON, FromJSON, S.ToSchema) via Schema Contact modelSearchContact :: Doc.Model modelSearchContact = Doc.defineModel "Contact" $ do @@ -164,26 +152,16 @@ modelSearchContact = Doc.defineModel "Contact" $ do Doc.description "Team ID" Doc.optional -instance ToJSON Contact where - toJSON c = - object - [ "id" .= qUnqualified (contactQualifiedId c), -- For backwards compatibility - "qualified_id" .= contactQualifiedId c, - "name" .= contactName c, - "accent_id" .= contactColorId c, - "handle" .= contactHandle c, - "team" .= contactTeam c - ] - -instance FromJSON Contact where - parseJSON = - withObject "Contact" $ \o -> +instance ToSchema Contact where + schema = + objectWithDocModifier "Contact" (description ?~ "Contact discovered through search") $ Contact - <$> o .: "qualified_id" - <*> o .: "name" - <*> o .:? "accent_id" - <*> o .:? "handle" - <*> o .:? "team" + <$> contactQualifiedId .= field "qualified_id" schema + <* (qUnqualified . contactQualifiedId) .= optField "id" schema + <*> contactName .= field "name" schema + <*> contactColorId .= optField "accent_id" (maybeWithDefault Aeson.Null schema) + <*> contactHandle .= optField "handle" (maybeWithDefault Aeson.Null schema) + <*> contactTeam .= optField "team" (maybeWithDefault Aeson.Null schema) -------------------------------------------------------------------------------- -- TeamContact @@ -225,17 +203,17 @@ modelTeamContact = Doc.defineModel "TeamContact" $ do instance ToJSON TeamContact where toJSON c = - object - [ "id" .= teamContactUserId c, - "name" .= teamContactName c, - "accent_id" .= teamContactColorId c, - "handle" .= teamContactHandle c, - "team" .= teamContactTeam c, - "email" .= teamContactEmail c, - "created_at" .= teamContactCreatedAt c, - "managed_by" .= teamContactManagedBy c, - "saml_idp" .= teamContactSAMLIdp c, - "role" .= teamContactRole c + Aeson.object + [ "id" Aeson..= teamContactUserId c, + "name" Aeson..= teamContactName c, + "accent_id" Aeson..= teamContactColorId c, + "handle" Aeson..= teamContactHandle c, + "team" Aeson..= teamContactTeam c, + "email" Aeson..= teamContactEmail c, + "created_at" Aeson..= teamContactCreatedAt c, + "managed_by" Aeson..= teamContactManagedBy c, + "saml_idp" Aeson..= teamContactSAMLIdp c, + "role" Aeson..= teamContactRole c ] instance FromJSON TeamContact where @@ -307,3 +285,20 @@ instance ToByteString RoleFilter where instance FromByteString RoleFilter where parser = RoleFilter <$> parser `sepBy` char ',' + +data FederatedUserSearchPolicy + = NoSearch + | ExactHandleSearch + | FullSearch + deriving (Show, Eq, Generic, Enum, Bounded) + deriving (Arbitrary) via (GenericUniform FederatedUserSearchPolicy) + deriving (ToJSON, FromJSON) via (Schema FederatedUserSearchPolicy) + +instance ToSchema FederatedUserSearchPolicy where + schema = + enum @Text "FederatedUserSearchPolicy" $ + element "no_search" NoSearch + <> element "exact_handle_search" ExactHandleSearch + <> element "full_search" FullSearch + +makePrisms ''FederatedUserSearchPolicy diff --git a/libs/wire-api/src/Wire/API/VersionInfo.hs b/libs/wire-api/src/Wire/API/VersionInfo.hs index 7c888e684df..cd0f6bbdf1d 100644 --- a/libs/wire-api/src/Wire/API/VersionInfo.hs +++ b/libs/wire-api/src/Wire/API/VersionInfo.hs @@ -16,12 +16,11 @@ -- with this program. If not, see . module Wire.API.VersionInfo - ( vinfoSchema, + ( vinfoObjectSchema, ) where import Data.Schema -import Imports -vinfoSchema :: ValueSchema NamedSwaggerDoc v -> ValueSchema NamedSwaggerDoc [v] -vinfoSchema sch = object "VersionInfo" $ field "supported" (array sch) +vinfoObjectSchema :: ValueSchema NamedSwaggerDoc v -> ObjectSchema SwaggerDoc [v] +vinfoObjectSchema sch = field "supported" (array sch) diff --git a/libs/wire-api/src/Wire/API/Wrapped.hs b/libs/wire-api/src/Wire/API/Wrapped.hs index 4c8b59b71ce..8a8095db863 100644 --- a/libs/wire-api/src/Wire/API/Wrapped.hs +++ b/libs/wire-api/src/Wire/API/Wrapped.hs @@ -19,6 +19,7 @@ module Wire.API.Wrapped where import Control.Lens ((.~), (?~)) import Data.Aeson +import qualified Data.Aeson.Key as Key import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap import Data.Proxy (Proxy (..)) import Data.Swagger @@ -33,11 +34,11 @@ newtype Wrapped (name :: Symbol) a = Wrapped {unwrap :: a} deriving stock (Show, Eq) instance (ToJSON a, KnownSymbol name) => ToJSON (Wrapped name a) where - toJSON (Wrapped thing) = object [Text.pack (symbolVal (Proxy @name)) .= thing] + toJSON (Wrapped thing) = object [Key.fromString (symbolVal (Proxy @name)) .= thing] instance (FromJSON a, KnownSymbol name) => FromJSON (Wrapped name a) where parseJSON = withObject ("Wrapped" <> symbolVal (Proxy @name)) $ \o -> - Wrapped <$> o .: Text.pack (symbolVal (Proxy @name)) + Wrapped <$> o .: Key.fromString (symbolVal (Proxy @name)) -- | Creates schema without name, as coming up with a _nice_ name is fairly hard -- here. diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/QueuedNotificationList_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/QueuedNotificationList_user.hs index 88824f28b1d..e760cef1efb 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/QueuedNotificationList_user.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/QueuedNotificationList_user.hs @@ -22,7 +22,6 @@ module Test.Wire.API.Golden.Generated.QueuedNotificationList_user where import Data.Aeson (Value (Bool, Null)) import Data.Id (Id (Id)) import qualified Data.List.NonEmpty as NonEmpty (fromList) -import Data.List1 (List1 (List1)) import qualified Data.UUID as UUID (fromString) import GHC.Exts (IsList (fromList)) import Imports (Bool (False, True), Functor (fmap), Maybe (Just, Nothing), fromJust, read) @@ -33,11 +32,9 @@ testObject_QueuedNotificationList_user_1 = queuedNotificationList [ queuedNotification (Id (fromJust (UUID.fromString "00000002-0000-0001-0000-000100000000"))) - ( List1 - ( NonEmpty.fromList - [ fromList [("", Null), ("p", Bool True)] - ] - ) + ( NonEmpty.fromList + [ fromList [("", Null), ("p", Bool True)] + ] ) ] True diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/QueuedNotification_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/QueuedNotification_user.hs index ed53f27d3a6..c638fcf0f93 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/QueuedNotification_user.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/QueuedNotification_user.hs @@ -22,7 +22,6 @@ module Test.Wire.API.Golden.Generated.QueuedNotification_user where import Data.Aeson (Value (Array)) import Data.Id (Id (Id)) import qualified Data.List.NonEmpty as NonEmpty (fromList) -import Data.List1 (List1 (List1)) import qualified Data.UUID as UUID (fromString) import GHC.Exts (IsList (fromList)) import Imports (fromJust) @@ -32,12 +31,9 @@ testObject_QueuedNotification_user_1 :: QueuedNotification testObject_QueuedNotification_user_1 = ( queuedNotification (Id (fromJust (UUID.fromString "0000005f-0000-007b-0000-001a0000000a"))) - ( ( List1 - ( NonEmpty.fromList - [ fromList [], - fromList [("\179372\&3", Array [])] - ] - ) - ) + ( NonEmpty.fromList + [ fromList [], + fromList [("\179372\&3", Array [])] + ] ) ) diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/SearchResult_20Contact_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/SearchResult_20Contact_user.hs index 1bc196350ec..91e91bd932e 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/SearchResult_20Contact_user.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/SearchResult_20Contact_user.hs @@ -24,15 +24,15 @@ import Data.Id (Id (Id)) import Data.Qualified (Qualified (Qualified, qDomain, qUnqualified)) import qualified Data.UUID as UUID (fromString) import Imports (Maybe (Just, Nothing), fromJust) -import Wire.API.User.Search (Contact (..), SearchResult (..)) +import Wire.API.User.Search (Contact (..), FederatedUserSearchPolicy (ExactHandleSearch, FullSearch), SearchResult (..)) testObject_SearchResult_20Contact_user_1 :: SearchResult Contact testObject_SearchResult_20Contact_user_1 = - SearchResult {searchFound = -6, searchReturned = 0, searchTook = 1, searchResults = []} + SearchResult {searchFound = -6, searchReturned = 0, searchTook = 1, searchResults = [], searchPolicy = FullSearch} testObject_SearchResult_20Contact_user_2 :: SearchResult Contact testObject_SearchResult_20Contact_user_2 = - SearchResult {searchFound = -4, searchReturned = 6, searchTook = -5, searchResults = []} + SearchResult {searchFound = -4, searchReturned = 6, searchTook = -5, searchResults = [], searchPolicy = FullSearch} testObject_SearchResult_20Contact_user_3 :: SearchResult Contact testObject_SearchResult_20Contact_user_3 = @@ -52,7 +52,8 @@ testObject_SearchResult_20Contact_user_3 = contactHandle = Just "", contactTeam = Just (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000000"))) } - ] + ], + searchPolicy = FullSearch } testObject_SearchResult_20Contact_user_4 :: SearchResult Contact @@ -128,7 +129,8 @@ testObject_SearchResult_20Contact_user_4 = contactHandle = Just "", contactTeam = Just (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000"))) } - ] + ], + searchPolicy = FullSearch } testObject_SearchResult_20Contact_user_5 :: SearchResult Contact @@ -149,12 +151,13 @@ testObject_SearchResult_20Contact_user_5 = contactHandle = Just "", contactTeam = Just (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000001"))) } - ] + ], + searchPolicy = FullSearch } testObject_SearchResult_20Contact_user_6 :: SearchResult Contact testObject_SearchResult_20Contact_user_6 = - SearchResult {searchFound = -5, searchReturned = -4, searchTook = 5, searchResults = []} + SearchResult {searchFound = -5, searchReturned = -4, searchTook = 5, searchResults = [], searchPolicy = FullSearch} testObject_SearchResult_20Contact_user_7 :: SearchResult Contact testObject_SearchResult_20Contact_user_7 = @@ -185,7 +188,8 @@ testObject_SearchResult_20Contact_user_7 = contactHandle = Nothing, contactTeam = Just (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000000"))) } - ] + ], + searchPolicy = FullSearch } testObject_SearchResult_20Contact_user_8 :: SearchResult Contact @@ -206,16 +210,17 @@ testObject_SearchResult_20Contact_user_8 = contactHandle = Just "", contactTeam = Just (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000000"))) } - ] + ], + searchPolicy = FullSearch } testObject_SearchResult_20Contact_user_9 :: SearchResult Contact testObject_SearchResult_20Contact_user_9 = - SearchResult {searchFound = -5, searchReturned = -6, searchTook = 3, searchResults = []} + SearchResult {searchFound = -5, searchReturned = -6, searchTook = 3, searchResults = [], searchPolicy = FullSearch} testObject_SearchResult_20Contact_user_10 :: SearchResult Contact testObject_SearchResult_20Contact_user_10 = - SearchResult {searchFound = 0, searchReturned = -7, searchTook = -5, searchResults = []} + SearchResult {searchFound = 0, searchReturned = -7, searchTook = -5, searchResults = [], searchPolicy = FullSearch} testObject_SearchResult_20Contact_user_11 :: SearchResult Contact testObject_SearchResult_20Contact_user_11 = @@ -246,12 +251,13 @@ testObject_SearchResult_20Contact_user_11 = contactHandle = Just "", contactTeam = Nothing } - ] + ], + searchPolicy = ExactHandleSearch } testObject_SearchResult_20Contact_user_12 :: SearchResult Contact testObject_SearchResult_20Contact_user_12 = - SearchResult {searchFound = 7, searchReturned = 5, searchTook = 3, searchResults = []} + SearchResult {searchFound = 7, searchReturned = 5, searchTook = 3, searchResults = [], searchPolicy = ExactHandleSearch} testObject_SearchResult_20Contact_user_13 :: SearchResult Contact testObject_SearchResult_20Contact_user_13 = @@ -304,7 +310,8 @@ testObject_SearchResult_20Contact_user_13 = contactHandle = Just "", contactTeam = Nothing } - ] + ], + searchPolicy = ExactHandleSearch } testObject_SearchResult_20Contact_user_14 :: SearchResult Contact @@ -336,24 +343,25 @@ testObject_SearchResult_20Contact_user_14 = contactHandle = Just "", contactTeam = Nothing } - ] + ], + searchPolicy = ExactHandleSearch } testObject_SearchResult_20Contact_user_15 :: SearchResult Contact testObject_SearchResult_20Contact_user_15 = - SearchResult {searchFound = 3, searchReturned = 2, searchTook = 4, searchResults = []} + SearchResult {searchFound = 3, searchReturned = 2, searchTook = 4, searchResults = [], searchPolicy = ExactHandleSearch} testObject_SearchResult_20Contact_user_16 :: SearchResult Contact testObject_SearchResult_20Contact_user_16 = - SearchResult {searchFound = -4, searchReturned = 4, searchTook = -7, searchResults = []} + SearchResult {searchFound = -4, searchReturned = 4, searchTook = -7, searchResults = [], searchPolicy = ExactHandleSearch} testObject_SearchResult_20Contact_user_17 :: SearchResult Contact testObject_SearchResult_20Contact_user_17 = - SearchResult {searchFound = 6, searchReturned = -1, searchTook = -1, searchResults = []} + SearchResult {searchFound = 6, searchReturned = -1, searchTook = -1, searchResults = [], searchPolicy = ExactHandleSearch} testObject_SearchResult_20Contact_user_18 :: SearchResult Contact testObject_SearchResult_20Contact_user_18 = - SearchResult {searchFound = -4, searchReturned = 0, searchTook = -5, searchResults = []} + SearchResult {searchFound = -4, searchReturned = 0, searchTook = -5, searchResults = [], searchPolicy = ExactHandleSearch} testObject_SearchResult_20Contact_user_19 :: SearchResult Contact testObject_SearchResult_20Contact_user_19 = @@ -384,7 +392,8 @@ testObject_SearchResult_20Contact_user_19 = contactHandle = Just "", contactTeam = Just (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000001"))) } - ] + ], + searchPolicy = ExactHandleSearch } testObject_SearchResult_20Contact_user_20 :: SearchResult Contact @@ -537,5 +546,6 @@ testObject_SearchResult_20Contact_user_20 = contactHandle = Nothing, contactTeam = Just (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000000"))) } - ] + ], + searchPolicy = ExactHandleSearch } diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/SearchResult_20TeamContact_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/SearchResult_20TeamContact_user.hs index 678bcf4038e..887d69eebe8 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/SearchResult_20TeamContact_user.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/SearchResult_20TeamContact_user.hs @@ -25,7 +25,7 @@ import qualified Data.UUID as UUID (fromString) import Imports (Maybe (Just, Nothing), fromJust) import Wire.API.Team.Role (Role (RoleAdmin, RoleExternalPartner, RoleMember, RoleOwner)) import Wire.API.User (Email (Email, emailDomain, emailLocal), ManagedBy (ManagedByScim, ManagedByWire)) -import Wire.API.User.Search (SearchResult (..), TeamContact (..)) +import Wire.API.User.Search (FederatedUserSearchPolicy (ExactHandleSearch, FullSearch), SearchResult (..), TeamContact (..)) testObject_SearchResult_20TeamContact_user_1 :: SearchResult TeamContact testObject_SearchResult_20TeamContact_user_1 = @@ -58,12 +58,13 @@ testObject_SearchResult_20TeamContact_user_1 = teamContactSAMLIdp = Nothing, teamContactRole = Just RoleExternalPartner } - ] + ], + searchPolicy = FullSearch } testObject_SearchResult_20TeamContact_user_2 :: SearchResult TeamContact testObject_SearchResult_20TeamContact_user_2 = - SearchResult {searchFound = -5, searchReturned = 4, searchTook = 6, searchResults = []} + SearchResult {searchFound = -5, searchReturned = 4, searchTook = 6, searchResults = [], searchPolicy = FullSearch} testObject_SearchResult_20TeamContact_user_3 :: SearchResult TeamContact testObject_SearchResult_20TeamContact_user_3 = @@ -108,7 +109,8 @@ testObject_SearchResult_20TeamContact_user_3 = teamContactSAMLIdp = Just "", teamContactRole = Nothing } - ] + ], + searchPolicy = FullSearch } testObject_SearchResult_20TeamContact_user_4 :: SearchResult TeamContact @@ -166,7 +168,8 @@ testObject_SearchResult_20TeamContact_user_4 = teamContactSAMLIdp = Just "", teamContactRole = Just RoleExternalPartner } - ] + ], + searchPolicy = ExactHandleSearch } testObject_SearchResult_20TeamContact_user_5 :: SearchResult TeamContact @@ -188,7 +191,8 @@ testObject_SearchResult_20TeamContact_user_5 = teamContactSAMLIdp = Just "", teamContactRole = Just RoleExternalPartner } - ] + ], + searchPolicy = FullSearch } testObject_SearchResult_20TeamContact_user_6 :: SearchResult TeamContact @@ -354,7 +358,8 @@ testObject_SearchResult_20TeamContact_user_6 = teamContactSAMLIdp = Nothing, teamContactRole = Just RoleExternalPartner } - ] + ], + searchPolicy = FullSearch } testObject_SearchResult_20TeamContact_user_7 :: SearchResult TeamContact @@ -436,7 +441,8 @@ testObject_SearchResult_20TeamContact_user_7 = teamContactSAMLIdp = Just "", teamContactRole = Just RoleExternalPartner } - ] + ], + searchPolicy = FullSearch } testObject_SearchResult_20TeamContact_user_8 :: SearchResult TeamContact @@ -494,7 +500,8 @@ testObject_SearchResult_20TeamContact_user_8 = teamContactSAMLIdp = Just "", teamContactRole = Nothing } - ] + ], + searchPolicy = FullSearch } testObject_SearchResult_20TeamContact_user_9 :: SearchResult TeamContact @@ -552,12 +559,13 @@ testObject_SearchResult_20TeamContact_user_9 = teamContactSAMLIdp = Just "", teamContactRole = Just RoleExternalPartner } - ] + ], + searchPolicy = FullSearch } testObject_SearchResult_20TeamContact_user_10 :: SearchResult TeamContact testObject_SearchResult_20TeamContact_user_10 = - SearchResult {searchFound = -3, searchReturned = -3, searchTook = -4, searchResults = []} + SearchResult {searchFound = -3, searchReturned = -3, searchTook = -4, searchResults = [], searchPolicy = FullSearch} testObject_SearchResult_20TeamContact_user_11 :: SearchResult TeamContact testObject_SearchResult_20TeamContact_user_11 = @@ -662,7 +670,8 @@ testObject_SearchResult_20TeamContact_user_11 = teamContactSAMLIdp = Just "", teamContactRole = Nothing } - ] + ], + searchPolicy = FullSearch } testObject_SearchResult_20TeamContact_user_12 :: SearchResult TeamContact @@ -684,7 +693,8 @@ testObject_SearchResult_20TeamContact_user_12 = teamContactSAMLIdp = Just "", teamContactRole = Nothing } - ] + ], + searchPolicy = FullSearch } testObject_SearchResult_20TeamContact_user_13 :: SearchResult TeamContact @@ -730,7 +740,8 @@ testObject_SearchResult_20TeamContact_user_13 = teamContactSAMLIdp = Just "", teamContactRole = Nothing } - ] + ], + searchPolicy = FullSearch } testObject_SearchResult_20TeamContact_user_14 :: SearchResult TeamContact @@ -752,7 +763,8 @@ testObject_SearchResult_20TeamContact_user_14 = teamContactSAMLIdp = Just "", teamContactRole = Just RoleAdmin } - ] + ], + searchPolicy = FullSearch } testObject_SearchResult_20TeamContact_user_15 :: SearchResult TeamContact @@ -774,7 +786,8 @@ testObject_SearchResult_20TeamContact_user_15 = teamContactSAMLIdp = Nothing, teamContactRole = Just RoleOwner } - ] + ], + searchPolicy = FullSearch } testObject_SearchResult_20TeamContact_user_16 :: SearchResult TeamContact @@ -820,7 +833,8 @@ testObject_SearchResult_20TeamContact_user_16 = teamContactSAMLIdp = Just "", teamContactRole = Just RoleAdmin } - ] + ], + searchPolicy = FullSearch } testObject_SearchResult_20TeamContact_user_17 :: SearchResult TeamContact @@ -842,7 +856,8 @@ testObject_SearchResult_20TeamContact_user_17 = teamContactSAMLIdp = Just "", teamContactRole = Just RoleExternalPartner } - ] + ], + searchPolicy = FullSearch } testObject_SearchResult_20TeamContact_user_18 :: SearchResult TeamContact @@ -864,13 +879,14 @@ testObject_SearchResult_20TeamContact_user_18 = teamContactSAMLIdp = Just "", teamContactRole = Just RoleOwner } - ] + ], + searchPolicy = FullSearch } testObject_SearchResult_20TeamContact_user_19 :: SearchResult TeamContact testObject_SearchResult_20TeamContact_user_19 = - SearchResult {searchFound = -6, searchReturned = -1, searchTook = -2, searchResults = []} + SearchResult {searchFound = -6, searchReturned = -1, searchTook = -2, searchResults = [], searchPolicy = FullSearch} testObject_SearchResult_20TeamContact_user_20 :: SearchResult TeamContact testObject_SearchResult_20TeamContact_user_20 = - SearchResult {searchFound = -6, searchReturned = -5, searchTook = 1, searchResults = []} + SearchResult {searchFound = -6, searchReturned = -5, searchTook = 1, searchResults = [], searchPolicy = FullSearch} diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual.hs index 177d4dd065c..b014d923785 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual.hs @@ -21,6 +21,7 @@ import Imports import Test.Tasty import Test.Wire.API.Golden.Manual.ClientCapability import Test.Wire.API.Golden.Manual.ClientCapabilityList +import Test.Wire.API.Golden.Manual.Contact import Test.Wire.API.Golden.Manual.ConvIdsPage import Test.Wire.API.Golden.Manual.ConversationCoverView import Test.Wire.API.Golden.Manual.ConversationPagingState @@ -30,6 +31,7 @@ import Test.Wire.API.Golden.Manual.FeatureConfigEvent import Test.Wire.API.Golden.Manual.GetPaginatedConversationIds import Test.Wire.API.Golden.Manual.ListConversations import Test.Wire.API.Golden.Manual.QualifiedUserClientPrekeyMap +import Test.Wire.API.Golden.Manual.SearchResultContact import Test.Wire.API.Golden.Manual.UserClientPrekeyMap import Test.Wire.API.Golden.Manual.UserIdList import Test.Wire.API.Golden.Runner @@ -108,5 +110,9 @@ tests = (testObject_CreateScimToken_2, "testObject_CreateScimToken_2.json"), (testObject_CreateScimToken_3, "testObject_CreateScimToken_3.json"), (testObject_CreateScimToken_4, "testObject_CreateScimToken_4.json") - ] + ], + testGroup "Contact" $ + testObjects [(testObject_Contact_1, "testObject_Contact_1.json"), (testObject_Contact_2, "testObject_Contact_2.json")], + testGroup "SearchResult Contact" $ + testObjects [(testObject_SearchResultContact_1, "testObject_SearchResultContact_1.json")] ] diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/Contact.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/Contact.hs new file mode 100644 index 00000000000..438b54c112c --- /dev/null +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/Contact.hs @@ -0,0 +1,45 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Test.Wire.API.Golden.Manual.Contact where + +import Data.Domain (Domain (Domain)) +import Data.Id (Id (Id)) +import Data.Qualified (Qualified (Qualified)) +import qualified Data.UUID as UUID +import Imports +import Wire.API.User.Search (Contact (..)) + +testObject_Contact_1 :: Contact +testObject_Contact_1 = + Contact + { contactQualifiedId = Qualified (Id (fromJust (UUID.fromString "00000018-0000-0020-0000-000e00000002"))) (Domain "example.com"), + contactName = "Foobar", + contactColorId = Just 1, + contactHandle = Just "foobar1", + contactTeam = Just $ Id (fromJust (UUID.fromString "00000018-0000-0020-0000-000e00000002")) + } + +testObject_Contact_2 :: Contact +testObject_Contact_2 = + Contact + { contactQualifiedId = Qualified (Id (fromJust (UUID.fromString "00000018-0000-0020-0000-000e00000003"))) (Domain "another.example.com"), + contactName = "Foobar2", + contactColorId = Nothing, + contactHandle = Nothing, + contactTeam = Nothing + } diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/SearchResultContact.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/SearchResultContact.hs new file mode 100644 index 00000000000..e1c58013e6d --- /dev/null +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/SearchResultContact.hs @@ -0,0 +1,31 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Test.Wire.API.Golden.Manual.SearchResultContact where + +import Test.Wire.API.Golden.Manual.Contact (testObject_Contact_1, testObject_Contact_2) +import Wire.API.User.Search (Contact (..), FederatedUserSearchPolicy (FullSearch), SearchResult (..)) + +testObject_SearchResultContact_1 :: SearchResult Contact +testObject_SearchResultContact_1 = + SearchResult + { searchFound = 2, + searchReturned = 2, + searchTook = 100, + searchResults = [testObject_Contact_1, testObject_Contact_2], + searchPolicy = FullSearch + } diff --git a/libs/wire-api/test/golden/testObject_Contact_1.json b/libs/wire-api/test/golden/testObject_Contact_1.json new file mode 100644 index 00000000000..fb1bdac6dda --- /dev/null +++ b/libs/wire-api/test/golden/testObject_Contact_1.json @@ -0,0 +1,11 @@ +{ + "accent_id": 1, + "handle": "foobar1", + "id": "00000018-0000-0020-0000-000e00000002", + "name": "Foobar", + "qualified_id": { + "domain": "example.com", + "id": "00000018-0000-0020-0000-000e00000002" + }, + "team": "00000018-0000-0020-0000-000e00000002" +} diff --git a/libs/wire-api/test/golden/testObject_Contact_2.json b/libs/wire-api/test/golden/testObject_Contact_2.json new file mode 100644 index 00000000000..aca23622496 --- /dev/null +++ b/libs/wire-api/test/golden/testObject_Contact_2.json @@ -0,0 +1,11 @@ +{ + "accent_id": null, + "handle": null, + "id": "00000018-0000-0020-0000-000e00000003", + "name": "Foobar2", + "qualified_id": { + "domain": "another.example.com", + "id": "00000018-0000-0020-0000-000e00000003" + }, + "team": null +} diff --git a/libs/wire-api/test/golden/testObject_SearchResultContact_1.json b/libs/wire-api/test/golden/testObject_SearchResultContact_1.json new file mode 100644 index 00000000000..3dfe76accec --- /dev/null +++ b/libs/wire-api/test/golden/testObject_SearchResultContact_1.json @@ -0,0 +1,30 @@ +{ + "documents": [ + { + "accent_id": 1, + "handle": "foobar1", + "id": "00000018-0000-0020-0000-000e00000002", + "name": "Foobar", + "qualified_id": { + "domain": "example.com", + "id": "00000018-0000-0020-0000-000e00000002" + }, + "team": "00000018-0000-0020-0000-000e00000002" + }, + { + "accent_id": null, + "handle": null, + "id": "00000018-0000-0020-0000-000e00000003", + "name": "Foobar2", + "qualified_id": { + "domain": "another.example.com", + "id": "00000018-0000-0020-0000-000e00000003" + }, + "team": null + } + ], + "found": 2, + "returned": 2, + "search_policy": "full_search", + "took": 100 +} diff --git a/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_1.json b/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_1.json index 18b6cbdb27d..a64f3d5ef87 100644 --- a/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_1.json +++ b/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_1.json @@ -2,5 +2,6 @@ "documents": [], "found": -6, "returned": 0, + "search_policy": "full_search", "took": 1 } diff --git a/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_10.json b/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_10.json index c9231b07179..7376ce1287d 100644 --- a/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_10.json +++ b/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_10.json @@ -2,5 +2,6 @@ "documents": [], "found": 0, "returned": -7, + "search_policy": "full_search", "took": -5 } diff --git a/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_11.json b/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_11.json index ec5f938e955..e3733172872 100644 --- a/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_11.json +++ b/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_11.json @@ -25,5 +25,6 @@ ], "found": -1, "returned": 3, + "search_policy": "exact_handle_search", "took": -7 } diff --git a/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_12.json b/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_12.json index dc6aa1c3b3d..ecdffc4e81f 100644 --- a/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_12.json +++ b/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_12.json @@ -2,5 +2,6 @@ "documents": [], "found": 7, "returned": 5, + "search_policy": "exact_handle_search", "took": 3 } diff --git a/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_13.json b/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_13.json index 629398aa62e..01c6c1eee86 100644 --- a/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_13.json +++ b/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_13.json @@ -47,5 +47,6 @@ ], "found": 3, "returned": 2, + "search_policy": "exact_handle_search", "took": -1 } diff --git a/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_14.json b/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_14.json index 68e71d3135f..7e80395ae68 100644 --- a/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_14.json +++ b/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_14.json @@ -25,5 +25,6 @@ ], "found": 1, "returned": 6, + "search_policy": "exact_handle_search", "took": 2 } diff --git a/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_15.json b/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_15.json index d83541152fb..261df2ff1ca 100644 --- a/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_15.json +++ b/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_15.json @@ -2,5 +2,6 @@ "documents": [], "found": 3, "returned": 2, + "search_policy": "exact_handle_search", "took": 4 } diff --git a/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_16.json b/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_16.json index db1bdb2026d..4a8d1d2e5db 100644 --- a/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_16.json +++ b/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_16.json @@ -2,5 +2,6 @@ "documents": [], "found": -4, "returned": 4, + "search_policy": "exact_handle_search", "took": -7 } diff --git a/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_17.json b/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_17.json index 3db94126754..20bb099f0e2 100644 --- a/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_17.json +++ b/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_17.json @@ -2,5 +2,6 @@ "documents": [], "found": 6, "returned": -1, + "search_policy": "exact_handle_search", "took": -1 } diff --git a/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_18.json b/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_18.json index f159d1deacf..89f13f0291d 100644 --- a/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_18.json +++ b/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_18.json @@ -2,5 +2,6 @@ "documents": [], "found": -4, "returned": 0, + "search_policy": "exact_handle_search", "took": -5 } diff --git a/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_19.json b/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_19.json index 4ba9a1b04eb..c34194c529b 100644 --- a/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_19.json +++ b/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_19.json @@ -25,5 +25,6 @@ ], "found": 4, "returned": 2, + "search_policy": "exact_handle_search", "took": -5 } diff --git a/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_2.json b/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_2.json index 833b308d8ce..af89b210bc6 100644 --- a/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_2.json +++ b/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_2.json @@ -2,5 +2,6 @@ "documents": [], "found": -4, "returned": 6, + "search_policy": "full_search", "took": -5 } diff --git a/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_20.json b/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_20.json index 187d019ebba..471a9a11c8b 100644 --- a/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_20.json +++ b/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_20.json @@ -146,5 +146,6 @@ ], "found": 7, "returned": 6, + "search_policy": "exact_handle_search", "took": -1 } diff --git a/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_3.json b/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_3.json index a837fae9d4d..6427ecca224 100644 --- a/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_3.json +++ b/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_3.json @@ -14,5 +14,6 @@ ], "found": 4, "returned": 0, + "search_policy": "full_search", "took": 7 } diff --git a/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_4.json b/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_4.json index 07d4484354a..b6352105943 100644 --- a/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_4.json +++ b/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_4.json @@ -69,5 +69,6 @@ ], "found": -5, "returned": -7, + "search_policy": "full_search", "took": 3 } diff --git a/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_5.json b/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_5.json index 4a3b7adea90..c958b205899 100644 --- a/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_5.json +++ b/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_5.json @@ -14,5 +14,6 @@ ], "found": -6, "returned": -6, + "search_policy": "full_search", "took": -1 } diff --git a/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_6.json b/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_6.json index d6976f9b1a2..85a07e6bfad 100644 --- a/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_6.json +++ b/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_6.json @@ -2,5 +2,6 @@ "documents": [], "found": -5, "returned": -4, + "search_policy": "full_search", "took": 5 } diff --git a/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_7.json b/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_7.json index d3575a1b405..4ec4137a7f0 100644 --- a/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_7.json +++ b/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_7.json @@ -25,5 +25,6 @@ ], "found": 7, "returned": 0, + "search_policy": "full_search", "took": -6 } diff --git a/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_8.json b/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_8.json index 124a473f512..e2881a4de65 100644 --- a/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_8.json +++ b/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_8.json @@ -14,5 +14,6 @@ ], "found": -7, "returned": -5, + "search_policy": "full_search", "took": -7 } diff --git a/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_9.json b/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_9.json index 831c7d108a8..2869fb9a53f 100644 --- a/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_9.json +++ b/libs/wire-api/test/golden/testObject_SearchResult_20Contact_user_9.json @@ -2,5 +2,6 @@ "documents": [], "found": -5, "returned": -6, + "search_policy": "full_search", "took": 3 } diff --git a/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_1.json b/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_1.json index 8d3bac38460..f27b4db7f7c 100644 --- a/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_1.json +++ b/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_1.json @@ -27,5 +27,6 @@ ], "found": -4, "returned": 2, + "search_policy": "full_search", "took": 0 } diff --git a/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_10.json b/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_10.json index d248f22b43f..025e1f48c43 100644 --- a/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_10.json +++ b/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_10.json @@ -2,5 +2,6 @@ "documents": [], "found": -3, "returned": -3, + "search_policy": "full_search", "took": -4 } diff --git a/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_11.json b/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_11.json index c932c9de481..c73c45b03f3 100644 --- a/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_11.json +++ b/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_11.json @@ -99,5 +99,6 @@ ], "found": -5, "returned": 7, + "search_policy": "full_search", "took": 1 } diff --git a/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_12.json b/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_12.json index e75ed6faa84..1ce613459b3 100644 --- a/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_12.json +++ b/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_12.json @@ -15,5 +15,6 @@ ], "found": 0, "returned": 0, + "search_policy": "full_search", "took": 0 } diff --git a/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_13.json b/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_13.json index 994796262d9..6b124877158 100644 --- a/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_13.json +++ b/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_13.json @@ -39,5 +39,6 @@ ], "found": -6, "returned": 3, + "search_policy": "full_search", "took": 1 } diff --git a/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_14.json b/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_14.json index 5a224f59409..59cb01d501e 100644 --- a/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_14.json +++ b/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_14.json @@ -15,5 +15,6 @@ ], "found": 1, "returned": 4, + "search_policy": "full_search", "took": -4 } diff --git a/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_15.json b/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_15.json index 790bbfe0fde..b5ec998869e 100644 --- a/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_15.json +++ b/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_15.json @@ -15,5 +15,6 @@ ], "found": 2, "returned": 6, + "search_policy": "full_search", "took": -6 } diff --git a/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_16.json b/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_16.json index c4a3bccf296..b8231401cdc 100644 --- a/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_16.json +++ b/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_16.json @@ -39,5 +39,6 @@ ], "found": 2, "returned": 2, + "search_policy": "full_search", "took": -5 } diff --git a/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_17.json b/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_17.json index d5d2786070e..058e0180887 100644 --- a/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_17.json +++ b/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_17.json @@ -15,5 +15,6 @@ ], "found": -7, "returned": -5, + "search_policy": "full_search", "took": 4 } diff --git a/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_18.json b/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_18.json index 40eec32bcb2..b6f06b30b27 100644 --- a/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_18.json +++ b/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_18.json @@ -15,5 +15,6 @@ ], "found": 1, "returned": -7, + "search_policy": "full_search", "took": -7 } diff --git a/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_19.json b/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_19.json index 8361d5800ed..19443bf8634 100644 --- a/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_19.json +++ b/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_19.json @@ -2,5 +2,6 @@ "documents": [], "found": -6, "returned": -1, + "search_policy": "full_search", "took": -2 } diff --git a/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_2.json b/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_2.json index 1b62fdfb204..c590e435273 100644 --- a/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_2.json +++ b/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_2.json @@ -2,5 +2,6 @@ "documents": [], "found": -5, "returned": 4, + "search_policy": "full_search", "took": 6 } diff --git a/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_20.json b/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_20.json index 8e62d841e7d..a4c647d5aeb 100644 --- a/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_20.json +++ b/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_20.json @@ -2,5 +2,6 @@ "documents": [], "found": -6, "returned": -5, + "search_policy": "full_search", "took": 1 } diff --git a/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_3.json b/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_3.json index 394c3fe4cfc..675ffa65c64 100644 --- a/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_3.json +++ b/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_3.json @@ -39,5 +39,6 @@ ], "found": -5, "returned": -2, + "search_policy": "full_search", "took": -7 } diff --git a/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_4.json b/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_4.json index 08178b115c0..040908096c9 100644 --- a/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_4.json +++ b/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_4.json @@ -51,5 +51,6 @@ ], "found": -2, "returned": 4, + "search_policy": "exact_handle_search", "took": 2 } diff --git a/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_5.json b/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_5.json index 0af69b51841..880e11fb96f 100644 --- a/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_5.json +++ b/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_5.json @@ -15,5 +15,6 @@ ], "found": -2, "returned": -3, + "search_policy": "full_search", "took": -7 } diff --git a/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_6.json b/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_6.json index 95242f6f6d5..210448d2384 100644 --- a/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_6.json +++ b/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_6.json @@ -159,5 +159,6 @@ ], "found": -4, "returned": -7, + "search_policy": "full_search", "took": -4 } diff --git a/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_7.json b/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_7.json index de3058a2da0..c749effad88 100644 --- a/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_7.json +++ b/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_7.json @@ -75,5 +75,6 @@ ], "found": 1, "returned": 5, + "search_policy": "full_search", "took": 5 } diff --git a/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_8.json b/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_8.json index ffedd1b7894..3d724eb1814 100644 --- a/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_8.json +++ b/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_8.json @@ -51,5 +51,6 @@ ], "found": 7, "returned": 2, + "search_policy": "full_search", "took": -7 } diff --git a/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_9.json b/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_9.json index c84c6405ee7..d65f345704e 100644 --- a/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_9.json +++ b/libs/wire-api/test/golden/testObject_SearchResult_20TeamContact_user_9.json @@ -51,5 +51,6 @@ ], "found": 2, "returned": 3, + "search_policy": "full_search", "took": -3 } diff --git a/libs/wire-api/test/resources/key_package1.mls b/libs/wire-api/test/resources/key_package1.mls new file mode 100644 index 00000000000..8023c690792 Binary files /dev/null and b/libs/wire-api/test/resources/key_package1.mls differ diff --git a/libs/wire-api/test/unit/Main.hs b/libs/wire-api/test/unit/Main.hs index b03243b5e93..8bd8aeefb91 100644 --- a/libs/wire-api/test/unit/Main.hs +++ b/libs/wire-api/test/unit/Main.hs @@ -24,6 +24,7 @@ import Imports import Test.Tasty import qualified Test.Wire.API.Call.Config as Call.Config import qualified Test.Wire.API.Conversation as Conversation +import qualified Test.Wire.API.MLS as MLS import qualified Test.Wire.API.Roundtrip.Aeson as Roundtrip.Aeson import qualified Test.Wire.API.Roundtrip.ByteString as Roundtrip.ByteString import qualified Test.Wire.API.Roundtrip.CSV as Roundtrip.CSV @@ -51,5 +52,6 @@ main = Swagger.tests, Roundtrip.CSV.tests, Routes.tests, - Conversation.tests + Conversation.tests, + MLS.tests ] diff --git a/libs/wire-api/test/unit/Test/Wire/API/Call/Config.hs b/libs/wire-api/test/unit/Test/Wire/API/Call/Config.hs index ac101293574..a7106562c52 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Call/Config.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Call/Config.hs @@ -18,7 +18,7 @@ module Test.Wire.API.Call.Config where import Data.Aeson -import qualified Data.HashMap.Strict as HM +import qualified Data.Aeson.KeyMap as KeyMap import Imports import Test.Tasty import Test.Tasty.QuickCheck hiding (total) @@ -68,7 +68,7 @@ udpPriority uris = do sftServersAreNeverNull :: RTCConfiguration -> Bool sftServersAreNeverNull cfg = case toJSON cfg of - Object o -> HM.lookup "sft_servers" o /= Just Null + Object o -> KeyMap.lookup "sft_servers" o /= Just Null v -> error . show $ "type mismatch, expected RTCConfiguration to be Object, but got: " <> encode v newtype ZeroToTen = ZeroToTen Int diff --git a/libs/wire-api/test/unit/Test/Wire/API/MLS.hs b/libs/wire-api/test/unit/Test/Wire/API/MLS.hs new file mode 100644 index 00000000000..662b94662a7 --- /dev/null +++ b/libs/wire-api/test/unit/Test/Wire/API/MLS.hs @@ -0,0 +1,57 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Test.Wire.API.MLS where + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import Data.Domain +import Data.Id +import qualified Data.Text as T +import qualified Data.UUID as UUID +import Imports +import Test.Tasty +import Test.Tasty.HUnit +import Wire.API.MLS.CipherSuite +import Wire.API.MLS.Credential +import Wire.API.MLS.KeyPackage +import Wire.API.MLS.Serialisation + +tests :: TestTree +tests = + testGroup "MLS" $ + [ testCase "parse key packages" testParseKeyPackage + ] + +testParseKeyPackage :: IO () +testParseKeyPackage = do + kpData <- LBS.readFile "test/resources/key_package1.mls" + case decodeMLS @KeyPackage kpData of + Left err -> assertFailure (T.unpack err) + Right (kpTBS -> kp) -> do + pvTag (kpProtocolVersion kp) @?= Just ProtocolMLS10 + kpCipherSuite kp @?= CipherSuite 1 + BS.length (kpInitKey kp) @?= 32 + case decodeMLS' @ClientIdentity (bcIdentity (kpCredential kp)) of + Left err -> assertFailure $ "Failed to parse identity: " <> T.unpack err + Right identity -> + identity + @?= ClientIdentity + { ciDomain = Domain "mls.example.com", + ciUser = Id (fromJust (UUID.fromString "b455a431-9db6-4404-86e7-6a3ebe73fcaf")), + ciClient = newClientId 0x3ae58155 + } diff --git a/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/Aeson.hs b/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/Aeson.hs index 339aeda0da1..5ff334d8a11 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/Aeson.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/Aeson.hs @@ -38,7 +38,6 @@ import qualified Wire.API.CustomBackend as CustomBackend import qualified Wire.API.Event.Conversation as Event.Conversation import qualified Wire.API.Event.Team as Event.Team import qualified Wire.API.Message as Message -import qualified Wire.API.Notification as Notification import qualified Wire.API.Properties as Properties import qualified Wire.API.Provider as Provider import qualified Wire.API.Provider.Bot as Provider.Bot @@ -141,8 +140,6 @@ tests = testRoundTrip @Message.OtrRecipients, testRoundTrip @Message.NewOtrMessage, testRoundTrip @Message.ClientMismatch, - testRoundTrip @Notification.QueuedNotification, - testRoundTrip @Notification.QueuedNotificationList, testRoundTrip @Properties.PropertyKey, testRoundTrip @Properties.PropertyValue, testRoundTrip @Provider.Provider, @@ -319,8 +316,6 @@ tests = testRoundTrip @User.RichInfo.RichInfoAssocList, testRoundTrip @User.RichInfo.RichInfoMapAndList, testRoundTrip @User.RichInfo.RichInfo, - testRoundTrip @(User.Search.SearchResult User.Search.Contact), - testRoundTrip @User.Search.Contact, testRoundTrip @(User.Search.SearchResult User.Search.TeamContact), testRoundTrip @User.Search.TeamContact, testRoundTrip @(Wrapped.Wrapped "some_int" Int) diff --git a/libs/wire-api/test/unit/Test/Wire/API/User/Search.hs b/libs/wire-api/test/unit/Test/Wire/API/User/Search.hs index bfccbdac7d4..c1508e89c15 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/User/Search.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/User/Search.hs @@ -19,7 +19,7 @@ module Test.Wire.API.User.Search where import Data.Aeson (encode, toJSON) import qualified Data.Aeson as Aeson -import qualified Data.HashMap.Strict as HashMap +import qualified Data.Aeson.KeyMap as KeyMap import Data.String.Conversions (cs) import Imports import qualified Test.Tasty as T @@ -36,6 +36,6 @@ searchResultBackwardsCompatibility = $ \(c :: Contact) -> let prop = case toJSON c of - Aeson.Object o -> "id" `elem` HashMap.keys o + Aeson.Object o -> "id" `elem` KeyMap.keys o _ -> False in counterexample ("This json doesn't contain 'id': \n" <> cs (encode c)) prop diff --git a/libs/wire-api/wire-api.cabal b/libs/wire-api/wire-api.cabal index cca067eaaaa..8fd943c89c4 100644 --- a/libs/wire-api/wire-api.cabal +++ b/libs/wire-api/wire-api.cabal @@ -36,6 +36,12 @@ library Wire.API.Event.Team Wire.API.Message Wire.API.Message.Proto + Wire.API.MLS.CipherSuite + Wire.API.MLS.Credential + Wire.API.MLS.KeyPackage + Wire.API.MLS.Proposal + Wire.API.MLS.Serialisation + Wire.API.MLS.Servant Wire.API.Notification Wire.API.Properties Wire.API.Provider @@ -148,11 +154,12 @@ library ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path build-depends: QuickCheck >=2.14 - , aeson >=0.6 + , aeson >=2.0.1.0 , attoparsec >=0.10 , base ==4.* , base64-bytestring >=1.0 , binary + , binary-parsers , bytestring >=0.9 , bytestring-conversion >=0.2 , case-insensitive @@ -161,6 +168,7 @@ library , cereal , comonad , conduit + , constraints , containers >=0.5 , cookie , cryptonite @@ -457,6 +465,7 @@ test-suite wire-api-golden-tests Test.Wire.API.Golden.Manual Test.Wire.API.Golden.Manual.ClientCapability Test.Wire.API.Golden.Manual.ClientCapabilityList + Test.Wire.API.Golden.Manual.Contact Test.Wire.API.Golden.Manual.ConversationCoverView Test.Wire.API.Golden.Manual.ConversationPagingState Test.Wire.API.Golden.Manual.ConversationsResponse @@ -466,6 +475,7 @@ test-suite wire-api-golden-tests Test.Wire.API.Golden.Manual.GetPaginatedConversationIds Test.Wire.API.Golden.Manual.ListConversations Test.Wire.API.Golden.Manual.QualifiedUserClientPrekeyMap + Test.Wire.API.Golden.Manual.SearchResultContact Test.Wire.API.Golden.Manual.UserClientPrekeyMap Test.Wire.API.Golden.Manual.UserIdList Test.Wire.API.Golden.Protobuf @@ -516,7 +526,7 @@ test-suite wire-api-golden-tests 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 - , aeson >=0.6 + , aeson >=2.0.1.0 , aeson-pretty , aeson-qq , base @@ -564,6 +574,7 @@ test-suite wire-api-tests other-modules: Test.Wire.API.Call.Config Test.Wire.API.Conversation + Test.Wire.API.MLS Test.Wire.API.Roundtrip.Aeson Test.Wire.API.Roundtrip.ByteString Test.Wire.API.Roundtrip.CSV @@ -620,7 +631,7 @@ test-suite wire-api-tests 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 - , aeson >=0.6 + , aeson >=2.0.1.0 , aeson-pretty , aeson-qq , base @@ -633,6 +644,7 @@ test-suite wire-api-tests , currency-codes , directory , filepath + , hex , hscim , imports , iso3166-country-codes diff --git a/nix/overlay.nix b/nix/overlay.nix index 771ec26e503..3a67607afe2 100644 --- a/nix/overlay.nix +++ b/nix/overlay.nix @@ -1,6 +1,7 @@ self: super: { cryptobox = self.callPackage ./pkgs/cryptobox { }; zauth = self.callPackage ./pkgs/zauth { }; + crypto_cli = self.callPackage ./pkgs/crypto_cli { }; nginxModules = super.nginxModules // { zauth = { diff --git a/nix/pkgs/crypto_cli/default.nix b/nix/pkgs/crypto_cli/default.nix new file mode 100644 index 00000000000..240883ff09b --- /dev/null +++ b/nix/pkgs/crypto_cli/default.nix @@ -0,0 +1,23 @@ +{ fetchFromGitHub +, lib +, libsodium +, perl +, pkg-config +, rustPlatform +, stdenv +}: + +rustPlatform.buildRustPackage rec { + name = "crypto-cli-${version}"; + version = "0.1.0"; + nativeBuildInputs = [ pkg-config perl ]; + buildInputs = [ libsodium ]; + src = fetchFromGitHub { + owner = "wireapp"; + repo = "core-crypto"; + rev = "bb9e7b6d21beaebcb4278dee1a9e6feaa77e711f"; + sha256 = "sha256-3D524DTgiNTqTlBIzCzTktCyYS0iA2TSi7axvzrvPLU="; + }; + cargoSha256 = "sha256-he7cytqEhVFiPw4bVAjveh2xQE0nO1dE4yzAVWz6sSc="; +} + diff --git a/nix/sources.json b/nix/sources.json index 987e681846e..75d13329c6e 100644 --- a/nix/sources.json +++ b/nix/sources.json @@ -17,10 +17,10 @@ "homepage": "https://github.com/NixOS/nixpkgs", "owner": "NixOS", "repo": "nixpkgs", - "rev": "cc61d6cca06aaa46ccde79a92cd94dbb27c634a7", - "sha256": "0qi05m6vk9zqqs9573w2rhwm5k7jga70sjzq370npcipayrifw99", + "rev": "7cd44abcc3f01accbcc450d4d67609a5ea3448ec", + "sha256": "0f8d797mhpxggq5idlbgsvf1nlknf5yh966mnl3bian32m11rik2", "type": "tarball", - "url": "https://github.com/NixOS/nixpkgs/archive/cc61d6cca06aaa46ccde79a92cd94dbb27c634a7.tar.gz", + "url": "https://github.com/NixOS/nixpkgs/archive/7cd44abcc3f01accbcc450d4d67609a5ea3448ec.tar.gz", "url_template": "https://github.com///archive/.tar.gz" } } diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal index eee5ef22f98..f65f170d6ea 100644 --- a/services/brig/brig.cabal +++ b/services/brig/brig.cabal @@ -37,6 +37,8 @@ library Brig.API.Federation Brig.API.Handler Brig.API.Internal + Brig.API.MLS.KeyPackages + Brig.API.MLS.KeyPackages.Validation Brig.API.Properties Brig.API.Public Brig.API.Types @@ -57,6 +59,8 @@ library Brig.Data.Connection Brig.Data.Instances Brig.Data.LoginCode + Brig.Data.MLS.KeyPackage + Brig.Data.MLS.KeyPackage.Instances Brig.Data.PasswordReset Brig.Data.Properties Brig.Data.Types @@ -116,6 +120,7 @@ library Brig.User.Search.TeamSize Brig.User.Search.TeamUserSearch Brig.User.Template + Brig.Version Brig.Whitelist Brig.ZAuth Main @@ -173,7 +178,7 @@ library , HsOpenSSL >=0.10 , HsOpenSSL-x509-system >=0.1 , MonadRandom >=0.5 - , aeson >=0.11 + , aeson >=2.0.1.0 , amazonka >=1.3.7 , amazonka-dynamodb >=1.3.7 , amazonka-ses >=1.3.7 @@ -405,6 +410,7 @@ executable brig-integration API.Internal API.Internal.Util API.Metrics + API.MLS API.Provider API.RichInfo.Util API.Search @@ -517,6 +523,7 @@ executable brig-integration , network , optparse-applicative , pem + , process , proto-lens , random >=1.0 , random-shuffle @@ -615,6 +622,7 @@ executable brig-schema V64_ClientCapabilities V65_FederatedConnections V66_PersonalFeatureConfCallInit + V67_MLSKeyPackages V9 Paths_brig hs-source-dirs: @@ -678,6 +686,7 @@ test-suite brig-tests other-modules: Test.Brig.Calling Test.Brig.Calling.Internal + Test.Brig.MLS Test.Brig.Roundtrip Test.Brig.User.Search.Index.Types Paths_brig @@ -727,9 +736,11 @@ test-suite brig-tests build-depends: aeson , base + , binary , bloodhound , brig , brig-types + , bytestring , containers , dns , dns-util diff --git a/services/brig/package.yaml b/services/brig/package.yaml index ed882bff0f8..43473e9945e 100644 --- a/services/brig/package.yaml +++ b/services/brig/package.yaml @@ -25,7 +25,7 @@ library: generated-other-modules: - Brig.Docs.Swagger dependencies: - - aeson >=0.11 + - aeson >=2.0.1.0 - amazonka >=1.3.7 - amazonka-dynamodb >=1.3.7 - amazonka-ses >=1.3.7 @@ -155,9 +155,11 @@ tests: dependencies: - aeson - base + - binary - bloodhound - brig - brig-types + - bytestring - containers - dns - dns-util @@ -241,6 +243,7 @@ executables: - network - optparse-applicative - pem + - process - proto-lens - QuickCheck - random >=1.0 diff --git a/services/brig/schema/src/Main.hs b/services/brig/schema/src/Main.hs index 01ab2e38a4d..848d0004a03 100644 --- a/services/brig/schema/src/Main.hs +++ b/services/brig/schema/src/Main.hs @@ -76,6 +76,7 @@ import qualified V63_AddUsersPendingActivation import qualified V64_ClientCapabilities import qualified V65_FederatedConnections import qualified V66_PersonalFeatureConfCallInit +import qualified V67_MLSKeyPackages import qualified V9 main :: IO () @@ -141,7 +142,8 @@ main = do V63_AddUsersPendingActivation.migration, V64_ClientCapabilities.migration, V65_FederatedConnections.migration, - V66_PersonalFeatureConfCallInit.migration + V66_PersonalFeatureConfCallInit.migration, + V67_MLSKeyPackages.migration -- When adding migrations here, don't forget to update -- 'schemaVersion' in Brig.App diff --git a/services/brig/schema/src/V67_MLSKeyPackages.hs b/services/brig/schema/src/V67_MLSKeyPackages.hs new file mode 100644 index 00000000000..71a933f553c --- /dev/null +++ b/services/brig/schema/src/V67_MLSKeyPackages.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE QuasiQuotes #-} + +-- 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 V67_MLSKeyPackages + ( migration, + ) +where + +import Cassandra.Schema +import Imports +import Text.RawString.QQ + +migration :: Migration +migration = + Migration 67 "Add table for MLS key packages" $ + schema' + [r| + CREATE TABLE mls_key_packages + ( user uuid + , client text + , ref blob + , data blob + , PRIMARY KEY ((user, client), ref) + ) WITH compaction = {'class': 'org.apache.cassandra.db.compaction.LeveledCompactionStrategy'} + AND gc_grace_seconds = 864000; + |] diff --git a/services/brig/src/Brig/API/Error.hs b/services/brig/src/Brig/API/Error.hs index b5830fe6657..bb97ae837a9 100644 --- a/services/brig/src/Brig/API/Error.hs +++ b/services/brig/src/Brig/API/Error.hs @@ -24,9 +24,9 @@ import Brig.Types (DeletionCodeTimeout (..)) import Brig.Types.Common (PhoneBudgetTimeout (..)) import Control.Monad.Error.Class hiding (Error) import Data.Aeson +import qualified Data.Aeson.KeyMap as KeyMap import Data.ByteString.Conversion import Data.Domain (Domain) -import qualified Data.HashMap.Strict as HashMap import Data.Proxy import Data.String.Conversions (cs) import qualified Data.Text.Lazy as LT @@ -100,7 +100,7 @@ throwErrorDescriptionType = throwErrorDescription (mkErrorDescription :: e) instance ToJSON Error where toJSON (StdError e) = toJSON e toJSON (RichError e x _) = case (toJSON e, toJSON x) of - (Object o1, Object o2) -> Object (HashMap.union o1 o2) + (Object o1, Object o2) -> Object (KeyMap.union o1 o2) (j, _) -> j -- Error Mapping ---------------------------------------------------------- diff --git a/services/brig/src/Brig/API/Federation.hs b/services/brig/src/Brig/API/Federation.hs index d18f6e37ba8..d1a7caf1ba8 100644 --- a/services/brig/src/Brig/API/Federation.hs +++ b/services/brig/src/Brig/API/Federation.hs @@ -24,6 +24,7 @@ import Brig.API.Connection.Remote (performRemoteAction) import Brig.API.Error (clientError) import Brig.API.Handler (Handler) import qualified Brig.API.User as API +import Brig.API.Util (lookupSearchPolicy) import Brig.App (qualifyLocal) import qualified Brig.Data.Connection as Data import qualified Brig.Data.User as Data @@ -84,13 +85,23 @@ sendConnectionAction originDomain NewConnectionRequest {..} = do else pure NewConnectionResponseUserNotActivated getUserByHandle :: Domain -> Handle -> (Handler r) (Maybe UserProfile) -getUserByHandle _ handle = lift $ do - maybeOwnerId <- API.lookupHandle handle - case maybeOwnerId of - Nothing -> - pure Nothing - Just ownerId -> - listToMaybe <$> API.lookupLocalProfiles Nothing [ownerId] +getUserByHandle domain handle = do + searchPolicy <- lookupSearchPolicy domain + + let performHandleLookup = + case searchPolicy of + NoSearch -> False + ExactHandleSearch -> True + FullSearch -> True + if not performHandleLookup + then pure Nothing + else lift $ do + maybeOwnerId <- API.lookupHandle handle + case maybeOwnerId of + Nothing -> + pure Nothing + Just ownerId -> + listToMaybe <$> API.lookupLocalProfiles Nothing [ownerId] getUsersByIds :: Domain -> [UserId] -> (Handler r) [UserProfile] getUsersByIds _ uids = @@ -110,29 +121,40 @@ claimMultiPrekeyBundle _ uc = API.claimLocalMultiPrekeyBundles LegalholdPlusFede -- | 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 :: Domain -> SearchRequest -> (Handler r) [Contact] -searchUsers _ (SearchRequest searchTerm) = do - let maxResults = 15 - - maybeExactHandleMatch <- exactHandleSearch +searchUsers :: Domain -> SearchRequest -> (Handler r) SearchResponse +searchUsers domain (SearchRequest searchTerm) = do + searchPolicy <- lookupSearchPolicy domain - let exactHandleMatchCount = length maybeExactHandleMatch - esMaxResults = maxResults - exactHandleMatchCount + let searches = case searchPolicy of + NoSearch -> [] + ExactHandleSearch -> [exactHandleSearch] + FullSearch -> [exactHandleSearch, fullSearch] - esResult <- - if esMaxResults > 0 - then Q.searchIndex Nothing Nothing searchTerm esMaxResults - else pure $ SearchResult 0 0 0 [] + let maxResults = 15 - pure $ maybeToList maybeExactHandleMatch <> searchResults esResult + contacts <- go [] maxResults searches + pure $ SearchResponse contacts searchPolicy where - exactHandleSearch :: (Handler r) (Maybe Contact) - exactHandleSearch = do - let maybeHandle = parseHandle searchTerm - maybeOwnerId <- maybe (pure Nothing) (lift . API.lookupHandle) maybeHandle - case maybeOwnerId of - Nothing -> pure Nothing - Just foundUser -> lift $ fmap listToMaybe $ contactFromProfile <$$> API.lookupLocalProfiles Nothing [foundUser] + go :: [Contact] -> Int -> [Int -> (Handler r) [Contact]] -> (Handler r) [Contact] + go contacts _ [] = pure contacts + go contacts maxResult (search : searches) = do + contactsNew <- search maxResult + go (contacts <> contactsNew) (maxResult - length contactsNew) searches + + fullSearch :: Int -> (Handler r) [Contact] + fullSearch n + | n > 0 = searchResults <$> Q.searchIndex Nothing Nothing searchTerm n + | otherwise = pure [] + + exactHandleSearch :: Int -> (Handler r) [Contact] + exactHandleSearch n + | n > 0 = 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] + | otherwise = pure [] getUserClients :: Domain -> GetUserClients -> (Handler r) (UserMap (Set PubClient)) getUserClients _ (GetUserClients uids) = API.lookupLocalPubClientsBulk uids !>> clientError diff --git a/services/brig/src/Brig/API/MLS/KeyPackages.hs b/services/brig/src/Brig/API/MLS/KeyPackages.hs new file mode 100644 index 00000000000..0e81942d5d0 --- /dev/null +++ b/services/brig/src/Brig/API/MLS/KeyPackages.hs @@ -0,0 +1,75 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Brig.API.MLS.KeyPackages + ( uploadKeyPackages, + claimKeyPackages, + countKeyPackages, + ) +where + +import Brig.API.Error +import Brig.API.Handler +import Brig.API.MLS.KeyPackages.Validation +import Brig.App +import qualified Brig.Data.Client as Data +import qualified Brig.Data.MLS.KeyPackage as Data +import Brig.IO.Intra +import Control.Monad.Trans.Except +import Control.Monad.Trans.Maybe +import Data.Id +import Data.Qualified +import qualified Data.Set as Set +import Imports +import Wire.API.Federation.Error +import Wire.API.MLS.Credential +import Wire.API.MLS.KeyPackage +import Wire.API.Team.LegalHold +import Wire.API.User.Client + +uploadKeyPackages :: Local UserId -> ClientId -> KeyPackageUpload -> Handler r () +uploadKeyPackages lusr cid (kpuKeyPackages -> kps) = do + let identity = mkClientIdentity (qUntagged lusr) cid + kps' <- traverse (validateKeyPackageData identity) kps + lift $ Data.insertKeyPackages (tUnqualified lusr) cid kps' + +claimKeyPackages :: Local UserId -> Qualified UserId -> Handler r KeyPackageBundle +claimKeyPackages lusr = + foldQualified + lusr + (claimLocalKeyPackages lusr) + (\_ -> throwStd federationNotImplemented) + +claimLocalKeyPackages :: Local UserId -> Local UserId -> Handler r KeyPackageBundle +claimLocalKeyPackages lusr target = do + clients <- map clientId <$> Data.lookupClients (tUnqualified target) + withExceptT clientError $ + guardLegalhold (ProtectedUser (tUnqualified lusr)) (mkUserClients [(tUnqualified target, clients)]) + lift $ + KeyPackageBundle . Set.fromList . catMaybes <$> traverse mkEntry clients + where + mkEntry :: ClientId -> AppIO r (Maybe KeyPackageBundleEntry) + mkEntry c = + runMaybeT $ + KeyPackageBundleEntry (qUntagged target) c + <$> Data.claimKeyPackage (tUnqualified target) c + +countKeyPackages :: Local UserId -> ClientId -> Handler r KeyPackageCount +countKeyPackages lusr c = + lift $ + KeyPackageCount . fromIntegral + <$> Data.countKeyPackages (tUnqualified lusr) c diff --git a/services/brig/src/Brig/API/MLS/KeyPackages/Validation.hs b/services/brig/src/Brig/API/MLS/KeyPackages/Validation.hs new file mode 100644 index 00000000000..cb9b600ee9c --- /dev/null +++ b/services/brig/src/Brig/API/MLS/KeyPackages/Validation.hs @@ -0,0 +1,135 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Brig.API.MLS.KeyPackages.Validation + ( -- * Main key package validation function + validateKeyPackageData, + + -- * Exported for unit tests + findExtensions, + validateLifetime', + ) +where + +import Brig.API.Error +import Brig.API.Handler +import Brig.App +import Brig.Options +import Control.Applicative +import Control.Lens (view) +import qualified Data.ByteString.Lazy as LBS +import Data.Time.Clock +import Data.Time.Clock.POSIX +import Imports +import Wire.API.ErrorDescription +import Wire.API.MLS.CipherSuite +import Wire.API.MLS.Credential +import Wire.API.MLS.KeyPackage +import Wire.API.MLS.Serialisation + +validateKeyPackageData :: ClientIdentity -> KeyPackageData -> Handler r (KeyPackageRef, KeyPackageData) +validateKeyPackageData identity kpd = do + -- parse key package data + (kp, tbs) <- parseKeyPackage kpd + -- get ciphersuite + cs <- + maybe + (throwErrorDescription (mlsProtocolError "Unsupported ciphersuite")) + pure + $ cipherSuiteTag (kpCipherSuite (kpTBS kp)) + -- validate signature + -- FUTUREWORK: authenticate signature key + let key = bcSignatureKey (kpCredential (kpTBS kp)) + unless (csVerifySignature cs key (LBS.toStrict tbs) (kpSignature kp)) $ + throwErrorDescription (mlsProtocolError "Invalid signature") + -- validate credential and extensions + validateKeyPackage identity kp + pure (kpRef cs kpd, kpd) + +-- | Parse a key package, and return parsed structure and signed data. +parseKeyPackage :: KeyPackageData -> Handler r (KeyPackage, LByteString) +parseKeyPackage (kpData -> kpd) = do + (kp, off) <- either (throwErrorDescription . mlsProtocolError) pure (decodeMLSWith kpSigOffset kpd) + pure (kp, LBS.take off kpd) + +validateKeyPackage :: ClientIdentity -> KeyPackage -> Handler r () +validateKeyPackage identity (kpTBS -> kp) = do + maybe + (throwErrorDescription (mlsProtocolError "Unsupported protocol version")) + pure + (pvTag (kpProtocolVersion kp) >>= guard . (== ProtocolMLS10)) + validateCredential identity (kpCredential kp) + validateExtensions (kpExtensions kp) + +validateCredential :: ClientIdentity -> Credential -> Handler r () +validateCredential identity cred = do + identity' <- + either (throwErrorDescription . mlsProtocolError) pure $ + decodeMLS' (bcIdentity cred) + when (identity /= identity') $ + throwErrorDescriptionType @MLSIdentityMismatch + +data RequiredExtensions f = RequiredExtensions + { reLifetime :: f Lifetime, + reCapabilities :: f () + } + +deriving instance (Show (f Lifetime), Show (f ())) => Show (RequiredExtensions f) + +instance Alternative f => Semigroup (RequiredExtensions f) where + RequiredExtensions lt1 cap1 <> RequiredExtensions lt2 cap2 = + RequiredExtensions (lt1 <|> lt2) (cap1 <|> cap2) + +instance Alternative f => Monoid (RequiredExtensions f) where + mempty = RequiredExtensions empty empty + +checkRequiredExtensions :: RequiredExtensions Maybe -> Either Text (RequiredExtensions Identity) +checkRequiredExtensions re = + RequiredExtensions + <$> maybe (Left "Missing lifetime extension") (pure . Identity) (reLifetime re) + <*> maybe (Left "Missing capability extension") (pure . Identity) (reCapabilities re) + +findExtensions :: [Extension] -> Either Text (RequiredExtensions Identity) +findExtensions = (checkRequiredExtensions =<<) . getAp . foldMap findExtension + +findExtension :: Extension -> Ap (Either Text) (RequiredExtensions Maybe) +findExtension ext = flip foldMap (decodeExtension ext) $ \case + (SomeExtension SLifetimeExtensionTag lt) -> pure $ RequiredExtensions (Just lt) Nothing + (SomeExtension SCapabilitiesExtensionTag _) -> pure $ RequiredExtensions Nothing (Just ()) + _ -> Ap (Left "Invalid extension") + +validateExtensions :: [Extension] -> Handler r () +validateExtensions exts = do + re <- either (throwErrorDescription . mlsProtocolError) pure $ findExtensions exts + validateLifetime . runIdentity . reLifetime $ re + +validateLifetime :: Lifetime -> Handler r () +validateLifetime lt = do + now <- liftIO getPOSIXTime + mMaxLifetime <- setKeyPackageMaximumLifetime <$> view settings + either (throwErrorDescription . mlsProtocolError) pure $ + validateLifetime' now mMaxLifetime lt + +validateLifetime' :: POSIXTime -> Maybe NominalDiffTime -> Lifetime -> Either Text () +validateLifetime' now mMaxLifetime lt = do + when (tsPOSIX (ltNotBefore lt) > now) $ + Left "Key package not_before date is in the future" + when (tsPOSIX (ltNotAfter lt) <= now) $ + Left "Key package is expired" + for_ mMaxLifetime $ \maxLifetime -> + when (tsPOSIX (ltNotAfter lt) > now + maxLifetime) $ + Left "Key package expiration time is too far in the future" diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index afffe057767..30d3d4b1df2 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -30,6 +30,7 @@ import qualified Brig.API.Client as API import qualified Brig.API.Connection as API import Brig.API.Error import Brig.API.Handler +import Brig.API.MLS.KeyPackages import qualified Brig.API.Properties as API import Brig.API.Types import qualified Brig.API.User as API @@ -161,7 +162,7 @@ swaggerDocsAPI = . (S.enum_ . _Just %~ nub) servantSitemap :: ServerT BrigAPI (Handler r) -servantSitemap = userAPI :<|> selfAPI :<|> clientAPI :<|> prekeyAPI :<|> userClientAPI :<|> connectionAPI +servantSitemap = userAPI :<|> selfAPI :<|> clientAPI :<|> prekeyAPI :<|> userClientAPI :<|> connectionAPI :<|> mlsAPI where userAPI :: ServerT UserAPI (Handler r) userAPI = @@ -227,6 +228,12 @@ servantSitemap = userAPI :<|> selfAPI :<|> clientAPI :<|> prekeyAPI :<|> userCli :<|> Named @"update-connection" updateConnection :<|> Named @"search-contacts" Search.search + mlsAPI :: ServerT MLSAPI (Handler r) + mlsAPI = + Named @"mls-key-packages-upload" uploadKeyPackages + :<|> Named @"mls-key-packages-claim" claimKeyPackages + :<|> Named @"mls-key-packages-count" countKeyPackages + -- Note [ephemeral user sideeffect] -- If the user is ephemeral and expired, it will be removed upon calling -- CheckUserExists[Un]Qualified, see 'Brig.API.User.userGC'. diff --git a/services/brig/src/Brig/API/Util.hs b/services/brig/src/Brig/API/Util.hs index 680b42fc6ae..b6af3b39a2a 100644 --- a/services/brig/src/Brig/API/Util.hs +++ b/services/brig/src/Brig/API/Util.hs @@ -24,6 +24,7 @@ module Brig.API.Util logEmail, traverseConcurrentlyWithErrors, exceptTToMaybe, + lookupSearchPolicy, ) where @@ -31,12 +32,16 @@ import Brig.API.Error import qualified Brig.API.Error as Error import Brig.API.Handler import Brig.API.Types -import Brig.App (AppIO) +import Brig.App (AppIO, settings) import qualified Brig.Data.User as Data +import Brig.Options (FederationDomainConfig, federationDomainConfigs) +import qualified Brig.Options as Opts import Brig.Types import Brig.Types.Intra (accountUser) +import Control.Lens (view) import Control.Monad.Catch (throwM) import Control.Monad.Trans.Except +import Data.Domain (Domain) import Data.Handle (Handle, parseHandle) import Data.Id import Data.Maybe @@ -49,6 +54,7 @@ import UnliftIO.Async import UnliftIO.Exception (throwIO, try) import Util.Logging (sha256String) import Wire.API.ErrorDescription +import Wire.API.User.Search (FederatedUserSearchPolicy (NoSearch)) lookupProfilesMaybeFilterSameTeamOnly :: UserId -> [UserProfile] -> (Handler r) [UserProfile] lookupProfilesMaybeFilterSameTeamOnly self us = do @@ -92,3 +98,12 @@ traverseConcurrentlyWithErrors f = exceptTToMaybe :: Monad m => ExceptT e m () -> m (Maybe e) exceptTToMaybe = (pure . either Just (const Nothing)) <=< runExceptT + +lookupDomainConfig :: Domain -> (Handler r) (Maybe FederationDomainConfig) +lookupDomainConfig domain = do + domainConfigs <- fromMaybe [] <$> view (settings . federationDomainConfigs) + pure $ find ((== domain) . Opts.domain) domainConfigs + +-- | If domain is not configured fall back to `FullSearch` +lookupSearchPolicy :: Domain -> (Handler r) FederatedUserSearchPolicy +lookupSearchPolicy domain = fromMaybe NoSearch <$> (Opts.cfgSearchPolicy <$$> lookupDomainConfig domain) diff --git a/services/brig/src/Brig/AWS.hs b/services/brig/src/Brig/AWS.hs index 2339a0114eb..f1331cdc2a6 100644 --- a/services/brig/src/Brig/AWS.hs +++ b/services/brig/src/Brig/AWS.hs @@ -44,10 +44,16 @@ module Brig.AWS ) where +import Amazonka (AWSRequest, AWSResponse) +import qualified Amazonka as AWS +import qualified Amazonka.DynamoDB as DDB +import qualified Amazonka.SES as SES +import qualified Amazonka.SES.Lens as SES +import qualified Amazonka.SQS as SQS +import qualified Amazonka.SQS.Lens as SQS import qualified Brig.Options as Opt 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.Aeson hiding ((.=)) @@ -57,15 +63,6 @@ import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import Data.UUID hiding (null) import Imports hiding (group) -import Network.AWS (AWSRequest, Rs) -import qualified Network.AWS as AWS -import qualified Network.AWS.Data as AWS -import qualified Network.AWS.DynamoDB as DDB -import qualified Network.AWS.Env as AWS -import qualified Network.AWS.SES as SES -import Network.AWS.SQS (rmrsMessages) -import qualified Network.AWS.SQS as SQS -import Network.AWS.SQS.Types hiding (sqs) import Network.HTTP.Client (HttpException (..), HttpExceptionContent (..), Manager) import Network.HTTP.Types.Status (status400) import Network.Mail.Mime @@ -104,32 +101,34 @@ newtype Amazon a = Amazon instance MonadLogger Amazon where log l m = view logger >>= \g -> Logger.log g l m -instance AWS.MonadAWS Amazon where - liftAWS a = view amazonkaEnv >>= flip AWS.runAWS a - mkEnv :: Logger -> Opt.AWSOpts -> Maybe Opt.EmailAWSOpts -> Manager -> IO Env mkEnv lgr opts emailOpts mgr = do let g = Logger.clone (Just "aws.brig") lgr let pk = Opt.prekeyTable opts - let sesEndpoint = mkEndpoint SES.ses . Opt.sesEndpoint <$> emailOpts - let dynamoEndpoint = mkEndpoint DDB.dynamoDB <$> Opt.dynamoDBEndpoint opts + let sesEndpoint = mkEndpoint SES.defaultService . Opt.sesEndpoint <$> emailOpts + let dynamoEndpoint = mkEndpoint DDB.defaultService <$> Opt.dynamoDBEndpoint opts e <- mkAwsEnv g sesEndpoint dynamoEndpoint - (mkEndpoint SQS.sqs (Opt.sqsEndpoint opts)) + (mkEndpoint SQS.defaultService (Opt.sqsEndpoint opts)) sq <- maybe (return Nothing) (fmap Just . getQueueUrl e . Opt.sesQueue) emailOpts jq <- maybe (return Nothing) (fmap Just . getQueueUrl e) (Opt.userJournalQueue opts) return (Env g sq jq pk e) where mkEndpoint svc e = AWS.setEndpoint (e ^. awsSecure) (e ^. awsHost) (e ^. awsPort) svc - mkAwsEnv g ses dyn sqs = - set AWS.envLogger (awsLogger g) - <$> AWS.newEnvWith AWS.Discover Nothing mgr - <&> maybe id AWS.configure ses - <&> maybe id AWS.configure dyn - <&> AWS.configure sqs + mkAwsEnv g ses dyn sqs = do + baseEnv <- + AWS.newEnv AWS.discover + <&> maybe id AWS.configure ses + <&> maybe id AWS.configure dyn + <&> AWS.configure sqs + pure $ + baseEnv + { AWS.envLogger = awsLogger g, + AWS.envManager = mgr + } awsLogger g l = Logger.log g (mapLevel l) . Logger.msg . toLazyByteString mapLevel AWS.Info = Logger.Info -- Debug output from amazonka can be very useful for tracing requests @@ -150,7 +149,7 @@ getQueueUrl :: AWS.Env -> Text -> m Text -getQueueUrl e q = view SQS.gqursQueueURL <$> exec e (SQS.getQueueURL q) +getQueueUrl e q = view SQS.getQueueUrlResponse_queueUrl <$> exec e (SQS.newGetQueueUrl q) execute :: MonadIO m => Env -> Amazon a -> m a execute e m = liftIO $ runResourceT (runReaderT (unAmazon m) e) @@ -170,22 +169,22 @@ instance Exception Error listen :: (FromJSON a, Show a) => Int -> Text -> (a -> IO ()) -> Amazon () listen throttleMillis url callback = forever . handleAny unexpectedError $ do - msgs <- view rmrsMessages <$> send receive + msgs <- fromMaybe [] . view SQS.receiveMessageResponse_messages <$> send receive void $ mapConcurrently onMessage msgs when (null msgs) $ threadDelay (1000 * throttleMillis) where receive = - SQS.receiveMessage url - & set SQS.rmWaitTimeSeconds (Just 20) - . set SQS.rmMaxNumberOfMessages (Just 10) + SQS.newReceiveMessage url + & set SQS.receiveMessage_waitTimeSeconds (Just 20) + . set SQS.receiveMessage_maxNumberOfMessages (Just 10) onMessage m = - case decodeStrict =<< Text.encodeUtf8 <$> m ^. mBody of + case decodeStrict =<< Text.encodeUtf8 <$> m ^. SQS.message_body of Nothing -> err $ msg ("Failed to parse SQS event: " ++ show m) Just n -> do debug $ msg ("Received SQS event: " ++ show n) liftIO $ callback n - for_ (m ^. mReceiptHandle) (void . send . SQS.deleteMessage url) + for_ (m ^. SQS.message_receiptHandle) (void . send . SQS.newDeleteMessage url) unexpectedError x = do err $ "error" .= show x ~~ msg (val "Failed to read from SQS") threadDelay 3000000 @@ -193,15 +192,15 @@ listen throttleMillis url callback = forever . handleAny unexpectedError $ do enqueueStandard :: Text -> BL.ByteString -> Amazon SQS.SendMessageResponse enqueueStandard url m = retrying retry5x (const canRetry) (const (sendCatch req)) >>= throwA where - req = SQS.sendMessage url $ Text.decodeLatin1 (BL.toStrict m) + req = SQS.newSendMessage url $ Text.decodeLatin1 (BL.toStrict m) enqueueFIFO :: Text -> Text -> UUID -> BL.ByteString -> Amazon SQS.SendMessageResponse enqueueFIFO url group dedup m = retrying retry5x (const canRetry) (const (sendCatch req)) >>= throwA where req = - SQS.sendMessage url (Text.decodeLatin1 (BL.toStrict m)) - & SQS.smMessageGroupId .~ Just group - & SQS.smMessageDeduplicationId .~ Just (toText dedup) + SQS.newSendMessage url (Text.decodeLatin1 (BL.toStrict m)) + & SQS.sendMessage_messageGroupId .~ Just group + & SQS.sendMessage_messageDeduplicationId .~ Just (toText dedup) ------------------------------------------------------------------------------- -- SES @@ -210,9 +209,9 @@ sendMail :: Mail -> Amazon () sendMail m = do body <- liftIO $ BL.toStrict <$> renderMail' m let raw = - SES.sendRawEmail (SES.rawMessage body) - & SES.sreDestinations .~ fmap addressEmail (mailTo m) - & SES.sreSource ?~ addressEmail (mailFrom m) + SES.newSendRawEmail (SES.newRawMessage body) + & SES.sendRawEmail_destinations ?~ fmap addressEmail (mailTo m) + & SES.sendRawEmail_source ?~ addressEmail (mailFrom m) resp <- retrying retry5x (const canRetry) $ const (sendCatch raw) void $ either check return resp where @@ -233,30 +232,32 @@ sendMail m = do -------------------------------------------------------------------------------- -- Utilities -sendCatch :: AWSRequest r => r -> Amazon (Either AWS.Error (Rs r)) -sendCatch = AWST.trying AWS._Error . AWS.send +sendCatch :: AWSRequest r => r -> Amazon (Either AWS.Error (AWSResponse r)) +sendCatch req = do + env <- view amazonkaEnv + AWS.trying AWS._Error . AWS.send env $ req -send :: AWSRequest r => r -> Amazon (Rs r) +send :: AWSRequest r => r -> Amazon (AWSResponse r) send r = throwA =<< sendCatch r throwA :: Either AWS.Error a -> Amazon a throwA = either (throwM . GeneralError) return execCatch :: - (AWSRequest a, AWS.HasEnv r, MonadUnliftIO m, MonadCatch m, MonadThrow m, MonadIO m) => - r -> + (AWSRequest a, MonadUnliftIO m, MonadCatch m, MonadThrow m, MonadIO m) => + AWS.Env -> a -> - m (Either AWS.Error (Rs a)) + m (Either AWS.Error (AWSResponse a)) execCatch e cmd = - runResourceT . AWST.runAWST e $ - AWST.trying AWS._Error $ - AWST.send cmd + runResourceT $ + AWS.trying AWS._Error $ + AWS.send e cmd exec :: - (AWSRequest a, AWS.HasEnv r, MonadUnliftIO m, MonadCatch m, MonadThrow m, MonadIO m) => - r -> + (AWSRequest a, MonadUnliftIO m, MonadCatch m, MonadThrow m, MonadIO m) => + AWS.Env -> a -> - m (Rs a) + m (AWSResponse a) exec e cmd = execCatch e cmd >>= either (throwM . GeneralError) return canRetry :: MonadIO m => Either AWS.Error a -> m Bool diff --git a/services/brig/src/Brig/App.hs b/services/brig/src/Brig/App.hs index cb48e47c77f..7f718d0ed27 100644 --- a/services/brig/src/Brig/App.hs +++ b/services/brig/src/Brig/App.hs @@ -55,6 +55,7 @@ module Brig.App internalEvents, emailSender, randomPrekeyLocalLock, + keyPackageLocalLock, -- * App Monad AppT, @@ -135,7 +136,7 @@ import Util.Options import Wire.API.User.Identity (Email) schemaVersion :: Int32 -schemaVersion = 66 +schemaVersion = 67 ------------------------------------------------------------------------------- -- Environment @@ -173,7 +174,8 @@ data Env = Env _digestSHA256 :: Digest, _digestMD5 :: Digest, _indexEnv :: IndexEnv, - _randomPrekeyLocalLock :: Maybe (MVar ()) + _randomPrekeyLocalLock :: Maybe (MVar ()), + _keyPackageLocalLock :: MVar () } makeLenses ''Env @@ -218,6 +220,7 @@ newEnv o = do prekeyLocalLock <- case Opt.randomPrekeys o of Just True -> Just <$> newMVar () _ -> pure Nothing + kpLock <- newMVar () return $! Env { _cargohold = mkEndpoint $ Opt.cargohold o, @@ -252,7 +255,8 @@ newEnv o = do _digestMD5 = md5, _digestSHA256 = sha256, _indexEnv = mkIndexEnv o lgr mgr mtr, - _randomPrekeyLocalLock = prekeyLocalLock + _randomPrekeyLocalLock = prekeyLocalLock, + _keyPackageLocalLock = kpLock } where emailConn _ (Opt.EmailAWS aws) = return (Just aws, Nothing) diff --git a/services/brig/src/Brig/Data/Client.hs b/services/brig/src/Brig/Data/Client.hs index 7b4d9ed1909..1f8095a0fdc 100644 --- a/services/brig/src/Brig/Data/Client.hs +++ b/services/brig/src/Brig/Data/Client.hs @@ -41,6 +41,9 @@ module Brig.Data.Client ) where +import qualified Amazonka as AWS +import qualified Amazonka.DynamoDB as AWS +import qualified Amazonka.DynamoDB.Lens as AWS import Bilge.Retry (httpHandlers) import Brig.AWS import Brig.App (AppIO, awsEnv, currentTime, metrics, randomPrekeyLocalLock) @@ -70,9 +73,6 @@ import qualified Data.Set as Set import qualified Data.Text as Text import qualified Data.UUID as UUID import Imports -import qualified Network.AWS as AWS -import qualified Network.AWS.Data as AWS -import qualified Network.AWS.DynamoDB as AWS import System.CryptoBox (Result (Success)) import qualified System.CryptoBox as CryptoBox import System.Logger.Class (field, msg, val) @@ -325,7 +325,7 @@ ddbVersion :: Text ddbVersion = "version" ddbKey :: UserId -> ClientId -> AWS.AttributeValue -ddbKey u c = AWS.attributeValue & AWS.avS ?~ UUID.toText (toUUID u) <> "." <> client c +ddbKey u c = AWS.S (UUID.toText (toUUID u) <> "." <> client c) key :: UserId -> ClientId -> HashMap Text AWS.AttributeValue key u c = HashMap.singleton ddbClient (ddbKey u c) @@ -334,7 +334,7 @@ deleteOptLock :: UserId -> ClientId -> (AppIO r) () deleteOptLock u c = do t <- view (awsEnv . prekeyTable) e <- view (awsEnv . amazonkaEnv) - void $ exec e (AWS.deleteItem t & AWS.diKey .~ (key u c)) + void $ exec e (AWS.newDeleteItem t & AWS.deleteItem_key .~ key u c) withOptLock :: forall effs a. UserId -> ClientId -> (AppIO effs) a -> (AppIO effs) a withOptLock u c ma = go (10 :: Int) @@ -348,30 +348,32 @@ withOptLock u c ma = go (10 :: Int) Nothing -> reportFailureAndLogError >> return a Just _ -> return a version :: AWS.GetItemResponse -> Maybe Word32 - version v = conv =<< HashMap.lookup ddbVersion (view AWS.girsItem v) + version v = conv =<< HashMap.lookup ddbVersion (view AWS.getItemResponse_item v) where conv :: AWS.AttributeValue -> Maybe Word32 - conv = readMaybe . Text.unpack <=< view AWS.avN + conv = \case + AWS.N t -> readMaybe $ Text.unpack t + _ -> Nothing get :: Text -> AWS.GetItem get t = - AWS.getItem t & AWS.giKey .~ (key u c) - & AWS.giConsistentRead ?~ True + AWS.newGetItem t & AWS.getItem_key .~ key u c + & AWS.getItem_consistentRead ?~ True put :: Maybe Word32 -> Text -> AWS.PutItem put v t = - AWS.putItem t & AWS.piItem .~ item v - & AWS.piExpected .~ check v + AWS.newPutItem t & AWS.putItem_item .~ item v + & AWS.putItem_expected ?~ check v check :: Maybe Word32 -> HashMap Text AWS.ExpectedAttributeValue - check Nothing = HashMap.singleton ddbVersion $ AWS.expectedAttributeValue & AWS.eavComparisonOperator ?~ AWS.Null + check Nothing = HashMap.singleton ddbVersion $ AWS.newExpectedAttributeValue & AWS.expectedAttributeValue_comparisonOperator ?~ AWS.ComparisonOperator_NULL check (Just v) = HashMap.singleton ddbVersion $ - AWS.expectedAttributeValue & AWS.eavComparisonOperator ?~ AWS.EQ' - & AWS.eavAttributeValueList .~ [toAttributeValue v] + AWS.newExpectedAttributeValue & AWS.expectedAttributeValue_comparisonOperator ?~ AWS.ComparisonOperator_EQ + & AWS.expectedAttributeValue_attributeValueList ?~ [toAttributeValue v] item :: Maybe Word32 -> HashMap Text AWS.AttributeValue item v = HashMap.insert ddbVersion (toAttributeValue (maybe (1 :: Word32) (+ 1) v)) $ key u c toAttributeValue :: Word32 -> AWS.AttributeValue - toAttributeValue w = AWS.attributeValue & AWS.avN ?~ AWS.toText (fromIntegral w :: Int) + toAttributeValue w = AWS.N $ AWS.toText (fromIntegral w :: Int) reportAttemptFailure :: (AppIO effs) () reportAttemptFailure = Metrics.counterIncr (Metrics.path "client.opt_lock.optimistic_lock_grab_attempt_failed") =<< view metrics @@ -382,7 +384,7 @@ withOptLock u c ma = go (10 :: Int) . Log.field "client" (toByteString' c) . msg (val "PreKeys: Optimistic lock failed") Metrics.counterIncr (Metrics.path "client.opt_lock.optimistic_lock_failed") =<< view metrics - execDyn :: forall r x. (AWS.AWSRequest r) => (AWS.Rs r -> Maybe x) -> (Text -> r) -> (AppIO effs) (Maybe x) + execDyn :: forall r x. (AWS.AWSRequest r) => (AWS.AWSResponse r -> Maybe x) -> (Text -> r) -> (AppIO effs) (Maybe x) execDyn cnv mkCmd = do cmd <- mkCmd <$> view (awsEnv . prekeyTable) e <- view (awsEnv . amazonkaEnv) @@ -394,7 +396,7 @@ withOptLock u c ma = go (10 :: Int) AWS.AWSRequest p => AWS.Env -> Metrics.Metrics -> - (AWS.Rs p -> Maybe y) -> + (AWS.AWSResponse p -> Maybe y) -> p -> IO (Maybe y) execDyn' e m conv cmd = recovering policy handlers (const run) diff --git a/services/brig/src/Brig/Data/MLS/KeyPackage.hs b/services/brig/src/Brig/Data/MLS/KeyPackage.hs new file mode 100644 index 00000000000..25f3eaabccd --- /dev/null +++ b/services/brig/src/Brig/Data/MLS/KeyPackage.hs @@ -0,0 +1,77 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Brig.Data.MLS.KeyPackage + ( insertKeyPackages, + claimKeyPackage, + countKeyPackages, + ) +where + +import Brig.App +import Brig.Data.MLS.KeyPackage.Instances () +import Cassandra +import Control.Error +import Control.Lens +import Control.Monad.Random (randomRIO) +import Data.Functor +import Data.Id +import Imports +import Wire.API.MLS.KeyPackage + +insertKeyPackages :: MonadClient m => UserId -> ClientId -> [(KeyPackageRef, KeyPackageData)] -> m () +insertKeyPackages uid cid kps = retry x5 . batch $ do + setType BatchLogged + setConsistency LocalQuorum + for_ kps $ \(ref, kp) -> do + addPrepQuery q (uid, cid, kp, ref) + where + q :: PrepQuery W (UserId, ClientId, KeyPackageData, KeyPackageRef) () + q = "INSERT INTO mls_key_packages (user, client, data, ref) VALUES (?, ?, ?, ?)" + +claimKeyPackage :: UserId -> ClientId -> MaybeT (AppIO r) KeyPackageData +claimKeyPackage u c = MaybeT $ do + -- FUTUREWORK: investigate better locking strategies + lock <- view keyPackageLocalLock + withMVar lock . const $ do + kps <- retry x1 $ query lookupQuery (params LocalQuorum (u, c)) + mk <- liftIO (pick kps) + for mk $ \(ref, kpd) -> do + retry x5 $ write deleteQuery (params LocalQuorum (u, c, ref)) + pure kpd + where + lookupQuery :: PrepQuery R (UserId, ClientId) (KeyPackageRef, KeyPackageData) + lookupQuery = "SELECT ref, data FROM mls_key_packages WHERE user = ? AND client = ?" + + deleteQuery :: PrepQuery W (UserId, ClientId, KeyPackageRef) () + deleteQuery = "DELETE FROM mls_key_packages WHERE user = ? AND client = ? AND ref = ?" + +countKeyPackages :: MonadClient m => UserId -> ClientId -> m Int64 +countKeyPackages u c = + retry x1 $ sum . fmap runIdentity <$> query1 q (params LocalQuorum (u, c)) + where + q :: PrepQuery R (UserId, ClientId) (Identity Int64) + q = "SELECT COUNT(*) FROM mls_key_packages WHERE user = ? AND client = ?" + +-------------------------------------------------------------------------------- +-- Utilities + +pick :: [a] -> IO (Maybe a) +pick [] = pure Nothing +pick xs = do + i <- randomRIO (0, length xs - 1) + pure (atMay xs i) diff --git a/services/brig/src/Brig/Data/MLS/KeyPackage/Instances.hs b/services/brig/src/Brig/Data/MLS/KeyPackage/Instances.hs new file mode 100644 index 00000000000..5add8976113 --- /dev/null +++ b/services/brig/src/Brig/Data/MLS/KeyPackage/Instances.hs @@ -0,0 +1,36 @@ +-- 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 . +{-# OPTIONS_GHC -Wno-orphans #-} + +module Brig.Data.MLS.KeyPackage.Instances () where + +import Cassandra +import qualified Data.ByteString.Lazy as LBS +import Imports +import Wire.API.MLS.KeyPackage + +instance Cql KeyPackageRef where + ctype = Tagged BlobColumn + toCql = CqlBlob . LBS.fromStrict . unKeyPackageRef + fromCql (CqlBlob b) = pure . KeyPackageRef . LBS.toStrict $ b + fromCql _ = Left "Expected CqlBlob" + +instance Cql KeyPackageData where + ctype = Tagged BlobColumn + toCql = CqlBlob . kpData + fromCql (CqlBlob b) = pure . KeyPackageData $ b + fromCql _ = Left "Expected CqlBlob" diff --git a/services/brig/src/Brig/Federation/Client.hs b/services/brig/src/Brig/Federation/Client.hs index ade024d4442..a7f41c8c2c4 100644 --- a/services/brig/src/Brig/Federation/Client.hs +++ b/services/brig/src/Brig/Federation/Client.hs @@ -25,7 +25,6 @@ module Brig.Federation.Client where import Brig.App import Brig.Types (PrekeyBundle) import Brig.Types.Client (PubClient) -import qualified Brig.Types.Search as Public import Brig.Types.User import Control.Lens import Control.Monad @@ -81,7 +80,7 @@ claimMultiPrekeyBundle domain uc = do Log.info $ Log.msg @Text "Brig-federation: claiming remote multi-user prekey bundle" executeFederated @"claim-multi-prekey-bundle" domain uc -searchUsers :: Domain -> SearchRequest -> (FederationAppIO r) [Public.Contact] +searchUsers :: Domain -> SearchRequest -> (FederationAppIO r) SearchResponse searchUsers domain searchTerm = do Log.info $ Log.msg $ T.pack "Brig-federation: search call on remote backend" executeFederated @"search-users" domain searchTerm diff --git a/services/brig/src/Brig/IO/Intra.hs b/services/brig/src/Brig/IO/Intra.hs index 2aa0c9cdd88..d2f239fdf00 100644 --- a/services/brig/src/Brig/IO/Intra.hs +++ b/services/brig/src/Brig/IO/Intra.hs @@ -87,6 +87,7 @@ import Control.Monad.Catch (MonadThrow (throwM)) import Control.Monad.Trans.Except (runExceptT, throwE) import Control.Retry import Data.Aeson hiding (json) +import qualified Data.Aeson.KeyMap as KeyMap import Data.ByteString.Conversion import qualified Data.ByteString.Lazy as BL import Data.Coerce (coerce) @@ -94,7 +95,6 @@ import qualified Data.Conduit.List as C import qualified Data.Currency as Currency import Data.Domain import Data.Either.Combinators (whenLeft) -import qualified Data.HashMap.Strict as M import Data.Id import Data.Json.Util (UTCTimeMillis, (#)) import Data.List.Split (chunksOf) @@ -416,19 +416,19 @@ notifyContacts events orig route conn = do toPushFormat :: Event -> Maybe Object toPushFormat (UserEvent (UserCreated u)) = Just $ - M.fromList + KeyMap.fromList [ "type" .= ("user.new" :: Text), "user" .= SelfProfile (u {userIdentity = Nothing}) ] toPushFormat (UserEvent (UserActivated u)) = Just $ - M.fromList + KeyMap.fromList [ "type" .= ("user.activate" :: Text), "user" .= SelfProfile u ] toPushFormat (UserEvent (UserUpdated (UserUpdatedData i n pic acc ass hdl loc mb ssoId ssoIdDel))) = Just $ - M.fromList + KeyMap.fromList [ "type" .= ("user.update" :: Text), "user" .= object @@ -447,7 +447,7 @@ toPushFormat (UserEvent (UserUpdated (UserUpdatedData i n pic acc ass hdl loc mb ] toPushFormat (UserEvent (UserIdentityUpdated UserIdentityUpdatedData {..})) = Just $ - M.fromList + KeyMap.fromList [ "type" .= ("user.update" :: Text), "user" .= object @@ -459,7 +459,7 @@ toPushFormat (UserEvent (UserIdentityUpdated UserIdentityUpdatedData {..})) = ] toPushFormat (UserEvent (UserIdentityRemoved (UserIdentityRemovedData i e p))) = Just $ - M.fromList + KeyMap.fromList [ "type" .= ("user.identity-remove" :: Text), "user" .= object @@ -471,7 +471,7 @@ toPushFormat (UserEvent (UserIdentityRemoved (UserIdentityRemovedData i e p))) = ] toPushFormat (ConnectionEvent (ConnectionUpdated uc _ name)) = Just $ - M.fromList $ + KeyMap.fromList $ "type" .= ("user.connection" :: Text) # "connection" .= uc # "user" .= case name of @@ -480,69 +480,69 @@ toPushFormat (ConnectionEvent (ConnectionUpdated uc _ name)) = # [] toPushFormat (UserEvent (UserSuspended i)) = Just $ - M.fromList + KeyMap.fromList [ "type" .= ("user.suspend" :: Text), "id" .= i ] toPushFormat (UserEvent (UserResumed i)) = Just $ - M.fromList + KeyMap.fromList [ "type" .= ("user.resume" :: Text), "id" .= i ] toPushFormat (UserEvent (UserDeleted qid)) = Just $ - M.fromList + KeyMap.fromList [ "type" .= ("user.delete" :: Text), "id" .= qUnqualified qid, "qualified_id" .= qid ] toPushFormat (UserEvent (UserLegalHoldDisabled i)) = Just $ - M.fromList + KeyMap.fromList [ "type" .= ("user.legalhold-disable" :: Text), "id" .= i ] toPushFormat (UserEvent (UserLegalHoldEnabled i)) = Just $ - M.fromList + KeyMap.fromList [ "type" .= ("user.legalhold-enable" :: Text), "id" .= i ] toPushFormat (PropertyEvent (PropertySet _ k v)) = Just $ - M.fromList + KeyMap.fromList [ "type" .= ("user.properties-set" :: Text), "key" .= k, "value" .= v ] toPushFormat (PropertyEvent (PropertyDeleted _ k)) = Just $ - M.fromList + KeyMap.fromList [ "type" .= ("user.properties-delete" :: Text), "key" .= k ] toPushFormat (PropertyEvent (PropertiesCleared _)) = Just $ - M.fromList + KeyMap.fromList [ "type" .= ("user.properties-clear" :: Text) ] toPushFormat (ClientEvent (ClientAdded _ c)) = Just $ - M.fromList + KeyMap.fromList [ "type" .= ("user.client-add" :: Text), "client" .= c ] toPushFormat (ClientEvent (ClientRemoved _ c)) = Just $ - M.fromList + KeyMap.fromList [ "type" .= ("user.client-remove" :: Text), "client" .= IdObject (clientId c) ] toPushFormat (UserEvent (LegalHoldClientRequested payload)) = let LegalHoldClientRequestedData targetUser lastPrekey' clientId = payload in Just $ - M.fromList + KeyMap.fromList [ "type" .= ("user.legalhold-request" :: Text), "id" .= targetUser, "last_prekey" .= lastPrekey', diff --git a/services/brig/src/Brig/Index/Eval.hs b/services/brig/src/Brig/Index/Eval.hs index 11f9bc61ac1..3bafd7704a9 100644 --- a/services/brig/src/Brig/Index/Eval.hs +++ b/services/brig/src/Brig/Index/Eval.hs @@ -28,12 +28,12 @@ import Brig.User.Search.Index import qualified Cassandra as C import qualified Cassandra.Settings as C import Control.Lens -import qualified Control.Lens.Internal.ByteString as LensBS import Control.Monad.Catch import Control.Retry import Data.Aeson (FromJSON) import qualified Data.Aeson as Aeson import qualified Data.Metrics as Metrics +import Data.String.Conversions (cs) import qualified Database.Bloodhound as ES import Imports import Network.HTTP.Client as HTTP @@ -121,7 +121,7 @@ waitForTaskToComplete timeoutSeconds taskNodeId = do throwM $ ReindexFromAnotherIndexError $ "Task failed with error: " - <> LensBS.unpackLazy8 (Aeson.encode $ ES.taskResponseError task) + <> cs (Aeson.encode $ ES.taskResponseError task) where isTaskComplete :: Either ES.EsError (ES.TaskResponse a) -> m Bool isTaskComplete (Left e) = throwM $ ReindexFromAnotherIndexError $ "Error response while getting task: " <> show e diff --git a/services/brig/src/Brig/Options.hs b/services/brig/src/Brig/Options.hs index 5c0f617e64f..a78957f2e5e 100644 --- a/services/brig/src/Brig/Options.hs +++ b/services/brig/src/Brig/Options.hs @@ -37,7 +37,7 @@ import Data.Id import Data.LanguageCodes (ISO639_1 (EN)) import Data.Misc (HttpsUrl) import Data.Range -import Data.Schema (Schema (Schema), ToSchema (schema), element, enum) +import Data.Schema import Data.Scientific (toBoundedInteger) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text @@ -50,6 +50,7 @@ import System.Logger.Extended (Level, LogFormat) import Util.Options import Wire.API.Arbitrary (Arbitrary, GenericUniform (GenericUniform)) import qualified Wire.API.Team.Feature as ApiFT +import Wire.API.User.Search (FederatedUserSearchPolicy) newtype Timeout = Timeout { timeoutDiff :: NominalDiffTime @@ -356,6 +357,42 @@ instance ToSchema ListAllSFTServers where element "disabled" HideAllSFTServers ] +data AllowedUserSearch + = NoSearch + | ExactHandleSearch + | FullSearch + deriving (Show, Generic, Enum, Bounded) + +instance ToJSON AllowedUserSearch where + toJSON NoSearch = "no_search" + toJSON ExactHandleSearch = "exact_handle_search" + toJSON FullSearch = "full_search" + +instance FromJSON AllowedUserSearch where + parseJSON = withText "AllowedUserSearch" $ \case + "no_search" -> pure NoSearch + "exact_handle_search" -> pure ExactHandleSearch + "full_search" -> pure FullSearch + _ -> + fail $ + "unexpected value for AllowedUserSearch settings: " + <> "expected one of " + <> show (Aeson.encode <$> [(minBound :: AllowedUserSearch) ..]) + +data FederationDomainConfig = FederationDomainConfig + { domain :: Domain, + cfgSearchPolicy :: FederatedUserSearchPolicy + } + deriving (Show, Generic) + deriving (ToJSON, FromJSON) via Schema FederationDomainConfig + +instance ToSchema FederationDomainConfig where + schema = + object "FederationDomainConfig" $ + FederationDomainConfig + <$> domain .= field "domain" schema + <*> cfgSearchPolicy .= field "search_policy" schema + -- | Options that are consumed on startup data Opts = Opts -- services @@ -488,7 +525,7 @@ data Settings = Settings -- returns users from the same team setSearchSameTeamOnly :: !(Maybe Bool), -- | FederationDomain is required, even when not wanting to federate with other backends - -- (in that case the 'setFederationAllowedDomains' can be set to empty in Federator) + -- (in that case the 'allowedDomains' 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: @@ -496,10 +533,11 @@ data Settings = Settings -- 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. -- Example: - -- setFederationAllowedDomains: + -- allowedDomains: -- - wire.com -- - example.com setFederationDomain :: !Domain, + setFederationDomainConfigs :: !(Maybe [FederationDomainConfig]), -- | 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'. @@ -525,7 +563,8 @@ data Settings = Settings -- loadbalanced servers of `setSftStaticUrl` under the @sft_servers_all@ -- field. The default setting is to exclude and omit the field from the -- response. - setSftListAllServers :: Maybe ListAllSFTServers + setSftListAllServers :: Maybe ListAllSFTServers, + setKeyPackageMaximumLifetime :: Maybe NominalDiffTime } deriving (Show, Generic) @@ -736,7 +775,8 @@ Lens.makeLensesFor ("setFederationDomain", "federationDomain"), ("setSqsThrottleMillis", "sqsThrottleMillis"), ("setSftStaticUrl", "sftStaticUrl"), - ("setSftListAllServers", "sftListAllServers") + ("setSftListAllServers", "sftListAllServers"), + ("setFederationDomainConfigs", "federationDomainConfigs") ] ''Settings diff --git a/services/brig/src/Brig/Queue.hs b/services/brig/src/Brig/Queue.hs index c4c811853e3..ae8dc36cd44 100644 --- a/services/brig/src/Brig/Queue.hs +++ b/services/brig/src/Brig/Queue.hs @@ -23,6 +23,7 @@ module Brig.Queue ) where +import Amazonka.SQS.Lens (sendMessageResponse_mD5OfMessageBody) import qualified Brig.AWS as AWS import Brig.App import Brig.Options @@ -36,7 +37,6 @@ import qualified Data.ByteString.Base16 as B16 import qualified Data.ByteString.Lazy as BL import qualified Data.Text.Encoding as T import Imports -import Network.AWS.SQS (smrsMD5OfMessageBody) import OpenSSL.EVP.Digest (Digest, digestLBS) import System.Logger.Class as Log hiding (settings) @@ -77,11 +77,11 @@ enqueue (SqsQueue queue) message = let body = encode message bodyMD5 <- digest <$> view digestMD5 <*> pure body resp <- AWS.execute env (AWS.enqueueStandard queue body) - unless (resp ^. smrsMD5OfMessageBody == Just bodyMD5) $ do + unless (resp ^. sendMessageResponse_mD5OfMessageBody == Just bodyMD5) $ do Log.err $ msg (val "Returned hash (MD5) doesn't match message hash") . field "SqsQueue" (show queue) - . field "returned_hash" (show (resp ^. smrsMD5OfMessageBody)) + . field "returned_hash" (show (resp ^. sendMessageResponse_mD5OfMessageBody)) . field "message_hash" (show (Just bodyMD5)) throwM (ErrorCall "The server couldn't access a queue") where diff --git a/services/brig/src/Brig/Run.hs b/services/brig/src/Brig/Run.hs index ed77926081e..cd046c4aaaf 100644 --- a/services/brig/src/Brig/Run.hs +++ b/services/brig/src/Brig/Run.hs @@ -39,6 +39,7 @@ import qualified Brig.InternalEvent.Process as Internal import Brig.Options hiding (internalEvents, sesQueue) import qualified Brig.Queue as Queue import Brig.Types.Intra (AccountStatus (PendingInvitation)) +import Brig.Version import Cassandra (Page (Page), liftClient) import qualified Control.Concurrent.Async as Async import Control.Exception.Safe (catchAny) @@ -47,6 +48,7 @@ import Control.Monad.Catch (MonadCatch, finally) import Control.Monad.Random (randomRIO) import qualified Data.Aeson as Aeson import Data.Default (Default (def)) +import Data.Domain import Data.Id (RequestId (..)) import qualified Data.Metrics.Servant as Metrics import Data.Proxy (Proxy (Proxy)) @@ -123,16 +125,26 @@ mkApp o = do -- the servant API wraps the one defined using wai-routing servantApp :: Env -> Wai.Application servantApp e = - Servant.serveWithContext - (Proxy @ServantCombinedAPI) - (customFormatters :. Servant.EmptyContext) - ( swaggerDocsAPI - :<|> Servant.hoistServer (Proxy @BrigAPI) (toServantHandler e) servantSitemap - :<|> Servant.hoistServer (Proxy @IAPI.API) (toServantHandler e) IAPI.servantSitemap - :<|> Servant.hoistServer (Proxy @FederationAPI) (toServantHandler e) federationSitemap - :<|> versionAPI - :<|> Servant.Tagged (app e) - ) + let localDomain = view (settings . federationDomain) e + in Servant.serveWithContext + (Proxy @ServantCombinedAPI) + (customFormatters :. localDomain :. Servant.EmptyContext) + ( swaggerDocsAPI + :<|> hoistServer' @BrigAPI (toServantHandler e) servantSitemap + :<|> hoistServer' @IAPI.API (toServantHandler e) IAPI.servantSitemap + :<|> hoistServer' @FederationAPI (toServantHandler e) federationSitemap + :<|> hoistServer' @VersionAPI (toServantHandler e) versionAPI + :<|> Servant.Tagged (app e) + ) + +-- | See 'Galley.Run' for an explanation of this function. +hoistServer' :: + forall api m n. + Servant.HasServer api '[Domain] => + (forall x. m x -> n x) -> + Servant.ServerT api m -> + Servant.ServerT api n +hoistServer' = Servant.hoistServerWithContext (Proxy @api) (Proxy @'[Domain]) type ServantCombinedAPI = ( SwaggerDocsAPI diff --git a/services/brig/src/Brig/User/API/Search.hs b/services/brig/src/Brig/User/API/Search.hs index 4a3124c1ed9..4f01f330997 100644 --- a/services/brig/src/Brig/User/API/Search.hs +++ b/services/brig/src/Brig/User/API/Search.hs @@ -56,8 +56,10 @@ import System.Logger (field, msg) import System.Logger.Class (val, (~~)) import qualified System.Logger.Class as Log import qualified Wire.API.Federation.API.Brig as FedBrig +import qualified Wire.API.Federation.API.Brig as S import qualified Wire.API.Team.Permission as Public import Wire.API.Team.SearchVisibility (TeamSearchVisibility) +import Wire.API.User.Search (FederatedUserSearchPolicy (FullSearch)) import qualified Wire.API.User.Search as Public routesPublic :: Routes Doc.ApiBuilder (Handler r) () @@ -135,14 +137,16 @@ searchRemotely domain searchTerm = do msg (val "searchRemotely") ~~ field "domain" (show domain) ~~ field "searchTerm" searchTerm - contacts <- Federation.searchUsers domain (FedBrig.SearchRequest searchTerm) !>> fedError + searchResponse <- Federation.searchUsers domain (FedBrig.SearchRequest searchTerm) !>> fedError + let contacts = S.contacts searchResponse let count = length contacts pure SearchResult { searchResults = contacts, searchFound = count, searchReturned = count, - searchTook = 0 + searchTook = 0, + searchPolicy = S.searchPolicy searchResponse } searchLocally :: UserId -> Text -> Maybe (Range 1 500 Int32) -> (Handler r) (Public.SearchResult Public.Contact) @@ -158,7 +162,7 @@ searchLocally searcherId searchTerm maybeMaxResults = do esResult <- if esMaxResults > 0 then Q.searchIndex (Just searcherId) (Just teamSearchInfo) searchTerm esMaxResults - else pure $ SearchResult 0 0 0 [] + else pure $ SearchResult 0 0 0 [] FullSearch -- Prepend results matching exact handle and results from ES. pure $ diff --git a/services/brig/src/Brig/User/Search/SearchIndex.hs b/services/brig/src/Brig/User/Search/SearchIndex.hs index 9a323b02231..55df94e369b 100644 --- a/services/brig/src/Brig/User/Search/SearchIndex.hs +++ b/services/brig/src/Brig/User/Search/SearchIndex.hs @@ -38,6 +38,7 @@ import Data.Qualified (Qualified (Qualified)) import qualified Database.Bloodhound as ES import Imports hiding (log, searchable) import Wire.API.User (ColourId (..), Name (fromName)) +import Wire.API.User.Search (FederatedUserSearchPolicy (FullSearch)) searchIndex :: (MonadIndexIO m, MonadReader Env m) => @@ -72,7 +73,8 @@ queryIndex (IndexQuery q f _) s = do { searchFound = ES.hitsTotal . ES.searchHits $ es, searchReturned = length results, searchTook = ES.took es, - searchResults = results + searchResults = results, + searchPolicy = FullSearch } userDocToContact :: MonadThrow m => Domain -> UserDoc -> m Contact diff --git a/services/brig/src/Brig/User/Search/TeamUserSearch.hs b/services/brig/src/Brig/User/Search/TeamUserSearch.hs index 7a4ba095f20..b8cc78b5bc2 100644 --- a/services/brig/src/Brig/User/Search/TeamUserSearch.hs +++ b/services/brig/src/Brig/User/Search/TeamUserSearch.hs @@ -65,7 +65,8 @@ teamUserSearch tid mbSearchText mRoleFilter mSortBy mSortOrder (fromRange -> s) { searchFound = ES.hitsTotal . ES.searchHits $ es, searchReturned = length results, searchTook = ES.took es, - searchResults = results + searchResults = results, + searchPolicy = FullSearch } -- FUTURWORK: Implement role filter (needs galley data) diff --git a/services/brig/src/Brig/Version.hs b/services/brig/src/Brig/Version.hs new file mode 100644 index 00000000000..6909e8f03a7 --- /dev/null +++ b/services/brig/src/Brig/Version.hs @@ -0,0 +1,37 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Brig.Version where + +import Brig.API.Handler +import Brig.App +import Control.Lens +import Imports +import Servant (ServerT) +import Wire.API.Routes.Named +import Wire.API.Routes.Version + +versionAPI :: ServerT VersionAPI (Handler r) +versionAPI = Named $ do + fed <- view federator + dom <- viewFederationDomain + pure $ + VersionInfo + { vinfoSupported = supportedVersions, + vinfoFederation = isJust fed, + vinfoDomain = dom + } diff --git a/services/brig/test/integration/API/Federation.hs b/services/brig/test/integration/API/Federation.hs index d1559afc4c5..eb2724f9de1 100644 --- a/services/brig/test/integration/API/Federation.hs +++ b/services/brig/test/integration/API/Federation.hs @@ -1,21 +1,3 @@ --- 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 . -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2022 Wire Swiss GmbH @@ -32,6 +14,7 @@ -- -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module API.Federation where @@ -42,6 +25,7 @@ import Bilge.Assert import qualified Brig.Options as Opt import Brig.Types import Control.Arrow (Arrow (first), (&&&)) +import Control.Lens ((?~)) import Data.Aeson import Data.Domain (Domain (Domain)) import Data.Handle (Handle (..)) @@ -61,9 +45,11 @@ 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 qualified Wire.API.Federation.API.Brig as S import Wire.API.Federation.Component import Wire.API.Message (UserClients (..)) import Wire.API.User.Client (mkUserClientPrekeyMap) +import Wire.API.User.Search (FederatedUserSearchPolicy (..)) import Wire.API.UserMap (UserMap (UserMap)) -- Note: POST /federation/send-connection-action is implicitly tested in API.User.Connection @@ -72,13 +58,15 @@ tests m opts brig cannon fedBrigClient = return $ testGroup "federation" - [ test m "POST /federation/search-users : Found" (testSearchSuccess brig fedBrigClient), - test m "POST /federation/search-users : Found (fulltext)" (testFulltextSearchSuccess brig fedBrigClient), - test m "POST /federation/search-users : Found (multiple users)" (testFulltextSearchMultipleUsers brig fedBrigClient), - test m "POST /federation/search-users : NotFound" (testSearchNotFound fedBrigClient), - test m "POST /federation/search-users : Empty Input - NotFound" (testSearchNotFoundEmpty fedBrigClient), - test m "POST /federation/get-user-by-handle : Found" (testGetUserByHandleSuccess brig fedBrigClient), - test m "POST /federation/get-user-by-handle : NotFound" (testGetUserByHandleNotFound fedBrigClient), + [ test m "POST /federation/search-users : Found" (testSearchSuccess opts brig), + test m "POST /federation/search-users : Found (fulltext)" (testFulltextSearchSuccess opts brig), + test m "POST /federation/search-users : Found (multiple users)" (testFulltextSearchMultipleUsers opts brig), + test m "POST /federation/search-users : NotFound" (testSearchNotFound opts), + test m "POST /federation/search-users : Empty Input - NotFound" (testSearchNotFoundEmpty opts), + test m "POST /federation/search-users : configured restrictions" (testSearchRestrictions opts brig), + test m "POST /federation/get-user-by-handle : configured restrictions" (testGetUserByHandleRestrictions opts brig), + test m "POST /federation/get-user-by-handle : Found" (testGetUserByHandleSuccess opts brig), + test m "POST /federation/get-user-by-handle : NotFound" (testGetUserByHandleNotFound opts), test m "POST /federation/get-users-by-ids : 200 all found" (testGetUsersByIdsSuccess brig fedBrigClient), test m "POST /federation/get-users-by-ids : 200 partially found" (testGetUsersByIdsPartial brig fedBrigClient), test m "POST /federation/get-users-by-ids : 200 none found" (testGetUsersByIdsNoneFound fedBrigClient), @@ -90,36 +78,46 @@ tests m opts brig cannon fedBrigClient = test m "POST /federation/on-user-deleted-connections : 200" (testRemoteUserGetsDeleted opts brig cannon fedBrigClient) ] -testSearchSuccess :: Brig -> FedClient 'Brig -> Http () -testSearchSuccess brig fedBrigClient = do +allowFullSearch :: Domain -> Opt.Opts -> Opt.Opts +allowFullSearch domain opts = + opts & Opt.optionSettings . Opt.federationDomainConfigs ?~ [Opt.FederationDomainConfig domain FullSearch] + +testSearchSuccess :: Opt.Opts -> Brig -> Http () +testSearchSuccess opts brig = do (handle, user) <- createUserWithHandle brig refreshIndex brig let quid = userQualifiedId user + let domain = Domain "example.com" + + searchResponse <- withSettingsOverrides (allowFullSearch domain opts) $ do + runWaiTestFedClient domain $ + createWaiTestFedClient @"search-users" @'Brig $ + SearchRequest (fromHandle handle) - searchResult <- - runFedClient @"search-users" fedBrigClient (Domain "example.com") $ - SearchRequest (fromHandle handle) liftIO $ do - let contacts = contactQualifiedId <$> searchResult + let contacts = contactQualifiedId <$> S.contacts searchResponse assertEqual "should return the user id" [quid] contacts -testFulltextSearchSuccess :: Brig -> FedClient 'Brig -> Http () -testFulltextSearchSuccess brig fedBrigClient = do +testFulltextSearchSuccess :: Opt.Opts -> Brig -> Http () +testFulltextSearchSuccess opts brig = do (_, user) <- createUserWithHandle brig refreshIndex brig let quid = userQualifiedId user + let domain = Domain "example.com" + + searchResponse <- withSettingsOverrides (allowFullSearch domain opts) $ do + runWaiTestFedClient domain $ + createWaiTestFedClient @"search-users" @'Brig $ + SearchRequest ((fromName . userDisplayName) user) - searchResult <- - runFedClient @"search-users" fedBrigClient (Domain "example.com") $ - SearchRequest ((fromName . userDisplayName) user) liftIO $ do - let contacts = contactQualifiedId <$> searchResult + let contacts = contactQualifiedId <$> S.contacts searchResponse assertEqual "should return the user id" [quid] contacts -testFulltextSearchMultipleUsers :: Brig -> FedClient 'Brig -> Http () -testFulltextSearchMultipleUsers brig fedBrigClient = do +testFulltextSearchMultipleUsers :: Opt.Opts -> Brig -> Http () +testFulltextSearchMultipleUsers opts brig = do (handle, user) <- createUserWithHandle brig let quid = userQualifiedId user @@ -134,32 +132,114 @@ testFulltextSearchMultipleUsers brig fedBrigClient = do refreshIndex brig - searchResult <- - runFedClient @"search-users" fedBrigClient (Domain "example.com") $ - SearchRequest (fromHandle handle) + let domain = Domain "example.com" + + searchResponse <- withSettingsOverrides (allowFullSearch domain opts) $ do + runWaiTestFedClient domain $ + createWaiTestFedClient @"search-users" @'Brig $ + SearchRequest (fromHandle handle) + liftIO $ do - let contacts = contactQualifiedId <$> searchResult + let contacts = contactQualifiedId <$> S.contacts searchResponse assertEqual "should find both users" (sort [quid, userQualifiedId identityThief]) (sort contacts) -testSearchNotFound :: FedClient 'Brig -> Http () -testSearchNotFound fedBrigClient = do - searchResult <- - runFedClient @"search-users" fedBrigClient (Domain "example.com") $ - SearchRequest "this-handle-should-not-exist" - liftIO $ assertEqual "should return empty array of users" [] searchResult - -testSearchNotFoundEmpty :: FedClient 'Brig -> Http () -testSearchNotFoundEmpty fedBrigClient = do - searchResult <- - runFedClient @"search-users" fedBrigClient (Domain "example.com") $ - SearchRequest "" - liftIO $ assertEqual "should return empty array of users" [] searchResult - -testGetUserByHandleSuccess :: Brig -> FedClient 'Brig -> Http () -testGetUserByHandleSuccess brig fedBrigClient = do +testSearchNotFound :: Opt.Opts -> Http () +testSearchNotFound opts = do + let domain = Domain "example.com" + + searchResponse <- withSettingsOverrides (allowFullSearch domain opts) $ do + runWaiTestFedClient domain $ + createWaiTestFedClient @"search-users" @'Brig $ + SearchRequest "this-handle-should-not-exist" + + liftIO $ assertEqual "should return empty array of users" [] (S.contacts searchResponse) + +testSearchNotFoundEmpty :: Opt.Opts -> Http () +testSearchNotFoundEmpty opts = do + let domain = Domain "example.com" + + searchResponse <- withSettingsOverrides (allowFullSearch domain opts) $ do + runWaiTestFedClient domain $ + createWaiTestFedClient @"search-users" @'Brig $ + SearchRequest "this-handle-should-not-exist" + + liftIO $ assertEqual "should return empty array of users" [] (S.contacts searchResponse) + +testSearchRestrictions :: Opt.Opts -> Brig -> Http () +testSearchRestrictions opts brig = do + let domainNoSearch = Domain "no-search.example.com" + domainExactHandle = Domain "exact-handle-only.example.com" + domainFullSearch = Domain "full-search.example.com" + domainUnconfigured = Domain "unconfigured.example.com" + (handle, user) <- createUserWithHandle brig let quid = userQualifiedId user - maybeProfile <- runFedClient @"get-user-by-handle" fedBrigClient (Domain "example.com") handle + refreshIndex brig + + let opts' = + opts & Opt.optionSettings . Opt.federationDomainConfigs + ?~ [ Opt.FederationDomainConfig domainNoSearch NoSearch, + Opt.FederationDomainConfig domainExactHandle ExactHandleSearch, + Opt.FederationDomainConfig domainFullSearch FullSearch + ] + + let expectSearch domain squery expectedUsers expectedSearchPolicy = do + searchResponse <- + runWaiTestFedClient domain $ + createWaiTestFedClient @"search-users" @'Brig (SearchRequest squery) + liftIO $ assertEqual "Unexpected search result" expectedUsers (contactQualifiedId <$> S.contacts searchResponse) + liftIO $ assertEqual "Unexpected search result" expectedSearchPolicy (S.searchPolicy searchResponse) + + withSettingsOverrides opts' $ do + expectSearch domainNoSearch (fromHandle handle) [] NoSearch + expectSearch domainExactHandle (fromHandle handle) [quid] ExactHandleSearch + expectSearch domainExactHandle (fromName (userDisplayName user)) [] ExactHandleSearch + expectSearch domainFullSearch (fromHandle handle) [quid] FullSearch + expectSearch domainFullSearch (fromName (userDisplayName user)) [quid] FullSearch + expectSearch domainUnconfigured (fromHandle handle) [] NoSearch + expectSearch domainUnconfigured (fromName (userDisplayName user)) [] NoSearch + +testGetUserByHandleRestrictions :: Opt.Opts -> Brig -> Http () +testGetUserByHandleRestrictions opts brig = do + let domainNoSearch = Domain "no-search.example.com" + domainExactHandle = Domain "exact-handle-only.example.com" + domainFullSearch = Domain "full-search.example.com" + domainUnconfigured = Domain "unconfigured.example.com" + + (handle, user) <- createUserWithHandle brig + let quid = userQualifiedId user + refreshIndex brig + + let opts' = + opts & Opt.optionSettings . Opt.federationDomainConfigs + ?~ [ Opt.FederationDomainConfig domainNoSearch NoSearch, + Opt.FederationDomainConfig domainExactHandle ExactHandleSearch, + Opt.FederationDomainConfig domainFullSearch FullSearch + ] + + let expectSearch domain expectedUser = do + maybeUserProfile <- + runWaiTestFedClient domain $ + createWaiTestFedClient @"get-user-by-handle" @'Brig handle + liftIO $ assertEqual "Unexpected search result" expectedUser (profileQualifiedId <$> maybeUserProfile) + + withSettingsOverrides opts' $ do + expectSearch domainNoSearch Nothing + expectSearch domainExactHandle (Just quid) + expectSearch domainFullSearch (Just quid) + expectSearch domainUnconfigured Nothing + +testGetUserByHandleSuccess :: Opt.Opts -> Brig -> Http () +testGetUserByHandleSuccess opts brig = do + (handle, user) <- createUserWithHandle brig + let quid = userQualifiedId user + let domain = Domain "example.com" + + maybeProfile <- withSettingsOverrides (allowFullSearch domain opts) $ do + runWaiTestFedClient domain $ + createWaiTestFedClient @"get-user-by-handle" @'Brig $ + handle + liftIO $ do case maybeProfile of Nothing -> assertFailure "Expected to find profile, found Nothing" @@ -167,12 +247,16 @@ testGetUserByHandleSuccess brig fedBrigClient = do assertEqual "should return correct user Id" quid (profileQualifiedId profile) assertEqual "should not have email address" Nothing (profileEmail profile) -testGetUserByHandleNotFound :: FedClient 'Brig -> Http () -testGetUserByHandleNotFound fedBrigClient = do +testGetUserByHandleNotFound :: Opt.Opts -> Http () +testGetUserByHandleNotFound opts = do hdl <- randomHandle - maybeProfile <- - runFedClient @"get-user-by-handle" fedBrigClient (Domain "example.com") $ - Handle hdl + let domain = Domain "example.com" + + maybeProfile <- withSettingsOverrides (allowFullSearch domain opts) $ do + runWaiTestFedClient domain $ + createWaiTestFedClient @"get-user-by-handle" @'Brig $ + Handle hdl + liftIO $ assertEqual "should not return any UserProfile" Nothing maybeProfile testGetUsersByIdsSuccess :: Brig -> FedClient 'Brig -> Http () diff --git a/services/brig/test/integration/API/MLS.hs b/services/brig/test/integration/API/MLS.hs new file mode 100644 index 00000000000..b85678be23b --- /dev/null +++ b/services/brig/test/integration/API/MLS.hs @@ -0,0 +1,126 @@ +module API.MLS where + +import Bilge +import Bilge.Assert +import Brig.Options +import Data.ByteString.Conversion +import qualified Data.ByteString.Lazy as LBS +import Data.Domain +import Data.Id +import Data.Qualified +import qualified Data.Set as Set +import qualified Data.Text as T +import Imports +import System.Process +import Test.Tasty +import Test.Tasty.HUnit +import UnliftIO.Temporary +import Util +import Wire.API.MLS.KeyPackage +import Wire.API.User +import Wire.API.User.Client + +tests :: Manager -> Brig -> Opts -> TestTree +tests m b _opts = + testGroup + "MLS" + [ test m "POST /mls/key-packages/self/:client" (testKeyPackageUpload b), + test m "GET /mls/key-packages/self/:client/count" (testKeyPackageZeroCount b), + test m "GET /mls/key-packages/claim/:domain/:user" (testKeyPackageClaim b) + ] + +testKeyPackageUpload :: Brig -> Http () +testKeyPackageUpload brig = do + u <- userQualifiedId <$> randomUser brig + c <- createClient brig u 0 + withSystemTempFile "store.db" $ \store _ -> + uploadKeyPackages brig store u c 5 + + count :: KeyPackageCount <- + responseJsonError + =<< get + ( brig . paths ["mls", "key-packages", "self", toByteString' c, "count"] + . zUser (qUnqualified u) + ) + Http () +testKeyPackageZeroCount brig = do + u <- userQualifiedId <$> randomUser brig + c <- randomClient + count :: KeyPackageCount <- + responseJsonError + =<< get + ( brig . paths ["mls", "key-packages", "self", toByteString' c, "count"] + . zUser (qUnqualified u) + ) + Http () +testKeyPackageClaim brig = do + -- setup a user u with two clients c1 and c2 + u <- userQualifiedId <$> randomUser brig + [c1, c2] <- for [0, 1] $ \i -> do + c <- createClient brig u i + -- upload 5 key packages for each client + withSystemTempFile "store.db" $ \store _ -> + uploadKeyPackages brig store u c 5 + pure c + + -- claim packages for both clients of u + u' <- userQualifiedId <$> randomUser brig + bundle <- + responseJsonError + =<< post + ( brig + . paths ["mls", "key-packages", "claim", toByteString' (qDomain u), toByteString' (qUnqualified u)] + . zUser (qUnqualified u') + ) + (kpbeUser e, kpbeClient e)) (kpbEntries bundle) @?= Set.fromList [(u, c1), (u, c2)] + + -- check that we have one fewer key package now + for_ [c1, c2] $ \c -> do + count :: KeyPackageCount <- + responseJsonError + =<< get + ( brig . paths ["mls", "key-packages", "self", toByteString' c, "count"] + . zUser (qUnqualified u) + ) + Qualified UserId -> Int -> Http ClientId +createClient brig u i = + fmap clientId $ + responseJsonError + =<< addClient + brig + (qUnqualified u) + (defNewClient PermanentClientType [somePrekeys !! i] (someLastPrekeys !! i)) + FilePath -> Qualified UserId -> ClientId -> Int -> Http () +uploadKeyPackages brig store u c n = do + let cmd0 = ["crypto-cli", "--store", store, "--enc-key", "test"] + clientId = + show (qUnqualified u) + <> ":" + <> T.unpack (client c) + <> "@" + <> T.unpack (domainText (qDomain u)) + kps <- + replicateM n . liftIO . fmap (KeyPackageData . LBS.fromStrict) . spawn . shell . unwords $ + cmd0 <> ["key-package", clientId] + let upload = KeyPackageUpload kps + post + ( brig + . paths ["mls", "key-packages", "self", toByteString' c] + . zUser (qUnqualified u) + . json upload + ) + !!! const 201 === statusCode diff --git a/services/brig/test/integration/API/Search.hs b/services/brig/test/integration/API/Search.hs index b38852c422d..5d59f2c14bd 100644 --- a/services/brig/test/integration/API/Search.hs +++ b/services/brig/test/integration/API/Search.hs @@ -65,7 +65,9 @@ import Text.RawString.QQ (r) import qualified URI.ByteString as URI import UnliftIO (Concurrently (..), async, bracket, cancel, runConcurrently) import Util +import Wire.API.Federation.API.Brig (SearchResponse (SearchResponse)) import Wire.API.Team.Feature (TeamFeatureStatusValue (..)) +import Wire.API.User.Search (FederatedUserSearchPolicy (ExactHandleSearch, FullSearch)) tests :: Opt.Opts -> Manager -> Galley -> Brig -> IO TestTree tests opts mgr galley brig = do @@ -457,18 +459,19 @@ testSearchOtherDomain opts brig = do -- We cannot assert on a real federated request here, so we make a request to -- a mocked federator started and stopped during this test otherSearchResult :: [Contact] <- liftIO $ generate arbitrary - let mockResponse = Aeson.encode otherSearchResult - (results, _) <- liftIO . withTempMockFederator opts mockResponse $ do + let mockResponse = Aeson.encode (SearchResponse otherSearchResult ExactHandleSearch) + (searchResult, _) <- liftIO . withTempMockFederator opts mockResponse $ do executeSearchWithDomain brig (userId user) "someSearchText" (Domain "non-existent.example.com") let expectedResult = SearchResult { searchResults = otherSearchResult, searchFound = length otherSearchResult, searchReturned = length otherSearchResult, - searchTook = 0 + searchTook = 0, + searchPolicy = ExactHandleSearch } liftIO $ do - assertEqual "The search request should get its result from federator" expectedResult results + assertEqual "The search request should get its result from federator" expectedResult searchResult -- | Migration sequence: -- 1. A migration is planned, in this time brig writes to two indices diff --git a/services/brig/test/integration/Main.hs b/services/brig/test/integration/Main.hs index 2311032d7dd..275715a012c 100644 --- a/services/brig/test/integration/Main.hs +++ b/services/brig/test/integration/Main.hs @@ -23,6 +23,7 @@ where import qualified API.Calling as Calling import qualified API.Federation import qualified API.Internal +import qualified API.MLS as MLS import qualified API.Metrics as Metrics import qualified API.Provider as Provider import qualified API.Search as Search @@ -139,7 +140,11 @@ runTests iConf brigOpts otherArgs = do 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 + let versionApi = API.Version.tests mg b + + let mlsApi = MLS.tests mg b brigOpts + withArgs otherArgs . defaultMain $ testGroup "Brig API Integration" @@ -160,7 +165,8 @@ runTests iConf brigOpts otherArgs = do browseTeam, federationEndpoints, internalApi, - versionApi + versionApi, + mlsApi ] <> [federationEnd2End | includeFederationTests] where diff --git a/services/brig/test/integration/Util.hs b/services/brig/test/integration/Util.hs index 3d67663cb98..c453caed3c8 100644 --- a/services/brig/test/integration/Util.hs +++ b/services/brig/test/integration/Util.hs @@ -17,7 +17,7 @@ -- for SES notifications {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NumericUnderscores #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-orphans -Wno-deprecations #-} -- This file is part of the Wire Server implementation. -- @@ -54,6 +54,7 @@ import Brig.Types.Intra import Brig.Types.User import Brig.Types.User.Auth import qualified Brig.ZAuth as ZAuth +import Control.Exception (throw) import Control.Lens ((^.), (^?), (^?!)) import Control.Monad.Catch (MonadCatch, MonadMask) import qualified Control.Monad.Catch as Catch @@ -65,6 +66,7 @@ import Data.Aeson hiding (json) import Data.Aeson.Lens (key, _Integral, _JSON, _String) import qualified Data.Aeson.Types as Aeson import qualified Data.ByteString as BS +import Data.ByteString.Builder (toLazyByteString) import Data.ByteString.Char8 (pack) import qualified Data.ByteString.Char8 as C8 import Data.ByteString.Conversion @@ -77,10 +79,13 @@ import Data.Misc (PlainTextPassword (..)) import Data.Proxy import Data.Qualified import Data.Range +import qualified Data.Sequence as Seq +import Data.String.Conversions (cs) 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.Text.Encoding as T import qualified Data.UUID as UUID import qualified Data.UUID.V4 as UUID import qualified Federator.MockServer as Mock @@ -91,17 +96,25 @@ 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.HTTP.Media.RenderHeader (renderHeader) +import Network.HTTP.Types (Method, http11, renderQuery) +import qualified Network.HTTP.Types as HTTP 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 OpenSSL.BN (randIntegerZeroToNMinusOne) +import Servant.Client (ClientError (FailureResponse)) import qualified Servant.Client as Servant +import Servant.Client.Core (RunClient (throwClientError)) import qualified Servant.Client.Core as Servant +import qualified Servant.Client.Core.Request as ServantRequest +import System.Exit +import System.Process import System.Random (randomIO, randomRIO) import qualified System.Timeout as System +import Test.QuickCheck (arbitrary, generate) import Test.Tasty (TestName, TestTree) import Test.Tasty.Cannon import qualified Test.Tasty.Cannon as WS @@ -229,6 +242,9 @@ localAndRemoteUserWithConvId brig shouldBeLocal = do fakeRemoteUser :: (HasCallStack, MonadIO m) => m (Qualified UserId) fakeRemoteUser = Qualified <$> randomId <*> pure (Domain "far-away.example.com") +randomClient :: MonadIO m => m ClientId +randomClient = liftIO $ generate arbitrary + randomUser :: (MonadCatch m, MonadIO m, MonadHttp m, HasCallStack) => Brig -> @@ -924,13 +940,13 @@ randomNameWithMaxLen maxLen = liftIO $ do chars <- fill len [] return $ Name (Text.pack chars) where - fill 0 cs = return cs - fill 1 cs = (: cs) <$> randLetter - fill n cs = do + fill 0 chars = return chars + fill 1 chars = (: chars) <$> randLetter + fill n chars = do c <- randChar if isLetter c || isNumber c || isPunctuation c || isSymbol c - then fill (n - 1) (c : cs) - else fill n cs + then fill (n - 1) (c : chars) + else fill n chars randChar = chr <$> randomRIO (0x0000, 0xFFFF) randLetter = do c <- randChar @@ -1118,3 +1134,98 @@ withMockedFederatorAndGalley opts _domain fedResp galleyHandler action = do where combineResults :: ((a, [Mock.FederatedRequest]), [ReceivedRequest]) -> (a, [Mock.FederatedRequest], [ReceivedRequest]) combineResults ((a, mrr), rr) = (a, mrr, rr) + +newtype WaiTestFedClient a = WaiTestFedClient {unWaiTestFedClient :: ReaderT Domain WaiTest.Session a} + deriving (Functor, Applicative, Monad, MonadIO) + +instance Servant.RunClient WaiTestFedClient where + runRequestAcceptStatus expectedStatuses servantRequest = WaiTestFedClient $ do + domain <- ask + let req' = fromServantRequest domain servantRequest + res <- lift $ WaiTest.srequest req' + let servantResponse = toServantResponse res + let status = Servant.responseStatusCode servantResponse + let statusIsSuccess = + case expectedStatuses of + Nothing -> HTTP.statusIsSuccessful status + Just ex -> status `elem` ex + unless statusIsSuccess $ + unWaiTestFedClient $ throwClientError (FailureResponse (bimap (const ()) (\x -> (Servant.BaseUrl Servant.Http "" 80 "", cs (toLazyByteString x))) servantRequest) servantResponse) + pure servantResponse + throwClientError = liftIO . throw + +fromServantRequest :: Domain -> Servant.Request -> WaiTest.SRequest +fromServantRequest domain r = + let pathBS = "/federation" <> Data.String.Conversions.cs (toLazyByteString (Servant.requestPath r)) + bodyBS = case Servant.requestBody r of + Nothing -> "" + Just (bdy, _) -> case bdy of + Servant.RequestBodyLBS lbs -> Data.String.Conversions.cs lbs + Servant.RequestBodyBS bs -> bs + Servant.RequestBodySource _ -> error "fromServantRequest: not implemented for RequestBodySource" + + -- Content-Type and Accept are specified by requestBody and requestAccept + headers = + filter (\(h, _) -> h /= "Accept" && h /= "Content-Type") $ + toList $ Servant.requestHeaders r + acceptHdr + | null hs = Nothing + | otherwise = Just ("Accept", renderHeader hs) + where + hs = toList $ ServantRequest.requestAccept r + contentTypeHdr = case ServantRequest.requestBody r of + Nothing -> Nothing + Just (_', typ) -> Just (HTTP.hContentType, renderHeader typ) + req = + Wai.defaultRequest + { Wai.requestMethod = Servant.requestMethod r, + Wai.rawPathInfo = pathBS, + Wai.rawQueryString = renderQuery True (toList (Servant.requestQueryString r)), + Wai.requestHeaders = + -- Inspired by 'Servant.Client.Internal.HttpClient.defaultMakeClientRequest', + -- the Servant function that maps @Request@ to @Client.Request@. + -- This solution is a bit sophisticated due to two constraints: + -- - Accept header may contain a list of accepted media types. + -- - Accept and Content-Type headers should only appear once in the result. + maybeToList acceptHdr + <> maybeToList contentTypeHdr + <> headers + <> [(originDomainHeaderName, T.encodeUtf8 (domainText domain))], + Wai.isSecure = True, + Wai.pathInfo = filter (not . T.null) (map Data.String.Conversions.cs (C8.split '/' pathBS)), + Wai.queryString = toList (Servant.requestQueryString r) + } + in WaiTest.SRequest req (cs bodyBS) + +toServantResponse :: WaiTest.SResponse -> Servant.Response +toServantResponse res = + Servant.Response + { Servant.responseStatusCode = WaiTest.simpleStatus res, + Servant.responseHeaders = Seq.fromList (WaiTest.simpleHeaders res), + Servant.responseBody = WaiTest.simpleBody res, + Servant.responseHttpVersion = http11 + } + +createWaiTestFedClient :: + forall (name :: Symbol) comp api. + ( HasFedEndpoint comp api name, + Servant.HasClient WaiTestFedClient api + ) => + Servant.Client WaiTestFedClient api +createWaiTestFedClient = + Servant.clientIn (Proxy @api) (Proxy @WaiTestFedClient) + +runWaiTestFedClient :: + Domain -> + WaiTestFedClient a -> + WaiTest.Session a +runWaiTestFedClient domain action = + runReaderT (unWaiTestFedClient action) domain + +spawn :: CreateProcess -> IO ByteString +spawn cp = do + (mout, ex) <- withCreateProcess cp {std_out = CreatePipe} $ \_ mouth _ ph -> + (,) <$> traverse BS.hGetContents mouth <*> waitForProcess ph + case (mout, ex) of + (Just out, ExitSuccess) -> pure out + _ -> assertFailure "Failed spawning process" diff --git a/services/brig/test/unit/Main.hs b/services/brig/test/unit/Main.hs index dfb70f64485..5918fe29631 100644 --- a/services/brig/test/unit/Main.hs +++ b/services/brig/test/unit/Main.hs @@ -23,6 +23,7 @@ where import Imports import qualified Test.Brig.Calling import qualified Test.Brig.Calling.Internal +import qualified Test.Brig.MLS import qualified Test.Brig.Roundtrip import qualified Test.Brig.User.Search.Index.Types import Test.Tasty @@ -35,5 +36,6 @@ main = [ Test.Brig.User.Search.Index.Types.tests, Test.Brig.Calling.tests, Test.Brig.Calling.Internal.tests, - Test.Brig.Roundtrip.tests + Test.Brig.Roundtrip.tests, + Test.Brig.MLS.tests ] diff --git a/services/brig/test/unit/Test/Brig/MLS.hs b/services/brig/test/unit/Test/Brig/MLS.hs new file mode 100644 index 00000000000..f38e8e4852b --- /dev/null +++ b/services/brig/test/unit/Test/Brig/MLS.hs @@ -0,0 +1,150 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Test.Brig.MLS where + +import Brig.API.MLS.KeyPackages.Validation +import Data.Binary +import Data.Binary.Put +import qualified Data.ByteString.Lazy as LBS +import Data.Either +import Data.Time.Clock +import Imports +import Test.Tasty +import Test.Tasty.QuickCheck +import Wire.API.MLS.CipherSuite +import Wire.API.MLS.KeyPackage + +-- | A lifetime with a length of at least 1 day. +newtype ValidLifetime = ValidLifetime Lifetime + deriving (Show) + +instance Arbitrary ValidLifetime where + arbitrary = + ValidLifetime <$> do + -- all values are 32 bits to avoid overflow + t1 <- promote <$> arbitrary + dt <- promote <$> arbitrary + pure $ Lifetime (Timestamp t1) (Timestamp (t1 + dt + 86400)) + where + promote :: Word32 -> Word64 + promote = fromIntegral + +midpoint :: Lifetime -> NominalDiffTime +midpoint lt = + secondsToNominalDiffTime + ( fromInteger + ( div + ( fromIntegral (timestampSeconds (ltNotBefore lt)) + + fromIntegral (timestampSeconds (ltNotBefore lt)) + ) + 2 + ) + ) + +newtype ValidExtensions = ValidExtensions [Extension] + +instance Show ValidExtensions where + show (ValidExtensions exts) = "ValidExtensions (length " <> show (length exts) <> ")" + +-- | Generate a list of extensions containing all the required ones. +instance Arbitrary ValidExtensions where + arbitrary = do + exts0 <- listOf (arbitrary `suchThat` ((/= 0) . extType)) + LifetimeAndExtension ext1 _ <- arbitrary + exts2 <- listOf (arbitrary `suchThat` ((/= 0) . extType)) + CapabilitiesAndExtension ext3 _ <- arbitrary + exts4 <- listOf (arbitrary `suchThat` ((/= 0) . extType)) + pure . ValidExtensions $ exts0 <> [ext1] <> exts2 <> [ext3] <> exts4 + +newtype InvalidExtensions = InvalidExtensions [Extension] + +-- | Generate a list of extensions which does not contain one of the required extensions. +instance Show InvalidExtensions where + show (InvalidExtensions exts) = "InvalidExtensions (length " <> show (length exts) <> ")" + +instance Arbitrary InvalidExtensions where + arbitrary = do + req <- fromIntegral . fromEnum <$> elements [LifetimeExtensionTag, CapabilitiesExtensionTag] + InvalidExtensions <$> listOf (arbitrary `suchThat` ((/= req) . extType)) + +data LifetimeAndExtension = LifetimeAndExtension Extension Lifetime + deriving (Show) + +instance Arbitrary LifetimeAndExtension where + arbitrary = do + lt <- arbitrary + let ext = Extension (fromIntegral (fromEnum LifetimeExtensionTag)) . LBS.toStrict . runPut $ do + put (timestampSeconds (ltNotBefore lt)) + put (timestampSeconds (ltNotAfter lt)) + pure $ LifetimeAndExtension ext lt + +data CapabilitiesAndExtension = CapabilitiesAndExtension Extension Capabilities + deriving (Show) + +instance Arbitrary CapabilitiesAndExtension where + arbitrary = do + caps <- arbitrary + let ext = Extension (fromIntegral (fromEnum CapabilitiesExtensionTag)) . LBS.toStrict . runPut $ do + putWord8 (fromIntegral (length (capVersions caps))) + traverse_ (putWord8 . pvNumber) (capVersions caps) + + putWord8 (fromIntegral (length (capCiphersuites caps) * 2)) + traverse_ (put . cipherSuiteNumber) (capCiphersuites caps) + + putWord8 (fromIntegral (length (capExtensions caps) * 2)) + traverse_ put (capExtensions caps) + + putWord8 (fromIntegral (length (capProposals caps) * 2)) + traverse_ put (capProposals caps) + pure $ CapabilitiesAndExtension ext caps + +tests :: TestTree +tests = + testGroup + "MLS" + [ testGroup + "Lifetime" + [ testProperty "not_before in the future" $ \lt -> + isLeft $ + validateLifetime' + (secondsToNominalDiffTime (fromIntegral (timestampSeconds (ltNotBefore lt) - 86400))) + Nothing + lt, + testProperty "not_after in the past" $ \lt -> + isLeft $ + validateLifetime' + (secondsToNominalDiffTime (fromIntegral (timestampSeconds (ltNotAfter lt) + 86400))) + Nothing + lt, + testProperty "valid" $ \(ValidLifetime lt) -> + isRight $ validateLifetime' (midpoint lt) Nothing lt, + testProperty "expiration too far" $ \(ValidLifetime lt) -> + isLeft $ validateLifetime' (midpoint lt) (Just 10) lt + ], + testGroup + "Extensions" + [ testProperty "required extensions are found" $ \(ValidExtensions exts) -> + isRight (findExtensions exts), + testProperty "missing required extensions" $ \(InvalidExtensions exts) -> + isLeft (findExtensions exts), + testProperty "lifetime extension" $ \(LifetimeAndExtension ext lt) -> + decodeExtension ext == Just (SomeExtension SLifetimeExtensionTag lt), + testProperty "capabilities extension" $ \(CapabilitiesAndExtension ext caps) -> + decodeExtension ext == Just (SomeExtension SCapabilitiesExtensionTag caps) + ] + ] diff --git a/services/cannon/cannon.cabal b/services/cannon/cannon.cabal index afe223905a5..6b13332c7b9 100644 --- a/services/cannon/cannon.cabal +++ b/services/cannon/cannon.cabal @@ -78,7 +78,7 @@ library 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 + aeson >=2.0.1.0 , api-field-json-th >=0.1.0.2 , async >=2.0 , base >=4.6 && <5 diff --git a/services/cannon/package.yaml b/services/cannon/package.yaml index 274eca7524b..734d95d95d2 100644 --- a/services/cannon/package.yaml +++ b/services/cannon/package.yaml @@ -16,7 +16,7 @@ library: source-dirs: src dependencies: - base >=4.6 && <5 - - aeson >=0.11 + - aeson >=2.0.1.0 - api-field-json-th >=0.1.0.2 - async >=2.0 - bilge >=0.12 diff --git a/services/cannon/src/Cannon/App.hs b/services/cannon/src/Cannon/App.hs index a49e3681911..f4e08807ca9 100644 --- a/services/cannon/src/Cannon/App.hs +++ b/services/cannon/src/Cannon/App.hs @@ -26,7 +26,7 @@ import Cannon.WS import Control.Concurrent.Async import Control.Concurrent.Timeout import Control.Monad.Catch -import Data.Aeson hiding (Error, (.=)) +import Data.Aeson hiding (Error, Key, (.=)) import Data.ByteString.Conversion import Data.ByteString.Lazy (toStrict) import Data.Id (ClientId) diff --git a/services/cannon/src/Cannon/WS.hs b/services/cannon/src/Cannon/WS.hs index cbcaaf0f72d..caf339eed33 100644 --- a/services/cannon/src/Cannon/WS.hs +++ b/services/cannon/src/Cannon/WS.hs @@ -54,7 +54,7 @@ import Conduit import Control.Concurrent.Timeout import Control.Monad.Catch import Control.Retry -import Data.Aeson hiding (Error) +import Data.Aeson hiding (Error, Key) import Data.ByteString.Char8 (pack) import Data.ByteString.Conversion import qualified Data.ByteString.Lazy as L diff --git a/services/cargohold/cargohold.cabal b/services/cargohold/cargohold.cabal index 7aad0bc98a8..db96b1dda97 100644 --- a/services/cargohold/cargohold.cabal +++ b/services/cargohold/cargohold.cabal @@ -87,7 +87,7 @@ library build-depends: HsOpenSSL >=0.11 , HsOpenSSL-x509-system >=0.1 - , aeson >=0.11 + , aeson >=2.0.1.0 , amazonka >=1.3.7 , amazonka-core >=1.3.7 , amazonka-s3 >=1.3.7 @@ -185,7 +185,7 @@ executable cargohold 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 - , aeson >=0.11 + , aeson >=2.0.1.0 , base , base64-bytestring >=1.0 , bilge >=0.21 @@ -265,7 +265,7 @@ executable cargohold-integration ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path build-depends: HsOpenSSL >=0.11 - , aeson >=0.11 + , aeson >=2.0.1.0 , base ==4.* , base64-bytestring >=1.0 , bilge >=0.21 diff --git a/services/cargohold/package.yaml b/services/cargohold/package.yaml index 9bc22fa1204..d59cff100a6 100644 --- a/services/cargohold/package.yaml +++ b/services/cargohold/package.yaml @@ -10,7 +10,7 @@ maintainer: Wire Swiss GmbH copyright: (c) 2017 Wire Swiss GmbH license: AGPL-3 dependencies: -- aeson >=0.11 +- aeson >=2.0.1.0 - bilge >=0.21 - bytestring >=0.10 - bytestring-conversion >=0.2 diff --git a/services/cargohold/src/CargoHold/AWS.hs b/services/cargohold/src/CargoHold/AWS.hs index 2051e788ace..bacb72ac898 100644 --- a/services/cargohold/src/CargoHold/AWS.hs +++ b/services/cargohold/src/CargoHold/AWS.hs @@ -22,7 +22,7 @@ module CargoHold.AWS ( -- * Monad Env, mkEnv, - useDownloadEndpoint, + amazonkaEnvWithDownloadEndpoint, Amazon, amazonkaEnv, execute, @@ -39,19 +39,17 @@ module CargoHold.AWS ) where +import Amazonka (AWSRequest, AWSResponse) +import qualified Amazonka as AWS +import qualified Amazonka.S3 as S3 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.Retry import Data.ByteString.Builder (toLazyByteString) import Imports -import Network.AWS (AWSRequest, Rs) -import qualified Network.AWS as AWS -import qualified Network.AWS.Env as AWS -import qualified Network.AWS.S3 as S3 import Network.HTTP.Client (HttpException (..), HttpExceptionContent (..), Manager) import qualified System.Logger as Logger import System.Logger.Class (Logger, MonadLogger (log), (~~)) @@ -72,9 +70,9 @@ data Env = Env makeLenses ''Env -- | Override the endpoint in the '_amazonkaEnv' with '_amazonkaDownloadEndpoint'. -useDownloadEndpoint :: Env -> Env -useDownloadEndpoint e = - e & amazonkaEnv %~ AWS.override (setAWSEndpoint (e ^. amazonkaDownloadEndpoint)) +amazonkaEnvWithDownloadEndpoint :: Env -> AWS.Env +amazonkaEnvWithDownloadEndpoint e = + AWS.override (setAWSEndpoint (e ^. amazonkaDownloadEndpoint)) (e ^. amazonkaEnv) setAWSEndpoint :: AWSEndpoint -> AWS.Service -> AWS.Service setAWSEndpoint e = AWS.setEndpoint (_awsSecure e) (_awsHost e) (_awsPort e) @@ -98,9 +96,6 @@ newtype Amazon a = Amazon instance MonadLogger Amazon where log l m = view logger >>= \g -> Logger.log g l m -instance AWS.MonadAWS Amazon where - liftAWS a = view amazonkaEnv >>= flip AWS.runAWS a - mkEnv :: Logger -> -- | S3 endpoint @@ -114,16 +109,21 @@ mkEnv :: IO Env mkEnv lgr s3End s3Download bucket cfOpts mgr = do let g = Logger.clone (Just "aws.cargohold") lgr - e <- mkAwsEnv g (setAWSEndpoint s3End S3.s3) + e <- mkAwsEnv g (setAWSEndpoint s3End S3.defaultService) cf <- mkCfEnv cfOpts return (Env g bucket e s3Download cf) where mkCfEnv (Just o) = Just <$> initCloudFront (o ^. cfPrivateKey) (o ^. cfKeyPairId) 300 (o ^. cfDomain) mkCfEnv Nothing = return Nothing - mkAwsEnv g s3 = - AWS.newEnvWith AWS.Discover Nothing mgr - <&> set AWS.envLogger (awsLogger g) - <&> AWS.configure s3 + mkAwsEnv g s3 = do + baseEnv <- + AWS.newEnv AWS.discover + <&> AWS.configure s3 + pure $ + baseEnv + { AWS.envLogger = awsLogger g, + AWS.envManager = mgr + } awsLogger g l = Logger.log g (mapLevel l) . Log.msg . toLazyByteString mapLevel AWS.Info = Logger.Info -- Debug output from amazonka can be very useful for tracing requests @@ -154,11 +154,11 @@ instance Exception Error -------------------------------------------------------------------------------- -- Utilities -sendCatch :: (MonadCatch m, AWS.MonadAWS m, AWSRequest r) => r -> m (Either AWS.Error (Rs r)) -sendCatch = AWST.trying AWS._Error . AWS.send +sendCatch :: (MonadCatch m, AWSRequest r, MonadResource m) => AWS.Env -> r -> m (Either AWS.Error (AWSResponse r)) +sendCatch env = AWS.trying AWS._Error . AWS.send env -send :: AWSRequest r => r -> Amazon (Rs r) -send r = throwA =<< sendCatch r +send :: AWSRequest r => AWS.Env -> r -> Amazon (AWSResponse r) +send env r = throwA =<< sendCatch env r throwA :: Either AWS.Error a -> Amazon a throwA = either (throwM . GeneralError) return @@ -167,10 +167,10 @@ exec :: (AWSRequest r, Show r, MonadLogger m, MonadIO m, MonadThrow m) => Env -> (Text -> r) -> - m (Rs r) + m (AWSResponse r) exec env request = do let req = request (_s3Bucket env) - resp <- execute env (sendCatch req) + resp <- execute env (sendCatch (env ^. amazonkaEnv) req) case resp of Left err -> do Logger.info (view logger env) $ @@ -186,10 +186,10 @@ execStream :: (AWSRequest r, Show r) => Env -> (Text -> r) -> - ResourceT IO (Rs r) + ResourceT IO (AWSResponse r) execStream env request = do let req = request (_s3Bucket env) - resp <- AWS.runAWS (view amazonkaEnv env) (sendCatch req) + resp <- sendCatch (env ^. amazonkaEnv) req case resp of Left err -> do Logger.info (view logger env) $ @@ -205,10 +205,10 @@ execCatch :: (AWSRequest r, Show r, MonadLogger m, MonadIO m) => Env -> (Text -> r) -> - m (Maybe (Rs r)) + m (Maybe (AWSResponse r)) execCatch env request = do let req = request (_s3Bucket env) - resp <- execute env (retrying retry5x (const canRetry) (const (sendCatch req))) + resp <- execute env (retrying retry5x (const canRetry) (const (sendCatch (env ^. amazonkaEnv) req))) case resp of Left err -> do Log.info $ diff --git a/services/cargohold/src/CargoHold/Options.hs b/services/cargohold/src/CargoHold/Options.hs index 450d994a78f..9e04cd510b9 100644 --- a/services/cargohold/src/CargoHold/Options.hs +++ b/services/cargohold/src/CargoHold/Options.hs @@ -81,7 +81,7 @@ data Settings = Settings -- | TTL for download links, in seconds _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) + -- (in that case the 'allowedDomains' 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: diff --git a/services/cargohold/src/CargoHold/S3.hs b/services/cargohold/src/CargoHold/S3.hs index 10e4f006bb0..f0a34a241f7 100644 --- a/services/cargohold/src/CargoHold/S3.hs +++ b/services/cargohold/src/CargoHold/S3.hs @@ -37,7 +37,11 @@ module CargoHold.S3 ) where +import Amazonka hiding (Error, ToByteString, (.=)) +import Amazonka.S3 +import Amazonka.S3.Lens import CargoHold.API.Error +import CargoHold.AWS (amazonkaEnvWithDownloadEndpoint) import qualified CargoHold.AWS as AWS import CargoHold.App hiding (Env, Handler) import CargoHold.Options @@ -61,9 +65,6 @@ import qualified Data.Text.Encoding as Text import Data.Time.Clock import qualified Data.UUID as UUID import Imports -import Network.AWS hiding (Error) -import Network.AWS.Data.Body -import Network.AWS.S3 import Network.Wai.Utilities.Error (Error (..)) import qualified System.Logger.Class as Log import System.Logger.Message (msg, val, (.=), (~~)) @@ -125,9 +126,9 @@ uploadV3 prc (s3Key . mkKey -> key) originalHeaders@(V3.AssetHeaders _ cl) tok s req :: Text -> PutObject req b = - putObject (BucketName b) (ObjectKey key) (toBody reqBdy) - & poContentType ?~ MIME.showType ct - & poMetadata .~ metaHeaders tok prc + newPutObject (BucketName b) (ObjectKey key) (toBody reqBdy) + & putObject_contentType ?~ MIME.showType ct + & putObject_metadata .~ metaHeaders tok prc -- | Turn a 'ResourceT IO' action into a pure @Conduit@. -- @@ -144,12 +145,12 @@ downloadV3 :: ExceptT Error App (ConduitM () ByteString (ResourceT IO) ()) downloadV3 (s3Key . mkKey -> key) = do env <- view aws - pure . flattenResourceT $ _streamBody . view gorsBody <$> AWS.execStream env req + pure . flattenResourceT $ _streamBody . view getObjectResponse_body <$> AWS.execStream env req where req :: Text -> GetObject req b = - getObject (BucketName b) (ObjectKey key) - & goResponseContentType ?~ MIME.showType octets + newGetObject (BucketName b) (ObjectKey key) + & getObject_responseContentType ?~ MIME.showType octets getMetadataV3 :: V3.AssetKey -> ExceptT Error App (Maybe S3AssetMeta) getMetadataV3 (s3Key . mkKey -> key) = do @@ -160,10 +161,10 @@ getMetadataV3 (s3Key . mkKey -> key) = do (val "Getting asset metadata") maybe (return Nothing) handle =<< execCatch req where - req b = headObject (BucketName b) (ObjectKey key) + req b = newHeadObject (BucketName b) (ObjectKey key) handle r = do - let ct = fromMaybe octets (MIME.parseMIMEType =<< r ^. horsContentType) - let meta = HML.toList $ r ^. horsMetadata + let ct = fromMaybe octets (MIME.parseMIMEType =<< r ^. headObjectResponse_contentType) + let meta = HML.toList $ r ^. headObjectResponse_metadata return $ parse ct meta parse ct h = S3AssetMeta @@ -183,7 +184,7 @@ deleteV3 (s3Key . mkKey -> key) = do ~~ msg (val "Deleting asset") void $ exec req where - req b = deleteObject (BucketName b) (ObjectKey key) + req b = newDeleteObject (BucketName b) (ObjectKey key) updateMetadataV3 :: V3.AssetKey -> S3AssetMeta -> ExceptT Error App () updateMetadataV3 (s3Key . mkKey -> key) (S3AssetMeta prc tok _) = do @@ -201,10 +202,10 @@ updateMetadataV3 (s3Key . mkKey -> key) (S3AssetMeta prc tok _) = do urlEncode [] $ Text.encodeUtf8 (b <> "/" <> key) req b = - copyObject (BucketName b) (copySrc b) (ObjectKey key) - & coContentType ?~ MIME.showType ct - & coMetadataDirective ?~ MDReplace - & coMetadata .~ metaHeaders tok prc + newCopyObject (BucketName b) (copySrc b) (ObjectKey key) + & copyObject_contentType ?~ MIME.showType ct + & copyObject_metadataDirective ?~ MetadataDirective_REPLACE + & copyObject_metadata .~ metaHeaders tok prc signedURL :: (ToByteString p) => p -> ExceptT Error App URI signedURL path = do @@ -212,10 +213,9 @@ signedURL path = do let b = view AWS.s3Bucket e now <- liftIO getCurrentTime ttl <- view (settings . setDownloadLinkTTL) - let req = getObject (BucketName b) (ObjectKey . Text.decodeLatin1 $ toByteString' path) + let req = newGetObject (BucketName b) (ObjectKey . Text.decodeLatin1 $ toByteString' path) signed <- - AWS.execute (AWS.useDownloadEndpoint e) $ - presignURL now (Seconds (fromIntegral ttl)) req + presignURL (amazonkaEnvWithDownloadEndpoint e) now (Seconds (fromIntegral ttl)) req toUri signed where toUri x = case parseURI strictURIParserOptions x of @@ -311,7 +311,7 @@ parseAmzMeta k h = lookupCI k h >>= fromByteString . encodeUtf8 octets :: MIME.Type octets = MIME.Type (MIME.Application "octet-stream") [] -exec :: (AWSRequest r, Show r) => (Text -> r) -> ExceptT Error App (Rs r) +exec :: (AWSRequest r, Show r) => (Text -> r) -> ExceptT Error App (AWSResponse r) exec req = do env <- view aws AWS.exec env req @@ -319,7 +319,7 @@ exec req = do execCatch :: (AWSRequest r, Show r) => (Text -> r) -> - ExceptT Error App (Maybe (Rs r)) + ExceptT Error App (Maybe (AWSResponse r)) execCatch req = do env <- view aws AWS.execCatch env req @@ -336,9 +336,9 @@ otrKey c a = S3AssetKey $ "otr/" <> Text.pack (show c) <> "/" <> Text.pack (show getMetadata :: AssetId -> ExceptT Error App (Maybe Bool) getMetadata ast = do r <- execCatch req - return $ parse <$> HML.toList <$> view horsMetadata <$> r + return $ parse <$> HML.toList <$> view headObjectResponse_metadata <$> r where - req b = headObject (BucketName b) (ObjectKey . Text.pack $ show ast) + req b = newHeadObject (BucketName b) (ObjectKey . Text.pack $ show ast) parse = maybe False (Text.isInfixOf "public=true" . Text.toLower) . lookupCI "zasset" @@ -347,6 +347,6 @@ getOtrMetadata :: ConvId -> AssetId -> ExceptT Error App (Maybe UserId) getOtrMetadata cnv ast = do let S3AssetKey key = otrKey cnv ast r <- execCatch (req key) - return $ getAmzMetaUser =<< HML.toList <$> view horsMetadata <$> r + return $ getAmzMetaUser =<< HML.toList <$> view headObjectResponse_metadata <$> r where - req k b = headObject (BucketName b) (ObjectKey k) + req k b = newHeadObject (BucketName b) (ObjectKey k) diff --git a/services/cargohold/test/integration/API.hs b/services/cargohold/test/integration/API.hs index f5f840ddb13..c1c81a0143e 100644 --- a/services/cargohold/test/integration/API.hs +++ b/services/cargohold/test/integration/API.hs @@ -23,6 +23,7 @@ import API.Util import Bilge hiding (body) import Bilge.Assert import CargoHold.API.Error +import CargoHold.Options (awsS3DownloadEndpoint, optAws) import CargoHold.Types import qualified CargoHold.Types.V3 as V3 import qualified Codec.MIME.Type as MIME @@ -43,6 +44,7 @@ import Data.UUID.V4 import Federator.MockServer import Imports hiding (head) import Network.HTTP.Client (parseUrlThrow) +import qualified Network.HTTP.Client as HTTP import Network.HTTP.Media ((//)) import qualified Network.HTTP.Types as HTTP import Network.Wai.Utilities (Error (label)) @@ -50,6 +52,7 @@ import qualified Network.Wai.Utilities.Error as Wai import Test.Tasty import Test.Tasty.HUnit import TestSetup +import Util.Options import Wire.API.Federation.API.Cargohold import Wire.API.Federation.Component @@ -63,7 +66,8 @@ tests s = test s "download with accept header" testDownloadWithAcceptHeader, test s "tokens" testSimpleTokens, test s "s3-upstream-closed" testSimpleS3ClosedConnectionReuse, - test s "client-compatibility" testUploadCompatibility + test s "client-compatibility" testUploadCompatibility, + test s "download url override" testDownloadURLOverride ], testGroup "remote" @@ -219,6 +223,35 @@ testSimpleS3ClosedConnectionReuse = go >> wait >> go uploadSimple (path "/assets/v3") uid sets part2 !!! const 201 === statusCode +testDownloadURLOverride :: TestM () +testDownloadURLOverride = do + -- This is a .example domain, it shouldn't resolve. But it is also not + -- supposed to be used by cargohold to make connections. + let downloadEndpoint = "external-s3-url.example" + withSettingsOverrides (optAws . awsS3DownloadEndpoint ?~ AWSEndpoint downloadEndpoint True 443) $ do + uid <- liftIO $ Id <$> nextRandom + + -- Upload, should work, shouldn't try to use the S3DownloadEndpoint + let bdy = (applicationText, "Hello World") + uploadRes <- + uploadSimple (path "/assets/v3") uid V3.defAssetSettings bdy + =0.11 , HsOpenSSL-x509-system >=0.1 , QuickCheck >=2.14 - , aeson >=0.11 + , aeson >=2.0.1.0 , amazonka >=1.4.5 , amazonka-sqs >=1.4.5 , async >=2.0 diff --git a/services/galley/package.yaml b/services/galley/package.yaml index 0b490e184b2..8b17a10f8cd 100644 --- a/services/galley/package.yaml +++ b/services/galley/package.yaml @@ -27,7 +27,7 @@ dependencies: library: source-dirs: src dependencies: - - aeson >=0.11 + - aeson >=2.0.1.0 - amazonka >=1.4.5 - amazonka-sqs >=1.4.5 - async >=2.0 diff --git a/services/galley/src/Galley/API/Teams/Features.hs b/services/galley/src/Galley/API/Teams/Features.hs index 6d10186d14e..2d5a1228adb 100644 --- a/services/galley/src/Galley/API/Teams/Features.hs +++ b/services/galley/src/Galley/API/Teams/Features.hs @@ -53,9 +53,10 @@ where import Control.Lens import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Key as AesonKey +import qualified Data.Aeson.KeyMap as KeyMap import Data.ByteString.Conversion hiding (fromList) import Data.Either.Extra (eitherToMaybe) -import qualified Data.HashMap.Strict as HashMap import Data.Id import Data.Qualified import Data.String.Conversions (cs) @@ -218,15 +219,15 @@ getAllFeatureConfigs zusr = do Members '[Error ActionError, Error TeamError, Error NotATeamMember, TeamStore] r ) => (GetFeatureInternalParam -> Sem r (Public.TeamFeatureStatus ps a)) -> - Sem r (Text, Aeson.Value) + Sem r (Aeson.Key, Aeson.Value) getStatus getter = do when (isJust mbTeam) $ do void $ permissionCheck (ViewTeamFeature (Public.knownTeamFeatureName @a)) zusrMembership status <- getter (maybe (Left (Just zusr)) Right mbTeam) let feature = Public.knownTeamFeatureName @a - pure $ cs (toByteString' feature) Aeson..= status + pure $ AesonKey.fromText (cs (toByteString' feature)) Aeson..= status - AllFeatureConfigs . HashMap.fromList + AllFeatureConfigs . KeyMap.fromList <$> sequence [ getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureLegalHold getLegalholdStatusInternal, getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureSSO getSSOStatusInternal, @@ -298,11 +299,11 @@ getAllFeatures uid tid = do Aeson.ToJSON (Public.TeamFeatureStatus ps a) ) => (GetFeatureInternalParam -> Sem r (Public.TeamFeatureStatus ps a)) -> - Sem r (Text, Aeson.Value) + Sem r (Aeson.Key, Aeson.Value) getStatus getter = do status <- getFeatureStatus @ps @a getter (DoAuth uid) tid let feature = Public.knownTeamFeatureName @a - pure $ cs (toByteString' feature) Aeson..= status + pure $ AesonKey.fromText (cs (toByteString' feature)) Aeson..= status getFeatureStatusNoConfig :: forall (a :: Public.TeamFeatureName) r. diff --git a/services/galley/src/Galley/Aws.hs b/services/galley/src/Galley/Aws.hs index aa7447f1061..41afefb6d51 100644 --- a/services/galley/src/Galley/Aws.hs +++ b/services/galley/src/Galley/Aws.hs @@ -32,9 +32,11 @@ module Galley.Aws ) where +import qualified Amazonka as AWS +import qualified Amazonka.SQS as SQS +import qualified Amazonka.SQS.Lens as SQS import Control.Lens hiding ((.=)) import Control.Monad.Catch -import qualified Control.Monad.Trans.AWS as AWST import Control.Monad.Trans.Resource import Control.Retry (exponentialBackoff, limitRetries, retrying) import qualified Data.ByteString.Base64 as B64 @@ -45,9 +47,6 @@ import Data.UUID (toText) import Data.UUID.V4 import Galley.Options import Imports -import qualified Network.AWS as AWS -import qualified Network.AWS.Env as AWS -import qualified Network.AWS.SQS as SQS import Network.HTTP.Client ( HttpException (..), HttpExceptionContent (..), @@ -98,9 +97,6 @@ newtype Amazon a = Amazon instance MonadLogger Amazon where log l m = view logger >>= \g -> Logger.log g l m -instance AWS.MonadAWS Amazon where - liftAWS aws = view awsEnv >>= \e -> AWS.runAWS e aws - mkEnv :: Logger -> Manager -> JournalOpts -> IO Env mkEnv lgr mgr opts = do let g = Logger.clone (Just "aws.galley") lgr @@ -108,12 +104,17 @@ mkEnv lgr mgr opts = do q <- getQueueUrl e (opts ^. awsQueueName) return (Env e g q) where - sqs e = AWS.setEndpoint (e ^. awsSecure) (e ^. awsHost) (e ^. awsPort) SQS.sqs - mkAwsEnv g = - set AWS.envLogger (awsLogger g) - . set AWS.envRetryCheck retryCheck - <$> AWS.newEnvWith AWS.Discover Nothing mgr - <&> AWS.configure (sqs (opts ^. awsEndpoint)) + sqs e = AWS.setEndpoint (e ^. awsSecure) (e ^. awsHost) (e ^. awsPort) SQS.defaultService + mkAwsEnv g = do + baseEnv <- + AWS.newEnv AWS.discover + <&> AWS.configure (sqs (opts ^. awsEndpoint)) + pure $ + baseEnv + { AWS.envLogger = awsLogger g, + AWS.envRetryCheck = retryCheck, + AWS.envManager = mgr + } awsLogger g l = Logger.log g (mapLevel l) . Logger.msg . toLazyByteString mapLevel AWS.Info = Logger.Info -- Debug output from amazonka can be very useful for tracing requests @@ -146,12 +147,12 @@ mkEnv lgr mgr opts = do getQueueUrl :: AWS.Env -> Text -> IO QueueUrl getQueueUrl e q = do x <- - runResourceT . AWST.runAWST e $ - AWST.trying AWS._Error $ - AWST.send (SQS.getQueueURL q) + runResourceT $ + AWS.trying AWS._Error $ + AWS.send e (SQS.newGetQueueUrl q) either (throwM . GeneralError) - (return . QueueUrl . view SQS.gqursQueueURL) + (return . QueueUrl . view SQS.getQueueUrlResponse_queueUrl) x execute :: MonadIO m => Env -> Amazon a -> m a @@ -161,19 +162,20 @@ enqueue :: E.TeamEvent -> Amazon () enqueue e = do QueueUrl url <- view eventQueue rnd <- liftIO nextRandom - res <- retrying (limitRetries 5 <> exponentialBackoff 1000000) (const canRetry) $ const (sendCatch (req url rnd)) + amaznkaEnv <- view awsEnv + res <- retrying (limitRetries 5 <> exponentialBackoff 1000000) (const canRetry) $ const (sendCatch amaznkaEnv (req url rnd)) either (throwM . GeneralError) (const (return ())) res where event = decodeLatin1 $ B64.encode $ encodeMessage e req url dedup = - SQS.sendMessage url event & SQS.smMessageGroupId .~ Just "team.events" - & SQS.smMessageDeduplicationId .~ Just (toText dedup) + SQS.newSendMessage url event & SQS.sendMessage_messageGroupId ?~ "team.events" + & SQS.sendMessage_messageDeduplicationId ?~ toText dedup -------------------------------------------------------------------------------- -- Utilities -sendCatch :: AWS.AWSRequest r => r -> Amazon (Either AWS.Error (AWS.Rs r)) -sendCatch = AWST.trying AWS._Error . AWS.send +sendCatch :: AWS.AWSRequest r => AWS.Env -> r -> Amazon (Either AWS.Error (AWS.AWSResponse r)) +sendCatch e = AWS.trying AWS._Error . AWS.send e canRetry :: MonadIO m => Either AWS.Error a -> m Bool canRetry (Right _) = pure False diff --git a/services/galley/src/Galley/Options.hs b/services/galley/src/Galley/Options.hs index 3c62289fb71..5ea9d2b8604 100644 --- a/services/galley/src/Galley/Options.hs +++ b/services/galley/src/Galley/Options.hs @@ -82,7 +82,7 @@ data Settings = Settings -- | Throttling: delay between sending events upon team deletion _setDeleteConvThrottleMillis :: !(Maybe Int), -- | FederationDomain is required, even when not wanting to federate with other backends - -- (in that case the 'setFederationAllowedDomains' can be set to empty in Federator) + -- (in that case the 'allowedDomains' 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: @@ -90,7 +90,7 @@ data Settings = Settings -- 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. -- Example: - -- setFederationAllowedDomains: + -- allowedDomains: -- - wire.com -- - example.com _setFederationDomain :: !(Domain), diff --git a/services/galley/test/integration/API/SQS.hs b/services/galley/test/integration/API/SQS.hs index d8fbc5f475e..741b75fdf16 100644 --- a/services/galley/test/integration/API/SQS.hs +++ b/services/galley/test/integration/API/SQS.hs @@ -19,6 +19,9 @@ -- instead. module API.SQS where +import qualified Amazonka as AWS +import qualified Amazonka.SQS as SQS +import qualified Amazonka.SQS.Lens as SQS import Control.Exception (asyncExceptionFromException) import Control.Lens hiding ((.=)) import Control.Monad.Catch hiding (bracket) @@ -36,8 +39,6 @@ import Galley.Aws import qualified Galley.Aws as Aws import Galley.Options (JournalOpts) import Imports -import qualified Network.AWS as AWS -import qualified Network.AWS.SQS as SQS import Network.HTTP.Client import Network.HTTP.Client.OpenSSL import OpenSSL.Session as Ssl @@ -122,13 +123,15 @@ tUpdateUncertainCount _ _ l Nothing = assertFailure $ l <> ": Expected 1 TeamUpd ensureNoMessages :: HasCallStack => Amazon () ensureNoMessages = do QueueUrl url <- view eventQueue - msgs <- view SQS.rmrsMessages <$> AWS.send (receive 1 url) + amazonkaEnv <- view awsEnv + msgs <- fromMaybe [] . view SQS.receiveMessageResponse_messages <$> AWS.send amazonkaEnv (receive 1 url) liftIO $ assertEqual "ensureNoMessages: length" 0 (length msgs) fetchMessage :: String -> (String -> Maybe E.TeamEvent -> IO ()) -> Amazon () fetchMessage label callback = do QueueUrl url <- view eventQueue - msgs <- view SQS.rmrsMessages <$> AWS.send (receive 1 url) + amazonkaEnv <- view awsEnv + msgs <- fromMaybe [] . view SQS.receiveMessageResponse_messages <$> AWS.send amazonkaEnv (receive 1 url) events <- mapM (parseDeleteMessage url) msgs liftIO $ callback label (headDef Nothing events) @@ -180,44 +183,48 @@ purgeQueue = void $ readAllUntilEmpty receive :: Int -> Text -> SQS.ReceiveMessage receive n url = - SQS.receiveMessage url - & set SQS.rmWaitTimeSeconds (Just 1) - . set SQS.rmMaxNumberOfMessages (Just n) - . set SQS.rmVisibilityTimeout (Just 1) + SQS.newReceiveMessage url + & set SQS.receiveMessage_waitTimeSeconds (Just 1) + . set SQS.receiveMessage_maxNumberOfMessages (Just n) + . set SQS.receiveMessage_visibilityTimeout (Just 1) queueEvent :: E.TeamEvent -> Amazon () queueEvent e = do QueueUrl url <- view eventQueue rnd <- liftIO nextRandom - void $ AWS.send (req url rnd) + amazonkaEnv <- view awsEnv + void $ AWS.send amazonkaEnv (req url rnd) where event = Text.decodeLatin1 $ B64.encode $ encodeMessage e req url dedup = - SQS.sendMessage url event - & SQS.smMessageGroupId .~ Just "team.events" - & SQS.smMessageDeduplicationId .~ Just (UUID.toText dedup) + SQS.newSendMessage url event + & SQS.sendMessage_messageGroupId ?~ "team.events" + & SQS.sendMessage_messageDeduplicationId ?~ UUID.toText dedup readAllUntilEmpty :: Amazon [SQS.Message] readAllUntilEmpty = do QueueUrl url <- view eventQueue - msgs <- view SQS.rmrsMessages <$> AWS.send (receive 10 url) + amazonkaEnv <- view awsEnv + msgs <- fromMaybe [] . view SQS.receiveMessageResponse_messages <$> AWS.send amazonkaEnv (receive 10 url) readUntilEmpty msgs url msgs where readUntilEmpty acc _ [] = return acc readUntilEmpty acc url msgs = do forM_ msgs $ deleteMessage url - newMsgs <- view SQS.rmrsMessages <$> AWS.send (receive 10 url) + amazonkaEnv <- view awsEnv + newMsgs <- fromMaybe [] . view SQS.receiveMessageResponse_messages <$> AWS.send amazonkaEnv (receive 10 url) readUntilEmpty (acc ++ newMsgs) url newMsgs deleteMessage :: Text -> SQS.Message -> Amazon () deleteMessage url m = do + amazonkaEnv <- view awsEnv for_ - (m ^. SQS.mReceiptHandle) - (void . AWS.send . SQS.deleteMessage url) + (m ^. SQS.message_receiptHandle) + (void . AWS.send amazonkaEnv . SQS.newDeleteMessage url) parseDeleteMessage :: Text -> SQS.Message -> Amazon (Maybe E.TeamEvent) parseDeleteMessage url m = do - evt <- case (>>= decodeMessage) . B64.decode . Text.encodeUtf8 <$> (m ^. SQS.mBody) of + evt <- case (>>= decodeMessage) . B64.decode . Text.encodeUtf8 <$> (m ^. SQS.message_body) of Just (Right e) -> do trace $ msg $ val "SQS event received" return (Just e) diff --git a/services/galley/test/integration/API/Teams/Feature.hs b/services/galley/test/integration/API/Teams/Feature.hs index 700ecd965ed..7d122c4a398 100644 --- a/services/galley/test/integration/API/Teams/Feature.hs +++ b/services/galley/test/integration/API/Teams/Feature.hs @@ -26,10 +26,10 @@ import Control.Lens (over, to, view) import Control.Monad.Catch (MonadCatch) import Data.Aeson (FromJSON, ToJSON, object, (.=)) import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Key as AesonKey +import qualified Data.Aeson.KeyMap as KeyMap import Data.ByteString.Conversion (toByteString') import Data.Domain (Domain (..)) -import qualified Data.HashMap.Strict as HashMap -import qualified Data.HashSet as HashSet import Data.Id import Data.List1 (list1) import qualified Data.List1 as List1 @@ -683,8 +683,8 @@ testAllFeatures = do toS TeamFeatureGuestLinks .= Public.TeamFeatureStatusNoConfigAndLockStatus TeamFeatureEnabled Public.Unlocked, toS TeamFeatureSndFactorPasswordChallenge .= Public.TeamFeatureStatusNoConfigAndLockStatus TeamFeatureDisabled Public.Unlocked ] - toS :: TeamFeatureName -> Text - toS = TE.decodeUtf8 . toByteString' + toS :: TeamFeatureName -> Aeson.Key + toS = AesonKey.fromText . TE.decodeUtf8 . toByteString' testFeatureConfigConsistency :: TestM () testFeatureConfigConsistency = do @@ -708,7 +708,7 @@ testFeatureConfigConsistency = do Left err -> liftIO $ assertFailure ("Did not parse as an object" <> err) Right (val :: Aeson.Value) -> case val of - (Aeson.Object hm) -> pure (Set.fromList . HashSet.toList . HashMap.keysSet $ hm) + (Aeson.Object hm) -> pure (Set.fromList . map AesonKey.toText . KeyMap.keys $ hm) x -> liftIO $ assertFailure ("JSON was not an object, but " <> show x) allFeatures :: Set.Set Text diff --git a/services/galley/test/integration/API/Util.hs b/services/galley/test/integration/API/Util.hs index d18f5d28365..1c644e37cc1 100644 --- a/services/galley/test/integration/API/Util.hs +++ b/services/galley/test/integration/API/Util.hs @@ -1212,7 +1212,7 @@ getTeamQueue zusr msince msize onlyLast = fmap (_2 %~ parseEvt) . mconcat . fmap parseEvts . view queuedNotifications $ qnl parseEvts :: QueuedNotification -> [(NotificationId, Object)] - parseEvts qn = (qn ^. queuedNotificationId,) <$> (toList . toNonEmpty $ qn ^. queuedNotificationPayload) + parseEvts qn = (qn ^. queuedNotificationId,) <$> (toList $ qn ^. queuedNotificationPayload) parseEvt :: Object -> UserId parseEvt o = case fromJSON (Object o) of @@ -1994,7 +1994,7 @@ retryWhileN n f m = -- | Changing this will break tests; all prekeys and client Id must match the same -- fingerprint someClientId :: ClientId -someClientId = ClientId "1dbfbe22c8a35cb2" +someClientId = ClientId "550d8c614fd20299" -- | Changing these will break tests; all prekeys and client Id must match the same -- fingerprint diff --git a/services/gundeck/gundeck.cabal b/services/gundeck/gundeck.cabal index a8643ca98c1..8f8bae8e839 100644 --- a/services/gundeck/gundeck.cabal +++ b/services/gundeck/gundeck.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 4b94342561027580e950514565f60bb0d8d1465d92c773a7c4f588966dab6ffc +-- hash: b5ae0ca8cfcc22e0751375eaf5b925d7557c88056d881b85cf7d82e3a8c322be name: gundeck version: 1.45.0 @@ -101,7 +101,7 @@ library 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 - , aeson >=0.11 + , aeson >=2.0.1.0 , amazonka >=1.3.7 , amazonka-sns >=1.3.7 , amazonka-sqs >=1.3.7 diff --git a/services/gundeck/package.yaml b/services/gundeck/package.yaml index cc2526da238..1c02ff12980 100644 --- a/services/gundeck/package.yaml +++ b/services/gundeck/package.yaml @@ -16,7 +16,7 @@ library: ghc-options: - -fwarn-incomplete-uni-patterns dependencies: - - aeson >=0.11 + - aeson >=2.0.1.0 - amazonka >=1.3.7 - amazonka-sns >=1.3.7 - amazonka-sqs >=1.3.7 diff --git a/services/gundeck/src/Gundeck/Aws.hs b/services/gundeck/src/Gundeck/Aws.hs index bf2967791fe..0c4a4e4c1e4 100644 --- a/services/gundeck/src/Gundeck/Aws.hs +++ b/services/gundeck/src/Gundeck/Aws.hs @@ -50,10 +50,16 @@ module Gundeck.Aws ) where +import Amazonka (AWSRequest, AWSResponse, serviceAbbrev, serviceCode, serviceMessage, serviceStatus) +import qualified Amazonka as AWS +import qualified Amazonka.SNS as SNS +import qualified Amazonka.SNS.Lens as SNS +import qualified Amazonka.SQS as SQS +import qualified Amazonka.SQS.Lens as SQS +import Amazonka.SQS.Types import Control.Error hiding (err, isRight) import Control.Lens hiding ((.=)) import Control.Monad.Catch -import qualified Control.Monad.Trans.AWS as AWST import Control.Monad.Trans.Resource import Control.Retry (limitRetries, retrying) import Data.Aeson (decodeStrict) @@ -72,14 +78,6 @@ import Gundeck.Options import Gundeck.Types.Push (AppName (..), Token, Transport (..)) import qualified Gundeck.Types.Push as Push import Imports -import Network.AWS (AWSRequest, Rs, serviceAbbrev, serviceCode, serviceMessage, serviceStatus) -import qualified Network.AWS as AWS -import qualified Network.AWS.Data as AWS -import qualified Network.AWS.Env as AWS -import qualified Network.AWS.SNS as SNS -import Network.AWS.SQS (rmrsMessages) -import qualified Network.AWS.SQS as SQS -import Network.AWS.SQS.Types hiding (sqs) import Network.HTTP.Client (HttpException (..), HttpExceptionContent (..), Manager) import Network.HTTP.Types import qualified Network.TLS as TLS @@ -143,28 +141,31 @@ newtype Amazon a = Amazon instance MonadLogger Amazon where log l m = view logger >>= \g -> Logger.log g l m -instance AWS.MonadAWS Amazon where - liftAWS a = view awsEnv >>= \e -> AWS.runAWS e a - mkEnv :: Logger -> Opts -> Manager -> IO Env mkEnv lgr opts mgr = do let g = Logger.clone (Just "aws.gundeck") lgr e <- mkAwsEnv g - (mkEndpoint SQS.sqs (opts ^. optAws . awsSqsEndpoint)) - (mkEndpoint SNS.sns (opts ^. optAws . awsSnsEndpoint)) + (mkEndpoint SQS.defaultService (opts ^. optAws . awsSqsEndpoint)) + (mkEndpoint SNS.defaultService (opts ^. optAws . awsSnsEndpoint)) q <- getQueueUrl e (opts ^. optAws . awsQueueName) return (Env e g q (opts ^. optAws . awsRegion) (opts ^. optAws . awsAccount)) where mkEndpoint svc e = AWS.setEndpoint (e ^. awsSecure) (e ^. awsHost) (e ^. awsPort) svc - mkAwsEnv g sqs sns = - set AWS.envLogger (awsLogger g) - . set AWS.envRegion (opts ^. optAws . awsRegion) - . set AWS.envRetryCheck retryCheck - <$> AWS.newEnvWith AWS.Discover Nothing mgr - <&> AWS.configure sqs - <&> AWS.configure (sns & set AWS.serviceTimeout (Just (AWS.Seconds 5))) + mkAwsEnv g sqs sns = do + baseEnv <- + AWS.newEnv AWS.discover + <&> AWS.configure sqs + <&> AWS.configure (sns & set AWS.serviceTimeout (Just (AWS.Seconds 5))) + pure $ + baseEnv + { AWS.envLogger = awsLogger g, + AWS.envRegion = opts ^. optAws . awsRegion, + AWS.envRetryCheck = retryCheck, + AWS.envManager = mgr + } + awsLogger g l = Logger.log g (mapLevel l) . Logger.msg . toLazyByteString mapLevel AWS.Info = Logger.Info -- Debug output from amazonka can be very useful for tracing requests @@ -197,12 +198,12 @@ mkEnv lgr opts mgr = do getQueueUrl :: AWS.Env -> Text -> IO QueueUrl getQueueUrl e q = do x <- - runResourceT . AWST.runAWST e $ - AWST.trying AWS._Error $ - AWST.send (SQS.getQueueURL q) + runResourceT $ + AWS.trying AWS._Error $ + AWS.send e (SQS.newGetQueueUrl q) either (throwM . GeneralError) - (return . QueueUrl . view SQS.gqursQueueURL) + (return . QueueUrl . view SQS.getQueueUrlResponse_queueUrl) x execute :: MonadIO m => Env -> Amazon a -> m a @@ -228,12 +229,13 @@ data CreateEndpointError -- the the list of given 'UserId's and enable the endpoint. updateEndpoint :: Set UserId -> Token -> EndpointArn -> Amazon () updateEndpoint us tk arn = do - let req = over SNS.seaAttributes fun (SNS.setEndpointAttributes (toText arn)) - res <- retrying (limitRetries 1) (const isTimeout) (const (sendCatch req)) + let req = over SNS.setEndpointAttributes_attributes fun (SNS.newSetEndpointAttributes (toText arn)) + env <- ask + res <- retrying (limitRetries 1) (const isTimeout) (const (sendCatch (env ^. awsEnv) req)) case res of Right _ -> return () Left x@(AWS.ServiceError e) - | is "SNS" 400 x && AWS.errorCode "InvalidParameter" == e ^. serviceCode + | is "SNS" 400 x && AWS.newErrorCode "InvalidParameter" == e ^. serviceCode && isMetadataLengthError (e ^. serviceMessage) -> throwM $ InvalidCustomData arn Left x -> @@ -256,20 +258,22 @@ updateEndpoint us tk arn = do deleteEndpoint :: EndpointArn -> Amazon () deleteEndpoint arn = do - res <- retrying (limitRetries 1) (const isTimeout) (const (sendCatch req)) + e <- view awsEnv + res <- retrying (limitRetries 1) (const isTimeout) (const (sendCatch e req)) either (throwM . GeneralError) (const (return ())) res where - req = SNS.deleteEndpoint (toText arn) + req = SNS.newDeleteEndpoint (toText arn) lookupEndpoint :: EndpointArn -> Amazon (Maybe SNSEndpoint) lookupEndpoint arn = do - res <- retrying (limitRetries 1) (const isTimeout) (const (sendCatch req)) - let attrs = view SNS.gearsAttributes <$> res + e <- view awsEnv + res <- retrying (limitRetries 1) (const isTimeout) (const (sendCatch e req)) + let attrs = fromMaybe mempty . view SNS.getEndpointAttributesResponse_attributes <$> res case attrs of Right a -> Just <$> mkEndpoint a Left x -> if is "SNS" 404 x then return Nothing else throwM (GeneralError x) where - req = SNS.getEndpointAttributes (toText arn) + req = SNS.newGetEndpointAttributes (toText arn) mkEndpoint a = do t <- maybe (throwM $ NoToken arn) return (Map.lookup "Token" a) let e = either (const Nothing) Just . fromText =<< Map.lookup "Enabled" a @@ -278,29 +282,29 @@ lookupEndpoint arn = do mkUsers = Set.fromList . mapMaybe (hush . fromText) . Text.split (== ':') createEndpoint :: UserId -> Push.Transport -> ArnEnv -> AppName -> Push.Token -> Amazon (Either CreateEndpointError EndpointArn) -createEndpoint u tr env app token = do - aEnv <- ask - let top = mkAppTopic env tr app - let arn = mkSnsArn (aEnv ^. region) (aEnv ^. account) top +createEndpoint u tr arnEnv app token = do + env <- ask + let top = mkAppTopic arnEnv tr app + let arn = mkSnsArn (env ^. region) (env ^. account) top let tkn = Push.tokenText token let req = - SNS.createPlatformEndpoint (toText arn) tkn - & set SNS.cpeCustomUserData (Just (toText u)) - & set SNS.cpeAttributes (Map.insert "Enabled" "true" Map.empty) - res <- retrying (limitRetries 2) (const isTimeout) (const (sendCatch req)) + SNS.newCreatePlatformEndpoint (toText arn) tkn + & set SNS.createPlatformEndpoint_customUserData (Just (toText u)) + & set SNS.createPlatformEndpoint_attributes (Just $ Map.insert "Enabled" "true" Map.empty) + res <- retrying (limitRetries 2) (const isTimeout) (const (sendCatch (env ^. awsEnv) req)) case res of Right r -> - case view SNS.cpersEndpointARN r of + case view SNS.createPlatformEndpointResponse_endpointArn r of Nothing -> throwM NoEndpointArn Just s -> Right <$> readArn s Left x@(AWS.ServiceError e) - | is "SNS" 400 x && AWS.errorCode "InvalidParameter" == e ^. serviceCode, + | is "SNS" 400 x && AWS.newErrorCode "InvalidParameter" == e ^. serviceCode, Just ep <- parseExistsError (e ^. serviceMessage) -> return (Left (EndpointInUse ep)) - | is "SNS" 400 x && AWS.errorCode "InvalidParameter" == e ^. serviceCode + | is "SNS" 400 x && AWS.newErrorCode "InvalidParameter" == e ^. serviceCode && isLengthError (e ^. serviceMessage) -> return (Left (TokenTooLong $ tokenLength token)) - | is "SNS" 400 x && AWS.errorCode "InvalidParameter" == e ^. serviceCode + | is "SNS" 400 x && AWS.newErrorCode "InvalidParameter" == e ^. serviceCode && isTokenError (e ^. serviceMessage) -> return (Left (InvalidToken token)) | is "SNS" 404 x -> @@ -316,8 +320,9 @@ createEndpoint u tr env app token = do parseExistsError Nothing = Nothing parseExistsError (Just s) = hush . flip parseOnly (toText s) $ do _ <- string "Invalid parameter: Token Reason: Endpoint " - a <- AWS.parser - _ <- string " already exists with the same Token, but different attributes." + let endParser = string " already exists with the same Token, but different attributes." + a <- manyTill anyChar endParser >>= either fail pure . AWS.fromText . Text.pack + _ <- endParser return a isTokenError Nothing = False isTokenError (Just s) = isRight . flip parseOnly (toText s) $ do @@ -368,8 +373,8 @@ timeToLive t s = Attributes (Endo (ttlAttr s)) | n == 0 = setTTL (ttlNow t) | otherwise = setTTL (toText n) setTTL v = - let ty = SNS.messageAttributeValue "String" - in Map.insert (ttlKey t) (ty & SNS.mavStringValue .~ Just v) + let ty = SNS.newMessageAttributeValue "String" + in Map.insert (ttlKey t) (ty & SNS.messageAttributeValue_stringValue ?~ v) ttlNow GCM = "0" ttlNow APNS = "0" ttlNow APNSSandbox = "0" @@ -385,23 +390,24 @@ publish :: EndpointArn -> LT.Text -> Attributes -> Amazon (Either PublishError ( publish arn txt attrs = do -- TODO: Make amazonka accept a lazy text or bytestring. let req = - SNS.publish (LT.toStrict txt) - & SNS.pTargetARN .~ Just (toText arn) - & SNS.pMessageStructure .~ Just "json" - & SNS.pMessageAttributes .~ appEndo (setAttributes attrs) Map.empty - res <- retrying (limitRetries 3) (const isTimeout) (const (sendCatch req)) + SNS.newPublish (LT.toStrict txt) + & SNS.publish_targetArn ?~ toText arn + & SNS.publish_messageStructure ?~ "json" + & SNS.publish_messageAttributes ?~ appEndo (setAttributes attrs) Map.empty + env <- ask + res <- retrying (limitRetries 3) (const isTimeout) (const (sendCatch (env ^. awsEnv) req)) case res of Right _ -> return (Right ()) Left x@(AWS.ServiceError e) - | is "SNS" 400 x && AWS.errorCode "EndpointDisabled" == e ^. serviceCode -> + | is "SNS" 400 x && AWS.newErrorCode "EndpointDisabled" == e ^. serviceCode -> return (Left (EndpointDisabled arn)) - | is "SNS" 400 x && AWS.errorCode "InvalidParameter" == e ^. serviceCode + | is "SNS" 400 x && AWS.newErrorCode "InvalidParameter" == e ^. serviceCode && isProtocolSizeError (e ^. serviceMessage) -> return (Left (PayloadTooLarge arn)) - | is "SNS" 400 x && AWS.errorCode "InvalidParameter" == e ^. serviceCode + | is "SNS" 400 x && AWS.newErrorCode "InvalidParameter" == e ^. serviceCode && isSnsSizeError (e ^. serviceMessage) -> return (Left (PayloadTooLarge arn)) - | is "SNS" 400 x && AWS.errorCode "InvalidParameter" == e ^. serviceCode + | is "SNS" 400 x && AWS.newErrorCode "InvalidParameter" == e ^. serviceCode && isArnError (e ^. serviceMessage) -> return (Left (InvalidEndpoint arn)) Left x -> throwM (GeneralError x) @@ -432,19 +438,20 @@ publish arn txt attrs = do listen :: Int -> (Event -> IO ()) -> Amazon () listen throttleMillis callback = do + amazonkaEnv <- view awsEnv QueueUrl url <- view eventQueue forever . handleAny unexpectedError $ do - msgs <- view rmrsMessages <$> send (receive url) - void $ mapConcurrently (onMessage url) msgs + msgs <- fromMaybe [] . view SQS.receiveMessageResponse_messages <$> send amazonkaEnv (receive url) + void $ mapConcurrently (onMessage amazonkaEnv url) msgs when (null msgs) $ threadDelay (1000 * throttleMillis) where receive url = - SQS.receiveMessage url - & set SQS.rmWaitTimeSeconds (Just 20) - . set SQS.rmMaxNumberOfMessages (Just 10) - onMessage url m = - case decodeStrict =<< Text.encodeUtf8 <$> m ^. mBody of + SQS.newReceiveMessage url + & set SQS.receiveMessage_waitTimeSeconds (Just 20) + . set SQS.receiveMessage_maxNumberOfMessages (Just 10) + onMessage awsE url m = + case decodeStrict =<< Text.encodeUtf8 <$> m ^. SQS.message_body of Nothing -> err . msg $ val "Failed to parse SQS event notification" Just e -> do @@ -453,7 +460,7 @@ listen throttleMillis callback = do ~~ "arn" .= toText (e ^. evEndpoint) ~~ msg (val "Received SQS event") liftIO $ callback e - for_ (m ^. mReceiptHandle) (void . send . SQS.deleteMessage url) + for_ (m ^. message_receiptHandle) (void . send awsE . SQS.newDeleteMessage url) unexpectedError x = do err $ "error" .= show x ~~ msg (val "Failed to read from SQS") threadDelay 3000000 @@ -461,11 +468,11 @@ listen throttleMillis callback = do -------------------------------------------------------------------------------- -- Utilities -sendCatch :: AWSRequest r => r -> Amazon (Either AWS.Error (Rs r)) -sendCatch = AWST.trying AWS._Error . AWS.send +sendCatch :: AWSRequest r => AWS.Env -> r -> Amazon (Either AWS.Error (AWSResponse r)) +sendCatch env = AWS.trying AWS._Error . AWS.send env -send :: AWSRequest r => r -> Amazon (Rs r) -send r = either (throwM . GeneralError) return =<< sendCatch r +send :: AWSRequest r => AWS.Env -> r -> Amazon (AWSResponse r) +send env r = either (throwM . GeneralError) return =<< sendCatch env r is :: AWS.Abbrev -> Int -> AWS.Error -> Bool is srv s (AWS.ServiceError e) = srv == e ^. serviceAbbrev && s == statusCode (e ^. serviceStatus) diff --git a/services/gundeck/src/Gundeck/Aws/Arn.hs b/services/gundeck/src/Gundeck/Aws/Arn.hs index cbe3e443751..c205089c3c7 100644 --- a/services/gundeck/src/Gundeck/Aws/Arn.hs +++ b/services/gundeck/src/Gundeck/Aws/Arn.hs @@ -50,14 +50,13 @@ module Gundeck.Aws.Arn ) where +import Amazonka (Region (..)) +import Amazonka.Data import Control.Lens import Data.Attoparsec.Text import qualified Data.Text as Text -import Data.Yaml (FromJSON) import Gundeck.Types (AppName (..), Transport (..)) import Imports -import Network.AWS (Region (..)) -import Network.AWS.Data newtype ArnEnv = ArnEnv {arnEnvText :: Text} deriving (Show, ToText, FromJSON) @@ -102,7 +101,7 @@ instance ToText (SnsArn a) where toText = view snsAsText instance (FromText a, ToText a) => FromText (SnsArn a) where - parser = snsArnParser + fromText = parseOnly snsArnParser instance ToText AppTopic where toText = view appAsText @@ -111,7 +110,7 @@ instance ToText EndpointTopic where toText = view endpointAsText instance FromText EndpointTopic where - parser = endpointTopicParser + fromText = parseOnly endpointTopicParser mkSnsArn :: ToText topic => Region -> Account -> topic -> SnsArn topic mkSnsArn r a t = @@ -142,9 +141,9 @@ arnTransportText APNSVoIPSandbox = "APNS_VOIP_SANDBOX" snsArnParser :: (FromText t, ToText t) => Parser (SnsArn t) snsArnParser = do _ <- string "arn" *> char ':' *> string "aws" *> char ':' *> string "sns" - r <- char ':' *> takeTill (== ':') >>= either fail return . parseOnly parser + r <- char ':' *> takeTill (== ':') >>= either fail return . fromText a <- char ':' *> takeTill (== ':') - t <- char ':' *> parser + t <- char ':' *> takeText >>= either fail return . fromText return $ mkSnsArn r (Account a) t endpointTopicParser :: Parser EndpointTopic diff --git a/services/gundeck/src/Gundeck/Aws/Sns.hs b/services/gundeck/src/Gundeck/Aws/Sns.hs index 7cc47428045..1b8b1911454 100644 --- a/services/gundeck/src/Gundeck/Aws/Sns.hs +++ b/services/gundeck/src/Gundeck/Aws/Sns.hs @@ -24,13 +24,13 @@ module Gundeck.Aws.Sns ) where +import Amazonka.Data (ToText (..), fromText) import Control.Error import Control.Lens import Data.Aeson import Data.Aeson.Lens import Gundeck.Aws.Arn (EndpointArn) import Imports -import Network.AWS.Data (ToText (..), fromText) data EventType = EndpointCreated diff --git a/services/gundeck/src/Gundeck/Instances.hs b/services/gundeck/src/Gundeck/Instances.hs index 62973bdee88..5dc0665bc40 100644 --- a/services/gundeck/src/Gundeck/Instances.hs +++ b/services/gundeck/src/Gundeck/Instances.hs @@ -23,6 +23,7 @@ module Gundeck.Instances ) where +import Amazonka.Data import Cassandra.CQL import qualified Data.Attoparsec.Text as Parser import qualified Data.ByteString.Lazy as Bytes @@ -32,7 +33,6 @@ import qualified Data.UUID as Uuid import Gundeck.Aws.Arn (EndpointArn) import Gundeck.Types import Imports -import Network.AWS.Data instance Cql Transport where ctype = Tagged IntColumn @@ -82,8 +82,9 @@ instance ToText (Id a) where toText = Text.decodeUtf8 . Uuid.toASCIIBytes . toUUID instance FromText (Id a) where - parser = - Parser.take 36 >>= \txt -> - txt & Text.encodeUtf8 - & Uuid.fromASCIIBytes - & maybe (fail "Invalid UUID") (return . Id) + fromText = + Parser.parseOnly $ + Parser.take 36 >>= \txt -> + txt & Text.encodeUtf8 + & Uuid.fromASCIIBytes + & maybe (fail "Invalid UUID") (return . Id) diff --git a/services/gundeck/src/Gundeck/Presence/Data.hs b/services/gundeck/src/Gundeck/Presence/Data.hs index 47b9fcec833..6a28cc37dea 100644 --- a/services/gundeck/src/Gundeck/Presence/Data.hs +++ b/services/gundeck/src/Gundeck/Presence/Data.hs @@ -24,7 +24,7 @@ module Gundeck.Presence.Data where import Control.Monad.Catch -import Data.Aeson +import Data.Aeson hiding (Key) import qualified Data.ByteString as Strict import Data.ByteString.Builder (byteString) import Data.ByteString.Conversion hiding (fromList) diff --git a/services/gundeck/src/Gundeck/Push/Native.hs b/services/gundeck/src/Gundeck/Push/Native.hs index 6a97efd6e15..18366973b3b 100644 --- a/services/gundeck/src/Gundeck/Push/Native.hs +++ b/services/gundeck/src/Gundeck/Push/Native.hs @@ -22,6 +22,7 @@ module Gundeck.Push.Native ) where +import Amazonka.Data (toText) import Control.Lens (view, (.~), (^.)) import Control.Monad.Catch import Data.ByteString.Conversion.To @@ -42,7 +43,6 @@ import Gundeck.Push.Native.Types as Types import Gundeck.Types import Gundeck.Util import Imports -import Network.AWS.Data (toText) import System.Logger.Class (MonadLogger, field, msg, val, (~~)) import qualified System.Logger.Class as Log import UnliftIO (handleAny, mapConcurrently, pooledMapConcurrentlyN_) diff --git a/services/gundeck/test/bench/Main.hs b/services/gundeck/test/bench/Main.hs index 0a996245937..cbc7d99b059 100644 --- a/services/gundeck/test/bench/Main.hs +++ b/services/gundeck/test/bench/Main.hs @@ -20,6 +20,7 @@ module Main ) where +import Amazonka (Region (Ireland)) import Control.Lens ((^.)) import Criterion.Main import Data.Id (ClientId (..), ConnId (..), randomId) @@ -31,7 +32,6 @@ import Gundeck.Push.Native.Types import Gundeck.ThreadBudget.Internal import Gundeck.Types.Push import Imports -import Network.AWS (Region (Ireland)) import OpenSSL (withOpenSSL) import System.Random (randomRIO) diff --git a/services/gundeck/test/integration/API.hs b/services/gundeck/test/integration/API.hs index 4dad766a03b..d905e3b6d02 100644 --- a/services/gundeck/test/integration/API.hs +++ b/services/gundeck/test/integration/API.hs @@ -30,6 +30,7 @@ import Control.Concurrent.Async (Async, async, concurrently_, forConcurrently_, import Control.Lens (view, (%~), (.~), (^.), (^?), _2) import Control.Retry (constantDelay, limitRetries, recoverAll, retrying) import Data.Aeson hiding (json) +import qualified Data.Aeson.KeyMap as KeyMap import Data.Aeson.Lens import qualified Data.Aeson.Types as Aeson import qualified Data.ByteString as BS @@ -38,8 +39,8 @@ import qualified Data.ByteString.Char8 as C import Data.ByteString.Conversion import Data.ByteString.Lazy (fromStrict) import qualified Data.ByteString.Lazy as BL -import qualified Data.HashMap.Strict as HashMap import Data.Id +import qualified Data.List.NonEmpty as NonEmpty import Data.List1 (List1) import qualified Data.List1 as List1 import Data.Range @@ -172,7 +173,7 @@ replacePresence = do assertTrue "Old Cannon is removed" $ notElem localhost8080 . map resource . decodePresence where - pload = List1.singleton $ HashMap.fromList ["foo" .= (42 :: Int)] + pload = List1.singleton $ KeyMap.fromList ["foo" .= (42 :: Int)] push u us = newPush (Just u) (toRecipients us) pload & pushOriginConnection .~ Just (ConnId "dev") removeStalePresence :: TestM () @@ -192,14 +193,14 @@ removeStalePresence = do sendPush (push (Just uid) [uid]) ensurePresent uid 0 where - pload = List1.singleton $ HashMap.fromList ["foo" .= (42 :: Int)] + pload = List1.singleton $ KeyMap.fromList ["foo" .= (42 :: Int)] push u us = newPush u (toRecipients us) pload & pushOriginConnection .~ Just (ConnId "dev") singleUserPush :: TestM () singleUserPush = testSingleUserPush smallMsgPayload where -- JSON: {"foo":42} - smallMsgPayload = List1.singleton $ HashMap.fromList ["foo" .= (42 :: Int)] + smallMsgPayload = List1.singleton $ KeyMap.fromList ["foo" .= (42 :: Int)] testSingleUserPush :: List1 Object -> TestM () testSingleUserPush msgPayload = do @@ -221,7 +222,7 @@ singleUserPushLargeMessage :: TestM () singleUserPushLargeMessage = testSingleUserPush largeMsgPayload where -- JSON: {"list":["1","2", ... ,"10000"]} - largeMsgPayload = List1.singleton $ HashMap.fromList ["list" .= [show i | i <- [1 .. 10000] :: [Int]]] + largeMsgPayload = List1.singleton $ KeyMap.fromList ["list" .= [show i | i <- [1 .. 10000] :: [Int]]] -- | Create a number of users with a number of connections each, and connect each user's connections -- | Create a number of users with a number of connections each, and connect each user's connections @@ -263,7 +264,7 @@ bulkPush isE2E numUsers numConnsPerUser = do where shoulds' = drop (length connids) shoulds ploadGroup :: List1 Aeson.Object - ploadGroup = List1.singleton $ HashMap.fromList [("foo" :: Text) .= (42 :: Int)] + ploadGroup = List1.singleton $ KeyMap.fromList ["foo" .= (42 :: Int)] pushGroup :: UserId -> [(UserId, [(ConnId, Bool)])] -> [Push] pushGroup u ucs = [newPush (Just u) (toRecipients $ fst <$> ucs) ploadGroup & pushConnections .~ Set.fromList conns] where @@ -271,7 +272,7 @@ bulkPush isE2E numUsers numConnsPerUser = do [ connid | (_, cns) <- ucs, (connid, shouldSend) <- cns, shouldSend ] ploadE2E :: ConnId -> List1 Aeson.Object - ploadE2E connid = List1.singleton $ HashMap.fromList ["connid" .= connid] + ploadE2E connid = List1.singleton $ KeyMap.fromList ["connid" .= connid] pushE2E :: UserId -> [(UserId, [(ConnId, Bool)])] -> [Push] pushE2E u ucs = targets <&> \(uid, connid) -> @@ -307,7 +308,7 @@ sendSingleUserNoPiggyback = do msg <- waitForMessage ch assertBool "Push message received" (isNothing msg) where - pload = List1.singleton $ HashMap.fromList ["foo" .= (42 :: Int)] + pload = List1.singleton $ KeyMap.fromList ["foo" .= (42 :: Int)] push u us d = newPush u (toRecipients us) pload & pushOriginConnection .~ Just d sendMultipleUsers :: TestM () @@ -339,7 +340,7 @@ sendMultipleUsers = do liftIO . forM_ [ntfs1, ntfs2] $ \ntfs -> do assertEqual "Not exactly 1 notification" 1 (length ntfs) let p = view queuedNotificationPayload (Prelude.head ntfs) - assertEqual "Wrong events in notification" pload p + assertEqual "Wrong events in notification" (List1.toNonEmpty pload) p -- 'uid3' should have two notifications, one for the message and one -- for the removed token. ntfs3 <- listNotifications uid3 Nothing @@ -348,16 +349,16 @@ sendMultipleUsers = do let (n1, nx) = checkNotifications ntfs3 -- The first notification must be the test payload let p1 = view queuedNotificationPayload n1 - assertEqual "Wrong events in 1st notification" pload p1 + assertEqual "Wrong events in 1st notification" (List1.toNonEmpty pload) p1 -- Followed by at least one notification for the token removal forM_ nx $ \n -> - let p2 = fromJSON (Object (List1.head (n ^. queuedNotificationPayload))) + let p2 = fromJSON (Object (NonEmpty.head (n ^. queuedNotificationPayload))) in assertEqual "Wrong events in notification" (Success (PushRemove tok)) p2 where checkNotifications [] = error "No notifications received!" checkNotifications (x : xs) = (x, xs) pload = List1.singleton pevent - pevent = HashMap.fromList ["foo" .= (42 :: Int)] + pevent = KeyMap.fromList ["foo" .= (42 :: Int)] push u us = newPush (Just u) (toRecipients us) pload & pushOriginConnection .~ Just (ConnId "dev") targetConnectionPush :: TestM () @@ -374,7 +375,7 @@ targetConnectionPush = do assertBool "No push message received" (isJust e1) assertBool "Unexpected push message received" (isNothing e2) where - pload = List1.singleton $ HashMap.fromList ["foo" .= (42 :: Int)] + pload = List1.singleton $ KeyMap.fromList ["foo" .= (42 :: Int)] push u t = newPush (Just u) (toRecipients [u]) pload & pushConnections .~ Set.singleton t targetClientPush :: TestM () @@ -407,9 +408,9 @@ targetClientPush = do liftIO . forM_ [(ns1, cid1), (ns2, cid2)] $ \(ns, c) -> do assertEqual "Not exactly 1 notification" 1 (length ns) let p = view queuedNotificationPayload (Prelude.head ns) - assertEqual "Wrong events in notification" (pload c) p + assertEqual "Wrong events in notification" (List1.toNonEmpty (pload c)) p where - pevent c = HashMap.fromList ["foo" .= client c] + pevent c = KeyMap.fromList ["foo" .= client c] pload c = List1.singleton (pevent c) rcpt u c = recipient u RouteAny @@ -435,7 +436,7 @@ testFetchAllNotifs = do liftIO $ assertEqual "Unexpected notification payloads" - (replicate 10 pload) + (replicate 10 (List1.toNonEmpty pload)) (map (view queuedNotificationPayload) ns) testFetchNewNotifs :: TestM () @@ -1131,7 +1132,7 @@ randomBytes :: MonadIO m => Int -> m ByteString randomBytes n = liftIO $ BS.pack <$> replicateM n (randomIO :: IO Word8) textPayload :: Text -> List1 Object -textPayload txt = List1.singleton (HashMap.fromList ["text" .= txt]) +textPayload txt = List1.singleton (KeyMap.fromList ["text" .= txt]) parseNotification :: Response (Maybe BL.ByteString) -> Maybe QueuedNotification parseNotification = responseBody >=> decode diff --git a/services/gundeck/test/unit/Json.hs b/services/gundeck/test/unit/Json.hs index 253c2d2aa68..4514fa8da68 100644 --- a/services/gundeck/test/unit/Json.hs +++ b/services/gundeck/test/unit/Json.hs @@ -19,7 +19,7 @@ module Json where import Control.Lens (set, view) import Data.Aeson -import Data.HashMap.Strict (fromList) +import Data.Aeson.KeyMap (fromList) import Data.Id import Data.List1 import Gundeck.Types.BulkPush diff --git a/services/gundeck/test/unit/MockGundeck.hs b/services/gundeck/test/unit/MockGundeck.hs index 67f2b22eecf..ee2773c2b93 100644 --- a/services/gundeck/test/unit/MockGundeck.hs +++ b/services/gundeck/test/unit/MockGundeck.hs @@ -46,7 +46,7 @@ import Control.Monad.State import Data.Aeson import qualified Data.Aeson as Aeson import qualified Data.Aeson.Encode.Pretty as Aeson -import qualified Data.HashMap.Lazy as HashMap +import qualified Data.Aeson.KeyMap as KeyMap import Data.Id import Data.IntMultiSet (IntMultiSet) import qualified Data.IntMultiSet as MSet @@ -382,7 +382,7 @@ shrinkPushes = shrinkList shrinkPush genPayload :: Gen Payload genPayload = do num :: Int <- arbitrary - pure $ List1 (HashMap.singleton "val" (Aeson.toJSON num) NE.:| []) + pure $ List1 (KeyMap.singleton "val" (Aeson.toJSON num) NE.:| []) genNotif :: Gen Notification genNotif = Notification <$> genId <*> arbitrary <*> genPayload diff --git a/services/gundeck/test/unit/Native.hs b/services/gundeck/test/unit/Native.hs index 4e35710baac..c305f6e5ce3 100644 --- a/services/gundeck/test/unit/Native.hs +++ b/services/gundeck/test/unit/Native.hs @@ -17,9 +17,10 @@ module Native where +import Amazonka (Region (Ireland)) import Control.Lens ((^.)) import Data.Aeson -import qualified Data.HashMap.Strict as HashMap +import qualified Data.Aeson.KeyMap as KeyMap import Data.Id (ClientId (..), ConnId (..), UserId, randomId) import qualified Data.List1 as List1 import qualified Data.Text as T @@ -30,7 +31,6 @@ import Gundeck.Push.Native.Types import Gundeck.Types.Notification import Gundeck.Types.Push import Imports -import Network.AWS (Region (Ireland)) import Test.Tasty import Test.Tasty.QuickCheck @@ -69,7 +69,7 @@ data SnsNotification = SnsNotification instance FromJSON SnsNotification where parseJSON = withObject "SnsNotification" $ \o -> - case HashMap.toList o of + case KeyMap.toList o of [("GCM", String n)] -> parseGcm n [("APNS", String n)] -> parseApns APNS n [("APNS_SANDBOX", String n)] -> parseApns APNSSandbox n @@ -121,8 +121,8 @@ newtype Bundle = NoticeBundle NotificationId instance FromJSON Bundle where parseJSON = withObject "Bundle" $ \o -> - case HashMap.lookup "type" o of - Just (String "notice") -> case HashMap.lookup "data" o of + case KeyMap.lookup "type" o of + Just (String "notice") -> case KeyMap.lookup "data" o of Just (Object o') -> NoticeBundle <$> o' .: "id" _ -> mempty _ -> mempty @@ -149,7 +149,7 @@ randNotif size = do generate $ do l <- choose size v <- T.pack <$> vectorOf l (elements ['a' .. 'z']) - let pload = List1.singleton (HashMap.fromList ["data" .= v]) + let pload = List1.singleton (KeyMap.fromList ["data" .= v]) Notification i <$> arbitrary <*> pure pload randMessage :: Notification -> IO NativePush diff --git a/services/proxy/package.yaml b/services/proxy/package.yaml index 2bb1686209e..7629fe3ba03 100644 --- a/services/proxy/package.yaml +++ b/services/proxy/package.yaml @@ -17,7 +17,7 @@ library: - -funbox-strict-fields dependencies: - base >=4.6 && <5 - - aeson >=1.0 + - aeson >=2.0.1.0 - bilge >=0.21 - bytestring >=0.10 - case-insensitive >=1.2 diff --git a/services/proxy/proxy.cabal b/services/proxy/proxy.cabal index 55ac7910011..0acf4625737 100644 --- a/services/proxy/proxy.cabal +++ b/services/proxy/proxy.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: c31f9c4911b4326363bf2d4063f32f056fd40c97d528cbbec21cbe97ccdf1833 +-- hash: 0dc85028d7242fe9422dc7b97417fd157c235bd8b6aa74a3c61f093e04e0f57a name: proxy version: 0.9.0 @@ -77,7 +77,7 @@ library 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 + aeson >=2.0.1.0 , base >=4.6 && <5 , bilge >=0.21 , bytestring >=0.10 diff --git a/services/spar/test/Test/Spar/ScimSpec.hs b/services/spar/test/Test/Spar/ScimSpec.hs index b00f2d658cc..8dddea10dd7 100644 --- a/services/spar/test/Test/Spar/ScimSpec.hs +++ b/services/spar/test/Test/Spar/ScimSpec.hs @@ -104,7 +104,7 @@ spec = describe "toScimStoredUser'" $ do { Scim.resourceType = ScimR.UserResource, Scim.created = fromUTCTimeMillis now, Scim.lastModified = fromUTCTimeMillis now, - Scim.version = Scim.Weak "46246ab15ccab8a70b59f97f7182d6fb557dd454c0f06cdcb83d99d027cff08e", + Scim.version = Scim.Weak "ee3ebd2f5722d0b95e20ded809a81321b3810543457ca6ca459d822294c12c71", Scim.location = Scim.URI . fromJust $ Network.URI.parseURI diff --git a/stack.yaml b/stack.yaml index 7432f78f6b3..8abd0c00e60 100644 --- a/stack.yaml +++ b/stack.yaml @@ -106,32 +106,49 @@ extra-deps: commit: 0a5142cd3ba48116ff059c041348b817fb7bdb25 - git: https://github.com/wireapp/bloodhound - commit: 92de9aa632d590f288a353d03591c38ba72b3cb3 # (2020-10-27) branch: wire-fork-ghc-8.8 + commit: d444579f808115ddb0f20a1fe169fafad24f5165 # (2022-02-17) branch: wire-fork, aeson 2 support # For bloodhound -- deriving-aeson-0.2.5@sha256:a1efa4ab7ff94f73e6d2733a9d4414cb4c3526761295722cff28027b5b3da1a4,1277 -- aeson-1.4.7.1@sha256:6d8d2fd959b7122a1df9389cf4eca30420a053d67289f92cdc0dbc0dab3530ba,7098 - -# amazonka-1.6.1 is buggy: -# https://github.com/brendanhay/amazonka/pull/493 -# Also, we needed a fix to make V4 signatures work with custom ports: -# https://github.com/brendanhay/amazonka/pull/588 -# -# Therefore we pin an unreleased commit directly. -# -# Once the fix has been merged (and released on hackage), we can pin that instead. +- aeson-2.0.3.0 +- deriving-aeson-0.2.8 +- semialign-1.2.0.1 +- OneTuple-0.3.1 +- hashable-1.4.0.2 +- attoparsec-0.14.4 +- text-short-0.1.5 +- time-compat-1.9.6.1 +- lens-5.0.1 +- quickcheck-instances-0.3.27 +- swagger2-2.8.2 +- optics-extra-0.4 +- optics-core-0.4 +- optics-th-0.4 +- http-api-data-0.4.3 +- shakespeare-2.0.25.1 +- servant-swagger-1.1.10 +- foldl-1.4.12 +- stache-2.3.1 +- microlens-aeson-2.4.1 + +# Fork to force usage of path-style s3 URLs. More about S3 URLs: +# https://aws.amazon.com/blogs/aws/amazon-s3-path-deprecation-plan-the-rest-of-the-story/ - git: https://github.com/wireapp/amazonka - commit: 412172d8c28906591f01576a78792de7c34cc3eb + commit: 7ced54b0396296307b9871d293cc0ac161e5743d # (2022-02-24) branch: s3-no-vhost subdirs: - - amazonka - - amazonka-cloudfront - - amazonka-dynamodb - - amazonka-s3 - - amazonka-ses - - amazonka-sns - - amazonka-sqs - - core - + - lib/amazonka + - lib/amazonka-core + - lib/services/amazonka-cloudfront + - lib/services/amazonka-dynamodb + - lib/services/amazonka-s3 + - lib/services/amazonka-ses + - lib/services/amazonka-sns + - lib/services/amazonka-sqs + - lib/services/amazonka-sso + - lib/services/amazonka-sts + +# Use forked swagger to support aeson >= 2 +- git: https://gitlab.com/axeman/swagger + commit: e2d3f5b5274b8d8d301b5377b0af4319cea73f9e ############################################################ # Wire packages @@ -190,10 +207,6 @@ extra-deps: - tls-1.5.5 - cryptonite-0.29 -# For changes from #128 and #135, not released to hackage yet -- git: https://github.com/haskell-servant/servant-swagger - commit: bb0a84faa073fa9530f60337610d7da3d5b9393c - # For changes from https://github.com/haskell-servant/servant/pull/1502 # Not released to hackage yet - git: https://github.com/haskell-servant/servant.git @@ -261,3 +274,6 @@ extra-deps: - headroom-0.4.2.0 - implicit-hie-0.1.2.6 + +# For aeson >= 2 +- hoogle-5.0.18.3 diff --git a/stack.yaml.lock b/stack.yaml.lock index b8831b6c919..fe04f582229 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -95,130 +95,293 @@ packages: version: 0.17.0.0 git: https://github.com/wireapp/bloodhound pantry-tree: - size: 4587 - sha256: fc77d3295fba77f96f80bf10860afac1855d393020f3d04d71bf530afa17c143 - commit: 92de9aa632d590f288a353d03591c38ba72b3cb3 + size: 4588 + sha256: 336bd360dc9f16416eca78d884661f4a9405601d3e09b443b9157cb5fb675dca + commit: d444579f808115ddb0f20a1fe169fafad24f5165 original: git: https://github.com/wireapp/bloodhound - commit: 92de9aa632d590f288a353d03591c38ba72b3cb3 + commit: d444579f808115ddb0f20a1fe169fafad24f5165 - completed: - hackage: deriving-aeson-0.2.5@sha256:a1efa4ab7ff94f73e6d2733a9d4414cb4c3526761295722cff28027b5b3da1a4,1277 + hackage: aeson-2.0.3.0@sha256:130bda8e10dc6dd159b79b306abb10025d7f8b5d9cbc2f7d6d7e6768a0272058,5845 + pantry-tree: + size: 38191 + sha256: bccfc5a7259a27aad7e4193f367c3d7d67799f42632fdcb90241c1e9fbb0cf40 + original: + hackage: aeson-2.0.3.0 +- completed: + hackage: deriving-aeson-0.2.8@sha256:67bdea3463df1a3b9b38761d3ff4889817f08588d2dc4514c1f21e0ba6a8ad17,1291 pantry-tree: size: 441 - sha256: 8fa77245ed0f169fae3a337bf4b9114c44e6bd0cd02ce748998f46c19ef32277 + sha256: 973735207c29fbe7483966a07287343b3432a85b352da805a3585a456d47a4ac + original: + hackage: deriving-aeson-0.2.8 +- completed: + hackage: semialign-1.2.0.1@sha256:0e179b4d3a8eff79001d374d6c91917c6221696b9620f0a4d86852fc6a9b9501,2836 + pantry-tree: + size: 537 + sha256: 635bbbb517f0c063a4bc2e9e6efdb0e598b9d9fd467f52df81ab3a4af1fd923b + original: + hackage: semialign-1.2.0.1 +- completed: + hackage: OneTuple-0.3.1@sha256:a848c096c9d29e82ffdd30a9998aa2931cbccb3a1bc137539d80f6174d31603e,2262 + pantry-tree: + size: 506 + sha256: a685b08622f1fe0641e4f228a290878a1db4f7ef3eb63d00b10e8632097d1e6f + original: + hackage: OneTuple-0.3.1 +- completed: + hackage: hashable-1.4.0.2@sha256:0cddd0229d1aac305ea0404409c0bbfab81f075817bd74b8b2929eff58333e55,5005 + pantry-tree: + size: 1248 + sha256: 51dda0aa70849588d074125f324beba1c8736cfa486e7f4a90a798b1d0e6019d + original: + hackage: hashable-1.4.0.2 +- completed: + hackage: attoparsec-0.14.4@sha256:79584bdada8b730cb5138fca8c35c76fbef75fc1d1e01e6b1d815a5ee9843191,5810 + pantry-tree: + size: 5039 + sha256: 5b8e087f73d334019252606b1f64b986cef61946a085ccb77c6bc4d038691c48 + original: + hackage: attoparsec-0.14.4 +- completed: + hackage: text-short-0.1.5@sha256:962c6228555debdc46f758d0317dea16e5240d01419b42966674b08a5c3d8fa6,3498 + pantry-tree: + size: 727 + sha256: 1fc6561c4acb94a41e58cd8f8c7cce161c18c5629dac63a54a9c62f9c778c52b + original: + hackage: text-short-0.1.5 +- completed: + hackage: time-compat-1.9.6.1@sha256:42d8f2e08e965e1718917d54ad69e1d06bd4b87d66c41dc7410f59313dba4ed1,5033 + pantry-tree: + size: 4113 + sha256: b262c5ae8d72d2073d12e1de1863abd234fad8c138df28f32bb51bc232ced608 + original: + hackage: time-compat-1.9.6.1 +- completed: + hackage: lens-5.0.1@sha256:63ed57e4d54c583ae2873d6892ef690942d90030864d0b772413a1458e98159f,15544 + pantry-tree: + size: 8291 + sha256: cd3ee6c79afa15e4e8ffe0efd1c7c929c5999b1a84a9b9a18ef4e7897927a896 original: - hackage: deriving-aeson-0.2.5@sha256:a1efa4ab7ff94f73e6d2733a9d4414cb4c3526761295722cff28027b5b3da1a4,1277 + hackage: lens-5.0.1 - completed: - hackage: aeson-1.4.7.1@sha256:6d8d2fd959b7122a1df9389cf4eca30420a053d67289f92cdc0dbc0dab3530ba,7098 + hackage: quickcheck-instances-0.3.27@sha256:df1a5d65519fea31d2eaa38da3b6aa5d1c7edb2d2420808b3030f10c217c27ac,4710 pantry-tree: - size: 40133 - sha256: caa9306e519c601ab0170d113daa03c1163db53e5466be2968bbd61a771bebcb + size: 2274 + sha256: da4d0e272b106167b2e2025758d566e0768c8c22a8ffcc365efcffba7ea8c758 original: - hackage: aeson-1.4.7.1@sha256:6d8d2fd959b7122a1df9389cf4eca30420a053d67289f92cdc0dbc0dab3530ba,7098 + hackage: quickcheck-instances-0.3.27 - completed: - subdir: amazonka + hackage: swagger2-2.8.2@sha256:eaa068e1b7d39179836c74c01dd07d4f4b8946b19af6ebb840317fa1042b02d6,4448 + pantry-tree: + size: 2192 + sha256: 2467e4b0dc0693cf6f4027a130de49a7f17b98e73713b8c96bf2256d6c6cac65 + original: + hackage: swagger2-2.8.2 +- completed: + hackage: optics-extra-0.4@sha256:397234d420519d810b23b861ff3a715b616cda7adea1c60d86e4d5d7791a4199,3488 + pantry-tree: + size: 1809 + sha256: a5d978fd23933b9ee045483a5f419f0afd0780520a13271cb412082324888a56 + original: + hackage: optics-extra-0.4 +- completed: + hackage: optics-core-0.4@sha256:59e04aebca536bd011ae50c781937f45af4c1456af1eb9fb578f9a69eee293cd,4995 + pantry-tree: + size: 5315 + sha256: 0b8b5824efec35faede5a4c5d7c6f47c6b4708885942f7a7f73c892a5c3c5738 + original: + hackage: optics-core-0.4 +- completed: + hackage: optics-th-0.4@sha256:8479f64f094346d31489221ad9742324fd6c5aed0722e58fc49f0a580ceb2a18,2045 + pantry-tree: + size: 741 + sha256: 26025e3641cc09e3c8abd9cdf8278710ed79ed09953c0b6047279624620c21b3 + original: + hackage: optics-th-0.4 +- completed: + hackage: http-api-data-0.4.3@sha256:f4134a06d6544193a4d088df362e132a6cb71a0538f5636bf860971cd0879960,3845 + pantry-tree: + size: 887 + sha256: 05c7bfafbf73d7d8eff5915b580e5ef6bf85232764fad871476a6952f746d9f9 + original: + hackage: http-api-data-0.4.3 +- completed: + hackage: shakespeare-2.0.25.1@sha256:af4f649fa5c3914b217f4d7f52dc46098891d38a6cf6a8ce71624d1997a82425,4836 + pantry-tree: + size: 3658 + sha256: a1754063865a1f39cd5336d916c30dc1432983f36d7a31df3a11a629c8572d6f + original: + hackage: shakespeare-2.0.25.1 +- completed: + hackage: servant-swagger-1.1.10@sha256:8cfb3fae40f00add2c4c3075568baf4774b6760a6823ef1bbc1cc7ac0fb528f4,4766 + pantry-tree: + size: 1636 + sha256: 3ba6a02d74bb530ec12afb863d0aa3cf68af28cfa4f134da903706746904264d + original: + hackage: servant-swagger-1.1.10 +- completed: + hackage: foldl-1.4.12@sha256:860dacd697f715023e21a94d5f46f5639f386530ce141f91348565ec6533f43d,2668 + pantry-tree: + size: 959 + sha256: 06c323172e93cd9b1f67eb8989cdb6e6d7b8d153a1749e8fad28ac25340d25ba + original: + hackage: foldl-1.4.12 +- completed: + hackage: stache-2.3.1@sha256:48a1637594feb3eab4e278192a7a029607db615e0bee8394a0cd52f54ebdb6ae,4385 + pantry-tree: + size: 2331 + sha256: b09e2069993cec19123fa71407c1b09abad172f0b00387ae1b9da427963cb86f + original: + hackage: stache-2.3.1 +- completed: + hackage: microlens-aeson-2.4.1@sha256:96c8b66150edee033b16ccdc471d7938593f462e4f6695e91982a6d5e26741c8,1583 + pantry-tree: + size: 575 + sha256: 8b31405f4bd5a6d9aa7a544dbed965467baffc957a493460c3c7a3f7ea154eea + original: + hackage: microlens-aeson-2.4.1 +- completed: + subdir: lib/amazonka name: amazonka - version: 1.6.1 + version: '2.0' git: https://github.com/wireapp/amazonka pantry-tree: - size: 1038 - sha256: 59c7840fe6c9609d1d5022149010e72db5778e4978b9384b6dee8a4a207c96b3 - commit: 412172d8c28906591f01576a78792de7c34cc3eb + size: 1257 + sha256: 0257a27c3332e400abc0f4a38f7a875c4a2a04b03ac342d7481e19d9d5665040 + commit: 7ced54b0396296307b9871d293cc0ac161e5743d original: - subdir: amazonka + subdir: lib/amazonka git: https://github.com/wireapp/amazonka - commit: 412172d8c28906591f01576a78792de7c34cc3eb + commit: 7ced54b0396296307b9871d293cc0ac161e5743d - completed: - subdir: amazonka-cloudfront + subdir: lib/amazonka-core + name: amazonka-core + version: '2.0' + git: https://github.com/wireapp/amazonka + pantry-tree: + size: 3117 + sha256: 4d7f1929bb36acfd5c2e852afe8f7d6fa7124f3c5ac3e7e30265c3bda6eab8a9 + commit: 7ced54b0396296307b9871d293cc0ac161e5743d + original: + subdir: lib/amazonka-core + git: https://github.com/wireapp/amazonka + commit: 7ced54b0396296307b9871d293cc0ac161e5743d +- completed: + subdir: lib/services/amazonka-cloudfront name: amazonka-cloudfront - version: 1.6.1 + version: '2.0' git: https://github.com/wireapp/amazonka pantry-tree: - size: 12839 - sha256: f0f27588c628d9996c298ab035b19999572ad8432ea05526497b608b009b1258 - commit: 412172d8c28906591f01576a78792de7c34cc3eb + size: 35830 + sha256: e823334938503329b08c904bb69cc745c855a6634e5152ff05d8cf04f384c9e9 + commit: 7ced54b0396296307b9871d293cc0ac161e5743d original: - subdir: amazonka-cloudfront + subdir: lib/services/amazonka-cloudfront git: https://github.com/wireapp/amazonka - commit: 412172d8c28906591f01576a78792de7c34cc3eb + commit: 7ced54b0396296307b9871d293cc0ac161e5743d - completed: - subdir: amazonka-dynamodb + subdir: lib/services/amazonka-dynamodb name: amazonka-dynamodb - version: 1.6.1 + version: '2.0' git: https://github.com/wireapp/amazonka pantry-tree: - size: 8379 - sha256: d513775676879e3b2ff8393528882df1670a79110120b65ce6c68765581a2473 - commit: 412172d8c28906591f01576a78792de7c34cc3eb + size: 24222 + sha256: 35c575ca698414ba74f43ab3825c9bc386e30b4ee052acfe86d187ee92bfd16e + commit: 7ced54b0396296307b9871d293cc0ac161e5743d original: - subdir: amazonka-dynamodb + subdir: lib/services/amazonka-dynamodb git: https://github.com/wireapp/amazonka - commit: 412172d8c28906591f01576a78792de7c34cc3eb + commit: 7ced54b0396296307b9871d293cc0ac161e5743d - completed: - subdir: amazonka-s3 + subdir: lib/services/amazonka-s3 name: amazonka-s3 - version: 1.6.1 + version: '2.0' git: https://github.com/wireapp/amazonka pantry-tree: - size: 18431 - sha256: a19d02da301bbcad502e6092d7418a59543747c8bb6f12932bcbc4606f7814ab - commit: 412172d8c28906591f01576a78792de7c34cc3eb + size: 37929 + sha256: 57bc3c2aa426230e1f339fee5710eb43ace36d05c91113bd035b4de5aac26329 + commit: 7ced54b0396296307b9871d293cc0ac161e5743d original: - subdir: amazonka-s3 + subdir: lib/services/amazonka-s3 git: https://github.com/wireapp/amazonka - commit: 412172d8c28906591f01576a78792de7c34cc3eb + commit: 7ced54b0396296307b9871d293cc0ac161e5743d - completed: - subdir: amazonka-ses + subdir: lib/services/amazonka-ses name: amazonka-ses - version: 1.6.1 + version: '2.0' git: https://github.com/wireapp/amazonka pantry-tree: - size: 18197 - sha256: cd9b02c30d7571dc87868b054ed3826d5b8d26b717f3158da6443377e8dfd563 - commit: 412172d8c28906591f01576a78792de7c34cc3eb + size: 22980 + sha256: b9345ff2c3c1a2c1fa8550314912a1f105e1275c9779d472121808cda3a95da9 + commit: 7ced54b0396296307b9871d293cc0ac161e5743d original: - subdir: amazonka-ses + subdir: lib/services/amazonka-ses git: https://github.com/wireapp/amazonka - commit: 412172d8c28906591f01576a78792de7c34cc3eb + commit: 7ced54b0396296307b9871d293cc0ac161e5743d - completed: - subdir: amazonka-sns + subdir: lib/services/amazonka-sns name: amazonka-sns - version: 1.6.1 + version: '2.0' git: https://github.com/wireapp/amazonka pantry-tree: - size: 7905 - sha256: e5a6d407b92e423ccf58d784fe42d4a0598204f65c0e7753569c130428bfb5eb - commit: 412172d8c28906591f01576a78792de7c34cc3eb + size: 10926 + sha256: 98e24892961bdee8bec5678f6e0840fd73be5f9092af19c50133be44afd4eaa9 + commit: 7ced54b0396296307b9871d293cc0ac161e5743d original: - subdir: amazonka-sns + subdir: lib/services/amazonka-sns git: https://github.com/wireapp/amazonka - commit: 412172d8c28906591f01576a78792de7c34cc3eb + commit: 7ced54b0396296307b9871d293cc0ac161e5743d - completed: - subdir: amazonka-sqs + subdir: lib/services/amazonka-sqs name: amazonka-sqs - version: 1.6.1 + version: '2.0' git: https://github.com/wireapp/amazonka pantry-tree: - size: 5351 - sha256: 990b7e4467d557e43959483063f7229f5039857a8cd67decb53f9a5c513db7f8 - commit: 412172d8c28906591f01576a78792de7c34cc3eb + size: 6376 + sha256: 75cc731a0b471b03aa224677552944fb0c4ea1330bfc58504e0af5efdf8b330c + commit: 7ced54b0396296307b9871d293cc0ac161e5743d original: - subdir: amazonka-sqs + subdir: lib/services/amazonka-sqs git: https://github.com/wireapp/amazonka - commit: 412172d8c28906591f01576a78792de7c34cc3eb + commit: 7ced54b0396296307b9871d293cc0ac161e5743d - completed: - subdir: core - name: amazonka-core - version: 1.6.1 + subdir: lib/services/amazonka-sso + name: amazonka-sso + version: '2.0' + git: https://github.com/wireapp/amazonka + pantry-tree: + size: 1869 + sha256: f11babeeaf0481ae68134ced86e9d1d9396d1beb7bd70e0a1e6b77bc4148a192 + commit: 7ced54b0396296307b9871d293cc0ac161e5743d + original: + subdir: lib/services/amazonka-sso + git: https://github.com/wireapp/amazonka + commit: 7ced54b0396296307b9871d293cc0ac161e5743d +- completed: + subdir: lib/services/amazonka-sts + name: amazonka-sts + version: '2.0' git: https://github.com/wireapp/amazonka pantry-tree: - size: 3484 - sha256: d4e427a362d66c9ee0dc0de810015633e43e3953944a84b24cfa2e71bcf0ed4d - commit: 412172d8c28906591f01576a78792de7c34cc3eb + size: 2932 + sha256: 64ed22eaaea868b32cf56f162d1bd7332b048d8f2ea073c4e9827ed08e71cc70 + commit: 7ced54b0396296307b9871d293cc0ac161e5743d original: - subdir: core + subdir: lib/services/amazonka-sts git: https://github.com/wireapp/amazonka - commit: 412172d8c28906591f01576a78792de7c34cc3eb + commit: 7ced54b0396296307b9871d293cc0ac161e5743d +- completed: + name: swagger + version: 0.3.0 + git: https://gitlab.com/axeman/swagger + pantry-tree: + size: 1010 + sha256: 88af56b825407fd96939d5e66198e5fda14de7323b15756ad66285affdd3a372 + commit: e2d3f5b5274b8d8d301b5377b0af4319cea73f9e + original: + git: https://gitlab.com/axeman/swagger + commit: e2d3f5b5274b8d8d301b5377b0af4319cea73f9e - completed: name: cryptobox-haskell version: 0.1.1 @@ -510,17 +673,6 @@ packages: sha256: 087de3ed0552cfb1f84d03629b0f98c77aadc076b85bb5cb787f77c5e5dac136 original: hackage: cryptonite-0.29 -- completed: - name: servant-swagger - version: 1.1.11 - git: https://github.com/haskell-servant/servant-swagger - pantry-tree: - size: 1965 - sha256: 8fd0d018aee725fa475a408d17a54ae8d190518e96453b304687bccafe4cddac - commit: bb0a84faa073fa9530f60337610d7da3d5b9393c - original: - git: https://github.com/haskell-servant/servant-swagger - commit: bb0a84faa073fa9530f60337610d7da3d5b9393c - completed: subdir: servant name: servant @@ -766,6 +918,13 @@ packages: sha256: 87e1a41e292526d86b55668bca628cf917056d82001438dc6975e4f35cf5210d original: hackage: implicit-hie-0.1.2.6 +- completed: + hackage: hoogle-5.0.18.3@sha256:91b0b724d283de28b5b7ba670ebb61867538a06aa1562982517c82660710bd2a,3173 + pantry-tree: + size: 3414 + sha256: c8eeaa1c1744fd293f1d8497e2f4bfdb09e38d4fdae8d7132c477d4a5d5e2679 + original: + hackage: hoogle-5.0.18.3 snapshots: - completed: size: 586296 diff --git a/tools/bonanza/bonanza.cabal b/tools/bonanza/bonanza.cabal index 6b3221f53e6..4b886ada922 100644 --- a/tools/bonanza/bonanza.cabal +++ b/tools/bonanza/bonanza.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: e99811a9a954d2a94b4ac9e909d56d22ede51a464f80aefefd5b4e1b8b93b231 +-- hash: 4c3c3c61ce43c6d11f5eed921640d7a287b190e400bc86db238b2aafac7d5c40 name: bonanza version: 3.6.0 @@ -86,7 +86,7 @@ library 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 + aeson >=2.0.1.0 , attoparsec >=0.10 , base ==4.* , binary @@ -219,7 +219,7 @@ executable kibana-raw 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 + aeson >=2.0.1.0 , base , bytestring , clock diff --git a/tools/bonanza/package.yaml b/tools/bonanza/package.yaml index ef7250b3539..ad29f4439d7 100644 --- a/tools/bonanza/package.yaml +++ b/tools/bonanza/package.yaml @@ -21,7 +21,7 @@ library: - -fno-warn-unused-do-bind dependencies: - base ==4.* - - aeson >=1.0 + - aeson >=2.0.1.0 - attoparsec >=0.10 - binary - cereal @@ -64,7 +64,7 @@ executables: - -funbox-small-strict-fields - -rtsopts dependencies: - - aeson >=1.0 + - aeson >=2.0.1.0 - base - clock - cryptonite diff --git a/tools/bonanza/src/Bonanza/Anon.hs b/tools/bonanza/src/Bonanza/Anon.hs index 48e453ae4eb..378b62d9665 100644 --- a/tools/bonanza/src/Bonanza/Anon.hs +++ b/tools/bonanza/src/Bonanza/Anon.hs @@ -22,12 +22,13 @@ where import Bonanza.Types import Control.Lens (over, (%~), _Wrapped') -import Data.HashMap.Strict (filterWithKey) +import qualified Data.Aeson.Key as Key +import Data.Aeson.KeyMap (filterWithKey) import Imports anonymise :: [Text] -> LogEvent -> LogEvent anonymise [] evt = evt anonymise ts evt = evt & logTags %~ stripTags where - stripTags = over _Wrapped' (filterWithKey (\k _ -> not (k `elem` ts))) + stripTags = over _Wrapped' (filterWithKey (\k _ -> Key.toText k `notElem` ts)) {-# INLINEABLE anonymise #-} diff --git a/tools/bonanza/src/Bonanza/Geo.hs b/tools/bonanza/src/Bonanza/Geo.hs index 6d9e8784cb6..106baff7feb 100644 --- a/tools/bonanza/src/Bonanza/Geo.hs +++ b/tools/bonanza/src/Bonanza/Geo.hs @@ -27,9 +27,10 @@ where import Bonanza.Types import Control.Lens import Data.Aeson +import qualified Data.Aeson.Key as Key +import qualified Data.Aeson.KeyMap as KeyMap import Data.Aeson.Lens import Data.GeoIP2 -import qualified Data.HashMap.Strict as HashMap import qualified Data.IP as IP import qualified Data.Text as Text import Imports @@ -53,13 +54,13 @@ geolocate db t evt = evt & logTags %~ _Wrapped' . at "geoip" - . non (Object HashMap.empty) + . non (Object KeyMap.empty) . _Object . at t .~ fmap (toJSON . toGeo) x ip :: Text -> LogEvent -> Maybe IP.IP -ip t = join . fmap parse . view (logTags . _Wrapped' . at t) +ip t = join . fmap parse . view (logTags . _Wrapped' . at (Key.fromText t)) where parse = join diff --git a/tools/bonanza/src/Bonanza/Parser/CommonLog.hs b/tools/bonanza/src/Bonanza/Parser/CommonLog.hs index 1974fa5d67b..66d24fe644f 100644 --- a/tools/bonanza/src/Bonanza/Parser/CommonLog.hs +++ b/tools/bonanza/src/Bonanza/Parser/CommonLog.hs @@ -41,9 +41,11 @@ import Bonanza.Types import Control.Applicative (optional) import Control.Lens.Operators import Data.Aeson hiding (()) +import qualified Data.Aeson.Key as Key +import qualified Data.Aeson.KeyMap as KeyMap import Data.Attoparsec.ByteString.Char8 +import Data.Bifunctor (first) import Data.ByteString.Char8 (unpack) -import Data.HashMap.Strict (fromList) import Data.Text.Encoding import Data.Time (UTCTime (..)) import Imports hiding (isSpace) @@ -74,7 +76,7 @@ instance ToLogEvent CommonLogRecord where where mth = decodeUtf8 $ renderStdMethod m tgs = - Tags . fromList $ + Tags . KeyMap.fromList . map (first Key.fromText) $ catMaybes [ Just ("http_method", String mth), Just ("http_path", String p), diff --git a/tools/bonanza/src/Bonanza/Parser/Rkt.hs b/tools/bonanza/src/Bonanza/Parser/Rkt.hs index 62624e3753b..a388672c721 100644 --- a/tools/bonanza/src/Bonanza/Parser/Rkt.hs +++ b/tools/bonanza/src/Bonanza/Parser/Rkt.hs @@ -28,9 +28,10 @@ import Bonanza.Parser.Svlogd import Bonanza.Types import Control.Lens.Operators import Data.Aeson +import qualified Data.Aeson.Key as Key +import Data.Aeson.KeyMap (fromList) import Data.Attoparsec.ByteString.Char8 import Data.Bifunctor -import Data.HashMap.Strict (fromList) import Data.Text (strip) import Imports @@ -49,7 +50,7 @@ instance ToLogEvent RktLogRecord where mempty & logTags .~ tgs & logMessage ?~ rktMessage where - tgs = Tags . fromList . map (second String) $ rktTags + tgs = Tags . fromList . map (bimap Key.fromText String) $ rktTags rktLogRecord :: Parser RktLogRecord rktLogRecord = do diff --git a/tools/bonanza/src/Bonanza/Parser/Socklog.hs b/tools/bonanza/src/Bonanza/Parser/Socklog.hs index f565d748644..0f3653e8a4b 100644 --- a/tools/bonanza/src/Bonanza/Parser/Socklog.hs +++ b/tools/bonanza/src/Bonanza/Parser/Socklog.hs @@ -34,9 +34,10 @@ import Bonanza.Types import Control.Applicative (optional) import Control.Lens ((.~), (?~)) import Data.Aeson +import qualified Data.Aeson.Key as Key +import qualified Data.Aeson.KeyMap as KeyMap import Data.Attoparsec.ByteString.Char8 import Data.Bifunctor -import Data.HashMap.Strict (fromList) import Data.Text.Lazy (toStrict) import Data.Text.Lazy.Builder (toLazyText) import qualified Data.Text.Lazy.Builder.Int as T @@ -59,7 +60,7 @@ instance ToLogEvent a => ToLogEvent (SockLogRecord a) where ) <> toLogEvent sockMessage where - tgs = Tags . fromList . map (second String) $ sockTags + tgs = Tags . KeyMap.fromList . map (bimap Key.fromText String) $ sockTags sockLogRecordWith :: Parser a -> Parser (SockLogRecord a) sockLogRecordWith p = diff --git a/tools/bonanza/src/Bonanza/Parser/Svlogd.hs b/tools/bonanza/src/Bonanza/Parser/Svlogd.hs index c37a06f4255..086f3e99441 100644 --- a/tools/bonanza/src/Bonanza/Parser/Svlogd.hs +++ b/tools/bonanza/src/Bonanza/Parser/Svlogd.hs @@ -32,9 +32,10 @@ import Bonanza.Types import Control.Applicative (optional) import Control.Lens ((.~)) import Data.Aeson +import qualified Data.Aeson.Key as Key +import Data.Aeson.KeyMap (fromList) import Data.Attoparsec.ByteString.Char8 import Data.Bifunctor -import Data.HashMap.Strict (fromList) import Data.Text (strip) import Data.Time (UTCTime (..)) import Imports @@ -51,7 +52,7 @@ instance ToLogEvent a => ToLogEvent (SvLogRecord a) where (mempty & logTime .~ svTime & logTags .~ tgs) <> toLogEvent svMessage where - tgs = Tags . fromList . map (second String) $ svTags + tgs = Tags . fromList . map (bimap Key.fromText String) $ svTags svLogRecord :: Parser (SvLogRecord Text) svLogRecord = svLogRecordWith $ strip . toText <$> takeTill (== '\n') diff --git a/tools/bonanza/src/Bonanza/Parser/Tinylog.hs b/tools/bonanza/src/Bonanza/Parser/Tinylog.hs index c5192b089fb..39f488293de 100644 --- a/tools/bonanza/src/Bonanza/Parser/Tinylog.hs +++ b/tools/bonanza/src/Bonanza/Parser/Tinylog.hs @@ -32,10 +32,11 @@ import Bonanza.Types import Control.Applicative (optional) import Control.Lens.Operators import Data.Aeson +import qualified Data.Aeson.Key as Key +import Data.Aeson.KeyMap (fromList) import Data.Attoparsec.ByteString.Char8 import Data.Bifunctor import qualified Data.ByteString.Char8 as B -import Data.HashMap.Strict (fromList) import qualified Data.Text as T import Imports hiding (isDigit) @@ -52,7 +53,7 @@ instance ToLogEvent TinyLogRecord where mempty & logTags .~ tgs & logMessage ?~ tMessage where tgs = - Tags . fromList . map (second String) $ + Tags . fromList . map (bimap Key.fromText String) $ ("level", T.singleton tLevel) : tFields ++ maybeToList ((,) "time" <$> tDate) diff --git a/tools/bonanza/src/Bonanza/Streaming/Kibana.hs b/tools/bonanza/src/Bonanza/Streaming/Kibana.hs index dc8f6830446..af6dafc1729 100644 --- a/tools/bonanza/src/Bonanza/Streaming/Kibana.hs +++ b/tools/bonanza/src/Bonanza/Streaming/Kibana.hs @@ -37,11 +37,12 @@ module Bonanza.Streaming.Kibana where import Bonanza.Types -import Control.Lens ((^.)) +import Control.Lens (ifoldl', over, (^.)) import Data.Aeson +import qualified Data.Aeson.Key as Key +import qualified Data.Aeson.KeyMap as KeyMap import qualified Data.ByteString.Builder as BB import qualified Data.ByteString.Lazy as BL -import qualified Data.HashMap.Strict as Map import Data.Text (pack) import qualified Data.Text as T import Data.Time @@ -104,11 +105,14 @@ fromLogEvent evt = do -- replace them by underscore dedotKeys = Tags - . Map.foldlWithKey' - (\m k v -> Map.insert (T.replace "." "_" k) v m) - Map.empty + . ifoldl' + (\k m v -> KeyMap.insert (k & over keyTextL (T.replace "." "_")) v m) + KeyMap.empty . fromTags +keyTextL :: Functor f => (Text -> f Text) -> Key -> f Key +keyTextL f key = fmap Key.fromText (f (Key.toText key)) + jsonEncode :: Text -> KibanaEvent -> BL.ByteString jsonEncode idxpre kev@KibanaEvent {..} = BB.toLazyByteString @@ -127,13 +131,13 @@ jsonEncode idxpre kev@KibanaEvent {..} = _type = fromMaybe "generic" srv, _id = mkDocId esTimestamp esTags } - srv = tagTxt $ Map.lookup "srv" (fromTags esTags) + srv = tagTxt $ KeyMap.lookup "srv" (fromTags esTags) idx = IndexName $ idxpre <> "-" <> ts ts = pack . showGregorian . localDay . zonedTimeToLocalTime $ esTimestamp mkDocId :: ZonedTime -> Tags -> Maybe Text mkDocId ts tgs = - if Map.member "srv" (fromTags tgs) + if KeyMap.member "srv" (fromTags tgs) then (<>) <$> requestId tgs <*> pure ("-" <> secs ts) else Nothing where @@ -141,7 +145,7 @@ mkDocId ts tgs = requestId :: Tags -> Maybe Text requestId (Tags t) = - let rid = Map.lookup "request" t + let rid = KeyMap.lookup "request" t in mfilter (/= "N/A") (tagTxt rid) tagTxt :: Maybe TagValue -> Maybe Text diff --git a/tools/bonanza/src/Bonanza/Types.hs b/tools/bonanza/src/Bonanza/Types.hs index c4ee4670965..1320d5f93a2 100644 --- a/tools/bonanza/src/Bonanza/Types.hs +++ b/tools/bonanza/src/Bonanza/Types.hs @@ -51,8 +51,8 @@ where import Bonanza.Parser.IP (IPv4 (..)) import Control.Lens import Data.Aeson hiding (Value) +import qualified Data.Aeson.KeyMap as KeyMap import qualified Data.Aeson.Types as Aeson -import qualified Data.HashMap.Strict as M import qualified Data.List as L import Data.Text.Encoding (decodeUtf8) import Data.Time @@ -98,7 +98,7 @@ instance Monoid LogEvent where -------------------------------------------------------------------------------- -- Auxiliary Types -newtype Tags = Tags {fromTags :: HashMap Text TagValue} +newtype Tags = Tags {fromTags :: KeyMap.KeyMap TagValue} deriving (Eq, Show, Generic) instance ToJSON Tags where @@ -106,9 +106,9 @@ instance ToJSON Tags where instance FromJSON Tags where parseJSON (Object o) = - fmap (Tags . M.fromList) + fmap (Tags . KeyMap.fromList) . mapM (\(k, v) -> (,) k <$> parseJSON v) - . M.toList + . KeyMap.toList $ o parseJSON _ = mzero diff --git a/tools/bonanza/test/unit/Test/Bonanza/Arbitrary.hs b/tools/bonanza/test/unit/Test/Bonanza/Arbitrary.hs index a66050a48c9..6c436870613 100644 --- a/tools/bonanza/test/unit/Test/Bonanza/Arbitrary.hs +++ b/tools/bonanza/test/unit/Test/Bonanza/Arbitrary.hs @@ -46,7 +46,6 @@ import qualified Data.Text.Lazy.Builder.Int as T import Data.Text.Lazy.Builder.Scientific import Data.Time import Data.Time.Clock.POSIX -import qualified Data.Vector as V import Imports import Network.HTTP.Types.Method import Test.QuickCheck hiding ((.&.)) @@ -240,16 +239,6 @@ instance Arbitrary FieldValue where utf8 . unquoted <$> arbitrary ] -instance Arbitrary TagValue where - arbitrary = - oneof - [ String . utf8 . unquoted <$> arbitrary, - Number . fromIntegral <$> (arbitrary :: Gen Int), - Number . realToFrac <$> (arbitrary :: Gen Double), - Bool <$> arbitrary, - Array . V.fromList <$> listOf (arbitrary :: Gen TagValue) - ] - newtype Field = Field {field :: (AlphaNumeric, FieldValue)} deriving (Eq, Show) diff --git a/tools/convert-to-cabal/generate.sh b/tools/convert-to-cabal/generate.sh index 3a0e8c5f421..4ce65c507b8 100755 --- a/tools/convert-to-cabal/generate.sh +++ b/tools/convert-to-cabal/generate.sh @@ -8,6 +8,6 @@ cd "$TOP_LEVEL" nix-shell ./tools/convert-to-cabal/shell.nix --command "stack2cabal --no-run-hpack" { - echo -e "\n-- Changes by ./tools/convert-to-cabal/generate.sh \n\ntests: True\n\n"; + echo -e "\n-- Changes by ./tools/convert-to-cabal/generate.sh \n\ntests: True\nbenchmarks: True\n"; ./hack/bin/cabal-project-local-template.sh "ghc-options: -Werror" } >> ./cabal.project diff --git a/tools/stern/package.yaml b/tools/stern/package.yaml index f7e0162c25d..1454198d8c2 100644 --- a/tools/stern/package.yaml +++ b/tools/stern/package.yaml @@ -18,11 +18,12 @@ library: - -funbox-strict-fields dependencies: - base >= 4.5 && < 5 - - aeson >= 0.11 + - aeson >= 2.0.1.0 && < 2.1 - bilge >= 0.12 - brig-types >= 0.9.6 - bytestring >= 0.10 - bytestring-conversion >= 0.2 + - containers - data-default >= 0.5 - errors >= 1.4 - exceptions >= 0.6 diff --git a/tools/stern/src/Stern/API.hs b/tools/stern/src/Stern/API.hs index 1085e5e96b8..bf10475c01a 100644 --- a/tools/stern/src/Stern/API.hs +++ b/tools/stern/src/Stern/API.hs @@ -32,11 +32,11 @@ import Brig.Types.Intra import Control.Error import Control.Lens ((^.)) import Data.Aeson hiding (Error, json) +import qualified Data.Aeson.KeyMap as KeyMap import Data.Aeson.Types (emptyArray) import Data.ByteString.Conversion import Data.ByteString.Lazy (fromStrict) import Data.Handle (Handle) -import qualified Data.HashMap.Strict as M import Data.Id import Data.Predicate import Data.Range @@ -747,7 +747,7 @@ getUserData uid = do "properties" .= properties ] where - noEmail = MarketoResult $ M.singleton "results" emptyArray + noEmail = MarketoResult $ KeyMap.singleton "results" emptyArray -- Utilities diff --git a/tools/stern/src/Stern/Intra.hs b/tools/stern/src/Stern/Intra.hs index 39cd68fa9f2..07126a01e1e 100644 --- a/tools/stern/src/Stern/Intra.hs +++ b/tools/stern/src/Stern/Intra.hs @@ -70,14 +70,15 @@ import Control.Error import Control.Lens (view, (^.)) import Control.Monad.Reader import Data.Aeson hiding (Error) +import qualified Data.Aeson.KeyMap as KeyMap import Data.Aeson.Types (emptyArray) import qualified Data.ByteString.Char8 as BS import Data.ByteString.Conversion import Data.Handle (Handle) -import qualified Data.HashMap.Strict as M import Data.Id import Data.Int import Data.List.Split (chunksOf) +import qualified Data.Map as Map import Data.Qualified (qUnqualified) import Data.String.Conversions (cs) import Data.Text (strip) @@ -691,7 +692,7 @@ getMarketoResult email = do 404 -> return noEmail _ -> throwE (mkError status502 "bad-upstream" "") where - noEmail = MarketoResult $ M.singleton "results" emptyArray + noEmail = MarketoResult $ KeyMap.singleton "results" emptyArray getUserConsentLog :: UserId -> Handler ConsentLog getUserConsentLog uid = do @@ -786,7 +787,7 @@ getUserProperties uid = do ) info $ msg ("Response" ++ show r) keys <- parseResponse (mkError status502 "bad-upstream") r :: Handler [PropertyKey] - UserProperties <$> fetchProperty b keys M.empty + UserProperties <$> fetchProperty b keys mempty where fetchProperty _ [] acc = return acc fetchProperty b (x : xs) acc = do @@ -802,7 +803,7 @@ getUserProperties uid = do ) info $ msg ("Response" ++ show r) value <- parseResponse (mkError status502 "bad-upstream") r - fetchProperty b xs (M.insert x value acc) + fetchProperty b xs (Map.insert x value acc) getUserNotifications :: UserId -> Handler [QueuedNotification] getUserNotifications uid = do diff --git a/tools/stern/src/Stern/Types.hs b/tools/stern/src/Stern/Types.hs index 221ee838ad0..b7e849ccc5a 100644 --- a/tools/stern/src/Stern/Types.hs +++ b/tools/stern/src/Stern/Types.hs @@ -27,9 +27,9 @@ module Stern.Types where import Brig.Types import Data.Aeson +import qualified Data.Aeson.KeyMap as KeyMap import Data.Aeson.TH import Data.ByteString.Conversion -import qualified Data.HashMap.Strict as M import Data.Json.Util import Data.Range import Galley.Types.Teams @@ -44,8 +44,8 @@ instance ToJSON TeamMemberInfo where case teamMemberJson (const True) m of Object o -> Object $ - M.insert "can_update_billing" (Bool (hasPermission m SetBilling)) $ - M.insert "can_view_billing" (Bool (hasPermission m GetBilling)) $ + KeyMap.insert "can_update_billing" (Bool (hasPermission m SetBilling)) $ + KeyMap.insert "can_view_billing" (Bool (hasPermission m GetBilling)) $ o other -> error $ "toJSON TeamMemberInfo: not an object: " <> show (encode other) @@ -95,7 +95,7 @@ instance ToJSON TeamAdminInfo where ] newtype UserProperties = UserProperties - { unUserProperties :: M.HashMap PropertyKey PropertyValue + { unUserProperties :: Map PropertyKey PropertyValue } deriving (Eq, Show, ToJSON) diff --git a/tools/stern/stern.cabal b/tools/stern/stern.cabal index ac2f1c8d88f..9ad23678758 100644 --- a/tools/stern/stern.cabal +++ b/tools/stern/stern.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 0da74867ac45ba54dd475f434f41b57a45950a001354df87fe6286f1c2db55d9 +-- hash: 546e7936cf8835f249ceaf80c981335ff160a2848a48cc55a707845fc3c5d2c5 name: stern version: 1.7.2 @@ -77,12 +77,13 @@ library 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 >=0.11 + aeson >=2.0.1.0 && <2.1 , base >=4.5 && <5 , bilge >=0.12 , brig-types >=0.9.6 , bytestring >=0.10 , bytestring-conversion >=0.2 + , containers , data-default >=0.5 , errors >=1.4 , exceptions >=0.6